Skip to content

Commit ddf3ba2

Browse files
MikolajMikolaj
authored
Merge pull request #7995 from robx/cleanup-processes
Cleanup around subprocess helpers
2 parents 001e3cc + 91fa33b commit ddf3ba2

File tree

10 files changed

+284
-378
lines changed

10 files changed

+284
-378
lines changed

‎Cabal/src/Distribution/Compat/Process.hs

+6-39
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,12 @@
11
{-# LANGUAGE CPP #-}
22
module Distribution.Compat.Process (
33
-- * Redefined functions
4-
createProcess,
5-
runInteractiveProcess,
6-
rawSystem,
4+
proc,
75
-- * Additions
86
enableProcessJobs,
97
) where
108

11-
import System.Exit (ExitCode (..))
12-
import System.IO (Handle)
13-
14-
import System.Process (CreateProcess, ProcessHandle, waitForProcess)
9+
import System.Process (CreateProcess)
1510
import qualified System.Process as Process
1611

1712
#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
@@ -60,35 +55,7 @@ enableProcessJobs cp = cp
6055
-- process redefinitions
6156
-------------------------------------------------------------------------------
6257

63-
-- | 'System.Process.createProcess' with process jobs enabled when appropriate.
64-
-- See 'enableProcessJobs'.
65-
createProcess :: CreateProcess
66-
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
67-
createProcess = Process.createProcess . enableProcessJobs
68-
69-
-- | 'System.Process.rawSystem' with process jobs enabled when appropriate.
70-
-- See 'enableProcessJobs'.
71-
rawSystem :: String -> [String] -> IO ExitCode
72-
rawSystem cmd args = do
73-
(_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True }
74-
waitForProcess p
75-
76-
-- | 'System.Process.runInteractiveProcess' with process jobs enabled when
77-
-- appropriate. See 'enableProcessJobs'.
78-
runInteractiveProcess
79-
:: FilePath -- ^ Filename of the executable (see 'RawCommand' for details)
80-
-> [String] -- ^ Arguments to pass to the executable
81-
-> Maybe FilePath -- ^ Optional path to the working directory
82-
-> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
83-
-> IO (Handle,Handle,Handle,ProcessHandle)
84-
runInteractiveProcess cmd args mb_cwd mb_env = do
85-
(mb_in, mb_out, mb_err, p) <-
86-
createProcess (Process.proc cmd args)
87-
{ Process.std_in = Process.CreatePipe,
88-
Process.std_out = Process.CreatePipe,
89-
Process.std_err = Process.CreatePipe,
90-
Process.env = mb_env,
91-
Process.cwd = mb_cwd }
92-
return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
93-
where
94-
fromJust = maybe (error "runInteractiveProcess: fromJust") id
58+
-- | 'System.Process.proc' with process jobs enabled when appropriate,
59+
-- and defaulting 'delegate_ctlc' to 'True'.
60+
proc :: FilePath -> [String] -> CreateProcess
61+
proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }

‎Cabal/src/Distribution/Simple/Test/LibV09.hs

+42-42
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,8 @@ import System.Directory
4141
, setCurrentDirectory )
4242
import System.FilePath ( (</>), (<.>) )
4343
import System.IO ( hClose, hPutStr )
44-
import System.Process (StdStream(..), createPipe, waitForProcess)
44+
import Distribution.Compat.Process (proc)
45+
import qualified System.Process as Process
4546

4647
runTest :: PD.PackageDescription
4748
-> LBI.LocalBuildInfo
@@ -78,49 +79,48 @@ runTest pkg_descr lbi clbi flags suite = do
7879

7980
suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
8081

82+
-- Run test executable
83+
let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
84+
dataDirPath = pwd </> PD.dataDir pkg_descr
85+
tixFile = pwd </> tixFilePath distPref way testName'
86+
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
87+
: existingEnv
88+
shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
89+
++ pkgPathEnv
90+
-- Add (DY)LD_LIBRARY_PATH if needed
91+
shellEnv' <-
92+
if LBI.withDynExe lbi
93+
then do
94+
let (Platform _ os) = LBI.hostPlatform lbi
95+
paths <- LBI.depLibraryPaths True False lbi clbi
96+
cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
97+
return (addLibraryPath os (cpath : paths) shellEnv)
98+
else return shellEnv
99+
let (cmd', opts') = case testWrapper flags of
100+
Flag path -> (path, cmd:opts)
101+
NoFlag -> (cmd, opts)
102+
81103
-- TODO: this setup is broken,
82104
-- if the test output is too big, we will deadlock.
83-
(rOut, wOut) <- createPipe
84-
85-
-- Run test executable
86-
(Just wIn, _, _, process) <- do
87-
let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
88-
dataDirPath = pwd </> PD.dataDir pkg_descr
89-
tixFile = pwd </> tixFilePath distPref way testName'
90-
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
91-
: existingEnv
92-
shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
93-
++ pkgPathEnv
94-
-- Add (DY)LD_LIBRARY_PATH if needed
95-
shellEnv' <-
96-
if LBI.withDynExe lbi
97-
then do
98-
let (Platform _ os) = LBI.hostPlatform lbi
99-
paths <- LBI.depLibraryPaths True False lbi clbi
100-
cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
101-
return (addLibraryPath os (cpath : paths) shellEnv)
102-
else return shellEnv
103-
case testWrapper flags of
104-
Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv')
105-
-- these handles are closed automatically
106-
CreatePipe (UseHandle wOut) (UseHandle wOut)
107-
108-
NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
109-
-- these handles are closed automatically
110-
CreatePipe (UseHandle wOut) (UseHandle wOut)
111-
112-
hPutStr wIn $ show (tempLog, PD.testName suite)
113-
hClose wIn
114-
115-
-- Append contents of temporary log file to the final human-
116-
-- readable log file
117-
logText <- LBS.hGetContents rOut
118-
-- Force the IO manager to drain the test output pipe
119-
_ <- evaluate (force logText)
120-
121-
exitcode <- waitForProcess process
122-
unless (exitcode == ExitSuccess) $ do
123-
debug verbosity $ cmd ++ " returned " ++ show exitcode
105+
(rOut, wOut) <- Process.createPipe
106+
(exitcode, logText) <- rawSystemProcAction verbosity
107+
(proc cmd' opts') { Process.env = Just shellEnv'
108+
, Process.std_in = Process.CreatePipe
109+
, Process.std_out = Process.UseHandle wOut
110+
, Process.std_err = Process.UseHandle wOut
111+
} $ \mIn _ _ -> do
112+
let wIn = fromCreatePipe mIn
113+
hPutStr wIn $ show (tempLog, PD.testName suite)
114+
hClose wIn
115+
116+
-- Append contents of temporary log file to the final human-
117+
-- readable log file
118+
logText <- LBS.hGetContents rOut
119+
-- Force the IO manager to drain the test output pipe
120+
_ <- evaluate (force logText)
121+
return logText
122+
unless (exitcode == ExitSuccess) $
123+
debug verbosity $ cmd ++ " returned " ++ show exitcode
124124

125125
-- Generate final log file name
126126
let finalLogName l = testLogDir

0 commit comments

Comments
 (0)