From deb7de892335df246812acfb977bb530cafc69de Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 30 Dec 2025 23:04:13 -0700 Subject: [PATCH 1/7] Add --warn-on-long-execution-ms --- sandwich/src/Test/Sandwich/ArgParsing.hs | 2 + .../Test/Sandwich/Interpreters/StartTree.hs | 48 ++++++++++++++----- sandwich/src/Test/Sandwich/Options.hs | 1 + .../src/Test/Sandwich/Types/ArgParsing.hs | 1 + sandwich/src/Test/Sandwich/Types/RunTree.hs | 3 +- 5 files changed, 43 insertions(+), 12 deletions(-) diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs index 518da31e..1cecbcaa 100644 --- a/sandwich/src/Test/Sandwich/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/ArgParsing.hs @@ -91,6 +91,7 @@ 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 (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 +279,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do xs -> Just $ TreeFilter xs , optionsFormatters = finalFormatters , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun + , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs } return (options, optRepeatCount) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 11bf109b..0acd07fe 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -8,7 +8,6 @@ module Test.Sandwich.Interpreters.StartTree ( ) where -import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class @@ -21,10 +20,10 @@ import Data.Sequence hiding ((:>)) import qualified Data.Set as S import Data.String.Interpolate import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Time.Clock import Data.Typeable import GHC.Stack -import System.Directory import System.FilePath import System.IO import Test.Sandwich.Formatters.Print @@ -40,6 +39,9 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util +import UnliftIO.Async +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Directory import UnliftIO.Exception import UnliftIO.STM @@ -53,7 +55,7 @@ startTree node@(RunNodeBefore {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - (timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case + (timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr) return (result, mkSetupTimingInfo setupFinishTime) @@ -75,7 +77,7 @@ startTree node@(RunNodeAfter {..}) ctx' = do result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx) (do - (ret, teardownStartTime, _teardownFinishTime) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ + (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) ) @@ -88,7 +90,7 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do bracket (do let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ - timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $ + timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $ runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) ) (\(ret, setupStartTime, setupFinishTime) -> case ret of @@ -96,7 +98,7 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do Right intro -> do teardownStartTime <- getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime - (ret', _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ + (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) ) @@ -160,7 +162,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do liftIO $ writeIORef didAllocateVar True - (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $ + (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $ liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx) teardownStartTime <- liftIO getCurrentTime @@ -222,7 +224,7 @@ startTree node@(RunNodeIt {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) runTreeLabel $ + (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) runTreeLabel $ runExampleM runNodeExample ctx runTreeLogs Nothing return (results, emptyExtraTimingInfo) @@ -417,11 +419,35 @@ recordExceptionInStatus status e = do Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret _ -> Done endTime Nothing Nothing endTime ret -timed :: (MonadUnliftIO m) => Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime) -timed recordTime bc@(BaseContext {..}) label action = do +timed :: forall m a s l t. (MonadUnliftIO m) => RunNodeCommonWithStatus s l t -> Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime) +timed (RunNodeCommonWithStatus {..}) recordTime bc@(BaseContext {..}) label action = do let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id startTime <- liftIO getCurrentTime - ret <- timerFn action + + ret <- case optionsWarnOnLongExecutionMs baseContextOptions of + Nothing -> timerFn action + Just maxTimeMs -> + withAsync (warnAfterMilliseconds maxTimeMs) $ \_ -> + timerFn action endTime <- liftIO getCurrentTime pure (ret, startTime, endTime) + where + warnAfterMilliseconds :: Int -> m () + warnAfterMilliseconds ms = do + threadDelay (ms * 1000) + + whenJust baseContextRunRoot $ \runRoot -> do + let warningsDir = runRoot "long-execution-warnings" + createDirectoryIfMissing True warningsDir + let fileName = warningsDir (nodeToFolderName [i|#{runTreeId}-#{label}|] 1 0) <.> "log" + bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do + liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label} + + Ancestors: #{runTreeAncestors} + + Folder: #{runTreeFolder} + |] + whenJust runTreeLoc $ \(SrcLoc {..}) -> + liftIO $ T.hPutStrLn h [__i|Loc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule} + |] diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs index ddc0a653..86e6a642 100644 --- a/sandwich/src/Test/Sandwich/Options.hs +++ b/sandwich/src/Test/Sandwich/Options.hs @@ -55,6 +55,7 @@ defaultOptions = Options { , optionsFormatters = [SomeFormatter defaultPrintFormatter] , optionsProjectRoot = Nothing , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False } + , optionsWarnOnLongExecutionMs = Nothing } -- | Generate a test artifacts directory based on a timestamp. diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs index 3d6bc0b6..a9936577 100644 --- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs @@ -56,6 +56,7 @@ data CommandLineOptions a = CommandLineOptions { , optRepeatCount :: Int , optFixedRoot :: Maybe String , optDryRun :: Maybe Bool + , optWarnOnLongExecutionMs :: Maybe Int , optMarkdownSummaryPath :: Maybe FilePath , optListAvailableTests :: Maybe Bool diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index b40f5ff7..f6f2f731 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -291,9 +291,10 @@ 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. } - -- | 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. From 72025584764411ad1e1fb981bc6198f2fab6aa00 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 30 Dec 2025 23:21:26 -0700 Subject: [PATCH 2/7] Add --cancel-on-long-execution-ms --- sandwich/src/Test/Sandwich/ArgParsing.hs | 2 + .../Test/Sandwich/Interpreters/StartTree.hs | 62 ++++++++++++------- sandwich/src/Test/Sandwich/Options.hs | 1 + .../src/Test/Sandwich/Types/ArgParsing.hs | 1 + sandwich/src/Test/Sandwich/Types/RunTree.hs | 2 + 5 files changed, 45 insertions(+), 23 deletions(-) diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs index 1cecbcaa..a318b082 100644 --- a/sandwich/src/Test/Sandwich/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/ArgParsing.hs @@ -92,6 +92,7 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio <*> 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")) @@ -280,6 +281,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do , optionsFormatters = finalFormatters , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs + , optionsCancelOnLongExecutionMs = (optionsCancelOnLongExecutionMs baseOptions) <|> optCancelOnLongExecutionMs } return (options, optRepeatCount) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 0acd07fe..f62d29b4 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -425,29 +425,45 @@ timed (RunNodeCommonWithStatus {..}) recordTime bc@(BaseContext {..}) label acti startTime <- liftIO getCurrentTime - ret <- case optionsWarnOnLongExecutionMs baseContextOptions of - Nothing -> timerFn action - Just maxTimeMs -> - withAsync (warnAfterMilliseconds maxTimeMs) $ \_ -> - timerFn action + ret <- + withMaybeWarnOnLongExecution $ + withMaybeCancelOnLongExecution $ + timerFn action + endTime <- liftIO getCurrentTime pure (ret, startTime, endTime) where - warnAfterMilliseconds :: Int -> m () - warnAfterMilliseconds ms = do - threadDelay (ms * 1000) - - whenJust baseContextRunRoot $ \runRoot -> do - let warningsDir = runRoot "long-execution-warnings" - createDirectoryIfMissing True warningsDir - let fileName = warningsDir (nodeToFolderName [i|#{runTreeId}-#{label}|] 1 0) <.> "log" - bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do - liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label} - - Ancestors: #{runTreeAncestors} - - Folder: #{runTreeFolder} - |] - whenJust runTreeLoc $ \(SrcLoc {..}) -> - liftIO $ T.hPutStrLn h [__i|Loc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule} - |] + withMaybeWarnOnLongExecution inner = case optionsWarnOnLongExecutionMs baseContextOptions of + Nothing -> inner + Just maxTimeMs -> + flip withAsync (const inner) $ do + threadDelay (maxTimeMs * 1000) + + whenJust baseContextRunRoot $ \runRoot -> do + let warningsDir = runRoot "long-execution-warnings" + createDirectoryIfMissing True warningsDir + writeInfoToFile maxTimeMs (warningsDir (nodeToFolderName [i|#{runTreeId}-warn-#{label}|] 1 0) <.> "log") + + withMaybeCancelOnLongExecution inner = case optionsWarnOnLongExecutionMs baseContextOptions of + Nothing -> inner + Just maxTimeMs -> + race (threadDelay (maxTimeMs * 1000)) inner >>= \case + Left _ -> do + whenJust baseContextRunRoot $ \runRoot -> do + let warningsDir = runRoot "long-execution-warnings" + createDirectoryIfMissing True warningsDir + writeInfoToFile maxTimeMs (warningsDir (nodeToFolderName [i|#{runTreeId}-cancel-#{label}|] 1 0) <.> "log") + throwIO $ Reason (Just callStack) $ [i|Timed out long-running node: #{label}|] + Right x -> return x + + writeInfoToFile ms fileName = + bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do + liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label} + + Ancestors: #{runTreeAncestors} + + Folder: #{runTreeFolder} + |] + whenJust runTreeLoc $ \(SrcLoc {..}) -> + liftIO $ T.hPutStrLn h [__i|\nLoc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule} + |] diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs index 86e6a642..c27928b0 100644 --- a/sandwich/src/Test/Sandwich/Options.hs +++ b/sandwich/src/Test/Sandwich/Options.hs @@ -56,6 +56,7 @@ defaultOptions = Options { , optionsProjectRoot = Nothing , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False } , optionsWarnOnLongExecutionMs = Nothing + , optionsCancelOnLongExecutionMs = Nothing } -- | Generate a test artifacts directory based on a timestamp. diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs index a9936577..f10b7032 100644 --- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs @@ -57,6 +57,7 @@ data CommandLineOptions a = CommandLineOptions { , optFixedRoot :: Maybe String , optDryRun :: Maybe Bool , optWarnOnLongExecutionMs :: Maybe Int + , optCancelOnLongExecutionMs :: Maybe Int , optMarkdownSummaryPath :: Maybe FilePath , optListAvailableTests :: Maybe Bool diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index f6f2f731..39147ac2 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -293,6 +293,8 @@ data Options = Options { -- ^ 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 From e89db0f32abcca5d751d31fe36e2561bc59d5a35 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 30 Dec 2025 23:21:39 -0700 Subject: [PATCH 3/7] Test.Sandwich.Formatters.Print.CallStacks: tidy --- .../Test/Sandwich/Formatters/Print/CallStacks.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs b/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs index 34ff0b10..70e17d96 100644 --- a/sandwich/src/Test/Sandwich/Formatters/Print/CallStacks.hs +++ b/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) From ff7d61b74905a99d60fbe0c40cd416c9440a6726 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Tue, 30 Dec 2025 23:45:30 -0700 Subject: [PATCH 4/7] Move long running warn/cancel logic into runExampleM --- .../Test/Sandwich/Interpreters/StartTree.hs | 138 ++++++++++-------- 1 file changed, 77 insertions(+), 61 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index f62d29b4..8698b3c9 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -21,7 +21,8 @@ import qualified Data.Set as S import Data.String.Interpolate import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock +import Data.Time +import Data.Time.Clock.POSIX import Data.Typeable import GHC.Stack import System.FilePath @@ -55,7 +56,8 @@ startTree node@(RunNodeBefore {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - (timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case + let label = runTreeLabel <> " (setup)" + (timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label (runExampleM runNodeCommon label runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr) return (result, mkSetupTimingInfo setupFinishTime) @@ -77,8 +79,9 @@ startTree node@(RunNodeAfter {..}) ctx' = do result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx) (do - (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ - runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) + let label = runTreeLabel <> " (teardown)" + (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM runNodeCommon label runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) ) liftIO $ readIORef result @@ -89,17 +92,19 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) bracket (do let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) + let label = runTreeLabel <> " (setup)" flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ - timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $ - runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) + timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM' runNodeCommon label runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) ) (\(ret, setupStartTime, setupFinishTime) -> case ret of Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) Right intro -> do teardownStartTime <- getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime - (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ - runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) + let label = runTreeLabel <> " (teardown)" + (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM runNodeCommon label (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) ) (\(ret, _setupStartTime, setupFinishTime) -> do @@ -125,6 +130,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo) + let label = runTreeLabel <> " (body)" runInAsync node ctx $ do let wrappedAction = do didAllocateVar <- liftIO $ newIORef False @@ -162,7 +168,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do liftIO $ writeIORef didAllocateVar True - (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $ + (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx) teardownStartTime <- liftIO getCurrentTime @@ -185,7 +191,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do liftIO (readIORef didRunWrappedAction) >>= \case (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|], timingInfo) (Right _, timingInfo) -> return (Success, timingInfo) - runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case + runExampleM' runNodeCommon label wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case Left err -> return (Failure err, emptyExtraTimingInfo) Right x -> pure x startTree node@(RunNodeAround {..}) ctx' = do @@ -205,7 +211,7 @@ startTree node@(RunNodeAround {..}) ctx' = do (liftIO $ readIORef didRunWrappedAction) >>= \case (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|], timingInfo) (Right _, timingInfo) -> return (Success, timingInfo) - runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in around '#{runTreeLabel}' handler|]) >>= \case + runExampleM' runNodeCommon runTreeLabel wrappedAction ctx runTreeLogs (Just [i|Exception in around '#{runTreeLabel}' handler|]) >>= \case Left err -> return (Failure err, emptyExtraTimingInfo) Right x -> pure x startTree node@(RunNodeDescribe {..}) ctx' = do @@ -224,8 +230,9 @@ startTree node@(RunNodeIt {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) runTreeLabel $ - runExampleM runNodeExample ctx runTreeLogs Nothing + let label = runTreeLabel + (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM runNodeCommon label runNodeExample ctx runTreeLogs Nothing return (results, emptyExtraTimingInfo) -- * Util @@ -357,13 +364,13 @@ shouldRunChild' ctx common = case baseContextOnlyRunIds $ getBaseContext ctx of -- * Running examples -runExampleM :: HasBaseContext r => ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result -runExampleM ex ctx logs exceptionMessage = runExampleM' ex ctx logs exceptionMessage >>= \case +runExampleM :: HasBaseContext r => RunNodeCommonWithStatus s l t -> String -> ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result +runExampleM rnc label ex ctx logs exceptionMessage = runExampleM' rnc label ex ctx logs exceptionMessage >>= \case Left err -> return $ Failure err Right () -> return Success -runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a) -runExampleM' ex ctx logs exceptionMessage = do +runExampleM' :: HasBaseContext r => RunNodeCommonWithStatus s l t -> String -> ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a) +runExampleM' rnc label ex ctx logs exceptionMessage = do maybeTestDirectory <- getTestDirectory ctx let options = baseContextOptions $ getBaseContext ctx @@ -371,8 +378,10 @@ runExampleM' ex ctx logs exceptionMessage = do -- withFile will catch IOException and fill in its own information, making the -- resulting error confusing withLogFn maybeTestDirectory options $ \logFn -> - handleAny (wrapInFailureReasonIfNecessary exceptionMessage) - (Right <$> (runLoggingT (runReaderT (unExampleT ex) ctx) logFn)) + handleAny (wrapInFailureReasonIfNecessary exceptionMessage) $ + withMaybeWarnOnLongExecution (getBaseContext ctx) rnc label $ + withMaybeCancelOnLongExecution (getBaseContext ctx) rnc label $ + (Right <$> (runLoggingT (runReaderT (unExampleT ex) ctx) logFn)) where withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a @@ -420,50 +429,57 @@ recordExceptionInStatus status e = do _ -> Done endTime Nothing Nothing endTime ret timed :: forall m a s l t. (MonadUnliftIO m) => RunNodeCommonWithStatus s l t -> Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime) -timed (RunNodeCommonWithStatus {..}) recordTime bc@(BaseContext {..}) label action = do +timed _rnc recordTime bc@(BaseContext {..}) label action = do let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id startTime <- liftIO getCurrentTime - - ret <- - withMaybeWarnOnLongExecution $ - withMaybeCancelOnLongExecution $ - timerFn action - + ret <- timerFn action endTime <- liftIO getCurrentTime pure (ret, startTime, endTime) - where - withMaybeWarnOnLongExecution inner = case optionsWarnOnLongExecutionMs baseContextOptions of - Nothing -> inner - Just maxTimeMs -> - flip withAsync (const inner) $ do - threadDelay (maxTimeMs * 1000) - - whenJust baseContextRunRoot $ \runRoot -> do - let warningsDir = runRoot "long-execution-warnings" - createDirectoryIfMissing True warningsDir - writeInfoToFile maxTimeMs (warningsDir (nodeToFolderName [i|#{runTreeId}-warn-#{label}|] 1 0) <.> "log") - - withMaybeCancelOnLongExecution inner = case optionsWarnOnLongExecutionMs baseContextOptions of - Nothing -> inner - Just maxTimeMs -> - race (threadDelay (maxTimeMs * 1000)) inner >>= \case - Left _ -> do - whenJust baseContextRunRoot $ \runRoot -> do - let warningsDir = runRoot "long-execution-warnings" - createDirectoryIfMissing True warningsDir - writeInfoToFile maxTimeMs (warningsDir (nodeToFolderName [i|#{runTreeId}-cancel-#{label}|] 1 0) <.> "log") - throwIO $ Reason (Just callStack) $ [i|Timed out long-running node: #{label}|] - Right x -> return x - - writeInfoToFile ms fileName = - bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do - liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label} - - Ancestors: #{runTreeAncestors} - - Folder: #{runTreeFolder} - |] - whenJust runTreeLoc $ \(SrcLoc {..}) -> - liftIO $ T.hPutStrLn h [__i|\nLoc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule} - |] + + +withMaybeWarnOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommonWithStatus s l t -> String -> m a -> m a +withMaybeWarnOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsWarnOnLongExecutionMs baseContextOptions of + Nothing -> inner + Just maxTimeMs -> + flip withAsync (const inner) $ do + threadDelay (maxTimeMs * 1000) + + micros <- liftIO getCurrentMicrosInteger + + whenJust baseContextRunRoot $ \runRoot -> do + let dir = runRoot "long-execution-warnings" + createDirectoryIfMissing True dir + writeInfoToFile rnc maxTimeMs (dir (nodeToFolderName [i|#{micros}-#{runTreeId}-warn-#{label}|] 1 0) <.> "log") label + +withMaybeCancelOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommonWithStatus s l t -> String -> m a -> m a +withMaybeCancelOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsCancelOnLongExecutionMs baseContextOptions of + Nothing -> inner + Just maxTimeMs -> + race (threadDelay (maxTimeMs * 1000)) inner >>= \case + Left _ -> do + micros <- liftIO getCurrentMicrosInteger + whenJust baseContextRunRoot $ \runRoot -> do + let dir = runRoot "long-execution-warnings" + createDirectoryIfMissing True dir + writeInfoToFile rnc maxTimeMs (dir (nodeToFolderName [i|#{micros}-#{runTreeId}-cancel-#{label}|] 1 0) <.> "log") label + throwIO $ Reason (Just callStack) $ [i|Timed out long-running node|] + Right x -> return x + +writeInfoToFile :: MonadUnliftIO m => RunNodeCommonWithStatus s l t -> Int -> FilePath -> String -> m () +writeInfoToFile (RunNodeCommonWithStatus {..}) ms fileName label = + bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do + liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label} + + Ancestors: #{runTreeAncestors} + + Folder: #{runTreeFolder} + |] + whenJust runTreeLoc $ \(SrcLoc {..}) -> + liftIO $ T.hPutStrLn h [__i|\nLoc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule} + |] + +getCurrentMicrosInteger :: IO Integer +getCurrentMicrosInteger = do + t <- getPOSIXTime + return $ round (t * 1000000) From e32cb86730e3dab7537a88c2e8e9d58858f96f8f Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 2 Jan 2026 13:51:12 -0800 Subject: [PATCH 5/7] Using unsafeUnmask, but maybe we want to just use base's bracket --- .../Test/Sandwich/Interpreters/StartTree.hs | 24 +++++++++++++++---- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 8698b3c9..38106cf5 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -24,6 +24,7 @@ import qualified Data.Text.IO as T import Data.Time import Data.Time.Clock.POSIX import Data.Typeable +import GHC.IO (unsafeUnmask) import GHC.Stack import System.FilePath import System.IO @@ -437,13 +438,18 @@ timed _rnc recordTime bc@(BaseContext {..}) label action = do endTime <- liftIO getCurrentTime pure (ret, startTime, endTime) - withMaybeWarnOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommonWithStatus s l t -> String -> m a -> m a withMaybeWarnOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsWarnOnLongExecutionMs baseContextOptions of Nothing -> inner - Just maxTimeMs -> - flip withAsync (const inner) $ do - threadDelay (maxTimeMs * 1000) + Just maxTimeMs -> do + withAsync (waiter maxTimeMs) $ \_ -> do + inner + + where + waiter maxTimeMs = do + -- Use unsafeUnmask to make threadDelay interruptible even in masked cleanup contexts + -- (like the bracket call of an Introduce node) + liftIO $ unsafeUnmask $ threadDelay (maxTimeMs * 1000) micros <- liftIO getCurrentMicrosInteger @@ -456,7 +462,7 @@ withMaybeCancelOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCom withMaybeCancelOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsCancelOnLongExecutionMs baseContextOptions of Nothing -> inner Just maxTimeMs -> - race (threadDelay (maxTimeMs * 1000)) inner >>= \case + race (waiter maxTimeMs) inner >>= \case Left _ -> do micros <- liftIO getCurrentMicrosInteger whenJust baseContextRunRoot $ \runRoot -> do @@ -465,6 +471,14 @@ withMaybeCancelOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus { writeInfoToFile rnc maxTimeMs (dir (nodeToFolderName [i|#{micros}-#{runTreeId}-cancel-#{label}|] 1 0) <.> "log") label throwIO $ Reason (Just callStack) $ [i|Timed out long-running node|] Right x -> return x + where + waiter maxTimeMs = + -- Use unsafeUnmask to make threadDelay interruptible even in masked cleanup contexts + -- (like the bracket call of an Introduce node) + -- + -- However, this function still won't work properly on + + liftIO $ unsafeUnmask $ threadDelay (maxTimeMs * 1000) writeInfoToFile :: MonadUnliftIO m => RunNodeCommonWithStatus s l t -> Int -> FilePath -> String -> m () writeInfoToFile (RunNodeCommonWithStatus {..}) ms fileName label = From 8099a667cfc2faf3abb8a08faacb0bcfac68f504 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Fri, 2 Jan 2026 13:56:33 -0800 Subject: [PATCH 6/7] More on avoiding deadlocks and long waits --- .../Test/Sandwich/Interpreters/StartTree.hs | 80 ++++++++++--------- 1 file changed, 41 insertions(+), 39 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 38106cf5..2425b55f 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -9,6 +9,7 @@ module Test.Sandwich.Interpreters.StartTree ( import Control.Concurrent.MVar +import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift @@ -91,41 +92,46 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) - bracket (do - let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) - let label = runTreeLabel <> " (setup)" - flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ - timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ - runExampleM' runNodeCommon label runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) - ) - (\(ret, setupStartTime, setupFinishTime) -> case ret of - Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) - Right intro -> do - teardownStartTime <- getCurrentTime - addTeardownStartTimeToStatus runTreeStatus teardownStartTime - let label = runTreeLabel <> " (teardown)" - (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ - runExampleM runNodeCommon label (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) - writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) - ) - (\(ret, _setupStartTime, setupFinishTime) -> do - addSetupFinishTimeToStatus runTreeStatus setupFinishTime - case ret of - Left failureReason@(Pending {}) -> do - -- TODO: add note about failure in allocation - markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason) - Left failureReason -> do - -- TODO: add note about failure in allocation - markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason)) - Right intro -> do - -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere. - -- It would be better to track the profile at the type level - let ctxFinal = case cast intro of - Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) - Nothing -> ctx - - void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) - ) + -- The bracket from @base@ uses 'mask', while the one from @unliftio@ uses 'uninterruptibleMask'. + -- We want to err on the side of avoiding deadlocks so we use the @base@ version. + -- This also plays nicer with the 'withMaybeWarnOnLongExecution' and 'withMaybeCancelOnLongExecution' functions. + -- See the discussion at https://github.com/fpco/safe-exceptions/issues/3 + liftIO $ E.bracket + (do + let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) + let label = runTreeLabel <> " (setup)" + flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ + timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM' runNodeCommon label runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) + ) + (\(ret, setupStartTime, setupFinishTime) -> case ret of + Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) + Right intro -> do + teardownStartTime <- getCurrentTime + addTeardownStartTimeToStatus runTreeStatus teardownStartTime + let label = runTreeLabel <> " (teardown)" + (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM runNodeCommon label (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) + writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) + ) + (\(ret, _setupStartTime, setupFinishTime) -> do + addSetupFinishTimeToStatus runTreeStatus setupFinishTime + case ret of + Left failureReason@(Pending {}) -> do + -- TODO: add note about failure in allocation + markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason) + Left failureReason -> do + -- TODO: add note about failure in allocation + markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason)) + Right intro -> do + -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere. + -- It would be better to track the profile at the type level + let ctxFinal = case cast intro of + Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t }) + Nothing -> ctx + + void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal) + ) readIORef result startTree node@(RunNodeIntroduceWith {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon @@ -474,10 +480,6 @@ withMaybeCancelOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus { where waiter maxTimeMs = -- Use unsafeUnmask to make threadDelay interruptible even in masked cleanup contexts - -- (like the bracket call of an Introduce node) - -- - -- However, this function still won't work properly on - liftIO $ unsafeUnmask $ threadDelay (maxTimeMs * 1000) writeInfoToFile :: MonadUnliftIO m => RunNodeCommonWithStatus s l t -> Int -> FilePath -> String -> m () From c3e16ccda384917fba1ccc5f3cf8f592415562c1 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Sat, 3 Jan 2026 19:58:35 -0800 Subject: [PATCH 7/7] Use finally from base, like we do for bracket --- .../src/Test/Sandwich/Interpreters/StartTree.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs index 2425b55f..43019838 100644 --- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs @@ -79,13 +79,14 @@ startTree node@(RunNodeAfter {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) - finally (void $ runNodesSequentially runNodeChildren ctx) - (do - let label = runTreeLabel <> " (teardown)" - (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ - runExampleM runNodeCommon label runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) - writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) - ) + -- We use the 'finally' from @base@; see the comment below about 'bracket' + E.finally (void $ runNodesSequentially runNodeChildren ctx) + (do + let label = runTreeLabel <> " (teardown)" + (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $ + runExampleM runNodeCommon label runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) + writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) + ) liftIO $ readIORef result startTree node@(RunNodeIntroduce {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon