Add test for terminating "cabal run" on unix

Author: robx

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