From 6e88f4abf63490b9347735a36f0110d2b17075d6 Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Mon, 3 Feb 2020 21:28:43 -0500 Subject: [PATCH 1/2] 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 | 57 ++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 2 deletions(-) diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 96c8406b7d2..c843bcd1ed7 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -230,13 +230,13 @@ 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) import System.Process - ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess + ( CreateProcess, ProcessHandle , showCommandForUser, waitForProcess) import qualified GHC.IO.Exception as GHC @@ -680,6 +680,59 @@ 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 +#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) + printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = withFrozenCallStack $ printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing From 5aac98839c9ce18013655f65dbb067c5d5658e78 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 7 Feb 2020 18:50:07 +0200 Subject: [PATCH 2/2] Add Distribution.Compat.Process module --- Cabal/Cabal.cabal | 1 + Cabal/ChangeLog.md | 1 + Cabal/Distribution/Compat/Process.hs | 82 +++++++++++++++++++ Cabal/Distribution/Simple/Utils.hs | 58 +------------ .../Distribution/Client/SetupWrapper.hs | 4 +- 5 files changed, 90 insertions(+), 56 deletions(-) create mode 100644 Cabal/Distribution/Compat/Process.hs diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 2d5fc23832b..3122f2168c1 100644 --- a/Cabal/Cabal.cabal +++ b/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 diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md index bf91e60f785..fba47483415 100644 --- a/Cabal/ChangeLog.md +++ b/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 diff --git a/Cabal/Distribution/Compat/Process.hs b/Cabal/Distribution/Compat/Process.hs new file mode 100644 index 00000000000..0862a9f3f15 --- /dev/null +++ b/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 diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index c843bcd1ed7..ccc35f5a997 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -230,15 +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 +import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) import System.Process - ( CreateProcess, ProcessHandle + ( ProcessHandle , showCommandForUser, waitForProcess) - +import qualified System.Process as Process import qualified GHC.IO.Exception as GHC import qualified Text.PrettyPrint as Disp @@ -680,58 +679,7 @@ 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 -#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) printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = withFrozenCallStack $ diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 5a8dac7def1..61ae534add4 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/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 -- ------------------------------------------------------------