--test-suite-timeout-grace

.stan.toml

@@ -151,7 +151,7 @@
 
 # Anti-pattern: Data.ByteString.Char8.pack
 [[ignore]]
-  id = "OBS-STAN-0203-tuE+RG-250:24"
+  id = "OBS-STAN-0203-tuE+RG-252:24"
 # ✦ Description:   Usage of 'pack' function that doesn't handle Unicode characters
 # ✦ Category:      #AntiPattern
 # ✦ File:          src\Stack\Build\ExecutePackage.hs
@@ -269,7 +269,7 @@
 
 # Anti-pattern: unsafe functions
 [[ignore]]
-  id = "OBS-STAN-0212-FNS1cF-80:14"
+  id = "OBS-STAN-0212-FNS1cF-81:14"
 # ✦ Description:   Usage of unsafe functions breaks referential transparency
 # ✦ Category:      #Unsafe #AntiPattern
 # ✦ File:          src\Stack\BuildOpts.hs
@@ -280,7 +280,7 @@
 
 # Anti-pattern: unsafe functions
 [[ignore]]
-  id = "OBS-STAN-0212-FNS1cF-91:15"
+  id = "OBS-STAN-0212-FNS1cF-92:15"
 # ✦ Description:   Usage of unsafe functions breaks referential transparency
 # ✦ Category:      #Unsafe #AntiPattern
 # ✦ File:          src/Stack/BuildOpts.hs

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:
 

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 |

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 |
@@ -826,6 +827,16 @@ suite in a timeout so that the test suite fails if no result is available within
 the specified number of seconds. The option is ignored if the number of seconds
 is not positive.
 
+### `--test-suite-timeout-grace` option
+
+Default: None
+
+`stack build --test --test-suite-timeout=<seconds> --test-suite-timeout-grace=<seconds>`
+uses staged timeout termination for each running test suite: after
+`--test-suite-timeout` is reached, Stack waits the specified grace period before
+force termination. The option is ignored if the number of seconds is not
+positive.
+
 ## Flags affecting GHC's behaviour
 
 ### `--[no-]executable-profiling` flag

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]

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]

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 |

doc/configure/yaml/non-project.md

@@ -216,6 +216,9 @@ build:
     no-run-tests: false
     # The option is ignored if the specified number of seconds is not positive:
     test-suite-timeout: 0
+    # Grace period in seconds after test-suite-timeout before force kill.
+    # Ignored if not positive, or if test-suite-timeout is not positive.
+    test-suite-timeout-grace: 0
   bench: false
   benchmark-opts:
 

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

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

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
   }
 

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."

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)

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"
 

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

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

tests/integration/tests/6867-timeout-grace/Main.hs

@@ -0,0 +1,38 @@
+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
+  stack ["test", "--no-run-tests"] -- pre-build to avoid counting build time in the test
+
+  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)
+
+  logInfo $ "Elapsed time: " ++ show elapsedSecs ++ "s"
+
+  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"