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

   1 import Test.Cabal.Prelude
   2 import qualified System.Process as Process
   3 import Control.Concurrent (threadDelay)
   4 import System.Directory (removeFile)
   5 import Control.Exception (catch, throwIO)
   6 import System.IO.Error (isDoesNotExistError)
   7 import qualified Data.Time.Clock as Time
   8 import qualified Data.Time.Format as Time
   9
  10 {-
  11 This test verifies that 'cabal run' terminates its
  12 child when it is killed. More generally, while we
  13 use the same code path for all child processes, this
  14 ensure that cabal-install cleans up after all children.
  15 (That might change if 'cabal run' is changed to exec(3)
  16 without forking in the future.)
  17 -}
  18
  19 main :: IO ()
  20 main = do
  21   skipIfWindows "depends on `unix`"
  22   cabalTest $ do
  23     -- timestamped logging to aid with #8416
  24     let logIO msg = do
  25           ts <- Time.getCurrentTime
  26           let tsfmt = Time.formatTime Time.defaultTimeLocale "%H:%M:%S.%q" ts
  27           putStrLn $ tsfmt <> " [cabal.test] " <> msg
  28         log = liftIO . logIO
  29
  30     dir <- fmap testCurrentDir getTestEnv
  31     let runFile = dir </> "exe.run"
  32     liftIO $ removeFile runFile `catchNoExist` return ()
  33
  34     log "about to v2-build"
  35     cabal_raw_action ["v2-build", "exe"] (\_ -> return ())
  36     log "about to v2-run"
  37     r <- fails $ cabal_raw_action ["v2-run", "exe"] $ \cabalHandle -> do
  38       -- wait for "cabal run" to have started "exe"
  39       logIO "about to wait for file"
  40       waitFile total runFile
  41       -- then kill "cabal run"
  42       logIO "about to terminate cabal"
  43       Process.terminateProcess cabalHandle
  44     log "v2-run done"
  45
  46     -- "exe" should exit, and should have been interrupted before
  47     -- finishing its sleep
  48     assertOutputContains "exiting" r
  49     assertOutputDoesNotContain "done sleeping" r
  50
  51   where
  52     catchNoExist action handle =
  53       action `catch`
  54         (\e -> if isDoesNotExistError e then handle else throwIO e)
  55     waitFile totalWait f
  56       | totalWait <= 0 = error "waitFile timed out"
  57       | otherwise      = readFile f `catchNoExist` do
  58                            threadDelay delta
  59                            waitFile (totalWait - delta) f
  60     delta = 50000 -- 0.05s
  61     total = 10000000 -- 10s
  62
  63 cabal_raw_action :: [String] -> (Process.ProcessHandle -> IO ()) -> TestM Result
  64 cabal_raw_action args action = do
  65     configured_prog <- requireProgramM cabalProgram
  66     env <- getTestEnv
  67     r <- liftIO $ runAction (testVerbosity env)
  68                  (Just $ testCurrentDir env)
  69                  (testEnvironment env)
  70                  (programPath configured_prog)
  71                  args
  72                  Nothing
  73                  action
  74     recordLog r
  75     requireSuccess r