From 67092dab6d50daead1135cd6ef577cf3e8452c2e Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 14:39:14 +0100 Subject: [PATCH 1/5] Use maybeExit in more places --- Cabal/src/Distribution/Simple/Program/Run.hs | 4 +--- cabal-install/src/Distribution/Client/ProjectConfig.hs | 5 ++--- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index 91ab9691bee..66ab3ac82a7 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/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 { diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index eb87215bd7b..2680707f411 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/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. From 0284bfbec393b0d1f74ebbb935e331029dc21c73 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Thu, 3 Feb 2022 13:52:34 +0100 Subject: [PATCH 2/5] Use Process.withCreateProcess to ensure child cleanup --- Cabal/src/Distribution/Simple/Utils.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 1772bfac096..8ad4fc3119e 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/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 From a03b4a79e09eebb76da6fc65825750ba708d69fa Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Sat, 22 Jan 2022 00:58:54 +0100 Subject: [PATCH 3/5] Handle SIGTERM by throwing an asynchronous exception That's roughly how Ctrl-C (SIGINT) is handled by the GHC runtime. This way, killing cabal via SIGTERM will give it a chance to terminate any running children. Previously, it would exit directly, leaving children behind to exit on their own. --- cabal-install/cabal-install.cabal | 1 + cabal-install/main/Main.hs | 3 ++ .../src/Distribution/Client/Signal.hs | 49 +++++++++++++++++++ 3 files changed, 53 insertions(+) create mode 100644 cabal-install/src/Distribution/Client/Signal.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index c9c7966e2c4..eea40b9f917 100644 --- a/cabal-install/cabal-install.cabal +++ b/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 diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index 7c812aece35..6e65f7bab9e 100644 --- a/cabal-install/main/Main.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/Signal.hs b/cabal-install/src/Distribution/Client/Signal.hs new file mode 100644 index 00000000000..726fd8cbcc3 --- /dev/null +++ b/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 From d2172d8963a7a8c7af20972f0e485dc683f91785 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 18:24:51 +0100 Subject: [PATCH 4/5] Add test for terminating "cabal run" on unix --- .../NewBuild/CmdRun/Terminate/Main.hs | 16 +++++ .../NewBuild/CmdRun/Terminate/RunKill.cabal | 9 +++ .../NewBuild/CmdRun/Terminate/cabal.project | 2 + .../NewBuild/CmdRun/Terminate/cabal.test.hs | 61 +++++++++++++++++++ cabal-testsuite/src/Test/Cabal/Run.hs | 13 +++- 5 files changed, 99 insertions(+), 2 deletions(-) create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/RunKill.cabal create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.project create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/Main.hs new file mode 100644 index 00000000000..9bd494ca9a2 --- /dev/null +++ b/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" diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/RunKill.cabal b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/RunKill.cabal new file mode 100644 index 00000000000..dd13e1ecf74 --- /dev/null +++ b/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 diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.project b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.project new file mode 100644 index 00000000000..b764c340a62 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.project @@ -0,0 +1,2 @@ +packages: . + diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdRun/Terminate/cabal.test.hs new file mode 100644 index 00000000000..b0fcc2466dc --- /dev/null +++ b/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 diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 8f0171a2e4c..5ebcf8971e3 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/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 From aa4f0ad3cbb7000d145296afa82004625c2c8e6f Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Wed, 23 Feb 2022 23:39:37 +0100 Subject: [PATCH 5/5] Add changelog --- changelog.d/pr-7921 | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 changelog.d/pr-7921 diff --git a/changelog.d/pr-7921 b/changelog.d/pr-7921 new file mode 100644 index 00000000000..3eeb4e8d979 --- /dev/null +++ b/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) + +}