Handle SIGTERM properly, on unix systems

Cabal/src/Distribution/Simple/Program/Run.hs

@@ -124,12 +124,10 @@ runProgramInvocation verbosity
   } = do
     pathOverride <- getExtraPathEnv envOverrides extraPath
     menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
-    exitCode <- rawSystemIOWithEnv verbosity
+    maybeExit $ rawSystemIOWithEnv verbosity
                                    path args
                                    mcwd menv
                                    Nothing Nothing Nothing
-    when (exitCode /= ExitSuccess) $
-      exitWith exitCode
 
 runProgramInvocation verbosity
   ProgramInvocation {

Cabal/src/Distribution/Simple/Utils.hs

@@ -789,9 +789,10 @@ rawSystemProcAction :: Verbosity -> Process.CreateProcess
                     -> 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
+  (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do
+    a <- action mStdin mStdout mStderr
+    exitcode <- Process.waitForProcess p
+    return (exitcode, a)
   unless (exitcode == ExitSuccess) $ do
     let cmd = case Process.cmdspec cp of
           Process.ShellCommand sh -> sh

cabal-install/cabal-install.cabal

@@ -165,6 +165,7 @@ library
         Distribution.Client.Security.HTTP
         Distribution.Client.Setup
         Distribution.Client.SetupWrapper
+        Distribution.Client.Signal
         Distribution.Client.SolverInstallPlan
         Distribution.Client.SourceFiles
         Distribution.Client.SrcDist

cabal-install/main/Main.hs

@@ -113,6 +113,8 @@ import Distribution.Client.Manpage            (manpageCmd)
 import Distribution.Client.ManpageFlags       (ManpageFlags (..))
 import Distribution.Client.Utils
          ( determineNumJobs, relaxEncodingErrors )
+import Distribution.Client.Signal
+         ( installTerminationHandler )
 import Distribution.Client.Version
          ( cabalInstallVersion )
 
@@ -170,6 +172,7 @@ import Control.Exception        (try)
 --
 main :: IO ()
 main = do
+  installTerminationHandler
   -- Enable line buffering so that we can get fast feedback even when piped.
   -- This is especially important for CI and build systems.
   hSetBuffering stdout LineBuffering

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -120,7 +120,7 @@ import Distribution.Simple.InstallDirs
          ( PathTemplate, fromPathTemplate
          , toPathTemplate, substPathTemplate, initialPathTemplateEnv )
 import Distribution.Simple.Utils
-         ( die', warn, notice, info, createDirectoryIfMissingVerbose, rawSystemIOWithEnv )
+         ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv )
 import Distribution.Client.Utils
          ( determineNumJobs )
 import Distribution.Utils.NubList
@@ -1193,8 +1193,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
         -- Run post-checkout-command if it is specified
         for_ repoGroupWithPaths $ \(repo, _, repoPath) ->
             for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do
-                exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing
-                unless (exitCode == ExitSuccess) $ exitWith exitCode
+                maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing
 
         -- But for reading we go through each 'SourceRepo' including its subdir
         -- value and have to know which path each one ended up in.

cabal-install/src/Distribution/Client/Signal.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE CPP #-}
+module Distribution.Client.Signal
+  ( installTerminationHandler
+  , Terminated(..)
+  )
+where
+
+import qualified Control.Exception as Exception
+
+#ifndef mingw32_HOST_OS
+import Control.Concurrent (myThreadId)
+import Control.Monad (void)
+import qualified System.Posix.Signals as Signals
+#endif
+
+-- | Terminated is an asynchronous exception, thrown when
+-- SIGTERM is received. It's to 'kill' what 'UserInterrupt'
+-- is to Ctrl-C.
+data Terminated = Terminated
+
+instance Exception.Exception Terminated where
+  toException = Exception.asyncExceptionToException
+  fromException = Exception.asyncExceptionFromException
+
+instance Show Terminated where
+  show Terminated = "terminated"
+
+-- | Install a signal handler that initiates a controlled shutdown on receiving
+-- SIGTERM by throwing an asynchronous exception at the main thread. Must be
+-- called from the main thread.
+--
+-- It is a noop on Windows.
+--
+installTerminationHandler :: IO ()
+
+#ifdef mingw32_HOST_OS
+
+installTerminationHandler = return ()
+
+#else
+
+installTerminationHandler = do
+  mainThreadId <- myThreadId
+  void $ Signals.installHandler
+    Signals.sigTERM
+    (Signals.CatchOnce $ Exception.throwTo mainThreadId Terminated)
+    Nothing
+
+#endif

cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs

@@ -0,0 +1,16 @@
+import Control.Concurrent (killThread, threadDelay, myThreadId)
+import Control.Exception (finally)
+import qualified System.Posix.Signals as Signal
+import System.Exit (exitFailure)
+
+main = do
+  writeFile "exe.run" "up and running"
+  mainThreadId <- myThreadId
+  Signal.installHandler Signal.sigTERM (Signal.Catch $ killThread mainThreadId) Nothing
+  sleep
+    `finally` putStrLn "exiting"
+  where
+    sleep = do
+      putStrLn "about to sleep"
+      threadDelay 10000000 -- 10s
+      putStrLn "done sleeping"

cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/RunKill.cabal

@@ -0,0 +1,9 @@
+name: RunKill
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.10
+
+executable exe
+  default-language: Haskell2010
+  build-depends: base, process, unix
+  main-is: Main.hs

cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.project

@@ -0,0 +1,2 @@
+packages: .
+

cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs

@@ -0,0 +1,61 @@
+import Test.Cabal.Prelude
+import qualified System.Process as Process
+import Control.Concurrent (threadDelay)
+import System.Directory (removeFile)
+import Control.Exception (catch, throwIO)
+import System.IO.Error (isDoesNotExistError)
+
+{-
+This test verifies that 'cabal run' terminates its
+child when it is killed. More generally, while we
+use the same code path for all child processes, this
+ensure that cabal-install cleans up after all children.
+(That might change if 'cabal run' is changed to exec(3)
+without forking in the future.)
+-}
+
+main :: IO ()
+main = cabalTest $ do
+  skipIfWindows -- test project relies on Posix
+
+  dir <- fmap testCurrentDir getTestEnv
+  let runFile = dir </> "exe.run"
+  liftIO $ removeFile runFile `catchNoExist` return ()
+
+  cabal_raw_action ["v2-build", "exe"] (\_ -> return ())
+  r <- fails $ cabal_raw_action ["v2-run", "exe"] $ \cabalHandle -> do
+    -- wait for "cabal run" to have started "exe"
+    waitFile total runFile
+    -- then kill "cabal run"
+    Process.terminateProcess cabalHandle
+
+  -- "exe" should exit, and should have been interrupted before
+  -- finishing its sleep
+  assertOutputContains "exiting" r
+  assertOutputDoesNotContain "done sleeping" r
+
+  where
+    catchNoExist action handle =
+      action `catch`
+        (\e -> if isDoesNotExistError e then handle else throwIO e)
+    waitFile totalWait f
+      | totalWait <= 0 = error "waitFile timed out"
+      | otherwise      = readFile f `catchNoExist` do
+                           threadDelay delta
+                           waitFile (totalWait - delta) f
+    delta = 50000 -- 0.05s
+    total = 10000000 -- 10s
+
+cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result
+cabal_raw_action args action = do
+    configured_prog <- requireProgramM cabalProgram
+    env <- getTestEnv
+    r <- liftIO $ runAction (testVerbosity env)
+                 (Just (testCurrentDir env))
+                 (testEnvironment env)
+                 (programPath configured_prog)
+                 args
+                 Nothing
+                 action
+    recordLog r
+    requireSuccess r

cabal-testsuite/src/Test/Cabal/Run.hs

@@ -2,6 +2,7 @@
 -- | A module for running commands in a chatty way.
 module Test.Cabal.Run (
     run,
+    runAction,
     Result(..)
 ) where
 
@@ -24,8 +25,14 @@ data Result = Result
 
 -- | Run a command, streaming its output to stdout, and return a 'Result'
 -- with this information.
-run :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String] -> Maybe String -> IO Result
-run _verbosity mb_cwd env_overrides path0 args input = do
+run :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String]
+    -> Maybe String -> IO Result
+run verbosity mb_cwd env_overrides path0 args input =
+    runAction verbosity mb_cwd env_overrides path0 args input (\_ -> return ())
+
+runAction :: Verbosity -> Maybe FilePath -> [(String, Maybe String)] -> FilePath -> [String]
+    -> Maybe String -> (ProcessHandle -> IO ()) -> IO Result
+runAction _verbosity mb_cwd env_overrides path0 args input action = do
     -- In our test runner, we allow a path to be relative to the
     -- current directory using the same heuristic as shells:
     -- 'foo' refers to an executable in the PATH, but './foo'
@@ -71,6 +78,8 @@ run _verbosity mb_cwd env_overrides path0 args input = do
           Nothing -> error "No stdin handle when input was specified!"
       Nothing -> return ()
 
+    action procHandle
+
     -- wait for the program to terminate
     exitcode <- waitForProcess procHandle
     out <- wait sync

changelog.d/pr-7921

@@ -0,0 +1,11 @@
+synopsis: Terminate subprocesses when killed
+packages: Cabal
+prs: #7921
+issues: #7914
+
+description: {
+
+- cabal (and 'cabal run' in particular) no longer leaves children running
+  when it is killed (unix)
+
+}