diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs
index a83da2319ce9e21b1391c2fe2067c07d0c55c7bb..18a1d9f53d0f8aa7b974b2a990d2d6dfb6a85564 100644
--- 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
index 9faacefb5f8bbc2af7ca9d03a65fe56d64a820e7..1cf84a25e4f517c596130b83b0cff125ec07c9f7 100644
--- 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
diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs
index 7257d79116acbc332739c4fd76bcc067e2ea961c..1772bfac096c061e691be293d2f525b5a5a2113d 100644
--- a/Cabal/src/Distribution/Simple/Utils.hs
+++ b/Cabal/src/Distribution/Simple/Utils.hs
@@ -38,7 +38,6 @@ module Distribution.Simple.Utils (
debug, debugNoWrap,
chattyTry,
annotateIO,
- printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
withOutputMarker,
-- * exceptions
@@ -48,12 +47,14 @@ module Distribution.Simple.Utils (
-- * running programs
rawSystemExit,
rawSystemExitCode,
+ rawSystemProc,
+ rawSystemProcAction,
rawSystemExitWithEnv,
rawSystemStdout,
rawSystemStdInOut,
rawSystemIOWithEnv,
rawSystemIOWithEnvAndAction,
- createProcessWithEnv,
+ fromCreatePipe,
maybeExit,
xargs,
findProgramVersion,
@@ -183,7 +184,7 @@ import qualified Distribution.Utils.IOData as IOData
import Distribution.ModuleName as ModuleName
import Distribution.System
import Distribution.Version
-import Distribution.Compat.Async
+import Distribution.Compat.Async (waitCatch, withAsyncNF)
import Distribution.Compat.CopyFile
import Distribution.Compat.FilePath as FilePath
import Distribution.Compat.Internal.TempFile
@@ -234,10 +235,7 @@ import qualified Control.Exception as Exception
import Foreign.C.Error (Errno (..), ePIPE)
import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
import Numeric (showFFloat)
-import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess)
-import System.Process
- ( ProcessHandle
- , showCommandForUser, waitForProcess)
+import Distribution.Compat.Process (proc)
import qualified System.Process as Process
import qualified GHC.IO.Exception as GHC
@@ -719,69 +717,114 @@ clearMarkers s = unlines . filter isMarker $ lines s
-- -----------------------------------------------------------------------------
-- rawSystem variants
+--
+-- These all use 'Distribution.Compat.Process.proc' to ensure we
+-- consistently use process jobs on Windows and Ctrl-C delegation
+-- on Unix.
+--
+-- Additionally, they take care of logging command execution.
+--
+
+-- | Helper to use with one of the 'rawSystem' variants, and exit
+-- unless the command completes successfully.
maybeExit :: IO ExitCode -> IO ()
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
-
-printRawCommandAndArgsAndEnv :: Verbosity
- -> FilePath
- -> [String]
- -> Maybe FilePath
- -> Maybe [(String, String)]
- -> IO ()
-printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do
- case menv of
- Just env -> debugNoWrap verbosity ("Environment: " ++ show env)
- Nothing -> return ()
- case mcwd of
- Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd)
- Nothing -> return ()
- infoNoWrap verbosity (showCommandForUser path args)
-
--- Exit with the same exit code if the subcommand fails
-rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
-rawSystemExit verbosity path args = withFrozenCallStack $ do
- printRawCommandAndArgs verbosity path args
+ exitcode <- cmd
+ unless (exitcode == ExitSuccess) $ exitWith exitcode
+
+-- | Log a command execution (that's typically about to happen)
+-- at info level, and log working directory and environment overrides
+-- at debug level if specified.
+--
+logCommand :: Verbosity -> Process.CreateProcess -> IO ()
+logCommand verbosity cp = do
+ infoNoWrap verbosity $ "Running: " <> case Process.cmdspec cp of
+ Process.ShellCommand sh -> sh
+ Process.RawCommand path args -> Process.showCommandForUser path args
+ case Process.env cp of
+ Just env -> debugNoWrap verbosity $ "with environment: " ++ show env
+ Nothing -> return ()
+ case Process.cwd cp of
+ Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd
+ Nothing -> return ()
hFlush stdout
- exitcode <- rawSystem path args
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
- exitWith exitcode
+-- | Execute the given command with the given arguments, exiting
+-- with the same exit code if the command fails.
+--
+rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
+rawSystemExit verbosity path args = withFrozenCallStack $
+ maybeExit $ rawSystemExitCode verbosity path args
+
+-- | Execute the given command with the given arguments, returning
+-- the command's exit code.
+--
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
-rawSystemExitCode verbosity path args = withFrozenCallStack $ do
- printRawCommandAndArgs verbosity path args
- hFlush stdout
- exitcode <- rawSystem path args
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
+rawSystemExitCode verbosity path args = withFrozenCallStack $
+ rawSystemProc verbosity $ proc path args
+
+-- | Execute the given command with the given arguments, returning
+-- the command's exit code.
+--
+-- Create the process argument with 'Distribution.Compat.Process.proc'
+-- to ensure consistent options with other 'rawSystem' functions in this
+-- module.
+--
+rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode
+rawSystemProc verbosity cp = withFrozenCallStack $ do
+ (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return ()
return exitcode
+-- | Execute the given command with the given arguments, returning
+-- the command's exit code. 'action' is executed while the command
+-- is running, and would typically be used to communicate with the
+-- process through pipes.
+--
+-- Create the process argument with 'Distribution.Compat.Process.proc'
+-- to ensure consistent options with other 'rawSystem' functions in this
+-- module.
+--
+rawSystemProcAction :: Verbosity -> Process.CreateProcess
+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
+ -> IO (ExitCode, a)
+rawSystemProcAction verbosity cp action = withFrozenCallStack $ do
+ logCommand verbosity cp
+ (mStdin, mStdout, mStderr, p) <- Process.createProcess cp
+ a <- action mStdin mStdout mStderr
+ exitcode <- Process.waitForProcess p
+ unless (exitcode == ExitSuccess) $ do
+ let cmd = case Process.cmdspec cp of
+ Process.ShellCommand sh -> sh
+ Process.RawCommand path _args -> path
+ debug verbosity $ cmd ++ " returned " ++ show exitcode
+ return (exitcode, a)
+
+-- | fromJust for dealing with 'Maybe Handle' values as obtained via
+-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees
+-- a 'Just' value for the corresponding handle.
+--
+fromCreatePipe :: Maybe Handle -> Handle
+fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id
+
+-- | Execute the given command with the given arguments and
+-- environment, exiting with the same exit code if the command fails.
+--
rawSystemExitWithEnv :: Verbosity
-> FilePath
-> [String]
-> [(String, String)]
-> IO ()
-rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do
- printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env)
- hFlush stdout
- (_,_,_,ph) <- createProcess $
- (Process.proc path args) { Process.env = (Just env)
- , Process.delegate_ctlc = True
- }
- exitcode <- waitForProcess ph
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
- exitWith exitcode
-
--- Closes the passed in handles before returning.
+rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $
+ maybeExit $ rawSystemProc verbosity $
+ (proc path args) { Process.env = Just env
+ }
+
+-- | Execute the given command with the given arguments, returning
+-- the command's exit code.
+--
+-- Optional arguments allow setting working directory, environment
+-- and input and output handles.
+--
rawSystemIOWithEnv :: Verbosity
-> FilePath
-> [String]
@@ -792,16 +835,20 @@ rawSystemIOWithEnv :: Verbosity
-> Maybe Handle -- ^ stderr
-> IO ExitCode
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
- (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv
- (mbToStd inp) (mbToStd out) (mbToStd err)
- exitcode <- waitForProcess ph
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
- return exitcode
+ (exitcode, _) <- rawSystemIOWithEnvAndAction
+ verbosity path args mcwd menv action inp out err
+ return exitcode
where
- mbToStd :: Maybe Handle -> Process.StdStream
- mbToStd = maybe Process.Inherit Process.UseHandle
+ action = return ()
+-- | Execute the given command with the given arguments, returning
+-- the command's exit code. 'action' is executed while the command
+-- is running, and would typically be used to communicate with the
+-- process through pipes.
+--
+-- Optional arguments allow setting working directory, environment
+-- and input and output handles.
+--
rawSystemIOWithEnvAndAction
:: Verbosity
-> FilePath
@@ -814,46 +861,21 @@ rawSystemIOWithEnvAndAction
-> Maybe Handle -- ^ stderr
-> IO (ExitCode, a)
rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do
- (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv
- (mbToStd inp) (mbToStd out) (mbToStd err)
- a <- action
- exitcode <- waitForProcess ph
- unless (exitcode == ExitSuccess) $ do
- debug verbosity $ path ++ " returned " ++ show exitcode
- return (exitcode, a)
+ let cp = (proc path args) { Process.cwd = mcwd
+ , Process.env = menv
+ , Process.std_in = mbToStd inp
+ , Process.std_out = mbToStd out
+ , Process.std_err = mbToStd err
+ }
+ rawSystemProcAction verbosity cp (\_ _ _ -> action)
where
mbToStd :: Maybe Handle -> Process.StdStream
mbToStd = maybe Process.Inherit Process.UseHandle
-createProcessWithEnv ::
- Verbosity
- -> FilePath
- -> [String]
- -> Maybe FilePath -- ^ New working dir or inherit
- -> Maybe [(String, String)] -- ^ New environment or inherit
- -> Process.StdStream -- ^ stdin
- -> Process.StdStream -- ^ stdout
- -> Process.StdStream -- ^ stderr
- -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle)
- -- ^ Any handles created for stdin, stdout, or stderr
- -- with 'CreateProcess', and a handle to the process.
-createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
- printRawCommandAndArgsAndEnv verbosity path args mcwd menv
- hFlush stdout
- (inp', out', err', ph) <- createProcess $
- (Process.proc path args) {
- Process.cwd = mcwd
- , Process.env = menv
- , Process.std_in = inp
- , Process.std_out = out
- , Process.std_err = err
- , Process.delegate_ctlc = True
- }
- return (inp', out', err', ph)
-
--- | Run a command and return its output.
+-- | Execute the given command with the given arguments, returning
+-- the command's output. Exits if the command exits with error.
--
--- The output is assumed to be text in the locale encoding.
+-- Provides control over the binary/text mode of the output.
--
rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode
rawSystemStdout verbosity path args = withFrozenCallStack $ do
@@ -863,9 +885,13 @@ rawSystemStdout verbosity path args = withFrozenCallStack $ do
die' verbosity errors
return output
--- | Run a command and return its output, errors and exit status. Optionally
--- also supply some input. Also provides control over whether the binary/text
--- mode of the input and output.
+-- | Execute the given command with the given arguments, returning
+-- the command's output, errors and exit code.
+--
+-- Optional arguments allow setting working directory, environment
+-- and command input.
+--
+-- Provides control over the binary/text mode of the input and output.
--
rawSystemStdInOut :: KnownIODataMode mode
=> Verbosity
@@ -877,13 +903,16 @@ rawSystemStdInOut :: KnownIODataMode mode
-> IODataMode mode -- ^ iodata mode, acts as proxy
-> IO (mode, String, ExitCode) -- ^ output, errors, exit
rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do
- printRawCommandAndArgs verbosity path args
-
- Exception.bracket
- (runInteractiveProcess path args mcwd menv)
- (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
- $ \(inh,outh,errh,pid) -> do
-
+ let cp = (proc path args) { Process.cwd = mcwd
+ , Process.env = menv
+ , Process.std_in = Process.CreatePipe
+ , Process.std_out = Process.CreatePipe
+ , Process.std_err = Process.CreatePipe
+ }
+
+ (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do
+ let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err)
+ flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do
-- output mode depends on what the caller wants
-- but the errors are always assumed to be text (in the current locale)
hSetBinaryMode errh False
@@ -900,28 +929,26 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $
-- wait for both to finish
mberr1 <- waitCatch outA
mberr2 <- waitCatch errA
+ return (mberr1, mberr2)
- -- wait for the program to terminate
- exitcode <- waitForProcess pid
-
- -- get the stderr, so it can be added to error message
- err <- reportOutputIOError mberr2
-
- unless (exitcode == ExitSuccess) $
- debug verbosity $ path ++ " returned " ++ show exitcode
- ++ if null err then "" else
- " with error message:\n" ++ err
- ++ case input of
- Nothing -> ""
- Just d | IOData.null d -> ""
- Just (IODataText inp) -> "\nstdin input:\n" ++ inp
- Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
+ -- get the stderr, so it can be added to error message
+ err <- reportOutputIOError mberr2
- -- Check if we hit an exception while consuming the output
- -- (e.g. a text decoding error)
- out <- reportOutputIOError mberr1
-
- return (out, err, exitcode)
+ unless (exitcode == ExitSuccess) $
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ ++ if null err then "" else
+ " with error message:\n" ++ err
+ ++ case input of
+ Nothing -> ""
+ Just d | IOData.null d -> ""
+ Just (IODataText inp) -> "\nstdin input:\n" ++ inp
+ Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
+
+ -- Check if we hit an exception while consuming the output
+ -- (e.g. a text decoding error)
+ out <- reportOutputIOError mberr1
+
+ return (out, err, exitcode)
where
reportOutputIOError :: Either Exception.SomeException a -> IO a
reportOutputIOError (Right x) = return x
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 1a2a49deebaa27ea4a11ca574d42c1e50ad2a7dc..9f68b0137b1716952d852a77b263c3f328480bd8 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -98,7 +98,6 @@ library
Distribution.Client.Compat.ExecutablePath
Distribution.Client.Compat.Orphans
Distribution.Client.Compat.Prelude
- Distribution.Client.Compat.Process
Distribution.Client.Compat.Semaphore
Distribution.Client.Config
Distribution.Client.Configure
diff --git a/cabal-install/src/Distribution/Client/Compat/Process.hs b/cabal-install/src/Distribution/Client/Compat/Process.hs
deleted file mode 100644
index c8039c3e0389a77dac09d11db4804bb074e32522..0000000000000000000000000000000000000000
--- a/cabal-install/src/Distribution/Client/Compat/Process.hs
+++ /dev/null
@@ -1,48 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Compat.Process
--- Copyright : (c) 2013 Liu Hao, Brent Yorgey
--- License : BSD-style (see the file LICENSE)
---
--- Maintainer : cabal-devel@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Cross-platform utilities for invoking processes.
---
------------------------------------------------------------------------------
-
-module Distribution.Client.Compat.Process (
- readProcessWithExitCode
-) where
-
-import Prelude (FilePath, IO, String, return, (||))
-
-import Control.Exception (catch, throw)
-import System.Exit (ExitCode (ExitFailure))
-import System.IO.Error (isDoesNotExistError, isPermissionError)
-import qualified System.Process as P
-
--- | @readProcessWithExitCode@ creates an external process, reads its
--- standard output and standard error strictly, waits until the
--- process terminates, and then returns the @ExitCode@ of the
--- process, the standard output, and the standard error.
---
--- See the documentation of the version from @System.Process@ for
--- more information.
---
--- The version from @System.Process@ behaves inconsistently across
--- platforms when an executable with the given name is not found: in
--- some cases it returns an @ExitFailure@, in others it throws an
--- exception. This variant catches \"does not exist\" and
--- \"permission denied\" exceptions and turns them into
--- @ExitFailure@s.
---
--- TODO: this doesn't use 'Distrubution.Compat.Process'.
---
-readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)
-readProcessWithExitCode cmd args input =
- P.readProcessWithExitCode cmd args input
- `catch` \e -> if isDoesNotExistError e || isPermissionError e
- then return (ExitFailure 127, "", "")
- else throw e
diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs
index 4408a32d3b76a75dffd4e945526653443287a29d..3b998adb510f31485bbe72d7694328833874d7c0 100644
--- a/cabal-install/src/Distribution/Client/Init/Types.hs
+++ b/cabal-install/src/Distribution/Client/Init/Types.hs
@@ -73,7 +73,7 @@ import Language.Haskell.Extension ( Language(..), Extension )
import qualified System.IO
import qualified System.Directory as P
-import qualified System.Process as P
+import qualified System.Process as Process
import qualified Distribution.Compat.Environment as P
import System.FilePath
@@ -342,7 +342,7 @@ instance Interactive IO where
doesDirectoryExist = P.doesDirectoryExist
doesFileExist = P.doesFileExist
canonicalizePathNoThrow = P.canonicalizePathNoThrow
- readProcessWithExitCode = P.readProcessWithExitCode
+ readProcessWithExitCode = Process.readProcessWithExitCode
getEnvironment = P.getEnvironment
getCurrentYear = P.getCurrentYear
listFilesInside = P.listFilesInside
diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs
index 736e82d9b81c860c77cda59eee3ee4f2f26cb439..f93c711753ce8239bc4eb6b768eadbe8ac9ac0f9 100644
--- a/cabal-install/src/Distribution/Client/Manpage.hs
+++ b/cabal-install/src/Distribution/Client/Manpage.hs
@@ -27,15 +27,14 @@ import qualified Data.List.NonEmpty as List1
import Distribution.Client.Init.Utils (trim)
import Distribution.Client.ManpageFlags
import Distribution.Client.Setup (globalCommand)
+import Distribution.Compat.Process (proc)
import Distribution.Simple.Command
-import Distribution.Simple.Flag (fromFlagOrDefault)
+import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault)
import Distribution.Simple.Utils
- ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut )
-import qualified Distribution.Verbosity as Verbosity
+ ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction, fromCreatePipe )
import System.IO (hClose, hPutStr)
import System.Environment (lookupEnv)
import System.FilePath (takeFileName)
-
import qualified System.Process as Process
data FileInfo = FileInfo String String -- ^ path, description
@@ -69,7 +68,7 @@ manpageCmd pname commands flags
-- Feed contents into @nroff -man /dev/stdin@
(formatted, _errors, ec1) <- rawSystemStdInOut
- Verbosity.normal
+ verbosity
"nroff"
[ "-man", "/dev/stdin" ]
Nothing -- Inherit working directory
@@ -83,22 +82,17 @@ manpageCmd pname commands flags
-- 'less' is borked with color sequences otherwise
let pagerArgs = if takeFileName pager == "less" then ["-R"] else []
-- Pipe output of @nroff@ into @less@
- (Just inLess, _, _, procLess) <- createProcessWithEnv
- Verbosity.normal
- pager
- pagerArgs
- Nothing -- Inherit working directory
- Nothing -- Inherit environment
- Process.CreatePipe -- in
- Process.Inherit -- out
- Process.Inherit -- err
-
- hPutStr inLess formatted
- hClose inLess
- exitWith =<< Process.waitForProcess procLess
+ (ec2, _) <- rawSystemProcAction verbosity
+ (proc pager pagerArgs) { Process.std_in = Process.CreatePipe }
+ $ \mIn _ _ -> do
+ let wIn = fromCreatePipe mIn
+ hPutStr wIn formatted
+ hClose wIn
+ exitWith ec2
where
contents :: String
contents = manpage pname commands
+ verbosity = fromFlag $ manpageVerbosity flags
-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs
index 69e936d7691f47c6ba158a3390f327aef395116c..1ac82efcbd746a6b795ed9cdea9a0f32046a40e3 100644
--- a/cabal-install/src/Distribution/Client/SetupWrapper.hs
+++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs
@@ -87,8 +87,8 @@ import Distribution.Simple.Setup
import Distribution.Utils.Generic
( safeHead )
import Distribution.Simple.Utils
- ( die', debug, info, infoNoWrap
- , cabalVersion, tryFindPackageDesc
+ ( die', debug, info, infoNoWrap, maybeExit
+ , cabalVersion, tryFindPackageDesc, rawSystemProc
, createDirectoryIfMissingVerbose, installExecutableFile
, copyFileVerbose, rewriteFileEx, rewriteFileLBS )
import Distribution.Client.Utils
@@ -109,9 +109,8 @@ import Distribution.Compat.Stack
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>) )
import System.IO ( Handle, hPutStr )
-import Distribution.Compat.Process (createProcess)
-import System.Process ( StdStream(..), proc, waitForProcess
- , ProcessHandle )
+import Distribution.Compat.Process (proc)
+import System.Process ( StdStream(..) )
import qualified System.Process as Process
import Data.List ( foldl1' )
import Distribution.Client.Compat.ExecutablePath ( getExecutablePath )
@@ -437,34 +436,31 @@ buildTypeAction Configure = Simple.defaultMainWithHooksArgs
buildTypeAction Make = Make.defaultMainArgs
buildTypeAction Custom = error "buildTypeAction Custom"
+invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()
+invoke verbosity path args options = do
+ info verbosity $ unwords (path : args)
+ case useLoggingHandle options of
+ Nothing -> return ()
+ Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle
--- | @runProcess'@ is a version of @runProcess@ where we have
--- the additional option to decide whether or not we should
--- delegate CTRL+C to the spawned process.
-runProcess' :: FilePath -- ^ Filename of the executable
- -> [String] -- ^ Arguments to pass to executable
- -> Maybe FilePath -- ^ Optional path to working directory
- -> Maybe [(String, String)] -- ^ Optional environment
- -> Maybe Handle -- ^ Handle for @stdin@
- -> Maybe Handle -- ^ Handle for @stdout@
- -> Maybe Handle -- ^ Handle for @stderr@
- -> Bool -- ^ Delegate Ctrl+C ?
- -> IO ProcessHandle
-runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do
- (_,_,_,ph) <-
- createProcess
- (proc cmd args){ Process.cwd = mb_cwd
- , Process.env = mb_env
- , Process.std_in = mbToStd mb_stdin
- , Process.std_out = mbToStd mb_stdout
- , Process.std_err = mbToStd mb_stderr
- , Process.delegate_ctlc = _delegate
- }
- return ph
- where
- mbToStd :: Maybe Handle -> StdStream
- mbToStd Nothing = Inherit
- mbToStd (Just hdl) = UseHandle hdl
+ searchpath <- programSearchPathAsPATHVar
+ (map ProgramSearchPathDir (useExtraPathEnv options) ++
+ getProgramSearchPath (useProgramDb options))
+ env <- getEffectiveEnvironment $
+ [ ("PATH", Just searchpath)
+ , ("HASKELL_DIST_DIR", Just (useDistPref options))
+ ] ++ useExtraEnvOverrides options
+
+ let loggingHandle = case useLoggingHandle options of
+ Nothing -> Inherit
+ Just hdl -> UseHandle hdl
+ cp = (proc path args) { Process.cwd = useWorkingDir options
+ , Process.env = env
+ , Process.std_out = loggingHandle
+ , Process.std_err = loggingHandle
+ , Process.delegate_ctlc = isInteractive options
+ }
+ maybeExit $ rawSystemProc verbosity cp
-- ------------------------------------------------------------
-- * Self-Exec SetupMethod
@@ -478,83 +474,43 @@ selfExecSetupMethod verbosity options bt args0 = do
info verbosity $ "Using self-exec internal setup method with build-type "
++ show bt ++ " and args:\n " ++ show args
path <- getExecutablePath
- info verbosity $ unwords (path : args)
- case useLoggingHandle options of
- Nothing -> return ()
- Just logHandle -> info verbosity $ "Redirecting build log to "
- ++ show logHandle
-
- searchpath <- programSearchPathAsPATHVar
- (map ProgramSearchPathDir (useExtraPathEnv options) ++
- getProgramSearchPath (useProgramDb options))
- env <- getEffectiveEnvironment $
- [ ("PATH", Just searchpath)
- , ("HASKELL_DIST_DIR", Just (useDistPref options))
- ] ++ useExtraEnvOverrides options
- process <- runProcess' path args
- (useWorkingDir options) env Nothing
- (useLoggingHandle options) (useLoggingHandle options)
- (isInteractive options)
- exitCode <- waitForProcess process
- unless (exitCode == ExitSuccess) $ exitWith exitCode
+ invoke verbosity path args options
-- ------------------------------------------------------------
-- * External SetupMethod
-- ------------------------------------------------------------
externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)
-externalSetupMethod path verbosity options _ args = do
- info verbosity $ unwords (path : args)
- case useLoggingHandle options of
- Nothing -> return ()
- Just logHandle -> info verbosity $ "Redirecting build log to "
- ++ show logHandle
-
- -- See 'Note: win32 clean hack' above.
-#ifdef mingw32_HOST_OS
- if useWin32CleanHack options then doWin32CleanHack path else doInvoke path
+externalSetupMethod path verbosity options _ args =
+#ifndef mingw32_HOST_OS
+ invoke verbosity path args options
#else
- doInvoke path
-#endif
-
+ -- See 'Note: win32 clean hack' above.
+ if useWin32CleanHack options
+ then invokeWithWin32CleanHack path
+ else invoke' path
where
- doInvoke path' = do
- searchpath <- programSearchPathAsPATHVar
- (map ProgramSearchPathDir (useExtraPathEnv options) ++
- getProgramSearchPath (useProgramDb options))
- env <- getEffectiveEnvironment $
- [ ("PATH", Just searchpath)
- , ("HASKELL_DIST_DIR", Just (useDistPref options))
- ] ++ useExtraEnvOverrides options
-
- debug verbosity $ "Setup arguments: "++unwords args
- process <- runProcess' path' args
- (useWorkingDir options) env Nothing
- (useLoggingHandle options) (useLoggingHandle options)
- (isInteractive options)
- exitCode <- waitForProcess process
- unless (exitCode == ExitSuccess) $ exitWith exitCode
+ invoke' p = invoke verbosity p args options
-#ifdef mingw32_HOST_OS
- doWin32CleanHack path' = do
+ invokeWithWin32CleanHack origPath = do
info verbosity $ "Using the Win32 clean hack."
-- Recursively removes the temp dir on exit.
withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->
- bracket (moveOutOfTheWay tmpDir path')
- (maybeRestore path')
- doInvoke
-
- moveOutOfTheWay tmpDir path' = do
- let newPath = tmpDir </> "setup" <.> exeExtension buildPlatform
- Win32.moveFile path' newPath
- return newPath
-
- maybeRestore oldPath path' = do
- let oldPathDir = takeDirectory oldPath
- oldPathDirExists <- doesDirectoryExist oldPathDir
+ bracket (moveOutOfTheWay tmpDir origPath)
+ (\tmpPath -> maybeRestore origPath tmpPath)
+ (\tmpPath -> invoke' tmpPath)
+
+ moveOutOfTheWay tmpDir origPath = do
+ let tmpPath = tmpDir </> "setup" <.> exeExtension buildPlatform
+ Win32.moveFile origPath tmpPath
+ return tmpPath
+
+ maybeRestore origPath tmpPath = do
+ let origPathDir = takeDirectory origPath
+ origPathDirExists <- doesDirectoryExist origPathDir
-- 'setup clean' didn't complete, 'dist/setup' still exists.
- when oldPathDirExists $
- Win32.moveFile path' oldPath
+ when origPathDirExists $
+ Win32.moveFile tmpPath origPath
#endif
getExternalSetupMethod
diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs
index 172f6708775d20ec402a43a88c1dd07a3c22bf56..5dc4f26a122ffa301a71c82da38b5e41e7e054a5 100644
--- a/cabal-testsuite/src/Test/Cabal/Server.hs
+++ b/cabal-testsuite/src/Test/Cabal/Server.hs
@@ -226,7 +226,6 @@ startServer chan senv = do
std_out = CreatePipe,
std_err = CreatePipe
}
- -- printRawCommandAndArgsAndEnv (runnerVerbosity senv) (programPath prog) ghc_args Nothing
when (verbosity >= verbose) $
writeChan chan (ServerLogMsg AllServers (showCommandForUser (programPath prog) ghc_args))
(Just hin, Just hout, Just herr, proch) <- createProcess proc_spec
diff --git a/changelog.d/pr-7995 b/changelog.d/pr-7995
new file mode 100644
index 0000000000000000000000000000000000000000..a92ae53acd34bde7989859bbcc977ba5aa43a84c
--- /dev/null
+++ b/changelog.d/pr-7995
@@ -0,0 +1,12 @@
+synopsis: Cleanup subprocess helpers, remove obsolete functions
+packages: Cabal
+prs: #7995
+
+description: {
+
+- Distribution.Compat.Process: Remove createProcess, runInteractiveProcess
+ and rawSystem.
+- Distribution.Simple.Utils: Remove printRawCommandAndArgs,
+ printRawCommandAndArgsAndEnv and createProcessWithEnv.
+
+}