Long running nodes

sandwich/src/Test/Sandwich/ArgParsing.hs

@@ -91,6 +91,8 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio
   <*> option auto (long "repeat" <> short 'r' <> showDefault <> help "Repeat the test N times and report how many failures occur" <> value 1 <> metavar "INT")
   <*> optional (strOption (long "fixed-root" <> help "Store test artifacts at a fixed path" <> metavar "STRING"))
   <*> optional (flag False True (long "dry-run" <> help "Skip actually launching the tests. This is useful if you want to see the set of the tests that would be run, or start them manually in the terminal UI."))
+  <*> optional (option auto (long "warn-on-long-execution-ms" <> showDefault <> help "Warn on long-running nodes by writing to a file in the run root." <> metavar "INT"))
+  <*> optional (option auto (long "cancel-on-long-execution-ms" <> showDefault <> help "Cancel long-running nodes and write to a file in the run root." <> metavar "INT"))
   <*> optional (strOption (long "markdown-summary" <> help "File path to write a Markdown summary of the results." <> metavar "STRING"))
 
   <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))
@@ -278,6 +280,8 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
         xs -> Just $ TreeFilter xs
     , optionsFormatters = finalFormatters
     , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun
+    , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs
+    , optionsCancelOnLongExecutionMs = (optionsCancelOnLongExecutionMs baseOptions) <|> optCancelOnLongExecutionMs
     }
 
   return (options, optRepeatCount)

sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs

@@ -1,6 +1,9 @@
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 
-module Test.Sandwich.Formatters.Print.CallStacks where
+module Test.Sandwich.Formatters.Print.CallStacks (
+  printCallStack
+  , printSrcLoc
+  ) where
 
 import Control.Monad
 import Control.Monad.IO.Class
@@ -20,10 +23,16 @@ printCallStack cs = forM_ (getCallStack cs) printCallStackLine
 printCallStackLine :: (
   MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
   ) => (String, SrcLoc) -> m ()
-printCallStackLine (f, (SrcLoc {..})) = do
+printCallStackLine (f, srcLoc) = do
   pic logFunctionColor f
 
   p " called at "
+  printSrcLoc srcLoc
+
+printSrcLoc :: (
+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
+  ) => SrcLoc -> m ()
+printSrcLoc (SrcLoc {..}) = do
   pc logFilenameColor srcLocFile
   p ":"
   pc logLineColor (show srcLocStartLine)

sandwich/src/Test/Sandwich/Options.hs

@@ -55,6 +55,8 @@ defaultOptions = Options {
   , optionsFormatters = [SomeFormatter defaultPrintFormatter]
   , optionsProjectRoot = Nothing
   , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False }
+  , optionsWarnOnLongExecutionMs = Nothing
+  , optionsCancelOnLongExecutionMs = Nothing
   }
 
 -- | Generate a test artifacts directory based on a timestamp.

sandwich/src/Test/Sandwich/Types/ArgParsing.hs

@@ -56,6 +56,8 @@ data CommandLineOptions a = CommandLineOptions {
   , optRepeatCount :: Int
   , optFixedRoot :: Maybe String
   , optDryRun :: Maybe Bool
+  , optWarnOnLongExecutionMs :: Maybe Int
+  , optCancelOnLongExecutionMs :: Maybe Int
   , optMarkdownSummaryPath :: Maybe FilePath
 
   , optListAvailableTests :: Maybe Bool

sandwich/src/Test/Sandwich/Types/RunTree.hs

@@ -291,9 +291,12 @@ data Options = Options {
   -- We use this hint to connect 'CallStack' paths (which are relative to the project root) to their actual path on disk.
   , optionsTestTimerType :: TestTimerType
   -- ^ Whether to enable the test timer. When the test timer is present, timing information will be emitted to the project root (if present).
+  , optionsWarnOnLongExecutionMs :: Maybe Int
+  -- ^ If set, alerts user to nodes that run for the given number of milliseconds, by writing to a file in the root directory.
+  , optionsCancelOnLongExecutionMs :: Maybe Int
+  -- ^ Same as 'optionsWarnOnLongExecutionMs', but also cancels the problematic nodes.
   }
 
-
 -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way
 -- to reliably get a callstack from an exception, but if you can throw (or catch+rethrow) this type
 -- then we'll unwrap it and present the callstack nicely.

sandwich/src/Test/Sandwich/Waits.hs

@@ -19,6 +19,7 @@ module Test.Sandwich.Waits (
   ) where
 
 import Control.Monad.IO.Unlift
+import qualified Data.List as L
 import Data.String.Interpolate
 import Data.Time
 import Data.Typeable
@@ -70,9 +71,12 @@ waitUntil' policy timeInSeconds action = do
       if
 #if MIN_VERSION_base(4,14,0)
         | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do
-            throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"
+            throwIO $ Reason (Just (popCallStackSafe callStack)) "Timeout in waitUntil"
         | Just (SyncExceptionWrapper (cast -> Just (SomeException (cast -> Just (SomeAsyncException (cast -> Just (_ :: Timeout))))))) <- cast inner -> do
-            throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"
+            throwIO $ Reason (Just (popCallStackSafe callStack)) "Timeout in waitUntil"
 #endif
         | otherwise -> do
             throwIO e
+
+popCallStackSafe :: CallStack -> CallStack
+popCallStackSafe cs = if L.null (getCallStack cs) then cs else popCallStack cs