diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index 24fc0c861c1..ea1404dbbdc 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -1,12 +1,17 @@ {-# LANGUAGE CPP #-} module Distribution.Compat.Process ( -- * Redefined functions - proc, + createProcess, + runInteractiveProcess, + rawSystem, -- * Additions enableProcessJobs, ) where -import System.Process (CreateProcess) +import System.Exit (ExitCode (..)) +import System.IO (Handle) + +import System.Process (CreateProcess, ProcessHandle, waitForProcess) import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) @@ -55,7 +60,35 @@ enableProcessJobs cp = cp -- process redefinitions ------------------------------------------------------------------------------- --- | '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 } +-- | '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 diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs index 1cf84a25e4f..9faacefb5f8 100644 --- a/Cabal/src/Distribution/Simple/Test/LibV09.hs +++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs @@ -41,8 +41,7 @@ import System.Directory , setCurrentDirectory ) import System.FilePath ( (), (<.>) ) import System.IO ( hClose, hPutStr ) -import Distribution.Compat.Process (proc) -import qualified System.Process as Process +import System.Process (StdStream(..), createPipe, waitForProcess) runTest :: PD.PackageDescription -> LBI.LocalBuildInfo @@ -79,48 +78,49 @@ 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) <- 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 + (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 -- 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 6bf0729410a..dc5d535fe51 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -38,6 +38,7 @@ module Distribution.Simple.Utils ( debug, debugNoWrap, chattyTry, annotateIO, + printRawCommandAndArgs, printRawCommandAndArgsAndEnv, withOutputMarker, -- * exceptions @@ -47,14 +48,12 @@ module Distribution.Simple.Utils ( -- * running programs rawSystemExit, rawSystemExitCode, - rawSystemProc, - rawSystemProcAction, rawSystemExitWithEnv, rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, rawSystemIOWithEnvAndAction, - fromCreatePipe, + createProcessWithEnv, maybeExit, xargs, findProgramVersion, @@ -184,7 +183,7 @@ import qualified Distribution.Utils.IOData as IOData import Distribution.ModuleName as ModuleName import Distribution.System import Distribution.Version -import Distribution.Compat.Async (waitCatch, withAsyncNF) +import Distribution.Compat.Async import Distribution.Compat.CopyFile import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Internal.TempFile @@ -229,7 +228,10 @@ 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 (proc) +import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) +import System.Process + ( ProcessHandle + , showCommandForUser, waitForProcess) import qualified System.Process as Process import qualified GHC.IO.Exception as GHC @@ -706,95 +708,50 @@ 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 - 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 - --- | Execute the given command with the given arguments, exiting --- with the same exit code if the command fails. --- + 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 $ - maybeExit $ rawSystemExitCode verbosity path args +rawSystemExit 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 + exitWith exitcode --- | 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 $ - 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 - (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do - a <- action mStdin mStdout mStderr - exitcode <- Process.waitForProcess p - return (exitcode, a) +rawSystemExitCode verbosity path args = withFrozenCallStack $ do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args 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 + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode -- | Execute the given command with the given arguments and -- environment, exiting with the same exit code if the command fails. @@ -804,17 +761,19 @@ rawSystemExitWithEnv :: Verbosity -> [String] -> [(String, String)] -> IO () -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. --- +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. rawSystemIOWithEnv :: Verbosity -> FilePath -> [String] @@ -825,20 +784,16 @@ rawSystemIOWithEnv :: Verbosity -> Maybe Handle -- ^ stderr -> IO ExitCode rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (exitcode, _) <- rawSystemIOWithEnvAndAction - verbosity path args mcwd menv action inp out err - return exitcode + (_,_,_,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 where - action = return () + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle --- | 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 @@ -851,21 +806,46 @@ rawSystemIOWithEnvAndAction -> Maybe Handle -- ^ stderr -> IO (ExitCode, a) rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - 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) + (_,_,_,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) where mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle --- | Execute the given command with the given arguments, returning --- the command's output. Exits if the command exits with error. +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. -- --- Provides control over the binary/text mode of the output. +-- The output is assumed to be text in the locale encoding. -- rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode rawSystemStdout verbosity path args = withFrozenCallStack $ do @@ -875,13 +855,9 @@ rawSystemStdout verbosity path args = withFrozenCallStack $ do die' verbosity errors return 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. +-- | 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. -- rawSystemStdInOut :: KnownIODataMode mode => Verbosity @@ -893,16 +869,13 @@ 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 - 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 + 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 + -- output mode depends on what the caller wants -- but the errors are always assumed to be text (in the current locale) hSetBinaryMode errh False @@ -919,26 +892,28 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ -- wait for both to finish mberr1 <- waitCatch outA mberr2 <- waitCatch errA - return (mberr1, mberr2) - -- get the stderr, so it can be added to error message - err <- reportOutputIOError mberr2 + -- wait for the program to terminate + exitcode <- waitForProcess pid - 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) + -- 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 + + -- 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/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index 36d32a89977..d3ec10c8eea 100644 --- a/cabal-install/src/Distribution/Client/Init/Types.hs +++ b/cabal-install/src/Distribution/Client/Init/Types.hs @@ -72,7 +72,7 @@ import Language.Haskell.Extension ( Language(..), Extension ) import qualified System.IO import qualified System.Directory as P -import qualified System.Process as Process +import qualified System.Process as P import qualified Distribution.Compat.Environment as P import System.FilePath import Distribution.FieldGrammar.Newtypes (SpecLicense) @@ -342,7 +342,7 @@ instance Interactive IO where doesDirectoryExist = P.doesDirectoryExist doesFileExist = P.doesFileExist canonicalizePathNoThrow = P.canonicalizePathNoThrow - readProcessWithExitCode = Process.readProcessWithExitCode + readProcessWithExitCode = P.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 f93c711753c..736e82d9b81 100644 --- a/cabal-install/src/Distribution/Client/Manpage.hs +++ b/cabal-install/src/Distribution/Client/Manpage.hs @@ -27,14 +27,15 @@ 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 (fromFlag, fromFlagOrDefault) +import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Simple.Utils - ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction, fromCreatePipe ) + ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut ) +import qualified Distribution.Verbosity as Verbosity 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 @@ -68,7 +69,7 @@ manpageCmd pname commands flags -- Feed contents into @nroff -man /dev/stdin@ (formatted, _errors, ec1) <- rawSystemStdInOut - verbosity + Verbosity.normal "nroff" [ "-man", "/dev/stdin" ] Nothing -- Inherit working directory @@ -82,17 +83,22 @@ 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@ - (ec2, _) <- rawSystemProcAction verbosity - (proc pager pagerArgs) { Process.std_in = Process.CreatePipe } - $ \mIn _ _ -> do - let wIn = fromCreatePipe mIn - hPutStr wIn formatted - hClose wIn - exitWith ec2 + (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 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 1ac82efcbd7..69e936d7691 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, maybeExit - , cabalVersion, tryFindPackageDesc, rawSystemProc + ( die', debug, info, infoNoWrap + , cabalVersion, tryFindPackageDesc , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) import Distribution.Client.Utils @@ -109,8 +109,9 @@ import Distribution.Compat.Stack import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) -import Distribution.Compat.Process (proc) -import System.Process ( StdStream(..) ) +import Distribution.Compat.Process (createProcess) +import System.Process ( StdStream(..), proc, waitForProcess + , ProcessHandle ) import qualified System.Process as Process import Data.List ( foldl1' ) import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) @@ -436,31 +437,34 @@ 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 - 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 +-- | @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 -- ------------------------------------------------------------ -- * Self-Exec SetupMethod @@ -474,43 +478,83 @@ 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 - invoke verbosity path args options + 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 -- ------------------------------------------------------------ -- * External SetupMethod -- ------------------------------------------------------------ externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) -externalSetupMethod path verbosity options _ args = -#ifndef mingw32_HOST_OS - invoke verbosity path args options -#else +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. - if useWin32CleanHack options - then invokeWithWin32CleanHack path - else invoke' path +#ifdef mingw32_HOST_OS + if useWin32CleanHack options then doWin32CleanHack path else doInvoke path +#else + doInvoke path +#endif + where - invoke' p = invoke verbosity p args options + 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 - invokeWithWin32CleanHack origPath = do +#ifdef mingw32_HOST_OS + doWin32CleanHack path' = 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 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 + 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 -- 'setup clean' didn't complete, 'dist/setup' still exists. - when origPathDirExists $ - Win32.moveFile tmpPath origPath + when oldPathDirExists $ + Win32.moveFile path' oldPath #endif getExternalSetupMethod diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index 450c6f660c7..01be0dbe6e7 100644 --- a/cabal-testsuite/src/Test/Cabal/Server.hs +++ b/cabal-testsuite/src/Test/Cabal/Server.hs @@ -226,6 +226,7 @@ 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 deleted file mode 100644 index a92ae53acd3..00000000000 --- a/changelog.d/pr-7995 +++ /dev/null @@ -1,12 +0,0 @@ -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. - -}