--test-suite-timeout-grace

DanBurton · DanBurton · commit 0ff25850e0da · 2026-04-03T18:58:22.000-07:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -23,6 +23,10 @@ Other enhancements:
 * Add option `--reach <packages>` to Stack's `dot` and `ls dependencies`
   commands, to prune packages that cannot reach any of the specified packages in
   the dependency graph.
+* Add option `--test-suite-timeout-grace ARG` (and corresponding non-project
+  configuration key `test-suite-timeout-grace`) to pair with
+  `--test-suite-timeout ARG` and perform staged timeout termination for test
+  suites.
 
 Bug fixes:
 
diff --git a/doc/commands/bench_command.md b/doc/commands/bench_command.md
@@ -17,6 +17,7 @@ stack bench [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS]
             [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty]
             [--[no-]test] [--[no-]rerun-tests] [--ta|--test-arguments TEST_ARGS]
             [--coverage] [--[no-]run-tests] [--test-suite-timeout ARG]
+            [--test-suite-timeout-grace ARG]
             [--[no-]tests-allow-stdin] [--[no-]bench]
             [--ba|--benchmark-arguments BENCH_ARGS] [--[no-]run-benchmarks]
             [--[no-]reconfigure] [--cabal-verbosity VERBOSITY |
diff --git a/doc/commands/build_command.md b/doc/commands/build_command.md
@@ -18,6 +18,7 @@ stack build [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS]
             [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty]
             [--[no-]test] [--[no-]rerun-tests] [--ta|--test-arguments TEST_ARGS]
             [--coverage] [--[no-]run-tests] [--test-suite-timeout ARG]
+            [--test-suite-timeout-grace ARG]
             [--[no-]tests-allow-stdin] [--[no-]bench]
             [--ba|--benchmark-arguments BENCH_ARGS] [--[no-]run-benchmarks]
             [--[no-]reconfigure] [--cabal-verbosity VERBOSITY |
diff --git a/doc/commands/haddock_command.md b/doc/commands/haddock_command.md
@@ -17,7 +17,8 @@ stack haddock [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS]
               [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty]
               [--[no-]test] [--[no-]rerun-tests]
               [--ta|--test-arguments TEST_ARGS] [--coverage] [--[no-]run-tests]
-              [--test-suite-timeout ARG] [--[no-]tests-allow-stdin]
+              [--test-suite-timeout ARG] [--test-suite-timeout-grace ARG]
+              [--[no-]tests-allow-stdin]
               [--[no-]bench] [--ba|--benchmark-arguments BENCH_ARGS]
               [--[no-]run-benchmarks] [--[no-]reconfigure]
               [--cabal-verbosity VERBOSITY | --[no-]cabal-verbose]
diff --git a/doc/commands/install_command.md b/doc/commands/install_command.md
@@ -17,7 +17,8 @@ stack install [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS]
               [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty]
               [--[no-]test] [--[no-]rerun-tests]
               [--ta|--test-arguments TEST_ARGS] [--coverage] [--[no-]run-tests]
-              [--test-suite-timeout ARG] [--[no-]tests-allow-stdin]
+              [--test-suite-timeout ARG] [--test-suite-timeout-grace ARG]
+              [--[no-]tests-allow-stdin]
               [--[no-]bench] [--ba|--benchmark-arguments BENCH_ARGS]
               [--[no-]run-benchmarks] [--[no-]reconfigure]
               [--cabal-verbosity VERBOSITY | --[no-]cabal-verbose]
diff --git a/doc/commands/test_command.md b/doc/commands/test_command.md
@@ -17,6 +17,7 @@ stack test [TARGET] [--dry-run] [--pedantic] [--fast] [--ghc-options OPTIONS]
             [--[no-]keep-going] [--[no-]keep-tmp-files] [--[no-]force-dirty]
             [--[no-]test] [--[no-]rerun-tests] [--ta|--test-arguments TEST_ARGS]
             [--coverage] [--[no-]run-tests] [--test-suite-timeout ARG]
+            [--test-suite-timeout-grace ARG]
             [--[no-]tests-allow-stdin] [--[no-]bench]
             [--ba|--benchmark-arguments BENCH_ARGS] [--[no-]run-benchmarks]
             [--[no-]reconfigure] [--cabal-verbosity VERBOSITY |
diff --git a/doc/configure/yaml/non-project.md b/doc/configure/yaml/non-project.md
@@ -214,6 +214,10 @@ build:
     additional-args: []
     coverage: false
     no-run-tests: false
+    # Maximum test suite run time in seconds.
+    test-suite-timeout:
+    # Grace period in seconds after test-suite-timeout before force kill.
+    test-suite-timeout-grace:
   bench: false
   benchmark-opts:
 
diff --git a/src/Stack/Build/ExecutePackage.hs b/src/Stack/Build/ExecutePackage.hs
@@ -68,6 +68,8 @@ import           Stack.Build.ExecuteEnv
                    ( ExcludeTHLoading (..), ExecuteEnv (..), KeepOutputOpen (..)
                    , OutputType (..), withSingleContext
                    )
+import           Stack.Build.TestSuiteTimeout
+                   ( forceKill, prepareForEscalation, terminateGracefully )
 import           Stack.Build.Source ( addUnlistedToBuildCache )
 import           Stack.Config.ConfigureScript ( ensureConfigureScript )
 import           Stack.ConfigureOpts
@@ -1156,13 +1158,47 @@ singleTest topts testsToRun ac ee task installedMap = do
                         )
                         createSource
                       OTLogFile _ h -> Nothing <$ useHandleOpen h
-                    optionalTimeout action
+                    runOutput p =
+                      case (getStdout p, getStderr p) of
+                        (Nothing, Nothing) -> pure ()
+                        (Just x, Just y) -> concurrently_ x y
+                        (x, y) -> assert False $
+                          concurrently_
+                            (fromMaybe (pure ()) x)
+                            (fromMaybe (pure ()) y)
+                    timeoutWithGrace p maxSecs graceSecs = do
+                      mExit <- timeout (maxSecs * 1000000) (waitExitCode p)
+                      case mExit of
+                        Just ec -> pure (Just ec)
+                        Nothing -> do
+                          terminateGracefully p
+                          mGraceExit <- timeout (graceSecs * 1000000)
+                            (waitExitCode p)
+                          case mGraceExit of
+                            Just _ -> pure Nothing
+                            Nothing -> do
+                              forceKill p
+                              void $ waitExitCode p
+                              pure Nothing
+                    runWithTimeout pc
+                      | Just maxSecs <- topts.maximumTimeSeconds, maxSecs > 0
+                      , Just graceSecs <- topts.timeoutGraceSeconds
+                      , graceSecs > 0 =
+                          withProcessWait (prepareForEscalation pc) $ \p -> do
+                            (_, mec') <- concurrently
+                              (runOutput p)
+                              (timeoutWithGrace p maxSecs graceSecs)
+                            pure mec'
                       | Just maxSecs <- topts.maximumTimeSeconds, maxSecs > 0 =
-                          timeout (maxSecs * 1000000) action
-                      | otherwise = Just <$> action
+                          timeout (maxSecs * 1000000) $
+                            withProcessWait pc $ \p -> do
+                              runOutput p
+                              waitExitCode p
+                      | otherwise =
+                          Just <$> withProcessWait pc (\p -> runOutput p *> waitExitCode p)
 
                 mec <- withWorkingDir (toFilePath pkgDir) $
-                  optionalTimeout $ proc (toFilePath exePath) args $ \pc0 -> do
+                  proc (toFilePath exePath) args $ \pc0 -> do
                     changeStdin <-
                       if isTestTypeLib
                         then do
@@ -1185,15 +1221,7 @@ singleTest topts testsToRun ac ee task installedMap = do
                            $ setStdout output
                            $ setStderr output
                              pc0
-                    withProcessWait pc $ \p -> do
-                      case (getStdout p, getStderr p) of
-                        (Nothing, Nothing) -> pure ()
-                        (Just x, Just y) -> concurrently_ x y
-                        (x, y) -> assert False $
-                          concurrently_
-                            (fromMaybe (pure ()) x)
-                            (fromMaybe (pure ()) y)
-                      waitExitCode p
+                    runWithTimeout pc
                 -- Add a trailing newline, incase the test
                 -- output didn't finish with a newline.
                 case outputType of
diff --git a/src/Stack/BuildOpts.hs b/src/Stack/BuildOpts.hs
@@ -74,6 +74,7 @@ defaultTestOpts = TestOpts
   , coverage = defaultFirstFalse toMonoid.coverage
   , runTests = defaultFirstTrue toMonoid.runTests
   , maximumTimeSeconds = Nothing
+  , timeoutGraceSeconds = Nothing
   , allowStdin = defaultFirstTrue toMonoid.allowStdin
   }
  where
diff --git a/src/Stack/Config/Build.hs b/src/Stack/Config/Build.hs
@@ -135,6 +135,10 @@ testOptsFromMonoid toMonoid madditional = defaultTestOpts
       fromFirst
         defaultTestOpts.maximumTimeSeconds
         toMonoid.maximumTimeSeconds
+  , TestOpts.timeoutGraceSeconds =
+      fromFirst
+        defaultTestOpts.timeoutGraceSeconds
+        toMonoid.timeoutGraceSeconds
   , TestOpts.allowStdin = fromFirstTrue toMonoid.allowStdin
   }
 
diff --git a/src/Stack/Options/TestParser.hs b/src/Stack/Options/TestParser.hs
@@ -47,6 +47,11 @@ testOptsParser hide0 = TestOptsMonoid
         <> help "Maximum test suite run time in seconds."
         <> hide
         ))
+  <*> optionalFirst (option (fmap Just auto)
+        (  long "test-suite-timeout-grace"
+        <> help "Grace period in seconds after timeout before force termination."
+        <> hide
+        ))
   <*> firstBoolFlagsTrue
         "tests-allow-stdin"
         "allow standard input in test suites."
diff --git a/src/Stack/Types/BuildOpts.hs b/src/Stack/Types/BuildOpts.hs
@@ -115,6 +115,8 @@ data TestOpts = TestOpts
   , coverage :: !Bool -- ^ Generate a code coverage report
   , runTests :: !Bool -- ^ Enable running of tests
   , maximumTimeSeconds :: !(Maybe Int) -- ^ test suite timeout in seconds
+  , timeoutGraceSeconds :: !(Maybe Int)
+    -- ^ additional grace period after timeout before force-killing
   , allowStdin :: !Bool -- ^ Whether to allow standard input
   }
   deriving (Eq, Show)
diff --git a/src/Stack/Types/BuildOptsMonoid.hs b/src/Stack/Types/BuildOptsMonoid.hs
@@ -274,6 +274,7 @@ data TestOptsMonoid = TestOptsMonoid
   , coverage :: !FirstFalse
   , runTests :: !FirstTrue
   , maximumTimeSeconds :: !(First (Maybe Int))
+  , timeoutGraceSeconds :: !(First (Maybe Int))
   , allowStdin :: !FirstTrue
   }
   deriving (Show, Generic)
@@ -285,13 +286,15 @@ instance FromJSON (WithJSONWarnings TestOptsMonoid) where
     coverage <- FirstFalse <$> o ..:? coverageArgName
     runTests <- FirstTrue . (not <$>) <$> o ..:? noRunTestsArgName
     maximumTimeSeconds <- First <$> o ..:? maximumTimeSecondsArgName
+    timeoutGraceSeconds <- First <$> o ..:? timeoutGraceSecondsArgName
     allowStdin <- FirstTrue <$> o ..:? testsAllowStdinName
     pure TestOptsMonoid
       { rerunTests
       , additionalArgs
       , coverage
       , runTests
       , maximumTimeSeconds
+      , timeoutGraceSeconds
       , allowStdin
       }
 
@@ -310,6 +313,9 @@ noRunTestsArgName = "no-run-tests"
 maximumTimeSecondsArgName :: Text
 maximumTimeSecondsArgName = "test-suite-timeout"
 
+timeoutGraceSecondsArgName :: Text
+timeoutGraceSecondsArgName = "test-suite-timeout-grace"
+
 testsAllowStdinName :: Text
 testsAllowStdinName = "tests-allow-stdin"
 
diff --git a/src/unix/Stack/Build/TestSuiteTimeout.hs b/src/unix/Stack/Build/TestSuiteTimeout.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+Module      : Stack.Build.TestSuiteTimeout
+Description : OS-specific test suite timeout termination helpers.
+License     : BSD-3-Clause
+-}
+
+module Stack.Build.TestSuiteTimeout
+  ( prepareForEscalation
+  , terminateGracefully
+  , forceKill
+  ) where
+
+import           RIO.Process ( ProcessConfig, setNewSession )
+import qualified RIO.Process as RP ( Process, unsafeProcessHandle )
+import           Stack.Prelude
+import           System.Posix.Signals
+                   ( sigKILL, sigTERM, signalProcess, signalProcessGroup )
+import qualified System.Process as Process
+
+prepareForEscalation :: ProcessConfig stdin stdout stderr -> ProcessConfig stdin stdout stderr
+prepareForEscalation = setNewSession True
+
+terminateGracefully :: RP.Process stdin stdout stderr -> RIO env ()
+terminateGracefully p = do
+  let processHandle = RP.unsafeProcessHandle p
+  mpid <- liftIO $ Process.getPid processHandle
+  forM_ mpid $ \pid -> do
+    -- In a new session, the initial pid is also the process group id.
+    void $ tryAny $ liftIO $ signalProcessGroup sigTERM pid
+    void $ tryAny $ liftIO $ signalProcess sigTERM pid
+
+forceKill :: RP.Process stdin stdout stderr -> RIO env ()
+forceKill p = do
+  let processHandle = RP.unsafeProcessHandle p
+  mpid <- liftIO $ Process.getPid processHandle
+  forM_ mpid $ \pid -> do
+    void $ tryAny $ liftIO $ signalProcessGroup sigKILL pid
+    void $ tryAny $ liftIO $ signalProcess sigKILL pid
diff --git a/src/windows/Stack/Build/TestSuiteTimeout.hs b/src/windows/Stack/Build/TestSuiteTimeout.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+{-|
+Module      : Stack.Build.TestSuiteTimeout
+Description : OS-specific test suite timeout termination helpers.
+License     : BSD-3-Clause
+-}
+
+module Stack.Build.TestSuiteTimeout
+  ( prepareForEscalation
+  , terminateGracefully
+  , forceKill
+  ) where
+
+import           RIO.Process ( ProcessConfig )
+import qualified RIO.Process as RP ( Process, unsafeProcessHandle )
+import           Stack.Prelude
+import qualified System.Process as Process
+
+prepareForEscalation :: ProcessConfig stdin stdout stderr -> ProcessConfig stdin stdout stderr
+prepareForEscalation = id
+
+terminateGracefully :: RP.Process stdin stdout stderr -> RIO env ()
+terminateGracefully p =
+  void $ tryAny $ liftIO $ Process.terminateProcess $ RP.unsafeProcessHandle p
+
+forceKill :: RP.Process stdin stdout stderr -> RIO env ()
+forceKill p =
+  void $ tryAny $ liftIO $ Process.terminateProcess $ RP.unsafeProcessHandle p
diff --git a/stack.cabal b/stack.cabal
diff --git a/tests/integration/tests/6867-timeout-grace/Main.hs b/tests/integration/tests/6867-timeout-grace/Main.hs
@@ -0,0 +1,34 @@
+import Data.Char (toLower)
+import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.List (isInfixOf)
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+import StackTest
+import Control.Monad (unless)
+
+main :: IO ()
+main = do
+  start <- getCurrentTime
+  errRef <- newIORef ""
+  stackErrStderr
+    [ "test"
+    , "--test-suite-timeout", "1"
+    , "--test-suite-timeout-grace", "1"
+    ]
+    (writeIORef errRef)
+  end <- getCurrentTime
+  err <- readIORef errRef
+
+  let errLower = map toLower err
+      elapsedSecs :: Double
+      elapsedSecs = realToFrac (diffUTCTime end start)
+
+  unless ("timed out" `isInfixOf` errLower) $
+    error "Expected test-suite timeout message in stderr output."
+
+  if isWindows
+    then unless (elapsedSecs < 5.0) $
+      error $ "Expected timeout+grace run to finish quickly on Windows, took "
+        ++ show elapsedSecs ++ "s"
+    else unless (elapsedSecs > 1.5 && elapsedSecs < 5.0) $
+      error $ "Expected timeout+grace run to take about timeout+grace on Unix, took "
+        ++ show elapsedSecs ++ "s"
diff --git a/tests/integration/tests/6867-timeout-grace/files/package.yaml b/tests/integration/tests/6867-timeout-grace/files/package.yaml
@@ -0,0 +1,17 @@
+name: timeout-grace-fixture
+version: 0.1.0.0
+license: BSD-3-Clause
+
+ghc-options:
+- -Wall
+
+tests:
+  timeout-grace-fixture-test:
+    main: Main.hs
+    source-dirs: test
+    dependencies:
+    - base
+    when:
+    - condition: '!os(windows)'
+      dependencies:
+      - unix
diff --git a/tests/integration/tests/6867-timeout-grace/files/stack.yaml b/tests/integration/tests/6867-timeout-grace/files/stack.yaml
@@ -0,0 +1,3 @@
+snapshot: lts-24.24
+packages:
+- .
diff --git a/tests/integration/tests/6867-timeout-grace/files/test/Main.hs b/tests/integration/tests/6867-timeout-grace/files/test/Main.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+
+module Main (main) where
+
+import Control.Concurrent (threadDelay)
+
+#ifndef mingw32_HOST_OS
+import System.Posix.Signals (Handler (Ignore), installHandler, sigTERM)
+#endif
+
+main :: IO ()
+main = do
+#ifndef mingw32_HOST_OS
+  _ <- installHandler sigTERM Ignore Nothing
+#endif
+  threadDelay 6000000
diff --git a/tests/integration/tests/6867-timeout-grace/files/timeout-grace-fixture.cabal b/tests/integration/tests/6867-timeout-grace/files/timeout-grace-fixture.cabal
diff --git a/tests/unit/Stack/ConfigSpec.hs b/tests/unit/Stack/ConfigSpec.hs

Original file line number	Diff line number	Diff line change
`@@ -74,6 +74,7 @@ defaultTestOpts = TestOpts`
`74`	`74`	`, coverage = defaultFirstFalse toMonoid.coverage`
`75`	`75`	`, runTests = defaultFirstTrue toMonoid.runTests`
`76`	`76`	`, maximumTimeSeconds = Nothing`
	`77`	`+ , timeoutGraceSeconds = Nothing`
`77`	`78`	`, allowStdin = defaultFirstTrue toMonoid.allowStdin`
`78`	`79`	`}`
`79`	`80`	`where`