Merge pull request #7995 from robx/cleanup-processes

Cleanup around subprocess helpers
haskell · Feb 23, 2022 · ddf3ba2 · ddf3ba2
2 parents 001e3cc + 91fa33b
commit ddf3ba2
Show file tree

Hide file tree

Showing 10 changed files with 284 additions and 378 deletions.
diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs
@@ -1,17 +1,12 @@
 {-# LANGUAGE CPP #-}
 module Distribution.Compat.Process (
     -- * Redefined functions
-    createProcess,
-    runInteractiveProcess,
-    rawSystem,
+    proc,
     -- * Additions
     enableProcessJobs,
     ) where
 
-import System.Exit (ExitCode (..))
-import System.IO   (Handle)
-
-import           System.Process (CreateProcess, ProcessHandle, waitForProcess)
+import           System.Process (CreateProcess)
 import qualified System.Process as Process
 
 #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
@@ -60,35 +55,7 @@ enableProcessJobs cp = cp
 -- process redefinitions
 -------------------------------------------------------------------------------
 
--- | 'System.Process.createProcess' with process jobs enabled when appropriate.
--- See 'enableProcessJobs'.
-createProcess :: CreateProcess
-              -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess = Process.createProcess . enableProcessJobs
-
--- | 'System.Process.rawSystem' with process jobs enabled when appropriate.
--- See 'enableProcessJobs'.
-rawSystem :: String -> [String] -> IO ExitCode
-rawSystem cmd args = do
-  (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True }
-  waitForProcess p
-
--- | 'System.Process.runInteractiveProcess' with process jobs enabled when
--- appropriate. See 'enableProcessJobs'.
-runInteractiveProcess
-  :: FilePath                   -- ^ Filename of the executable (see 'RawCommand' for details)
-  -> [String]                   -- ^ Arguments to pass to the executable
-  -> Maybe FilePath             -- ^ Optional path to the working directory
-  -> Maybe [(String,String)]    -- ^ Optional environment (otherwise inherit)
-  -> IO (Handle,Handle,Handle,ProcessHandle)
-runInteractiveProcess cmd args mb_cwd mb_env = do
-  (mb_in, mb_out, mb_err, p) <-
-      createProcess (Process.proc cmd args)
-              { Process.std_in  = Process.CreatePipe,
-                Process.std_out = Process.CreatePipe,
-                Process.std_err = Process.CreatePipe,
-                Process.env     = mb_env,
-                Process.cwd     = mb_cwd }
-  return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
-  where
-    fromJust = maybe (error "runInteractiveProcess: fromJust") id
+-- | 'System.Process.proc' with process jobs enabled when appropriate,
+-- and defaulting 'delegate_ctlc' to 'True'.
+proc :: FilePath -> [String] -> CreateProcess
+proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }
diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -41,7 +41,8 @@ import System.Directory
     , setCurrentDirectory )
 import System.FilePath ( (</>), (<.>) )
 import System.IO ( hClose, hPutStr )
-import System.Process (StdStream(..), createPipe, waitForProcess)
+import Distribution.Compat.Process (proc)
+import qualified System.Process as Process
 
 runTest :: PD.PackageDescription
         -> LBI.LocalBuildInfo
@@ -78,49 +79,48 @@ runTest pkg_descr lbi clbi flags suite = do
 
     suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
 
+        -- Run test executable
+        let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
+            dataDirPath = pwd </> PD.dataDir pkg_descr
+            tixFile = pwd </> tixFilePath distPref way testName'
+            pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+                       : existingEnv
+            shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
+                     ++ pkgPathEnv
+        -- Add (DY)LD_LIBRARY_PATH if needed
+        shellEnv' <-
+          if LBI.withDynExe lbi
+          then do
+            let (Platform _ os) = LBI.hostPlatform lbi
+            paths <- LBI.depLibraryPaths True False lbi clbi
+            cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
+            return (addLibraryPath os (cpath : paths) shellEnv)
+          else return shellEnv
+        let (cmd', opts') = case testWrapper flags of
+                              Flag path -> (path, cmd:opts)
+                              NoFlag -> (cmd, opts)
+
         -- TODO: this setup is broken,
         -- if the test output is too big, we will deadlock.
-        (rOut, wOut) <- createPipe
-
-        -- Run test executable
-        (Just wIn, _, _, process) <- do
-                let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
-                    dataDirPath = pwd </> PD.dataDir pkg_descr
-                    tixFile = pwd </> tixFilePath distPref way testName'
-                    pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
-                               : existingEnv
-                    shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
-                             ++ pkgPathEnv
-                -- Add (DY)LD_LIBRARY_PATH if needed
-                shellEnv' <-
-                  if LBI.withDynExe lbi
-                  then do
-                    let (Platform _ os) = LBI.hostPlatform lbi
-                    paths <- LBI.depLibraryPaths True False lbi clbi
-                    cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
-                    return (addLibraryPath os (cpath : paths) shellEnv)
-                  else return shellEnv
-                case testWrapper flags of
-                  Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv')
-                               -- these handles are closed automatically
-                               CreatePipe (UseHandle wOut) (UseHandle wOut)
-
-                  NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
-                            -- these handles are closed automatically
-                            CreatePipe (UseHandle wOut) (UseHandle wOut)
-
-        hPutStr wIn $ show (tempLog, PD.testName suite)
-        hClose wIn
-
-        -- Append contents of temporary log file to the final human-
-        -- readable log file
-        logText <- LBS.hGetContents rOut
-        -- Force the IO manager to drain the test output pipe
-        _ <- evaluate (force logText)
-
-        exitcode <- waitForProcess process
-        unless (exitcode == ExitSuccess) $ do
-            debug verbosity $ cmd ++ " returned " ++ show exitcode
+        (rOut, wOut) <- Process.createPipe
+        (exitcode, logText) <- rawSystemProcAction verbosity
+            (proc cmd' opts') { Process.env           = Just shellEnv'
+                              , Process.std_in        = Process.CreatePipe
+                              , Process.std_out       = Process.UseHandle wOut
+                              , Process.std_err       = Process.UseHandle wOut
+                              } $ \mIn _ _ -> do
+          let wIn = fromCreatePipe mIn
+          hPutStr wIn $ show (tempLog, PD.testName suite)
+          hClose wIn
+
+          -- Append contents of temporary log file to the final human-
+          -- readable log file
+          logText <- LBS.hGetContents rOut
+          -- Force the IO manager to drain the test output pipe
+          _ <- evaluate (force logText)
+          return logText
+        unless (exitcode == ExitSuccess) $
+          debug verbosity $ cmd ++ " returned " ++ show exitcode
 
         -- Generate final log file name
         let finalLogName l = testLogDir