From e4db2dcc3b7dde395358a5b77c2fe6fc18a900eb Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Mon, 3 Feb 2020 21:28:43 -0500
Subject: [PATCH] Use jobs when calling subprocesses
Many toolchain tools written for POSIX systems rely on the exec system
call. Unfortunately, it is not possible to implement `exec` in a
POSIX-compliant manner on Windows. In particular, the semantics of the
`exec` implementation provided by the widely-used `msvcrt` C runtime
will cause process's waiting on the `exec`'ing process to incorrectly
conclude that the process has successfully terminated when in fact it is
still running in another process.
For this reason, the `process` library exposes the `use_process_jobs`
flag to use a more strict (although still not POSIX-compliant) mechanism
for tracking process completion. This is explained in this comment [2].
Unfortunately, job support in the `process` library is currently quite
broken and was only recently fixed [1]. Consequently, we only enable job
object support for process releases >= 1.6.8.
[1] https://github.com/haskell/process/pull/168
[2] https://github.com/haskell/process/blob/master/System/Process.hs#L399
---
Cabal/Distribution/Simple/Utils.hs | 53 ++++++++++++++++++++++++++++--
1 file changed, 51 insertions(+), 2 deletions(-)
diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs
index 96c8406b7d..05e5fb71c1 100644
--- a/Cabal/Distribution/Simple/Utils.hs
+++ b/Cabal/Distribution/Simple/Utils.hs
@@ -230,13 +230,14 @@ import System.IO.Unsafe
import qualified Control.Exception as Exception
import Foreign.C.Error (Errno (..), ePIPE)
+import Data.Maybe (fromJust)
import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Control.Exception (IOException, evaluate, throwIO, fromException)
import Numeric (showFFloat)
import qualified System.Process as Process
- ( CreateProcess(..), StdStream(..), proc)
+ ( CreateProcess(..), StdStream(..), proc, createProcess )
import System.Process
- ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
+ ( CreateProcess, ProcessHandle
, showCommandForUser, waitForProcess)
import qualified GHC.IO.Exception as GHC
@@ -680,6 +681,54 @@ maybeExit cmd = do
res <- cmd
unless (res == ExitSuccess) $ exitWith res
+-- | Enable process jobs to ensure accurate determination of process completion
+-- in the presence of @exec(3)@ on Windows.
+--
+-- Unfortunately the process job support is badly broken in @process@ releases
+-- prior to 1.6.8, so we disable it in these versions, despite the fact that
+-- this means we may see sporatic build failures without jobs.
+enableProcessJobs :: CreateProcess -> CreateProcess
+#ifdef MIN_VERSION_process
+#if MIN_VERSION_process(1,6,8)
+enableProcessJobs cp = cp {Process.use_process_jobs = True}
+#else
+enableProcessJobs cp = cp
+#endif
+#else
+enableProcessJobs cp = cp
+#endif
+
+-- | '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)
+
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args = withFrozenCallStack $
printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing
--
GitLab