From 592a48e33ea2a94a65700e3156f015c2945169c1 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 2 Feb 2022 17:46:58 +0100 Subject: [PATCH 01/11] Disambiguate qualified imports --- cabal-install/src/Distribution/Client/Init/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs index 4408a32d3b7..3b998adb510 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 From eefe45d9f3e7e885fc5d0985c423fad752b60ebf Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 2 Feb 2022 17:18:47 +0100 Subject: [PATCH 02/11] Drop unused module Distribution.Client.Compat.Process --- cabal-install/cabal-install.cabal | 1 - .../src/Distribution/Client/Compat/Process.hs | 48 ------------------- 2 files changed, 49 deletions(-) delete mode 100644 cabal-install/src/Distribution/Client/Compat/Process.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 80c46e2b0c6..4237553af00 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 c8039c3e038..00000000000 --- 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 From a5986e37f45d3fca329fa2a0bf03d659b2f7354d Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Tue, 22 Feb 2022 22:01:43 +0100 Subject: [PATCH 03/11] Rework subprocess helpers - Set enable_process_jobs on a variant of System.Process.proc instead of just for System.Process.createProcess - In Distribution.Simple.Utils, only use this proc instance. - Replace use of printRawCommand* by a unified helper logCommand, and use this more consistently. The output format is changed slightly. - New helpers rawSystemProc{,Action} for use with new proc Aside from the logging changes, this should be a no-op. --- Cabal/src/Distribution/Compat/Process.hs | 20 +- Cabal/src/Distribution/Simple/Utils.hs | 281 ++++++++++++++--------- 2 files changed, 188 insertions(+), 113 deletions(-) diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index a83da2319ce..1daa0d5e3ea 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -2,6 +2,7 @@ module Distribution.Compat.Process ( -- * Redefined functions createProcess, + proc, runInteractiveProcess, rawSystem, -- * Additions @@ -11,7 +12,7 @@ module Distribution.Compat.Process ( import System.Exit (ExitCode (..)) import System.IO (Handle) -import System.Process (CreateProcess, ProcessHandle, waitForProcess) +import System.Process (CreateProcess, ProcessHandle) import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) @@ -60,6 +61,11 @@ 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) + -- | 'System.Process.createProcess' with process jobs enabled when appropriate. -- See 'enableProcessJobs'. createProcess :: CreateProcess @@ -68,10 +74,10 @@ 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 +rawSystem :: FilePath -> [String] -> IO ExitCode +rawSystem path args = do + (_,_,_,p) <- Process.createProcess (proc path args) { Process.delegate_ctlc = True } + Process.waitForProcess p -- | 'System.Process.runInteractiveProcess' with process jobs enabled when -- appropriate. See 'enableProcessJobs'. @@ -81,9 +87,9 @@ runInteractiveProcess -> 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 +runInteractiveProcess path args mb_cwd mb_env = do (mb_in, mb_out, mb_err, p) <- - createProcess (Process.proc cmd args) + Process.createProcess (proc path args) { Process.std_in = Process.CreatePipe, Process.std_out = Process.CreatePipe, Process.std_err = Process.CreatePipe, diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 7257d79116a..dd669db5e9d 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -48,12 +48,15 @@ module Distribution.Simple.Utils ( -- * running programs rawSystemExit, rawSystemExitCode, + rawSystemProc, + rawSystemProcAction, rawSystemExitWithEnv, rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, rawSystemIOWithEnvAndAction, createProcessWithEnv, + fromCreatePipe, maybeExit, xargs, findProgramVersion, @@ -183,7 +186,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 +237,8 @@ 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 System.Process (ProcessHandle) import qualified System.Process as Process import qualified GHC.IO.Exception as GHC @@ -719,16 +720,24 @@ 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 - - + exitcode <- cmd + unless (exitcode == ExitSuccess) $ exitWith exitcode printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args = withFrozenCallStack $ - printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing +printRawCommandAndArgs verbosity path args = withFrozenCallStack $ do + logCommand verbosity (proc path args) printRawCommandAndArgsAndEnv :: Verbosity -> FilePath @@ -736,52 +745,104 @@ printRawCommandAndArgsAndEnv :: Verbosity -> 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 +printRawCommandAndArgsAndEnv verbosity path args mcwd menv = withFrozenCallStack $ do + logCommand verbosity (proc path args) { Process.cwd = mcwd, Process.env = menv } + +-- | 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) { Process.delegate_ctlc = True } + +-- | 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 + , Process.delegate_ctlc = True + } + +-- | 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 +853,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,13 +879,14 @@ 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 + , Process.delegate_ctlc = True + } + rawSystemProcAction verbosity cp (\_ _ _ -> action) where mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle @@ -838,22 +904,20 @@ createProcessWithEnv :: -- ^ 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) + let cp = (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 + } + logCommand verbosity cp + Process.createProcess cp --- | 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 +927,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 +945,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 +971,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 From f972102ef3a4eb32bbfa2f03b04a4b8ef8780091 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 00:03:40 +0100 Subject: [PATCH 04/11] Default delegate_ctlc to True --- Cabal/src/Distribution/Compat/Process.hs | 4 ++-- Cabal/src/Distribution/Simple/Utils.hs | 7 ++----- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index 1daa0d5e3ea..1dde07d4351 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -64,7 +64,7 @@ enableProcessJobs cp = cp -- | '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) +proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True } -- | 'System.Process.createProcess' with process jobs enabled when appropriate. -- See 'enableProcessJobs'. @@ -76,7 +76,7 @@ createProcess = Process.createProcess . enableProcessJobs -- See 'enableProcessJobs'. rawSystem :: FilePath -> [String] -> IO ExitCode rawSystem path args = do - (_,_,_,p) <- Process.createProcess (proc path args) { Process.delegate_ctlc = True } + (_,_,_,p) <- Process.createProcess (proc path args) Process.waitForProcess p -- | 'System.Process.runInteractiveProcess' with process jobs enabled when diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index dd669db5e9d..4dec9817cac 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -777,8 +777,7 @@ rawSystemExit verbosity path args = withFrozenCallStack $ -- rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode rawSystemExitCode verbosity path args = withFrozenCallStack $ - rawSystemProc verbosity $ - (proc path args) { Process.delegate_ctlc = True } + rawSystemProc verbosity $ proc path args -- | Execute the given command with the given arguments, returning -- the command's exit code. @@ -834,7 +833,6 @@ rawSystemExitWithEnv :: Verbosity rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ maybeExit $ rawSystemProc verbosity $ (proc path args) { Process.env = Just env - , Process.delegate_ctlc = True } -- | Execute the given command with the given arguments, returning @@ -884,7 +882,6 @@ rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = w , Process.std_in = mbToStd inp , Process.std_out = mbToStd out , Process.std_err = mbToStd err - , Process.delegate_ctlc = True } rawSystemProcAction verbosity cp (\_ _ _ -> action) where @@ -909,7 +906,6 @@ createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallS , Process.std_in = inp , Process.std_out = out , Process.std_err = err - , Process.delegate_ctlc = True } logCommand verbosity cp Process.createProcess cp @@ -950,6 +946,7 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ , Process.std_in = Process.CreatePipe , Process.std_out = Process.CreatePipe , Process.std_err = Process.CreatePipe + , Process.delegate_ctlc = False -- !!! } (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do From 1969327c840a25a5cfc36f84cb5c1f20da2b1bdb Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 18 Feb 2022 20:48:29 +0100 Subject: [PATCH 05/11] Set delegate_ctlc for rawSystemStdInOut, too --- Cabal/src/Distribution/Simple/Utils.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 4dec9817cac..808cf61dcb2 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -946,7 +946,6 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ , Process.std_in = Process.CreatePipe , Process.std_out = Process.CreatePipe , Process.std_err = Process.CreatePipe - , Process.delegate_ctlc = False -- !!! } (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do From 200478ef95e4b37386b3199bb5641d60913ef8a4 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 31 Jan 2022 17:47:53 +0100 Subject: [PATCH 06/11] SetupWrapper: replace runProcess' by rawSystemProc --- .../src/Distribution/Client/SetupWrapper.hs | 148 ++++++------------ 1 file changed, 52 insertions(+), 96 deletions(-) diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 69e936d7691..1ac82efcbd7 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 From 3aa45a2d75921cca0132677019db593a0cf030f8 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 21 Jan 2022 23:59:49 +0100 Subject: [PATCH 07/11] LibV09: use rawSystemProcAction --- Cabal/src/Distribution/Simple/Test/LibV09.hs | 84 ++++++++++---------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs index 9faacefb5f8..1cf84a25e4f 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 From 9d33338c1f7e00152ac181b2cc7b1c905a5506fe Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Fri, 4 Feb 2022 15:10:09 +0100 Subject: [PATCH 08/11] manpage: use rawSystemProcAction --- .../src/Distribution/Client/Manpage.hs | 30 ++++++++----------- 1 file changed, 12 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs index 736e82d9b81..f93c711753c 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 From d5ae20cf94fbcba37eb54575934163bfad80e365 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Tue, 22 Feb 2022 23:43:25 +0100 Subject: [PATCH 09/11] Deprecate obsolete functions --- Cabal/src/Distribution/Compat/Process.hs | 10 +++++++--- Cabal/src/Distribution/Simple/Utils.hs | 10 ++++++++-- cabal-testsuite/src/Test/Cabal/Server.hs | 1 - 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index 1dde07d4351..bb66e145ce2 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -1,12 +1,13 @@ {-# LANGUAGE CPP #-} module Distribution.Compat.Process ( -- * Redefined functions - createProcess, proc, - runInteractiveProcess, - rawSystem, -- * Additions enableProcessJobs, + -- * Deprecated + createProcess, + runInteractiveProcess, + rawSystem, ) where import System.Exit (ExitCode (..)) @@ -68,12 +69,14 @@ proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_c -- | 'System.Process.createProcess' with process jobs enabled when appropriate. -- See 'enableProcessJobs'. +{-# DEPRECATED createProcess "use proc with System.Process.createProcess instead" #-} 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'. +{-# DEPRECATED rawSystem "use one of the functions exported by Distribution.Simple.Utils instead" #-} rawSystem :: FilePath -> [String] -> IO ExitCode rawSystem path args = do (_,_,_,p) <- Process.createProcess (proc path args) @@ -81,6 +84,7 @@ rawSystem path args = do -- | 'System.Process.runInteractiveProcess' with process jobs enabled when -- appropriate. See 'enableProcessJobs'. +{-# DEPRECATED runInteractiveProcess "use one of the functions exported by Distribution.Simple.Utils instead" #-} runInteractiveProcess :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) -> [String] -- ^ Arguments to pass to the executable diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 808cf61dcb2..76dca142aac 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -38,7 +38,7 @@ module Distribution.Simple.Utils ( debug, debugNoWrap, chattyTry, annotateIO, - printRawCommandAndArgs, printRawCommandAndArgsAndEnv, + logCommand, withOutputMarker, -- * exceptions @@ -55,7 +55,6 @@ module Distribution.Simple.Utils ( rawSystemStdInOut, rawSystemIOWithEnv, rawSystemIOWithEnvAndAction, - createProcessWithEnv, fromCreatePipe, maybeExit, xargs, @@ -175,6 +174,10 @@ module Distribution.Simple.Utils ( -- * FilePath stuff isAbsoluteOnAnyPlatform, isRelativeOnAnyPlatform, + + -- * Deprecated + printRawCommandAndArgs, printRawCommandAndArgsAndEnv, + createProcessWithEnv, ) where import Prelude () @@ -735,10 +738,12 @@ maybeExit cmd = do exitcode <- cmd unless (exitcode == ExitSuccess) $ exitWith exitcode +{-# DEPRECATED printRawCommandAndArgs "use logCommand" #-} printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = withFrozenCallStack $ do logCommand verbosity (proc path args) +{-# DEPRECATED printRawCommandAndArgsAndEnv "use logCommand" #-} printRawCommandAndArgsAndEnv :: Verbosity -> FilePath -> [String] @@ -888,6 +893,7 @@ rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = w mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle +{-# DEPRECATED createProcessWithEnv "use System.Process.createProcess with Distribution.Compat.Process.proc instead" #-} createProcessWithEnv :: Verbosity -> FilePath diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs index 172f6708775..5dc4f26a122 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 From 97f2c7b38df470f53b4c200bc23a2fcd14b1c72e Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 00:38:20 +0100 Subject: [PATCH 10/11] Remove newly deprecated functions --- Cabal/src/Distribution/Compat/Process.hs | 45 +----------------------- Cabal/src/Distribution/Simple/Utils.hs | 44 ----------------------- 2 files changed, 1 insertion(+), 88 deletions(-) diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index bb66e145ce2..18a1d9f53d0 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -4,16 +4,9 @@ module Distribution.Compat.Process ( proc, -- * Additions enableProcessJobs, - -- * Deprecated - createProcess, - runInteractiveProcess, - rawSystem, ) where -import System.Exit (ExitCode (..)) -import System.IO (Handle) - -import System.Process (CreateProcess, ProcessHandle) +import System.Process (CreateProcess) import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) @@ -66,39 +59,3 @@ enableProcessJobs cp = cp -- 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'. -{-# DEPRECATED createProcess "use proc with System.Process.createProcess instead" #-} -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'. -{-# DEPRECATED rawSystem "use one of the functions exported by Distribution.Simple.Utils instead" #-} -rawSystem :: FilePath -> [String] -> IO ExitCode -rawSystem path args = do - (_,_,_,p) <- Process.createProcess (proc path args) - Process.waitForProcess p - --- | 'System.Process.runInteractiveProcess' with process jobs enabled when --- appropriate. See 'enableProcessJobs'. -{-# DEPRECATED runInteractiveProcess "use one of the functions exported by Distribution.Simple.Utils instead" #-} -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 path args mb_cwd mb_env = do - (mb_in, mb_out, mb_err, p) <- - Process.createProcess (proc path 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/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 76dca142aac..1772bfac096 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, - logCommand, withOutputMarker, -- * exceptions @@ -174,10 +173,6 @@ module Distribution.Simple.Utils ( -- * FilePath stuff isAbsoluteOnAnyPlatform, isRelativeOnAnyPlatform, - - -- * Deprecated - printRawCommandAndArgs, printRawCommandAndArgsAndEnv, - createProcessWithEnv, ) where import Prelude () @@ -241,7 +236,6 @@ import Foreign.C.Error (Errno (..), ePIPE) import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) import Numeric (showFFloat) import Distribution.Compat.Process (proc) -import System.Process (ProcessHandle) import qualified System.Process as Process import qualified GHC.IO.Exception as GHC @@ -738,21 +732,6 @@ maybeExit cmd = do exitcode <- cmd unless (exitcode == ExitSuccess) $ exitWith exitcode -{-# DEPRECATED printRawCommandAndArgs "use logCommand" #-} -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args = withFrozenCallStack $ do - logCommand verbosity (proc path args) - -{-# DEPRECATED printRawCommandAndArgsAndEnv "use logCommand" #-} -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath - -> Maybe [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args mcwd menv = withFrozenCallStack $ do - logCommand verbosity (proc path args) { Process.cwd = mcwd, Process.env = menv } - -- | 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. @@ -893,29 +872,6 @@ rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = w mbToStd :: Maybe Handle -> Process.StdStream mbToStd = maybe Process.Inherit Process.UseHandle -{-# DEPRECATED createProcessWithEnv "use System.Process.createProcess with Distribution.Compat.Process.proc instead" #-} -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 - let cp = (proc path args) { Process.cwd = mcwd - , Process.env = menv - , Process.std_in = inp - , Process.std_out = out - , Process.std_err = err - } - logCommand verbosity cp - Process.createProcess cp - -- | Execute the given command with the given arguments, returning -- the command's output. Exits if the command exits with error. -- From 91fa33bd55e2090a088df34664436005efed384c Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 00:49:07 +0100 Subject: [PATCH 11/11] Add changelog --- changelog.d/pr-7995 | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 changelog.d/pr-7995 diff --git a/changelog.d/pr-7995 b/changelog.d/pr-7995 new file mode 100644 index 00000000000..a92ae53acd3 --- /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. + +}