Merge pull request #6536 from phadej/bgamari-use-process-jobs

use process jobs

Author: phadej

Cabal/Cabal.cabal

@@ -334,6 +334,7 @@ library
     Distribution.Compat.Newtype
     Distribution.Compat.ResponseFile
     Distribution.Compat.Prelude.Internal
+    Distribution.Compat.Process
     Distribution.Compat.Semigroup
     Distribution.Compat.Stack
     Distribution.Compat.Time

Cabal/ChangeLog.md

@@ -19,6 +19,7 @@
   * Add `unsnoc` and `unsnocNE` to `Distribution.Utils.Generic`
   * Add `Set'` modifier to `Distribution.Parsec.Newtypes`
   * Add `Distribution.Compat.Async`
+  * Add `Distribution.Compat.Process` with `enableProcessJobs`
 
 # 3.0.1.0 TBW
   * Add GHC-8.8 flags to normaliseGhcFlags

Cabal/Distribution/Compat/Process.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE CPP #-}
+module Distribution.Compat.Process (
+    -- * Redefined functions
+    createProcess,
+    runInteractiveProcess,
+    rawSystem,
+    -- * Additions
+    enableProcessJobs,
+    ) where
+
+import System.Exit (ExitCode (..))
+import System.IO   (Handle)
+
+import           System.Process (CreateProcess, ProcessHandle)
+import qualified System.Process as Process
+
+#if MIN_VERSION_process(1,2,0)
+import           System.Process (waitForProcess)
+#endif
+
+-------------------------------------------------------------------------------
+-- enableProcessJobs
+-------------------------------------------------------------------------------
+
+-- | 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
+
+-------------------------------------------------------------------------------
+-- 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
+#if MIN_VERSION_process(1,2,0)
+  (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True }
+  waitForProcess p
+#else
+  -- With very old 'process', just do its rawSystem
+  Process.rawSystem cmd args
+#endif
+
+-- | '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

Cabal/Distribution/Simple/Utils.hs

@@ -233,12 +233,11 @@ import Foreign.C.Error (Errno (..), ePIPE)
 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)
+import Distribution.Compat.Process  (createProcess, rawSystem, runInteractiveProcess)
 import System.Process
-         ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
+         ( ProcessHandle
          , showCommandForUser, waitForProcess)
-
+import qualified System.Process as Process
 import qualified GHC.IO.Exception as GHC
 
 import qualified Text.PrettyPrint as Disp
@@ -680,6 +679,8 @@ maybeExit cmd = do
   res <- cmd
   unless (res == ExitSuccess) $ exitWith res
 
+
+
 printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
 printRawCommandAndArgs verbosity path args = withFrozenCallStack $
     printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing

cabal-install/Distribution/Client/SetupWrapper.hs

@@ -111,7 +111,8 @@ import System.Directory    ( doesFileExist )
 import System.FilePath     ( (</>), (<.>) )
 import System.IO           ( Handle, hPutStr )
 import System.Exit         ( ExitCode(..), exitWith )
-import System.Process      ( createProcess, StdStream(..), proc, waitForProcess
+import Distribution.Compat.Process (createProcess)
+import System.Process      ( StdStream(..), proc, waitForProcess
                            , ProcessHandle )
 import qualified System.Process as Process
 import Data.List           ( foldl1' )
@@ -464,6 +465,7 @@ runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do
     mbToStd :: Maybe Handle -> StdStream
     mbToStd Nothing = Inherit
     mbToStd (Just hdl) = UseHandle hdl
+
 -- ------------------------------------------------------------
 -- * Self-Exec SetupMethod
 -- ------------------------------------------------------------