Skip to content

Commit

Permalink
Merge pull request #6536 from phadej/bgamari-use-process-jobs
Browse files Browse the repository at this point in the history
use process jobs
  • Loading branch information
phadej authored Feb 12, 2020
2 parents e5b508e + 5aac988 commit b744cde
Show file tree
Hide file tree
Showing 5 changed files with 92 additions and 5 deletions.
1 change: 1 addition & 0 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions Cabal/ChangeLog.md
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
82 changes: 82 additions & 0 deletions Cabal/Distribution/Compat/Process.hs
Original file line number Diff line number Diff line change
@@ -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
9 changes: 5 additions & 4 deletions Cabal/Distribution/Simple/Utils.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
4 changes: 3 additions & 1 deletion cabal-install/Distribution/Client/SetupWrapper.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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' )
Expand Down Expand Up @@ -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
-- ------------------------------------------------------------
Expand Down

0 comments on commit b744cde

Please sign in to comment.