diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index b75fb1361a4..924df377d76 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -46,7 +46,8 @@ library filepath >= 1.3.0.1 && < 1.5, pretty >= 1.1.1 && < 1.2, process >= 1.1.0.2 && < 1.7, - time >= 1.4.0.1 && < 1.12 + time >= 1.4.0.1 && < 1.12, + signal if flag(bundled-binary-generic) build-depends: binary >= 0.5.1.1 && < 0.7 diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs index 7d02ba9fe59..13a1095470f 100644 --- a/Cabal/src/Distribution/Compat/Process.hs +++ b/Cabal/src/Distribution/Compat/Process.hs @@ -6,10 +6,13 @@ module Distribution.Compat.Process ( rawSystem, -- * Additions enableProcessJobs, + cleanUpProcessOnInterrupt, ) where +import Control.Monad (forM_) import System.Exit (ExitCode (..)) import System.IO (Handle) +import System.Signal import System.Process (CreateProcess, ProcessHandle) import qualified System.Process as Process @@ -54,13 +57,23 @@ createProcess = Process.createProcess . enableProcessJobs rawSystem :: String -> [String] -> IO ExitCode rawSystem cmd args = do #if MIN_VERSION_process(1,2,0) - (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } + pp@(_, _, _, p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } + cleanUpProcessOnInterrupt pp waitForProcess p #else -- With very old 'process', just do its rawSystem Process.rawSystem cmd args #endif + +-- | Installs signal handlers to clean up the process on interrupt of: +-- - '[sigINT, sigTERM]' +cleanUpProcessOnInterrupt :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () +cleanUpProcessOnInterrupt (stdin, stdout, stderr, p) = + forM_ [sigINT, sigTERM] $ \sig -> + installHandler sig (\_ -> Process.cleanupProcess (stdin, stdout, stderr, p)) + + -- | 'System.Process.runInteractiveProcess' with process jobs enabled when -- appropriate. See 'enableProcessJobs'. runInteractiveProcess diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 15514b7abec..e41be85fb8f 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -237,7 +237,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 Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess, cleanUpProcessOnInterrupt) import System.Process ( ProcessHandle , showCommandForUser, waitForProcess) @@ -800,8 +800,10 @@ 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 + pp@(_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv (mbToStd inp) (mbToStd out) (mbToStd err) + cleanUpProcessOnInterrupt pp + exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode @@ -897,6 +899,7 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ (runInteractiveProcess path args mcwd menv) (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) $ \(inh,outh,errh,pid) -> do + cleanUpProcessOnInterrupt (Just inh,Just outh,Just errh,pid) -- output mode depends on what the caller wants -- but the errors are always assumed to be text (in the current locale)