Terminate child processes on sigINT/sigTERM etc

Author: hasufell

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

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:
+--     - '[sigABRT, sigFPE, sigILL, sigINT, sigSEGV, sigTERM]'
+cleanUpProcessOnInterrupt :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
+cleanUpProcessOnInterrupt (stdin, stdout, stderr, p) = 
+  forM_ [sigABRT, sigFPE, sigILL, sigINT, sigSEGV, sigTERM] $ \sig ->
+    installHandler sig (\_ -> Process.cleanupProcess (stdin, stdout, stderr, p))
+
+
 -- | 'System.Process.runInteractiveProcess' with process jobs enabled when
 -- appropriate. See 'enableProcessJobs'.
 runInteractiveProcess

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)