From f8ddeb7db86350887b7f3520f62f3dbb804e2a09 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 26 Feb 2026 15:25:30 -0800
Subject: [PATCH 01/41] Add --tui-debug option to run a debug socket

---
 sandwich/package.yaml                         |  1 +
 sandwich/sandwich.cabal                       |  8 ++++-
 sandwich/src/Test/Sandwich/ArgParsing.hs      |  6 +++-
 .../Test/Sandwich/Formatters/TerminalUI.hs    | 25 +++++++++++--
 .../Formatters/TerminalUI/DebugSocket.hs      | 36 +++++++++++++++++++
 .../Sandwich/Formatters/TerminalUI/Types.hs   |  4 +++
 .../src/Test/Sandwich/Types/ArgParsing.hs     |  1 +
 7 files changed, 77 insertions(+), 4 deletions(-)
 create mode 100644 sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index 5be75eb9..9012085a 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -44,6 +44,7 @@ dependencies:
 - monad-control
 - monad-logger
 - mtl
+- network
 - optparse-applicative
 - pretty-show
 - process
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index 8031b3bf..68855600 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.38.0.
+-- This file has been generated from package.yaml by hpack version 0.39.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -59,6 +59,7 @@ library
       Test.Sandwich.Formatters.Print.Util
       Test.Sandwich.Formatters.TerminalUI.AttrMap
       Test.Sandwich.Formatters.TerminalUI.CrossPlatform
+      Test.Sandwich.Formatters.TerminalUI.DebugSocket
       Test.Sandwich.Formatters.TerminalUI.Draw
       Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar
       Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes
@@ -128,6 +129,7 @@ library
     , monad-control
     , monad-logger
     , mtl
+    , network
     , optparse-applicative
     , pretty-show
     , process
@@ -190,6 +192,7 @@ executable sandwich-demo
     , monad-control
     , monad-logger
     , mtl
+    , network
     , optparse-applicative
     , pretty-show
     , process
@@ -250,6 +253,7 @@ executable sandwich-discover
     , monad-control
     , monad-logger
     , mtl
+    , network
     , optparse-applicative
     , pretty-show
     , process
@@ -316,6 +320,7 @@ executable sandwich-test
     , monad-control
     , monad-logger
     , mtl
+    , network
     , optparse-applicative
     , pretty-show
     , process
@@ -383,6 +388,7 @@ test-suite sandwich-test-suite
     , monad-control
     , monad-logger
     , mtl
+    , network
     , optparse-applicative
     , pretty-show
     , process
diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index a318b082..ffb910e3 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -94,6 +94,7 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio
   <*> 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"))
+  <*> switch (long "tui-debug" <> help "Enable TUI debug socket at <test-root>/tui-debug.sock")
 
   <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))
   <*> optional (flag False True (long "list-tests-json" <> help "List individual test modules in JSON format"))
@@ -253,7 +254,10 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
           printFormatter
         (_, TUI) ->
           let mainTerminalUiFormatter = headMay [x | SomeFormatter (cast -> Just x@(TerminalUIFormatter {})) <- optionsFormatters baseOptions]
-          in SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) { terminalUILogLevel = optLogLevel }
+          in SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) {
+            terminalUILogLevel = optLogLevel
+            , terminalUIDebugSocket = optTuiDebugSocket
+            }
         (_, Print) -> printFormatter
         (_, PrintFailures) -> failureReportFormatter
         (_, Silent) -> silentFormatter
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
index 54e0eaf0..0e3b6185 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -16,6 +16,7 @@ module Test.Sandwich.Formatters.TerminalUI (
   , terminalUIDefaultEditor
   , terminalUIOpenInEditor
   , terminalUICustomExceptionFormatters
+  , terminalUIDebugSocket
 
   -- * Auxiliary types
   , InitialFolding(..)
@@ -36,6 +37,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Logger hiding (logError)
 import Control.Monad.Trans
 import Control.Monad.Trans.State hiding (get, put)
+import qualified Data.ByteString.Char8 as BS8
 import Data.Either
 import Data.Foldable
 import qualified Data.List as L
@@ -43,6 +45,7 @@ import Data.Maybe
 import qualified Data.Sequence as Seq
 import qualified Data.Set as S
 import Data.String.Interpolate
+import Data.Text (Text)
 import Data.Time
 import qualified Data.Vector as Vec
 import GHC.Stack
@@ -52,6 +55,7 @@ import Lens.Micro
 import Safe
 import System.FilePath
 import Test.Sandwich.Formatters.TerminalUI.AttrMap
+import Test.Sandwich.Formatters.TerminalUI.DebugSocket
 import Test.Sandwich.Formatters.TerminalUI.CrossPlatform
 import Test.Sandwich.Formatters.TerminalUI.Draw
 import Test.Sandwich.Formatters.TerminalUI.Filter
@@ -85,6 +89,13 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
 
   (rtsFixed, initialSomethingRunning) <- liftIO $ atomically $ runStateT (mapM fixRunTree' rts) False
 
+  -- Create debug channel for optional debug socket server
+  debugChan <- liftIO $ newBroadcastTChanIO
+  let debugFn :: Text -> IO ()
+      debugFn msg = do
+        now <- getCurrentTime
+        atomically $ writeTChan debugChan (BS8.pack [i|#{formatTime defaultTimeLocale "%H:%M:%S%3Q" now} #{msg}\n|])
+
   let initialState = updateFilteredTree $
         AppState {
           _appRunTreeBase = rts
@@ -105,8 +116,8 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
           , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds
           , _appShowLogSizes = terminalUIShowLogSizes
 
-          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())
-          , _appDebug = (const $ return ())
+          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor debugFn
+          , _appDebug = debugFn
           , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters
         }
 
@@ -117,12 +128,15 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
   currentFixedTree <- liftIO $ newTVarIO rtsFixed
   let eventAsync = liftIO $ forever $ do
         handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do
+          debugFn "eventAsync: waiting for tree change"
           (newFixedTree, somethingRunning) <- atomically $ flip runStateT False $ do
             currentFixed <- lift $ readTVar currentFixedTree
             newFixed <- mapM fixRunTree' rts
             when (fmap getCommons newFixed == fmap getCommons currentFixed) (lift retry)
             lift $ writeTVar currentFixedTree newFixed
             return newFixed
+          let nodeCount = length $ concatMap getCommons newFixedTree
+          debugFn [i|eventAsync: tree changed, nodes=#{nodeCount} somethingRunning=#{somethingRunning}|]
           writeBChan eventChan (RunTreeUpdated newFixedTree somethingRunning)
           threadDelay terminalUIRefreshPeriod
 
@@ -136,10 +150,17 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
 
   let updateCurrentTimeForever period = forever $ do
         now <- getCurrentTime
+        debugFn "CurrentTimeUpdated tick"
         writeBChan eventChan (CurrentTimeUpdated now)
         threadDelay period
 
+  -- Optionally start the debug socket server in the test tree root
+  let withDebugSocket = case (terminalUIDebugSocket, baseContextRunRoot baseContext) of
+        (True, Just runRoot) -> \action -> withAsync (debugSocketServer (runRoot </> "tui-debug.sock") debugChan) (\_ -> action)
+        _ -> id
+
   liftIO $
+    withDebugSocket $
     (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> withAsync (updateCurrentTimeForever ts) (\_ -> action)) $
     withAsync eventAsync $ \_ ->
     void $ customMain initialVty buildVty (Just eventChan) app initialState
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs
new file mode 100644
index 00000000..74eed796
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs
@@ -0,0 +1,36 @@
+module Test.Sandwich.Formatters.TerminalUI.DebugSocket (
+  debugSocketServer
+  ) where
+
+import Control.Concurrent.Async
+import Control.Concurrent.STM
+import Control.Monad
+import Data.ByteString (ByteString)
+import Network.Socket
+import Network.Socket.ByteString (sendAll)
+import System.Directory (removeFile)
+import UnliftIO.Exception
+
+
+-- | Debug socket server that accepts connections and broadcasts events.
+-- Connect with @nc -U \<path\>@ to receive line-oriented debug events.
+debugSocketServer :: FilePath -> TChan ByteString -> IO ()
+debugSocketServer socketPath chan = do
+  -- Clean up any existing socket file
+  removeFile socketPath `catch` \(_ :: IOError) -> return ()
+
+  bracket (socket AF_UNIX Stream defaultProtocol) close $ \sock -> do
+    bind sock (SockAddrUnix socketPath)
+    listen sock 5
+    forever $ do
+      (conn, _) <- accept sock
+      -- Spawn a thread to handle this connection
+      void $ async $ handleConnection conn
+  where
+    handleConnection conn = do
+      -- Duplicate the channel so this client gets its own read position
+      chan' <- atomically $ dupTChan chan
+      -- Send events until error (client disconnect)
+      handle (\(_ :: IOError) -> close conn) $ forever $ do
+        msg <- atomically $ readTChan chan'
+        sendAll conn msg
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Types.hs
index 496f00ee..53ea3a04 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Types.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Types.hs
@@ -55,6 +55,9 @@ data TerminalUIFormatter = TerminalUIFormatter {
   -- It's also passed a debug callback that accepts a 'T.Text'; messages logged with this function will go into the formatter logs.
   , terminalUICustomExceptionFormatters :: CustomExceptionFormatters
   -- ^ Custom exception formatters, used to nicely format custom exception types.
+  , terminalUIDebugSocket :: Bool
+  -- ^ If True, create a Unix socket at @\<test-root\>/tui-debug.sock@ for debug output.
+  -- Connect with @nc -U \<path\>@ to receive line-oriented debug events about the TUI event loop.
   }
 
 instance Show TerminalUIFormatter where
@@ -81,6 +84,7 @@ defaultTerminalUIFormatter = TerminalUIFormatter {
   , terminalUIDefaultEditor = Just "emacsclient +$((LINE+1)):COLUMN --no-wait"
   , terminalUIOpenInEditor = autoOpenInEditor
   , terminalUICustomExceptionFormatters = []
+  , terminalUIDebugSocket = False
   }
 
 type CustomExceptionFormatters = [SomeException -> Maybe CustomTUIException]
diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
index f10b7032..3c11ac9c 100644
--- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
@@ -59,6 +59,7 @@ data CommandLineOptions a = CommandLineOptions {
   , optWarnOnLongExecutionMs :: Maybe Int
   , optCancelOnLongExecutionMs :: Maybe Int
   , optMarkdownSummaryPath :: Maybe FilePath
+  , optTuiDebugSocket :: Bool
 
   , optListAvailableTests :: Maybe Bool
   , optListAvailableTestsJson :: Maybe Bool

From 4cf90e954158daab167b0c35e264807a407d7c49 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 27 Feb 2026 16:03:31 -0800
Subject: [PATCH 02/41] Initial socket formatter

---
 sandwich/package.yaml                         |   1 +
 sandwich/sandwich.cabal                       |   3 +
 sandwich/src/Test/Sandwich/ArgParsing.hs      |  24 +-
 .../src/Test/Sandwich/Formatters/Socket.hs    |  73 ++++++
 .../Sandwich/Formatters/Socket/Commands.hs    | 243 ++++++++++++++++++
 .../Test/Sandwich/Formatters/Socket/Server.hs |  65 +++++
 .../src/Test/Sandwich/Types/ArgParsing.hs     |   1 +
 7 files changed, 406 insertions(+), 4 deletions(-)
 create mode 100644 sandwich/src/Test/Sandwich/Formatters/Socket.hs
 create mode 100644 sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
 create mode 100644 sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index 9012085a..f08591c8 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -87,6 +87,7 @@ library:
   - Test.Sandwich.Formatters.LogSaver
   - Test.Sandwich.Formatters.Print
   - Test.Sandwich.Formatters.Silent
+  - Test.Sandwich.Formatters.Socket
   - Test.Sandwich.Formatters.TerminalUI
   - Test.Sandwich.Internal
   - Test.Sandwich.TH
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index 68855600..5ad2ee48 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -38,6 +38,7 @@ library
       Test.Sandwich.Formatters.LogSaver
       Test.Sandwich.Formatters.Print
       Test.Sandwich.Formatters.Silent
+      Test.Sandwich.Formatters.Socket
       Test.Sandwich.Formatters.TerminalUI
       Test.Sandwich.Internal
       Test.Sandwich.TH
@@ -57,6 +58,8 @@ library
       Test.Sandwich.Formatters.Print.PrintPretty
       Test.Sandwich.Formatters.Print.Types
       Test.Sandwich.Formatters.Print.Util
+      Test.Sandwich.Formatters.Socket.Commands
+      Test.Sandwich.Formatters.Socket.Server
       Test.Sandwich.Formatters.TerminalUI.AttrMap
       Test.Sandwich.Formatters.TerminalUI.CrossPlatform
       Test.Sandwich.Formatters.TerminalUI.DebugSocket
diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index ffb910e3..7c8fd8af 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -19,6 +19,7 @@ import Test.Sandwich.Formatters.FailureReport
 import Test.Sandwich.Formatters.MarkdownSummary
 import Test.Sandwich.Formatters.Print.Types
 import Test.Sandwich.Formatters.Silent
+import Test.Sandwich.Formatters.Socket
 import Test.Sandwich.Formatters.TerminalUI
 import Test.Sandwich.Formatters.TerminalUI.Types
 import Test.Sandwich.Internal.Running
@@ -95,6 +96,7 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio
   <*> 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"))
   <*> switch (long "tui-debug" <> help "Enable TUI debug socket at <test-root>/tui-debug.sock")
+  <*> switch (long "socket" <> help "Enable interactive socket formatter at <test-root>/socket.sock")
 
   <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))
   <*> optional (flag False True (long "list-tests-json" <> help "List individual test modules in JSON format"))
@@ -263,11 +265,12 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
         (_, Silent) -> silentFormatter
 
   -- Strip out any "main" formatters since the options control that
-  let baseFormatters = optionsFormatters baseOptions
-                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath
-                     & filter (not . isMainFormatter)
+  baseFormatters <- optionsFormatters baseOptions
+                    & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath
+                    & tryAddSocketFormatter optSocketFormatter
+  let baseFormatters' = filter (not . isMainFormatter) baseFormatters
 
-  let finalFormatters = baseFormatters <> [mainFormatter]
+  let finalFormatters = baseFormatters' <> [mainFormatter]
                       & fmap (setVisibilityThreshold optVisibilityThreshold)
 
   let options = baseOptions {
@@ -322,3 +325,16 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
     tryAddMarkdownSummaryFormatter (Just path) xs
       | L.any isMarkdownSummaryFormatter xs = fmap (setMarkdownSummaryFormatterPath path) xs
       | otherwise = (SomeFormatter (defaultMarkdownSummaryFormatter path)) : xs
+
+    isSocketFormatter :: SomeFormatter -> Bool
+    isSocketFormatter (SomeFormatter x) = case cast x of
+      Just (_ :: SocketFormatter) -> True
+      Nothing -> False
+
+    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO [SomeFormatter]
+    tryAddSocketFormatter False xs = return xs
+    tryAddSocketFormatter True xs
+      | L.any isSocketFormatter xs = return xs
+      | otherwise = do
+          sf <- defaultSocketFormatter
+          return $ (SomeFormatter sf) : xs
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket.hs b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
new file mode 100644
index 00000000..397afbd1
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
@@ -0,0 +1,73 @@
+-- | The socket formatter creates a Unix domain socket that accepts interactive,
+-- line-based commands to query the live test tree state.
+--
+-- This is a "secondary formatter," i.e. one that can run in the background while
+-- a "primary formatter" (such as the TerminalUI or Print formatters) runs in the
+-- foreground.
+--
+-- The socket server stays alive for the entire duration of the test executable,
+-- so you can query it even after tests have completed (until 'finalizeFormatter'
+-- cleans it up).
+--
+-- Connect with @socat - UNIX-CONNECT:\<run-root\>/socket.sock@ and type
+-- @help@ to see available commands.
+
+module Test.Sandwich.Formatters.Socket (
+  defaultSocketFormatter
+  , SocketFormatter(..)
+  ) where
+
+import Control.Concurrent.Async
+import Control.Monad.IO.Class
+import Data.IORef
+import Data.Typeable
+import System.FilePath
+import Test.Sandwich.Formatters.Socket.Server
+import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)
+import Test.Sandwich.Types.ArgParsing
+import Test.Sandwich.Types.RunTree
+
+
+data SocketFormatter = SocketFormatter {
+  socketFormatterPath :: Maybe FilePath
+  -- ^ Socket path. Nothing = \<run-root\>/socket.sock
+  , socketFormatterServerAsync :: IORef (Maybe (Async ()))
+  -- ^ Internal: handle to the running server thread, used for cleanup.
+  } deriving (Typeable)
+
+instance Show SocketFormatter where
+  show (SocketFormatter {socketFormatterPath}) =
+    "SocketFormatter {socketFormatterPath = " <> show socketFormatterPath <> "}"
+
+defaultSocketFormatter :: IO SocketFormatter
+defaultSocketFormatter = do
+  ref <- newIORef Nothing
+  return SocketFormatter {
+    socketFormatterPath = Nothing
+    , socketFormatterServerAsync = ref
+    }
+
+instance Formatter SocketFormatter where
+  formatterName _ = "socket-formatter"
+  runFormatter = run
+  finalizeFormatter sf _ _ = liftIO $ do
+    mAsync <- readIORef (socketFormatterServerAsync sf)
+    case mAsync of
+      Nothing -> return ()
+      Just a -> cancel a
+
+run :: (MonadIO m) => SocketFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
+run (SocketFormatter {..}) rts _maybeCommandLineOptions bc = do
+  case resolveSocketPath of
+    Nothing -> return ()
+    Just path -> liftIO $ do
+      a <- async (socketServer path rts)
+      writeIORef socketFormatterServerAsync (Just a)
+      -- Block until all tests complete
+      mapM_ waitForTree rts
+  where
+    resolveSocketPath = case socketFormatterPath of
+      Just p -> Just p
+      Nothing -> case baseContextRunRoot bc of
+        Just runRoot -> Just (runRoot </> "socket.sock")
+        Nothing -> Nothing
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
new file mode 100644
index 00000000..37d9ffd6
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -0,0 +1,243 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Test.Sandwich.Formatters.Socket.Commands (
+  handleCommand
+  ) where
+
+import Control.Concurrent.STM
+import Control.Monad.Logger
+import qualified Data.ByteString.Char8 as BS8
+import Data.Foldable (toList)
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import Data.String.Interpolate
+import Data.Time
+import Test.Sandwich.Formatters.Common.Count
+import Test.Sandwich.Formatters.Common.Util
+import Test.Sandwich.RunTree
+import Test.Sandwich.Types.RunTree
+import Test.Sandwich.Types.Spec
+import Text.Read (readMaybe)
+
+
+-- | Handle a single command and return the response text.
+-- The response does NOT include the trailing ".\n" terminator; the caller adds that.
+handleCommand :: [RunNode BaseContext] -> UTCTime -> String -> IO String
+handleCommand rts now cmd = case words cmd of
+  ["help"] -> return helpText
+  ["status"] -> cmdStatus rts
+  ["active"] -> cmdActive rts now
+  ["failures"] -> cmdFailures rts
+  ["pending"] -> cmdPending rts
+  ["tree"] -> cmdTree rts
+  ["node", idStr] -> case readMaybe idStr of
+    Just nid -> cmdNode rts nid
+    Nothing -> return [i|Error: invalid node id "#{idStr}"|]
+  ["logs", idStr] -> case readMaybe idStr of
+    Just nid -> cmdLogs rts nid
+    Nothing -> return [i|Error: invalid node id "#{idStr}"|]
+  [] -> return ""
+  (c:_) -> return [i|Unknown command: #{c}\nType "help" for available commands.|]
+
+helpText :: String
+helpText = unlines
+  [ "Available commands:"
+  , "  help       - Show this help"
+  , "  status     - Summary counts: total, running, succeeded, failed, pending, not started"
+  , "  active     - List currently running nodes"
+  , "  failures   - List failed nodes with failure reason"
+  , "  pending    - List pending nodes"
+  , "  tree       - Full tree with indented status"
+  , "  node <id>  - Detail for a specific node"
+  , "  logs <id>  - Show logs for a specific node"
+  ]
+
+-- | Snapshot the tree atomically
+snapshot :: [RunNode BaseContext] -> IO [RunNodeFixed BaseContext]
+snapshot rts = atomically $ mapM fixRunTree rts
+
+-- * Commands
+
+cmdStatus :: [RunNode BaseContext] -> IO String
+cmdStatus rts = do
+  fixed <- snapshot rts
+  let total = countWhere isItBlock fixed
+      running = countWhere isRunningItBlock fixed
+      succeeded = countWhere isSuccessItBlock fixed
+      failed = countWhere isFailedItBlock fixed
+      pend = countWhere isPendingItBlock fixed
+      notStarted = countWhere isNotStartedItBlock fixed
+  return $ unlines
+    [ [i|total:       #{total}|]
+    , [i|running:     #{running}|]
+    , [i|succeeded:   #{succeeded}|]
+    , [i|failed:      #{failed}|]
+    , [i|pending:     #{pend}|]
+    , [i|not started: #{notStarted}|]
+    ]
+
+cmdActive :: [RunNode BaseContext] -> UTCTime -> IO String
+cmdActive rts now = do
+  fixed <- snapshot rts
+  let nodes = concatMap (extractValues getActiveInfo) fixed
+      activeNodes = [x | Just x <- nodes]
+  if null activeNodes
+    then return "No nodes currently running."
+    else return $ unlines [formatActive n | n <- activeNodes]
+  where
+    getActiveInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, NominalDiffTime)
+    getActiveInfo node = case runTreeStatus (runNodeCommon node) of
+      Running {statusStartTime} ->
+        let c = runNodeCommon node
+        in Just (runTreeLabel c, runTreeId c, diffUTCTime now statusStartTime)
+      _ -> Nothing
+
+    formatActive (label, nid, elapsed) =
+      let elapsedStr = formatNominalDiffTime elapsed
+      in [i|  [#{nid}] #{label} (#{elapsedStr})|]
+
+cmdFailures :: [RunNode BaseContext] -> IO String
+cmdFailures rts = do
+  fixed <- snapshot rts
+  let nodes = concatMap (extractValues getFailureInfo) fixed
+      failedNodes = [x | Just x <- nodes]
+  if null failedNodes
+    then return "No failures."
+    else return $ unlines [formatFailure n | n <- failedNodes]
+  where
+    getFailureInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, FailureReason)
+    getFailureInfo node = case runTreeStatus (runNodeCommon node) of
+      Done {statusResult = Failure reason@(Pending {})} -> Nothing
+      Done {statusResult = Failure reason} ->
+        let c = runNodeCommon node
+        in Just (runTreeLabel c, runTreeId c, reason)
+      _ -> Nothing
+
+    formatFailure (label, nid, reason) =
+      [i|  [#{nid}] #{label}: #{showFailureReason reason}|]
+
+cmdPending :: [RunNode BaseContext] -> IO String
+cmdPending rts = do
+  fixed <- snapshot rts
+  let nodes = concatMap (extractValues getPendingInfo) fixed
+      pendingNodes = [x | Just x <- nodes]
+  if null pendingNodes
+    then return "No pending nodes."
+    else return $ unlines [formatPendingNode n | n <- pendingNodes]
+  where
+    getPendingInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, Maybe String)
+    getPendingInfo node = case runTreeStatus (runNodeCommon node) of
+      Done {statusResult = Failure (Pending {failurePendingMessage})} ->
+        let c = runNodeCommon node
+        in Just (runTreeLabel c, runTreeId c, failurePendingMessage)
+      _ -> Nothing
+
+    formatPendingNode (label, nid, msg) = case msg of
+      Just m -> [i|  [#{nid}] #{label}: #{m}|]
+      Nothing -> [i|  [#{nid}] #{label}|]
+
+cmdTree :: [RunNode BaseContext] -> IO String
+cmdTree rts = do
+  fixed <- snapshot rts
+  return $ unlines $ concatMap (renderTree 0) fixed
+
+renderTree :: Int -> RunNodeWithStatus context Status (Seq LogEntry) Bool -> [String]
+renderTree depth node =
+  let c = runNodeCommon node
+      indent = replicate (depth * 2) ' '
+      statusStr = showStatusBrief (runTreeStatus c)
+      label = runTreeLabel c
+      nid = runTreeId c
+      line = [i|#{indent}[#{statusStr}] [#{nid}] #{label}|]
+      children = case node of
+        RunNodeIt {} -> []
+        RunNodeIntroduce {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented
+        RunNodeIntroduceWith {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented
+        _ -> concatMap (renderTree (depth + 1)) (runNodeChildren node)
+  in line : children
+
+cmdNode :: [RunNode BaseContext] -> Int -> IO String
+cmdNode rts nid = do
+  fixed <- snapshot rts
+  let allCommons = concatMap (extractValues (runNodeCommon)) fixed
+      match = [c | c <- allCommons, runTreeId c == nid]
+  case match of
+    [] -> return [i|Error: no node with id #{nid}|]
+    (c:_) -> return $ unlines
+      [ [i|id:     #{runTreeId c}|]
+      , [i|label:  #{runTreeLabel c}|]
+      , [i|status: #{showStatusDetail (runTreeStatus c)}|]
+      , [i|folder: #{maybe "(none)" id (runTreeFolder c)}|]
+      ]
+
+cmdLogs :: [RunNode BaseContext] -> Int -> IO String
+cmdLogs rts nid = do
+  fixed <- snapshot rts
+  let allNodes = concatMap (extractValues (\n -> (runNodeCommon n))) fixed
+      match = [c | c <- allNodes, runTreeId c == nid]
+  case match of
+    [] -> return [i|Error: no node with id #{nid}|]
+    (c:_) -> do
+      let logs = runTreeLogs c
+      if Seq.null logs
+        then return "(no logs)"
+        else return $ unlines [showLogEntry e | e <- toList logs]
+
+-- * Formatting helpers
+
+showStatusBrief :: Status -> String
+showStatusBrief NotStarted = "NOT STARTED"
+showStatusBrief (Running {}) = "RUNNING"
+showStatusBrief (Done {statusResult = Success}) = "OK"
+showStatusBrief (Done {statusResult = Failure (Pending {})}) = "PENDING"
+showStatusBrief (Done {statusResult = Failure _}) = "FAIL"
+showStatusBrief (Done {statusResult = DryRun}) = "DRY RUN"
+showStatusBrief (Done {statusResult = Cancelled}) = "CANCELLED"
+
+showStatusDetail :: Status -> String
+showStatusDetail NotStarted = "not started"
+showStatusDetail (Running {statusStartTime}) = [i|running (started #{show statusStartTime})|]
+showStatusDetail (Done {statusStartTime, statusEndTime, statusResult}) =
+  let elapsed = formatNominalDiffTime (diffUTCTime statusEndTime statusStartTime)
+  in [i|#{showResultBrief statusResult} (#{elapsed})|]
+
+showResultBrief :: Result -> String
+showResultBrief Success = "succeeded"
+showResultBrief (Failure (Pending {})) = "pending"
+showResultBrief (Failure _) = "failed"
+showResultBrief DryRun = "dry run"
+showResultBrief Cancelled = "cancelled"
+
+showFailureReason :: FailureReason -> String
+showFailureReason (Reason {failureReason}) = failureReason
+showFailureReason (ExpectedButGot {failureValue1, failureValue2}) =
+  [i|Expected #{show failureValue1} but got #{show failureValue2}|]
+showFailureReason (DidNotExpectButGot {failureValue1}) =
+  [i|Did not expect #{show failureValue1}|]
+showFailureReason (GotException {failureMessage, failureException}) =
+  case failureMessage of
+    Just msg -> [i|#{msg}: #{show failureException}|]
+    Nothing -> show failureException
+showFailureReason (Pending {failurePendingMessage}) =
+  maybe "pending" id failurePendingMessage
+showFailureReason (GetContextException {failureException}) =
+  [i|Context exception: #{show failureException}|]
+showFailureReason (GotAsyncException {failureMessage, failureAsyncException}) =
+  case failureMessage of
+    Just msg -> [i|#{msg}: #{show failureAsyncException}|]
+    Nothing -> show failureAsyncException
+showFailureReason (ChildrenFailed {failureNumChildren}) =
+  [i|#{failureNumChildren} children failed|]
+showFailureReason (RawImage {failureFallback}) = failureFallback
+
+showLogEntry :: LogEntry -> String
+showLogEntry (LogEntry {logEntryTime, logEntryLevel, logEntryStr}) =
+  let levelStr :: String
+      levelStr = case logEntryLevel of
+        LevelDebug -> "DEBUG"
+        LevelInfo -> "INFO"
+        LevelWarn -> "WARN"
+        LevelError -> "ERROR"
+        LevelOther t -> show t
+      msgStr = BS8.unpack (fromLogStr logEntryStr)
+  in [i|#{show logEntryTime} [#{levelStr}] #{msgStr}|]
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
new file mode 100644
index 00000000..b25795c6
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -0,0 +1,65 @@
+module Test.Sandwich.Formatters.Socket.Server (
+  socketServer
+  ) where
+
+import Control.Concurrent.Async
+import Control.Monad
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import Data.IORef
+import Data.Time
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+import System.Directory (removeFile)
+import Test.Sandwich.Formatters.Socket.Commands
+import Test.Sandwich.Types.RunTree
+import UnliftIO.Exception
+
+
+-- | Bidirectional Unix socket server. Each client connection reads line-based
+-- commands and sends back responses terminated by a line containing just ".".
+socketServer :: FilePath -> [RunNode BaseContext] -> IO ()
+socketServer socketPath rts = do
+  -- Clean up any existing socket file
+  removeFile socketPath `catch` \(_ :: IOError) -> return ()
+
+  bracket (socket AF_UNIX Stream defaultProtocol) close $ \sock -> do
+    bind sock (SockAddrUnix socketPath)
+    listen sock 5
+    forever $ do
+      (conn, _) <- accept sock
+      void $ async $ handleConnection conn rts
+
+handleConnection :: Socket -> [RunNode BaseContext] -> IO ()
+handleConnection conn rts = do
+  bufRef <- newIORef BS.empty
+  handle (\(_ :: IOError) -> close conn) $ forever $ do
+    line <- readLine conn bufRef
+    now <- getCurrentTime
+    response <- handleCommand rts now (BS8.unpack (stripCR line))
+    unless (null response) $ do
+      sendAll conn (BS8.pack response)
+      sendAll conn "\n"
+
+-- | Read a single line from the socket, buffering leftover bytes.
+-- Returns the line without the trailing newline.
+readLine :: Socket -> IORef BS.ByteString -> IO BS.ByteString
+readLine conn bufRef = do
+  buf <- readIORef bufRef
+  case BS8.elemIndex '\n' buf of
+    Just idx -> do
+      let (line, rest) = BS.splitAt idx buf
+      writeIORef bufRef (BS.drop 1 rest) -- skip the '\n'
+      return line
+    Nothing -> do
+      chunk <- recv conn 4096
+      when (BS.null chunk) $ throwIO (userError "connection closed")
+      writeIORef bufRef (buf <> chunk)
+      readLine conn bufRef
+
+-- | Strip trailing carriage return (for clients that send \r\n)
+stripCR :: BS.ByteString -> BS.ByteString
+stripCR bs
+  | BS.null bs = bs
+  | BS8.last bs == '\r' = BS.init bs
+  | otherwise = bs
diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
index 3c11ac9c..f56aa2c9 100644
--- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
@@ -60,6 +60,7 @@ data CommandLineOptions a = CommandLineOptions {
   , optCancelOnLongExecutionMs :: Maybe Int
   , optMarkdownSummaryPath :: Maybe FilePath
   , optTuiDebugSocket :: Bool
+  , optSocketFormatter :: Bool
 
   , optListAvailableTests :: Maybe Bool
   , optListAvailableTestsJson :: Maybe Bool

From 5037c9e4785e5e7303b8db3aa7ca229641563fff Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 27 Feb 2026 16:11:47 -0800
Subject: [PATCH 03/41] Show intro message + terminal indicator

---
 .../Test/Sandwich/Formatters/Socket/Server.hs   | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index b25795c6..f70d6879 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -33,13 +33,16 @@ socketServer socketPath rts = do
 handleConnection :: Socket -> [RunNode BaseContext] -> IO ()
 handleConnection conn rts = do
   bufRef <- newIORef BS.empty
-  handle (\(_ :: IOError) -> close conn) $ forever $ do
-    line <- readLine conn bufRef
-    now <- getCurrentTime
-    response <- handleCommand rts now (BS8.unpack (stripCR line))
-    unless (null response) $ do
-      sendAll conn (BS8.pack response)
-      sendAll conn "\n"
+  handle (\(_ :: IOError) -> close conn) $ do
+    sendAll conn "Connected to sandwich socket formatter. Type \"help\" for commands.\n\n> "
+    forever $ do
+      line <- readLine conn bufRef
+      now <- getCurrentTime
+      response <- handleCommand rts now (BS8.unpack (stripCR line))
+      unless (null response) $ do
+        sendAll conn (BS8.pack response)
+        sendAll conn "\n"
+      sendAll conn "> "
 
 -- | Read a single line from the socket, buffering leftover bytes.
 -- Returns the line without the trailing newline.

From 0376f5834fa322f1355a83b76640419b64432fec Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 27 Feb 2026 22:22:23 -0800
Subject: [PATCH 04/41] Use strict modifyTVar' to try to fix memory leak

---
 .../src/Test/Sandwich/Formatters/TerminalUI.hs     | 14 +++++++-------
 .../Test/Sandwich/Interpreters/RunTree/Logging.hs  |  4 ++--
 .../src/Test/Sandwich/Interpreters/RunTree/Util.hs |  2 +-
 .../src/Test/Sandwich/Interpreters/StartTree.hs    |  8 ++++----
 4 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
index 0e3b6185..c2e9b217 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -397,37 +397,37 @@ modifyToggled :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState ()
 modifyToggled s f = case listSelectedElement (s ^. appMainList) of
   Nothing -> continue s
   Just (_i, MainListElem {..}) -> do
-    liftIO $ atomically $ modifyTVar (runTreeToggled node) f
+    liftIO $ atomically $ modifyTVar' (runTreeToggled node) f
     continue s
 
 modifyOpen :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState ()
 modifyOpen s f = case listSelectedElement (s ^. appMainList) of
   Nothing -> continue s
   Just (_i, MainListElem {..}) -> do
-    liftIO $ atomically $ modifyTVar (runTreeOpen node) f
+    liftIO $ atomically $ modifyTVar' (runTreeOpen node) f
     continue s
 
 openIndices :: [RunNode context] -> Seq.Seq Int -> IO ()
 openIndices nodes openSet =
   atomically $ forM_ (concatMap getCommons nodes) $ \node ->
     when ((runTreeId node) `elem` (toList openSet)) $
-      modifyTVar (runTreeOpen node) (const True)
+      modifyTVar' (runTreeOpen node) (const True)
 
 openToDepth :: (Foldable t) => t MainListElem -> Int -> IO ()
 openToDepth elems thresh =
   atomically $ forM_ elems $ \(MainListElem {..}) ->
-    if | (depth < thresh) -> modifyTVar (runTreeOpen node) (const True)
-       | otherwise -> modifyTVar (runTreeOpen node) (const False)
+    if | (depth < thresh) -> modifyTVar' (runTreeOpen node) (const True)
+       | otherwise -> modifyTVar' (runTreeOpen node) (const False)
 
 setInitialFolding :: InitialFolding -> [RunNode BaseContext] -> IO ()
 setInitialFolding InitialFoldingAllOpen _rts = return ()
 setInitialFolding InitialFoldingAllClosed rts =
   atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->
-    modifyTVar runTreeOpen (const False)
+    modifyTVar' runTreeOpen (const False)
 setInitialFolding (InitialFoldingTopNOpen n) rts =
   atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->
     when (Seq.length runTreeAncestors > n) $
-      modifyTVar runTreeOpen (const False)
+      modifyTVar' runTreeOpen (const False)
 
 updateFilteredTree :: AppState -> AppState
 updateFilteredTree s = s
diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index ce97af07..a334d6fd 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -20,14 +20,14 @@ logToMemory Nothing _ _ _ _ _ = return ()
 logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
   when (logLevel >= minLevel) $ do
     ts <- getCurrentTime
-    atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)
+    atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel logStr)
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
   maybeTs <- case maybeMemLogLevel of
     Just x | x <= logLevel -> do
       ts <- getCurrentTime
-      atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)
+      atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel logStr)
       return $ Just ts
     _ -> return Nothing
 
diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
index 88c96ffb..71d2256a 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
@@ -28,7 +28,7 @@ waitForTree node = atomically $
 appendLogMessage :: ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()
 appendLogMessage logs msg = do
   ts <- getCurrentTime
-  atomically $ modifyTVar logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg))
+  atomically $ modifyTVar' logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg))
 
 -- | Count how many folder children are present as children or siblings of the given node.
 countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 43019838..3a367aa8 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -346,7 +346,7 @@ markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode co
 markAllChildrenWithResult children baseContext status = do
   now <- liftIO getCurrentTime
   forM_ (L.filter (shouldRunChild' baseContext) $ concatMap getCommons children) $ \child ->
-    liftIO $ atomically $ modifyTVar (runTreeStatus child) $ \case
+    liftIO $ atomically $ modifyTVar' (runTreeStatus child) $ \case
       Running {..} -> Done now statusSetupFinishTime statusTeardownStartTime now status
       done@(Done {}) -> done { statusResult = status }
       _ -> Done now Nothing Nothing now status
@@ -413,13 +413,13 @@ runExampleM' rnc label ex ctx logs exceptionMessage = do
         _ -> GotException Nothing msg (SomeExceptionWithEq e)
 
 addSetupFinishTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()
-addSetupFinishTimeToStatus statusVar setupFinishTime = atomically $ modifyTVar statusVar $ \case
+addSetupFinishTimeToStatus statusVar setupFinishTime = atomically $ modifyTVar' statusVar $ \case
   status@(Running {}) -> status { statusSetupFinishTime = Just setupFinishTime }
   status@(Done {}) -> status { statusSetupFinishTime = Just setupFinishTime }
   x -> x
 
 addTeardownStartTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()
-addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar statusVar $ \case
+addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar' statusVar $ \case
   status@(Running {}) -> status { statusTeardownStartTime = Just t }
   status@(Done {}) -> status { statusTeardownStartTime = Just t }
   x -> x
@@ -432,7 +432,7 @@ recordExceptionInStatus status e = do
         _ -> case fromException e of
           Just (e' :: FailureReason) -> Failure e'
           _ -> Failure (GotException Nothing Nothing (SomeExceptionWithEq e))
-  liftIO $ atomically $ modifyTVar status $ \case
+  liftIO $ atomically $ modifyTVar' status $ \case
     Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret
     _ -> Done endTime Nothing Nothing endTime ret
 

From be48d04698601b5f438cf0123e2f7f5654b24389 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 27 Feb 2026 23:15:09 -0800
Subject: [PATCH 05/41] tui: try always updating app current time

---
 sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
index c2e9b217..ee5af616 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -209,9 +209,7 @@ appEvent s (AppEvent (RunTreeUpdated newTree somethingRunning)) = do
     & appSomethingRunning .~ somethingRunning
     & updateFilteredTree
 appEvent s (AppEvent (CurrentTimeUpdated ts)) = do
-  continue $ case (s ^. appSomethingRunning) of
-    True -> s & appCurrentTime .~ ts
-    False -> s
+  continue $ s & appCurrentTime .~ ts
 
 appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do
   lookupExtent ColorBar >>= \case

From 7c57e876394a78c9759916077adbee867ed066aa Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 27 Feb 2026 23:15:32 -0800
Subject: [PATCH 06/41] socket: be able to broadcast all logs

---
 sandwich/src/Test/Sandwich/ArgParsing.hs      | 15 ++++--
 .../src/Test/Sandwich/Formatters/Socket.hs    |  7 ++-
 .../Sandwich/Formatters/Socket/Commands.hs    | 17 +++----
 .../Test/Sandwich/Formatters/Socket/Server.hs | 47 +++++++++++++++----
 .../Test/Sandwich/Interpreters/StartTree.hs   | 11 ++++-
 sandwich/src/Test/Sandwich/Options.hs         |  1 +
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  3 ++
 7 files changed, 75 insertions(+), 26 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index 7c8fd8af..c8b323d5 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -5,6 +5,7 @@
 
 module Test.Sandwich.ArgParsing where
 
+import Control.Concurrent.STM
 import Control.Monad.Logger
 import Data.Function
 import qualified Data.List as L
@@ -265,7 +266,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
         (_, Silent) -> silentFormatter
 
   -- Strip out any "main" formatters since the options control that
-  baseFormatters <- optionsFormatters baseOptions
+  (baseFormatters, maybeLogBroadcast) <- optionsFormatters baseOptions
                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath
                     & tryAddSocketFormatter optSocketFormatter
   let baseFormatters' = filter (not . isMainFormatter) baseFormatters
@@ -289,6 +290,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
     , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun
     , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs
     , optionsCancelOnLongExecutionMs = (optionsCancelOnLongExecutionMs baseOptions) <|> optCancelOnLongExecutionMs
+    , optionsLogBroadcast = maybeLogBroadcast
     }
 
   return (options, optRepeatCount)
@@ -331,10 +333,13 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
       Just (_ :: SocketFormatter) -> True
       Nothing -> False
 
-    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO [SomeFormatter]
-    tryAddSocketFormatter False xs = return xs
+    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO ([SomeFormatter], Maybe (TChan (Int, String, LogEntry)))
+    tryAddSocketFormatter False xs = return (xs, Nothing)
     tryAddSocketFormatter True xs
-      | L.any isSocketFormatter xs = return xs
+      | L.any isSocketFormatter xs =
+          -- Extract the broadcast channel from the existing formatter
+          let chan = headMay [socketFormatterLogBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]
+          in return (xs, chan)
       | otherwise = do
           sf <- defaultSocketFormatter
-          return $ (SomeFormatter sf) : xs
+          return ((SomeFormatter sf) : xs, Just (socketFormatterLogBroadcast sf))
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket.hs b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
index 397afbd1..3abfdd0a 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
@@ -18,6 +18,7 @@ module Test.Sandwich.Formatters.Socket (
   ) where
 
 import Control.Concurrent.Async
+import Control.Concurrent.STM
 import Control.Monad.IO.Class
 import Data.IORef
 import Data.Typeable
@@ -33,6 +34,8 @@ data SocketFormatter = SocketFormatter {
   -- ^ Socket path. Nothing = \<run-root\>/socket.sock
   , socketFormatterServerAsync :: IORef (Maybe (Async ()))
   -- ^ Internal: handle to the running server thread, used for cleanup.
+  , socketFormatterLogBroadcast :: TChan (Int, String, LogEntry)
+  -- ^ Broadcast channel for streaming logs to connected clients.
   } deriving (Typeable)
 
 instance Show SocketFormatter where
@@ -42,9 +45,11 @@ instance Show SocketFormatter where
 defaultSocketFormatter :: IO SocketFormatter
 defaultSocketFormatter = do
   ref <- newIORef Nothing
+  chan <- newBroadcastTChanIO
   return SocketFormatter {
     socketFormatterPath = Nothing
     , socketFormatterServerAsync = ref
+    , socketFormatterLogBroadcast = chan
     }
 
 instance Formatter SocketFormatter where
@@ -61,7 +66,7 @@ run (SocketFormatter {..}) rts _maybeCommandLineOptions bc = do
   case resolveSocketPath of
     Nothing -> return ()
     Just path -> liftIO $ do
-      a <- async (socketServer path rts)
+      a <- async (socketServer path rts socketFormatterLogBroadcast)
       writeIORef socketFormatterServerAsync (Just a)
       -- Block until all tests complete
       mapM_ waitForTree rts
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
index 37d9ffd6..e0e56157 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -42,14 +42,15 @@ handleCommand rts now cmd = case words cmd of
 helpText :: String
 helpText = unlines
   [ "Available commands:"
-  , "  help       - Show this help"
-  , "  status     - Summary counts: total, running, succeeded, failed, pending, not started"
-  , "  active     - List currently running nodes"
-  , "  failures   - List failed nodes with failure reason"
-  , "  pending    - List pending nodes"
-  , "  tree       - Full tree with indented status"
-  , "  node <id>  - Detail for a specific node"
-  , "  logs <id>  - Show logs for a specific node"
+  , "  help        - Show this help"
+  , "  status      - Summary counts: total, running, succeeded, failed, pending, not started"
+  , "  active      - List currently running nodes"
+  , "  failures    - List failed nodes with failure reason"
+  , "  pending     - List pending nodes"
+  , "  tree        - Full tree with indented status"
+  , "  node <id>   - Detail for a specific node"
+  , "  logs <id>   - Show logs for a specific node"
+  , "  stream-logs - Stream all logs live (disconnect to stop)"
   ]
 
 -- | Snapshot the tree atomically
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index f70d6879..773e0a9b 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -3,10 +3,13 @@ module Test.Sandwich.Formatters.Socket.Server (
   ) where
 
 import Control.Concurrent.Async
+import Control.Concurrent.STM
 import Control.Monad
+import Control.Monad.Logger
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
+import Data.String.Interpolate
 import Data.Time
 import Network.Socket
 import Network.Socket.ByteString (recv, sendAll)
@@ -18,8 +21,8 @@ import UnliftIO.Exception
 
 -- | Bidirectional Unix socket server. Each client connection reads line-based
 -- commands and sends back responses terminated by a line containing just ".".
-socketServer :: FilePath -> [RunNode BaseContext] -> IO ()
-socketServer socketPath rts = do
+socketServer :: FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> IO ()
+socketServer socketPath rts logBroadcast = do
   -- Clean up any existing socket file
   removeFile socketPath `catch` \(_ :: IOError) -> return ()
 
@@ -28,21 +31,45 @@ socketServer socketPath rts = do
     listen sock 5
     forever $ do
       (conn, _) <- accept sock
-      void $ async $ handleConnection conn rts
+      void $ async $ handleConnection conn rts logBroadcast
 
-handleConnection :: Socket -> [RunNode BaseContext] -> IO ()
-handleConnection conn rts = do
+handleConnection :: Socket -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> IO ()
+handleConnection conn rts logBroadcast = do
   bufRef <- newIORef BS.empty
   handle (\(_ :: IOError) -> close conn) $ do
     sendAll conn "Connected to sandwich socket formatter. Type \"help\" for commands.\n\n> "
     forever $ do
       line <- readLine conn bufRef
       now <- getCurrentTime
-      response <- handleCommand rts now (BS8.unpack (stripCR line))
-      unless (null response) $ do
-        sendAll conn (BS8.pack response)
-        sendAll conn "\n"
-      sendAll conn "> "
+      let cmd = BS8.unpack (stripCR line)
+      case words cmd of
+        ["stream-logs"] -> streamLogs conn logBroadcast
+        _ -> do
+          response <- handleCommand rts now cmd
+          unless (null response) $ do
+            sendAll conn (BS8.pack response)
+            sendAll conn "\n"
+          sendAll conn "> "
+
+-- | Stream all log entries to the client until the connection is closed.
+-- This is a blocking operation that never returns to the command loop.
+streamLogs :: Socket -> TChan (Int, String, LogEntry) -> IO ()
+streamLogs conn broadcastChan = do
+  sendAll conn "Streaming logs (disconnect to stop)...\n"
+  -- Duplicate the broadcast channel to get our own read position
+  chan <- atomically $ dupTChan broadcastChan
+  handle (\(_ :: IOError) -> return ()) $ forever $ do
+    (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan
+    let levelStr :: String
+        levelStr = case logEntryLevel of
+          LevelDebug -> "DEBUG"
+          LevelInfo -> "INFO"
+          LevelWarn -> "WARN"
+          LevelError -> "ERROR"
+          LevelOther t -> show t
+        msgStr = BS8.unpack (fromLogStr logEntryStr)
+        formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
+    sendAll conn (BS8.pack formatted)
 
 -- | Read a single line from the socket, buffering leftover bytes.
 -- Returns the line without the trailing newline.
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 3a367aa8..0fb04c9e 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -393,10 +393,17 @@ runExampleM' rnc label ex ctx logs exceptionMessage = do
 
   where
     withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a
-    withLogFn Nothing (Options {..}) action = action (logToMemory optionsSavedLogLevel logs)
+    withLogFn Nothing (Options {..}) action = action (withBroadcast optionsLogBroadcast $ logToMemory optionsSavedLogLevel logs)
     withLogFn (Just logPath) (Options {..}) action = withFile (logPath </> "test_logs.txt") AppendMode $ \h -> do
       hSetBuffering h LineBuffering
-      action (logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)
+      action (withBroadcast optionsLogBroadcast $ logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)
+
+    withBroadcast :: Maybe (TChan (Int, String, LogEntry)) -> LogFn -> LogFn
+    withBroadcast Nothing logFn = logFn
+    withBroadcast (Just chan) logFn = \loc logSrc logLevel logStr -> do
+      logFn loc logSrc logLevel logStr
+      ts <- getCurrentTime
+      atomically $ writeTChan chan (runTreeId rnc, runTreeLabel rnc, LogEntry ts loc logSrc logLevel logStr)
 
     getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)
     getTestDirectory (getBaseContext -> (BaseContext {..})) = case baseContextPath of
diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs
index c27928b0..81bfee77 100644
--- a/sandwich/src/Test/Sandwich/Options.hs
+++ b/sandwich/src/Test/Sandwich/Options.hs
@@ -57,6 +57,7 @@ defaultOptions = Options {
   , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False }
   , optionsWarnOnLongExecutionMs = Nothing
   , optionsCancelOnLongExecutionMs = Nothing
+  , optionsLogBroadcast = Nothing
   }
 
 -- | Generate a test artifacts directory based on a timestamp.
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 39147ac2..bde30dd8 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -295,6 +295,9 @@ data Options = Options {
   -- ^ 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.
+  , optionsLogBroadcast :: Maybe (TChan (Int, String, LogEntry))
+  -- ^ Broadcast channel for streaming log entries to external consumers (e.g. socket formatter).
+  -- Each entry is tagged with (nodeId, nodeLabel, logEntry).
   }
 
 -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way

From 5944fb21e93e1409be7b669938943a83cb70e3e9 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sat, 28 Feb 2026 04:09:04 -0800
Subject: [PATCH 07/41] Add demo-stress

---
 demos/demo-stress/app/Main.hs       | 64 +++++++++++++++++++++++++++++
 demos/demo-stress/demo-stress.cabal | 34 +++++++++++++++
 demos/demo-stress/package.yaml      | 33 +++++++++++++++
 stack.yaml                          |  1 +
 4 files changed, 132 insertions(+)
 create mode 100644 demos/demo-stress/app/Main.hs
 create mode 100644 demos/demo-stress/demo-stress.cabal
 create mode 100644 demos/demo-stress/package.yaml

diff --git a/demos/demo-stress/app/Main.hs b/demos/demo-stress/app/Main.hs
new file mode 100644
index 00000000..2d10d5b8
--- /dev/null
+++ b/demos/demo-stress/app/Main.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.String.Interpolate
+import Data.Text (Text)
+import System.Random
+import Test.Sandwich
+
+
+-- | 400 test nodes running in parallel, each generating a few hundred log lines
+-- over ~5 minutes total. Designed to stress-test the TUI's memory behavior
+-- when all tests finish and statuses stabilize.
+stressSpec :: TopSpec
+stressSpec = parallel $ do
+  forM_ [(1 :: Int)..400] $ \nodeId ->
+    it [i|test #{nodeId}|] $ stressTest nodeId
+
+stressTest :: Int -> ExampleM context ()
+stressTest nodeId = do
+  gen <- liftIO $ newStdGen
+  -- Each test generates 100-300 log lines
+  let logCount = 100 + (nodeId * 47 `mod` 200)
+  -- Spread the work over the 5-minute window.
+  -- Total run time per test: ~4-5 minutes with jitter.
+  let baseSleepUs = (5 * 60 * 1000000) `div` logCount
+  go gen logCount baseSleepUs (1 :: Int)
+  where
+    go _ 0 _ _ = return ()
+    go gen remaining baseSleepUs lineNum = do
+      let (jitter, gen') = uniformR (0, baseSleepUs `div` 2) gen
+      let sleepUs = baseSleepUs + jitter - (baseSleepUs `div` 4)
+      liftIO $ threadDelay sleepUs
+      -- Generate log lines of varying verbosity
+      let msg = makeLogMessage nodeId lineNum
+      case lineNum `mod` 4 of
+        0 -> debug msg
+        1 -> info msg
+        2 -> warn msg
+        _ -> debug msg
+      go gen' (remaining - 1) baseSleepUs (lineNum + 1)
+
+makeLogMessage :: Int -> Int -> Text
+makeLogMessage nodeId lineNum =
+  let padding = replicate ((nodeId + lineNum) `mod` 80 + 20) '='
+  in [i|[node=#{nodeId} line=#{lineNum}] Processing step #{lineNum}: #{padding} status=ok detail=#{detail lineNum}|]
+  where
+    detail n
+      | n `mod` 10 == 0 = "checkpoint reached, flushing buffers and syncing state across all connected peers" :: Text
+      | n `mod` 7 == 0 = "retrying operation after transient failure on upstream dependency"
+      | n `mod` 5 == 0 = "cache miss, fetching from backing store"
+      | n `mod` 3 == 0 = "validating intermediate result set"
+      | otherwise = "nominal"
+
+main :: IO ()
+main = runSandwichWithCommandLineArgs options stressSpec
+  where
+    options = defaultOptions {
+      optionsTestArtifactsDirectory = defaultTestArtifactsDirectory
+      }
diff --git a/demos/demo-stress/demo-stress.cabal b/demos/demo-stress/demo-stress.cabal
new file mode 100644
index 00000000..f35b37d3
--- /dev/null
+++ b/demos/demo-stress/demo-stress.cabal
@@ -0,0 +1,34 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.39.1.
+--
+-- see: https://github.com/sol/hpack
+
+name:           demo-stress
+version:        0.1.0.0
+license:        BSD3
+build-type:     Simple
+
+executable demo-stress
+  main-is: Main.hs
+  other-modules:
+      Paths_demo_stress
+  hs-source-dirs:
+      app
+  default-extensions:
+      OverloadedStrings
+      QuasiQuotes
+      NamedFieldPuns
+      RecordWildCards
+      ScopedTypeVariables
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -fdistinct-constructor-tables -finfo-table-map -g
+  build-depends:
+      base
+    , random
+    , sandwich
+    , string-interpolate
+    , text
+  default-language: Haskell2010
diff --git a/demos/demo-stress/package.yaml b/demos/demo-stress/package.yaml
new file mode 100644
index 00000000..2b297e7d
--- /dev/null
+++ b/demos/demo-stress/package.yaml
@@ -0,0 +1,33 @@
+name:                demo-stress
+version:             0.1.0.0
+license:             BSD3
+
+dependencies:
+- base
+- random
+- sandwich
+- string-interpolate
+- text
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+
+ghc-options:
+- -threaded
+- -rtsopts
+- -with-rtsopts=-N
+- -fdistinct-constructor-tables
+- -finfo-table-map
+- -g
+
+executables:
+  demo-stress:
+    main: Main.hs
+    source-dirs: app
diff --git a/stack.yaml b/stack.yaml
index 664c77e6..cf56ea31 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -48,6 +48,7 @@ packages:
 - ./demos/demo-setup-teardown
 - ./demos/demo-slack
 - ./demos/demo-stack-test
+- ./demos/demo-stress
 - ./demos/demo-timing
 - ./demos/demo-timing-parallel
 - ./demos/demo-tui

From cdc79bb936b0f9877098de21ad02a179445d9bc5 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sat, 28 Feb 2026 04:11:04 -0800
Subject: [PATCH 08/41] More strictness around LogEntry / logEntryStr

---
 .../src/Test/Sandwich/Formatters/Print/Logs.hs     |  3 ++-
 .../Test/Sandwich/Formatters/Socket/Commands.hs    |  2 +-
 .../src/Test/Sandwich/Formatters/Socket/Server.hs  |  2 +-
 .../Test/Sandwich/Formatters/TerminalUI/Draw.hs    |  4 ++--
 .../Test/Sandwich/Interpreters/RunTree/Logging.hs  |  9 ++++++---
 .../src/Test/Sandwich/Interpreters/RunTree/Util.hs |  7 -------
 .../src/Test/Sandwich/Interpreters/StartTree.hs    |  2 +-
 sandwich/src/Test/Sandwich/Types/RunTree.hs        | 14 +++++++-------
 sandwich/test/TestUtil.hs                          |  7 ++++---
 9 files changed, 24 insertions(+), 26 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
index d446b572..857bee0a 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
@@ -7,6 +7,7 @@ import Control.Concurrent.STM
 import Control.Monad.IO.Class
 import Control.Monad.Logger
 import Control.Monad.Reader
+import qualified Data.ByteString.Char8 as BS8
 import Data.String.Interpolate
 import System.IO
 import Test.Sandwich.Formatters.Print.Color
@@ -53,7 +54,7 @@ printLogEntry (LogEntry {..}) = do
   pc logChColor (show ch)
   p "] "
 
-  p (show logEntryStr)
+  p (BS8.unpack logEntryStr)
 
   p "\n"
 
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
index e0e56157..e851ae5b 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -240,5 +240,5 @@ showLogEntry (LogEntry {logEntryTime, logEntryLevel, logEntryStr}) =
         LevelWarn -> "WARN"
         LevelError -> "ERROR"
         LevelOther t -> show t
-      msgStr = BS8.unpack (fromLogStr logEntryStr)
+      msgStr = BS8.unpack logEntryStr
   in [i|#{show logEntryTime} [#{levelStr}] #{msgStr}|]
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index 773e0a9b..d3ba9527 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -67,7 +67,7 @@ streamLogs conn broadcastChan = do
           LevelWarn -> "WARN"
           LevelError -> "ERROR"
           LevelOther t -> show t
-        msgStr = BS8.unpack (fromLogStr logEntryStr)
+        msgStr = BS8.unpack logEntryStr
         formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
     sendAll conn (BS8.pack formatted)
 
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs
index b517dc41..9c6f504e 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs
@@ -77,7 +77,7 @@ mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (
                       , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel
                       , str "]"]
       , if not (app ^. appShowLogSizes) then Nothing else
-          let totalSize = sum $ fmap (BS.length . fromLogStr . logEntryStr) logs
+          let totalSize = sum $ fmap (BS.length . logEntryStr) logs
           in if totalSize > 0 then Just $ hBox [str " [", withAttr logSizeAttr (str $ formatBytes totalSize), str "]"] else Nothing
       , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]")
       , if not (app ^. appShowRunTimes) then Nothing else case status of
@@ -107,7 +107,7 @@ mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (
       , str " "
       , logLocWidget logEntryLoc
       , str " "
-      , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr)
+      , txtWrap (E.decodeUtf8 logEntryStr)
       ]
 
     logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [
diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index a334d6fd..16334b64 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 
 module Test.Sandwich.Interpreters.RunTree.Logging (
   logToMemory
@@ -20,19 +21,21 @@ logToMemory Nothing _ _ _ _ _ = return ()
 logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
   when (logLevel >= minLevel) $ do
     ts <- getCurrentTime
-    atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel logStr)
+    let !bs = fromLogStr logStr
+    atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
+  let !bs = fromLogStr logStr
   maybeTs <- case maybeMemLogLevel of
     Just x | x <= logLevel -> do
       ts <- getCurrentTime
-      atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel logStr)
+      atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
       return $ Just ts
     _ -> return Nothing
 
   case maybeSavedLogLevel of
     Just x | x <= logLevel -> do
       ts <- maybe getCurrentTime return maybeTs
-      BS8.hPutStr h $ formatter ts loc logSrc logLevel logStr
+      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
     _ -> return ()
diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
index 71d2256a..7dab7eb8 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
@@ -23,13 +23,6 @@ waitForTree node = atomically $
     NotStarted {} -> retry
     Running {} -> retry
 
--- | Append a log message outside of ExampleT. Only stored to in-memory logs, not disk.
--- Only for debugging the interpreter, should not be exposed.
-appendLogMessage :: ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()
-appendLogMessage logs msg = do
-  ts <- getCurrentTime
-  atomically $ modifyTVar' logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg))
-
 -- | Count how many folder children are present as children or siblings of the given node.
 countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int
 countImmediateFolderChildren (Free (It'' _loc no _l _ex next))
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 0fb04c9e..19fbc7cb 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -403,7 +403,7 @@ runExampleM' rnc label ex ctx logs exceptionMessage = do
     withBroadcast (Just chan) logFn = \loc logSrc logLevel logStr -> do
       logFn loc logSrc logLevel logStr
       ts <- getCurrentTime
-      atomically $ writeTChan chan (runTreeId rnc, runTreeLabel rnc, LogEntry ts loc logSrc logLevel logStr)
+      atomically $ writeTChan chan (runTreeId rnc, runTreeLabel rnc, LogEntry ts loc logSrc logLevel (fromLogStr logStr))
 
     getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)
     getTestDirectory (getBaseContext -> (BaseContext {..})) = case baseContextPath of
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index bde30dd8..0c818b0b 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -111,11 +111,11 @@ type RunNodeCommon = RunNodeCommonWithStatus (Var Status) (Var (Seq LogEntry)) (
 
 type Var = TVar
 data LogEntry = LogEntry {
-  logEntryTime :: UTCTime
-  , logEntryLoc :: Loc
-  , logEntrySource :: LogSource
-  , logEntryLevel :: LogLevel
-  , logEntryStr :: LogStr
+  logEntryTime :: !UTCTime
+  , logEntryLoc :: !Loc
+  , logEntrySource :: !LogSource
+  , logEntryLevel :: !LogLevel
+  , logEntryStr :: !BS8.ByteString
   } deriving (Show, Eq)
 
 -- | Context passed around through the evaluation of a RunTree
@@ -228,7 +228,7 @@ newtype TreeFilter = TreeFilter { unTreeFilter :: [String] }
 type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 
 -- | A callback for formatting a log entry to a 'BS8.ByteString'.
-type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> BS8.ByteString
+type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> BS8.ByteString -> BS8.ByteString
 
 -- The defaultLogStr formatter weirdly puts information after the message. Use our own
 defaultLogEntryFormatter :: LogEntryFormatter
@@ -240,7 +240,7 @@ defaultLogEntryFormatter ts loc src level msg = fromLogStr $
   <> toLogStr src
   <> ") "
   <> (if isDefaultLoc loc then "" else "@(" <> toLogStr (BS8.pack fileLocStr) <> ") ")
-  <> msg
+  <> toLogStr msg
   <> "\n"
 
   where
diff --git a/sandwich/test/TestUtil.hs b/sandwich/test/TestUtil.hs
index 98e54aad..14f45c09 100644
--- a/sandwich/test/TestUtil.hs
+++ b/sandwich/test/TestUtil.hs
@@ -4,6 +4,7 @@
 module TestUtil where
 
 import Control.Concurrent.STM
+import qualified Data.ByteString.Char8 as BS8
 import Control.Monad.IO.Class
 import Control.Monad.Logger
 import Control.Monad.Trans.Writer
@@ -58,7 +59,7 @@ runAndGetResults spec = do
   fixedTree <- atomically $ mapM fixRunTree finalTree
   return $ fmap statusToResult $ concatMap getStatuses fixedTree
 
-runAndGetResultsAndLogs :: (HasCallStack) => CoreSpec -> IO ([Result], [[LogStr]])
+runAndGetResultsAndLogs :: (HasCallStack) => CoreSpec -> IO ([Result], [[BS8.ByteString]])
 runAndGetResultsAndLogs spec = do
   finalTree <- runSandwichTree defaultOptions spec
   getResultsAndMessages <$> fixTree finalTree
@@ -66,13 +67,13 @@ runAndGetResultsAndLogs spec = do
 fixTree :: [RunNode context] -> IO [RunNodeFixed context]
 fixTree rts = atomically $ mapM fixRunTree rts
 
-getResultsAndMessages :: (HasCallStack) => [RunNodeFixed context] -> ([Result], [[LogStr]])
+getResultsAndMessages :: (HasCallStack) => [RunNodeFixed context] -> ([Result], [[BS8.ByteString]])
 getResultsAndMessages fixedTree = (results, msgs)
   where
     results = fmap statusToResult $ concatMap getStatuses fixedTree
     msgs = getMessages fixedTree
 
-getMessages :: [RunNodeFixed context] -> [[LogStr]]
+getMessages :: [RunNodeFixed context] -> [[BS8.ByteString]]
 getMessages fixedTree = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree
 
 getStatuses :: RunNodeWithStatus context s l t -> [(String, s)]

From 37442fcf6fe7d662769b81c6429cca289d6cb6fc Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sat, 28 Feb 2026 17:27:38 -0800
Subject: [PATCH 09/41] Just disable logging to debug memory leak

---
 .../Sandwich/Interpreters/RunTree/Logging.hs  | 34 ++++++++++---------
 1 file changed, 18 insertions(+), 16 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index 16334b64..c6776b4a 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -19,23 +19,25 @@ import Test.Sandwich.Types.RunTree
 logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemory Nothing _ _ _ _ _ = return ()
 logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
-  when (logLevel >= minLevel) $ do
-    ts <- getCurrentTime
-    let !bs = fromLogStr logStr
-    atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
+  return ()
+  -- when (logLevel >= minLevel) $ do
+  --   ts <- getCurrentTime
+  --   let !bs = fromLogStr logStr
+  --   atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
-  let !bs = fromLogStr logStr
-  maybeTs <- case maybeMemLogLevel of
-    Just x | x <= logLevel -> do
-      ts <- getCurrentTime
-      atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
-      return $ Just ts
-    _ -> return Nothing
+  return ()
+  -- let !bs = fromLogStr logStr
+  -- maybeTs <- case maybeMemLogLevel of
+  --   Just x | x <= logLevel -> do
+  --     ts <- getCurrentTime
+  --     atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
+  --     return $ Just ts
+  --   _ -> return Nothing
 
-  case maybeSavedLogLevel of
-    Just x | x <= logLevel -> do
-      ts <- maybe getCurrentTime return maybeTs
-      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
-    _ -> return ()
+  -- case maybeSavedLogLevel of
+  --   Just x | x <= logLevel -> do
+  --     ts <- maybe getCurrentTime return maybeTs
+  --     BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
+  --   _ -> return ()

From d0c2d2b6ac3ddd3d9db60eab55047bab3e1a446f Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sat, 28 Feb 2026 18:00:08 -0800
Subject: [PATCH 10/41] socket: add stream-rts-stats command

---
 .../Sandwich/Formatters/Socket/Commands.hs    |  3 +-
 .../Test/Sandwich/Formatters/Socket/Server.hs | 46 +++++++++++++++++++
 2 files changed, 48 insertions(+), 1 deletion(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
index e851ae5b..5142a0f2 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -50,7 +50,8 @@ helpText = unlines
   , "  tree        - Full tree with indented status"
   , "  node <id>   - Detail for a specific node"
   , "  logs <id>   - Show logs for a specific node"
-  , "  stream-logs - Stream all logs live (disconnect to stop)"
+  , "  stream-logs      - Stream all logs live (disconnect to stop)"
+  , "  stream-rts-stats - Stream GHC RTS memory stats every 1s (needs +RTS -T)"
   ]
 
 -- | Snapshot the tree atomically
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index d3ba9527..2e66d651 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -11,11 +11,14 @@ import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import Data.String.Interpolate
 import Data.Time
+import Data.Word
+import GHC.Stats
 import Network.Socket
 import Network.Socket.ByteString (recv, sendAll)
 import System.Directory (removeFile)
 import Test.Sandwich.Formatters.Socket.Commands
 import Test.Sandwich.Types.RunTree
+import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Exception
 
 
@@ -44,6 +47,7 @@ handleConnection conn rts logBroadcast = do
       let cmd = BS8.unpack (stripCR line)
       case words cmd of
         ["stream-logs"] -> streamLogs conn logBroadcast
+        ["stream-rts-stats"] -> streamRtsStats conn
         _ -> do
           response <- handleCommand rts now cmd
           unless (null response) $ do
@@ -71,6 +75,48 @@ streamLogs conn broadcastChan = do
         formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
     sendAll conn (BS8.pack formatted)
 
+-- | Stream RTS stats to the client every second until the connection is closed.
+-- Requires the program to be run with +RTS -T for stats to be available.
+streamRtsStats :: Socket -> IO ()
+streamRtsStats conn = do
+  enabled <- getRTSStatsEnabled
+  if not enabled
+    then sendAll conn "RTS stats not available. Run with +RTS -T to enable.\n> "
+    else do
+      sendAll conn "Streaming RTS stats every 1s (disconnect to stop)...\n"
+      handle (\(_ :: IOError) -> return ()) $ forever $ do
+        stats <- getRTSStats
+        let gc' = gc stats
+            line = formatRtsStats stats gc'
+        sendAll conn (BS8.pack line)
+        threadDelay 1000000
+
+formatRtsStats :: RTSStats -> GCDetails -> String
+formatRtsStats stats gc' = unlines
+  [ [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
+  , [i|heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}|]
+  , [i|allocated_bytes:    #{formatBytes (allocated_bytes stats)}|]
+  , [i|max_live_bytes:     #{formatBytes (max_live_bytes stats)}|]
+  , [i|large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}|]
+  , [i|compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}|]
+  , [i|slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}|]
+  , [i|gcs:                #{gcs stats}|]
+  , [i|major_gcs:          #{major_gcs stats}|]
+  , [i|gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms|]
+  , [i|mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms|]
+  , ""
+  ]
+  where
+    nsToMs :: RtsTime -> RtsTime
+    nsToMs ns = ns `div` 1000000
+
+formatBytes :: Word64 -> String
+formatBytes b
+  | b < 1024 = [i|#{b} B|]
+  | b < 1024 * 1024 = [i|#{b `div` 1024} KiB (#{b})|]
+  | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]
+  | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
+
 -- | Read a single line from the socket, buffering leftover bytes.
 -- Returns the line without the trailing newline.
 readLine :: Socket -> IORef BS.ByteString -> IO BS.ByteString

From e0b8003548938b29f2f739fe93989730a7425e98 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sat, 28 Feb 2026 18:00:25 -0800
Subject: [PATCH 11/41] Try forcing seqs

---
 .../Sandwich/Interpreters/RunTree/Logging.hs  | 39 ++++++++++---------
 1 file changed, 21 insertions(+), 18 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index c6776b4a..4929f587 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -16,28 +16,31 @@ import Data.Time.Clock
 import System.IO
 import Test.Sandwich.Types.RunTree
 
+forceSeq :: Seq LogEntry -> Seq LogEntry
+forceSeq s = foldl' (\_ e -> e `seq` ()) () s `seq` s
+
 logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemory Nothing _ _ _ _ _ = return ()
 logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
-  return ()
-  -- when (logLevel >= minLevel) $ do
-  --   ts <- getCurrentTime
-  --   let !bs = fromLogStr logStr
-  --   atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
+  when (logLevel >= minLevel) $ do
+    ts <- getCurrentTime
+    let !bs = fromLogStr logStr
+    let !entry = LogEntry ts loc logSrc logLevel bs
+    atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
-  return ()
-  -- let !bs = fromLogStr logStr
-  -- maybeTs <- case maybeMemLogLevel of
-  --   Just x | x <= logLevel -> do
-  --     ts <- getCurrentTime
-  --     atomically $ modifyTVar' logs (|> LogEntry ts loc logSrc logLevel bs)
-  --     return $ Just ts
-  --   _ -> return Nothing
+  let !bs = fromLogStr logStr
+  maybeTs <- case maybeMemLogLevel of
+    Just x | x <= logLevel -> do
+      ts <- getCurrentTime
+      let !entry = LogEntry ts loc logSrc logLevel bs
+      atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
+      return $ Just ts
+    _ -> return Nothing
 
-  -- case maybeSavedLogLevel of
-  --   Just x | x <= logLevel -> do
-  --     ts <- maybe getCurrentTime return maybeTs
-  --     BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
-  --   _ -> return ()
+  case maybeSavedLogLevel of
+    Just x | x <= logLevel -> do
+      ts <- maybe getCurrentTime return maybeTs
+      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
+    _ -> return ()

From 28c9e77c2ff0cdbea09252a94a9ed954948159f7 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Sun, 1 Mar 2026 02:32:50 -0800
Subject: [PATCH 12/41] socket: add stream-events command

---
 sandwich/src/Test/Sandwich/ArgParsing.hs      | 16 +++++----
 .../src/Test/Sandwich/Formatters/Socket.hs    |  6 +++-
 .../Sandwich/Formatters/Socket/Commands.hs    |  1 +
 .../Test/Sandwich/Formatters/Socket/Server.hs | 35 ++++++++++++++++---
 .../Test/Sandwich/Interpreters/StartTree.hs   |  7 ++++
 sandwich/src/Test/Sandwich/Options.hs         |  1 +
 sandwich/src/Test/Sandwich/Types/RunTree.hs   | 14 ++++++++
 7 files changed, 67 insertions(+), 13 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index c8b323d5..383b0912 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -266,7 +266,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
         (_, Silent) -> silentFormatter
 
   -- Strip out any "main" formatters since the options control that
-  (baseFormatters, maybeLogBroadcast) <- optionsFormatters baseOptions
+  (baseFormatters, maybeLogBroadcast, maybeEventBroadcast) <- optionsFormatters baseOptions
                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath
                     & tryAddSocketFormatter optSocketFormatter
   let baseFormatters' = filter (not . isMainFormatter) baseFormatters
@@ -291,6 +291,7 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
     , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs
     , optionsCancelOnLongExecutionMs = (optionsCancelOnLongExecutionMs baseOptions) <|> optCancelOnLongExecutionMs
     , optionsLogBroadcast = maybeLogBroadcast
+    , optionsEventBroadcast = maybeEventBroadcast
     }
 
   return (options, optRepeatCount)
@@ -333,13 +334,14 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
       Just (_ :: SocketFormatter) -> True
       Nothing -> False
 
-    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO ([SomeFormatter], Maybe (TChan (Int, String, LogEntry)))
-    tryAddSocketFormatter False xs = return (xs, Nothing)
+    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO ([SomeFormatter], Maybe (TChan (Int, String, LogEntry)), Maybe (TChan NodeEvent))
+    tryAddSocketFormatter False xs = return (xs, Nothing, Nothing)
     tryAddSocketFormatter True xs
       | L.any isSocketFormatter xs =
-          -- Extract the broadcast channel from the existing formatter
-          let chan = headMay [socketFormatterLogBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]
-          in return (xs, chan)
+          -- Extract the broadcast channels from the existing formatter
+          let logChan = headMay [socketFormatterLogBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]
+              eventChan = headMay [socketFormatterEventBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]
+          in return (xs, logChan, eventChan)
       | otherwise = do
           sf <- defaultSocketFormatter
-          return ((SomeFormatter sf) : xs, Just (socketFormatterLogBroadcast sf))
+          return ((SomeFormatter sf) : xs, Just (socketFormatterLogBroadcast sf), Just (socketFormatterEventBroadcast sf))
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket.hs b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
index 3abfdd0a..c7554c3a 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
@@ -36,6 +36,8 @@ data SocketFormatter = SocketFormatter {
   -- ^ Internal: handle to the running server thread, used for cleanup.
   , socketFormatterLogBroadcast :: TChan (Int, String, LogEntry)
   -- ^ Broadcast channel for streaming logs to connected clients.
+  , socketFormatterEventBroadcast :: TChan NodeEvent
+  -- ^ Broadcast channel for streaming node lifecycle events to connected clients.
   } deriving (Typeable)
 
 instance Show SocketFormatter where
@@ -46,10 +48,12 @@ defaultSocketFormatter :: IO SocketFormatter
 defaultSocketFormatter = do
   ref <- newIORef Nothing
   chan <- newBroadcastTChanIO
+  eventChan <- newBroadcastTChanIO
   return SocketFormatter {
     socketFormatterPath = Nothing
     , socketFormatterServerAsync = ref
     , socketFormatterLogBroadcast = chan
+    , socketFormatterEventBroadcast = eventChan
     }
 
 instance Formatter SocketFormatter where
@@ -66,7 +70,7 @@ run (SocketFormatter {..}) rts _maybeCommandLineOptions bc = do
   case resolveSocketPath of
     Nothing -> return ()
     Just path -> liftIO $ do
-      a <- async (socketServer path rts socketFormatterLogBroadcast)
+      a <- async (socketServer path rts socketFormatterLogBroadcast socketFormatterEventBroadcast)
       writeIORef socketFormatterServerAsync (Just a)
       -- Block until all tests complete
       mapM_ waitForTree rts
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
index 5142a0f2..26716177 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -51,6 +51,7 @@ helpText = unlines
   , "  node <id>   - Detail for a specific node"
   , "  logs <id>   - Show logs for a specific node"
   , "  stream-logs      - Stream all logs live (disconnect to stop)"
+  , "  stream-events    - Stream node lifecycle events (started/done) live"
   , "  stream-rts-stats - Stream GHC RTS memory stats every 1s (needs +RTS -T)"
   ]
 
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index 2e66d651..20d44909 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -18,14 +18,15 @@ import Network.Socket.ByteString (recv, sendAll)
 import System.Directory (removeFile)
 import Test.Sandwich.Formatters.Socket.Commands
 import Test.Sandwich.Types.RunTree
+import Test.Sandwich.Types.Spec
 import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Exception
 
 
 -- | Bidirectional Unix socket server. Each client connection reads line-based
 -- commands and sends back responses terminated by a line containing just ".".
-socketServer :: FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> IO ()
-socketServer socketPath rts logBroadcast = do
+socketServer :: FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()
+socketServer socketPath rts logBroadcast eventBroadcast = do
   -- Clean up any existing socket file
   removeFile socketPath `catch` \(_ :: IOError) -> return ()
 
@@ -34,10 +35,10 @@ socketServer socketPath rts logBroadcast = do
     listen sock 5
     forever $ do
       (conn, _) <- accept sock
-      void $ async $ handleConnection conn rts logBroadcast
+      void $ async $ handleConnection conn rts logBroadcast eventBroadcast
 
-handleConnection :: Socket -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> IO ()
-handleConnection conn rts logBroadcast = do
+handleConnection :: Socket -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()
+handleConnection conn rts logBroadcast eventBroadcast = do
   bufRef <- newIORef BS.empty
   handle (\(_ :: IOError) -> close conn) $ do
     sendAll conn "Connected to sandwich socket formatter. Type \"help\" for commands.\n\n> "
@@ -47,6 +48,7 @@ handleConnection conn rts logBroadcast = do
       let cmd = BS8.unpack (stripCR line)
       case words cmd of
         ["stream-logs"] -> streamLogs conn logBroadcast
+        ["stream-events"] -> streamEvents conn eventBroadcast
         ["stream-rts-stats"] -> streamRtsStats conn
         _ -> do
           response <- handleCommand rts now cmd
@@ -75,6 +77,29 @@ streamLogs conn broadcastChan = do
         formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
     sendAll conn (BS8.pack formatted)
 
+-- | Stream node lifecycle events (started, done) to the client.
+streamEvents :: Socket -> TChan NodeEvent -> IO ()
+streamEvents conn broadcastChan = do
+  sendAll conn "Streaming events (disconnect to stop)...\n"
+  chan <- atomically $ dupTChan broadcastChan
+  handle (\(_ :: IOError) -> return ()) $ forever $ do
+    NodeEvent {..} <- atomically $ readTChan chan
+    let typeStr :: String
+        typeStr = case nodeEventType of
+          EventStarted -> "STARTED"
+          EventDone Success -> "DONE:OK"
+          EventDone (Failure (Pending {})) -> "DONE:PENDING"
+          EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]
+          EventDone DryRun -> "DONE:DRYRUN"
+          EventDone Cancelled -> "DONE:CANCELLED"
+        formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
+    sendAll conn (BS8.pack formatted)
+
+showFailureReasonBrief :: FailureReason -> String
+showFailureReasonBrief (Reason {failureReason}) = failureReason
+showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]
+showFailureReasonBrief _ = "(see node detail)"
+
 -- | Stream RTS stats to the client every second until the connection is closed.
 -- Requires the program to be run with +RTS -T for stats to be available.
 streamRtsStats :: Socket -> IO ()
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 19fbc7cb..f6b22169 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -258,6 +258,7 @@ runInAsync node ctx action = do
       (result, extraTimingInfo) <- timerFn action
       endTime <- liftIO getCurrentTime
       liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime (setupFinishTime extraTimingInfo) (teardownStartTime extraTimingInfo) endTime result
+      liftIO $ emitEvent baseContextOptions endTime runTreeId runTreeLabel (EventDone result)
 
       whenFailure result $ \reason -> do
         -- Make sure the folder exists, if configured
@@ -312,6 +313,7 @@ runInAsync node ctx action = do
 
       return result
   liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing Nothing myAsync
+  liftIO $ emitEvent baseContextOptions startTime runTreeId runTreeLabel EventStarted
   liftIO $ putMVar mvar ()
   return myAsync  -- TODO: fix race condition with writing to runTreeStatus (here and above)
 
@@ -431,6 +433,11 @@ addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar' statusVar $
   status@(Done {}) -> status { statusTeardownStartTime = Just t }
   x -> x
 
+emitEvent :: Options -> UTCTime -> Int -> String -> NodeEventType -> IO ()
+emitEvent (Options {optionsEventBroadcast = Just chan}) ts nid label evtType =
+  atomically $ writeTChan chan (NodeEvent ts nid label evtType)
+emitEvent _ _ _ _ _ = return ()
+
 recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()
 recordExceptionInStatus status e = do
   endTime <- liftIO getCurrentTime
diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs
index 81bfee77..028b6140 100644
--- a/sandwich/src/Test/Sandwich/Options.hs
+++ b/sandwich/src/Test/Sandwich/Options.hs
@@ -58,6 +58,7 @@ defaultOptions = Options {
   , optionsWarnOnLongExecutionMs = Nothing
   , optionsCancelOnLongExecutionMs = Nothing
   , optionsLogBroadcast = Nothing
+  , optionsEventBroadcast = Nothing
   }
 
 -- | Generate a test artifacts directory based on a timestamp.
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 0c818b0b..95797a94 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -118,6 +118,18 @@ data LogEntry = LogEntry {
   , logEntryStr :: !BS8.ByteString
   } deriving (Show, Eq)
 
+data NodeEvent = NodeEvent {
+  nodeEventTime :: !UTCTime
+  , nodeEventId :: !Int
+  , nodeEventLabel :: !String
+  , nodeEventType :: !NodeEventType
+  } deriving (Show, Eq)
+
+data NodeEventType
+  = EventStarted
+  | EventDone !Result
+  deriving (Show, Eq)
+
 -- | Context passed around through the evaluation of a RunTree
 data RunTreeContext = RunTreeContext {
   runTreeCurrentAncestors :: Seq Int
@@ -298,6 +310,8 @@ data Options = Options {
   , optionsLogBroadcast :: Maybe (TChan (Int, String, LogEntry))
   -- ^ Broadcast channel for streaming log entries to external consumers (e.g. socket formatter).
   -- Each entry is tagged with (nodeId, nodeLabel, logEntry).
+  , optionsEventBroadcast :: Maybe (TChan NodeEvent)
+  -- ^ Broadcast channel for streaming node lifecycle events (started, done) to external consumers.
   }
 
 -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way

From c074c47fcbcdb92e12076836958fb95c7f68a989 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 01:19:09 -0800
Subject: [PATCH 13/41] Add --log-logs, --log-events, --log-rts-stats

---
 sandwich/sandwich.cabal                       |   1 +
 sandwich/src/Test/Sandwich.hs                 |  24 ++++
 sandwich/src/Test/Sandwich/ArgParsing.hs      |  16 ++-
 sandwich/src/Test/Sandwich/Instrumentation.hs | 104 ++++++++++++++++++
 .../src/Test/Sandwich/Types/ArgParsing.hs     |   3 +
 5 files changed, 147 insertions(+), 1 deletion(-)
 create mode 100644 sandwich/src/Test/Sandwich/Instrumentation.hs

diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index 5ad2ee48..acea6bff 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -74,6 +74,7 @@ library
       Test.Sandwich.Formatters.TerminalUI.OpenInEditor
       Test.Sandwich.Formatters.TerminalUI.Types
       Test.Sandwich.Golden.Update
+      Test.Sandwich.Instrumentation
       Test.Sandwich.Internal.Formatters
       Test.Sandwich.Internal.Inspection
       Test.Sandwich.Internal.Running
diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index ba5e4bd2..eb3bf038 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -95,6 +95,7 @@ import Test.Sandwich.Contexts
 import Test.Sandwich.Expectations
 import Test.Sandwich.Formatters.Common.Count
 import Test.Sandwich.Golden.Update
+import Test.Sandwich.Instrumentation
 import Test.Sandwich.Internal.Running
 import Test.Sandwich.Interpreters.FilterTreeModule
 import Test.Sandwich.Interpreters.RunTree
@@ -223,6 +224,25 @@ runSandwich' maybeCommandLineOptions options spec' = do
     loggingFn $
       runFormatter f rts maybeCommandLineOptions baseContext
 
+  -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats
+  fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
+    (Just clo, Just runRoot) -> fmap catMaybes $ sequence
+      [ if optLogLogs clo
+        then case optionsLogBroadcast options of
+          Just chan -> Just <$> async (streamLogsToFile (runRoot </> "logs.txt") chan)
+          Nothing -> return Nothing
+        else return Nothing
+      , if optLogEvents clo
+        then case optionsEventBroadcast options of
+          Just chan -> Just <$> async (streamEventsToFile (runRoot </> "events.txt") chan)
+          Nothing -> return Nothing
+        else return Nothing
+      , if optLogRtsStats clo
+        then Just <$> async (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
+        else return Nothing
+      ]
+    _ -> return []
+
   exitReasonRef <- newIORef NormalExit
 
   let shutdown sig = do
@@ -256,6 +276,9 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
   fixedTree <- atomically $ mapM fixRunTree rts
 
+  -- Cancel file stream asyncs
+  mapM_ cancel fileStreamAsyncs
+
   exitReason <- readIORef exitReasonRef
   let failedItBlocks = countWhere isFailedItBlock fixedTree
   let failedBlocks = countWhere isFailedBlock fixedTree
@@ -269,3 +292,4 @@ countItNodes (Free (IntroduceWith'' {..})) = countItNodes next + countItNodes su
 countItNodes (Free (Introduce'' {..})) = countItNodes next + countItNodes subspecAugmented
 countItNodes (Free x) = countItNodes (next x) + countItNodes (subspec x)
 countItNodes (Pure _) = 0
+
diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index 383b0912..2029f5e1 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -98,6 +98,9 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio
   <*> optional (strOption (long "markdown-summary" <> help "File path to write a Markdown summary of the results." <> metavar "STRING"))
   <*> switch (long "tui-debug" <> help "Enable TUI debug socket at <test-root>/tui-debug.sock")
   <*> switch (long "socket" <> help "Enable interactive socket formatter at <test-root>/socket.sock")
+  <*> switch (long "log-logs" <> help "Stream all test logs to <run-root>/logs.txt (for debugging)")
+  <*> switch (long "log-events" <> help "Stream node lifecycle events to <run-root>/events.txt (for debugging)")
+  <*> switch (long "log-rts-stats" <> help "Stream RTS memory stats to <run-root>/rts-stats.txt (for debugging)")
 
   <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))
   <*> optional (flag False True (long "list-tests-json" <> help "List individual test modules in JSON format"))
@@ -266,11 +269,22 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do
         (_, Silent) -> silentFormatter
 
   -- Strip out any "main" formatters since the options control that
-  (baseFormatters, maybeLogBroadcast, maybeEventBroadcast) <- optionsFormatters baseOptions
+  (baseFormatters, socketLogBroadcast, socketEventBroadcast) <- optionsFormatters baseOptions
                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath
                     & tryAddSocketFormatter optSocketFormatter
   let baseFormatters' = filter (not . isMainFormatter) baseFormatters
 
+  -- Ensure broadcast channels exist if file logging flags need them
+  maybeLogBroadcast <- case socketLogBroadcast of
+    Just ch -> return (Just ch)
+    Nothing | optLogLogs -> Just <$> newBroadcastTChanIO
+    Nothing -> return Nothing
+
+  maybeEventBroadcast <- case socketEventBroadcast of
+    Just ch -> return (Just ch)
+    Nothing | optLogEvents -> Just <$> newBroadcastTChanIO
+    Nothing -> return Nothing
+
   let finalFormatters = baseFormatters' <> [mainFormatter]
                       & fmap (setVisibilityThreshold optVisibilityThreshold)
 
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
new file mode 100644
index 00000000..982535e7
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -0,0 +1,104 @@
+module Test.Sandwich.Instrumentation (
+  streamLogsToFile
+  , streamEventsToFile
+  , streamRtsStatsToFile
+  ) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Logger
+import qualified Data.ByteString.Char8 as BS8
+import Data.String.Interpolate
+import Data.Word
+import GHC.Stats
+import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
+import Test.Sandwich.Types.RunTree
+import Test.Sandwich.Types.Spec
+import UnliftIO.Concurrent (threadDelay)
+
+
+-- | Stream all log entries from a broadcast channel to a file.
+streamLogsToFile :: FilePath -> TChan (Int, String, LogEntry) -> IO ()
+streamLogsToFile path broadcastChan = do
+  chan <- atomically $ dupTChan broadcastChan
+  withFile path AppendMode $ \h -> do
+    hSetBuffering h LineBuffering
+    forever $ do
+      (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan
+      let levelStr :: String
+          levelStr = case logEntryLevel of
+            LevelDebug -> "DEBUG"
+            LevelInfo -> "INFO"
+            LevelWarn -> "WARN"
+            LevelError -> "ERROR"
+            LevelOther t -> show t
+          msgStr = BS8.unpack logEntryStr
+          formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
+      hPutStr h formatted
+      hFlush h
+
+-- | Stream node lifecycle events from a broadcast channel to a file.
+streamEventsToFile :: FilePath -> TChan NodeEvent -> IO ()
+streamEventsToFile path broadcastChan = do
+  chan <- atomically $ dupTChan broadcastChan
+  withFile path AppendMode $ \h -> do
+    hSetBuffering h LineBuffering
+    forever $ do
+      NodeEvent {..} <- atomically $ readTChan chan
+      let typeStr :: String
+          typeStr = case nodeEventType of
+            EventStarted -> "STARTED"
+            EventDone Success -> "DONE:OK"
+            EventDone (Failure (Pending {})) -> "DONE:PENDING"
+            EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]
+            EventDone DryRun -> "DONE:DRYRUN"
+            EventDone Cancelled -> "DONE:CANCELLED"
+          formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
+      hPutStr h formatted
+      hFlush h
+
+-- | Poll RTS stats every second and append to a file.
+-- Requires the program to be run with +RTS -T for stats to be available.
+streamRtsStatsToFile :: FilePath -> IO ()
+streamRtsStatsToFile path = do
+  enabled <- getRTSStatsEnabled
+  when enabled $ do
+    withFile path AppendMode $ \h -> do
+      hSetBuffering h LineBuffering
+      forever $ do
+        stats <- getRTSStats
+        let gc' = gc stats
+        hPutStr h (formatRtsStats stats gc')
+        hFlush h
+        threadDelay 1000000
+
+showFailureReasonBrief :: FailureReason -> String
+showFailureReasonBrief (Reason {failureReason}) = failureReason
+showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]
+showFailureReasonBrief _ = "(see node detail)"
+
+formatRtsStats :: RTSStats -> GCDetails -> String
+formatRtsStats stats gc' = unlines
+  [ [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
+  , [i|heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}|]
+  , [i|allocated_bytes:    #{formatBytes (allocated_bytes stats)}|]
+  , [i|max_live_bytes:     #{formatBytes (max_live_bytes stats)}|]
+  , [i|large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}|]
+  , [i|compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}|]
+  , [i|slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}|]
+  , [i|gcs:                #{gcs stats}|]
+  , [i|major_gcs:          #{major_gcs stats}|]
+  , [i|gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms|]
+  , [i|mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms|]
+  , ""
+  ]
+  where
+    nsToMs :: RtsTime -> RtsTime
+    nsToMs ns = ns `div` 1000000
+
+formatBytes :: Word64 -> String
+formatBytes b
+  | b < 1024 = [i|#{b} B|]
+  | b < 1024 * 1024 = [i|#{b `div` 1024} KiB (#{b})|]
+  | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]
+  | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
index f56aa2c9..6a42d49d 100644
--- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
@@ -61,6 +61,9 @@ data CommandLineOptions a = CommandLineOptions {
   , optMarkdownSummaryPath :: Maybe FilePath
   , optTuiDebugSocket :: Bool
   , optSocketFormatter :: Bool
+  , optLogLogs :: Bool
+  , optLogEvents :: Bool
+  , optLogRtsStats :: Bool
 
   , optListAvailableTests :: Maybe Bool
   , optListAvailableTestsJson :: Maybe Bool

From e7f516250011a539d46db878e2e0db41d866e53b Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 02:38:50 -0800
Subject: [PATCH 14/41] Include timestamps in RTS stats

---
 sandwich/src/Test/Sandwich/Instrumentation.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index 982535e7..a2928010 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -9,6 +9,7 @@ import Control.Monad
 import Control.Monad.Logger
 import qualified Data.ByteString.Char8 as BS8
 import Data.String.Interpolate
+import Data.Time
 import Data.Word
 import GHC.Stats
 import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
@@ -66,9 +67,10 @@ streamRtsStatsToFile path = do
     withFile path AppendMode $ \h -> do
       hSetBuffering h LineBuffering
       forever $ do
+        now <- getCurrentTime
         stats <- getRTSStats
         let gc' = gc stats
-        hPutStr h (formatRtsStats stats gc')
+        hPutStr h (formatRtsStats now stats gc')
         hFlush h
         threadDelay 1000000
 
@@ -77,9 +79,10 @@ showFailureReasonBrief (Reason {failureReason}) = failureReason
 showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]
 showFailureReasonBrief _ = "(see node detail)"
 
-formatRtsStats :: RTSStats -> GCDetails -> String
-formatRtsStats stats gc' = unlines
-  [ [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
+formatRtsStats :: UTCTime -> RTSStats -> GCDetails -> String
+formatRtsStats now stats gc' = unlines
+  [ [i|#{show now}|]
+  , [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
   , [i|heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}|]
   , [i|allocated_bytes:    #{formatBytes (allocated_bytes stats)}|]
   , [i|max_live_bytes:     #{formatBytes (max_live_bytes stats)}|]

From e4b15f49d886cc0a7ced3f08ac10f144a3ebb157 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 16:46:21 -0800
Subject: [PATCH 15/41] Try removing printLogs calls

---
 .../Test/Sandwich/Formatters/Print/Common.hs   |  2 +-
 .../src/Test/Sandwich/Formatters/Print/Logs.hs | 18 +++++++++---------
 .../Test/Sandwich/Interpreters/StartTree.hs    |  2 +-
 3 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
index 4dea89b7..2026f1d5 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
@@ -30,4 +30,4 @@ finishPrinting (RunNodeCommonWithStatus {..}) result = do
       _ -> return ()
 
   -- Print the logs, if configured
-  printLogs runTreeLogs
+  -- printLogs runTreeLogs
diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
index 857bee0a..bb7f0877 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
@@ -21,15 +21,15 @@ import Control.Monad
 #endif
 
 
-printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
-printLogs runTreeLogs = do
-  (asks (printFormatterLogLevel . fst3)) >>= \case
-    Nothing -> return ()
-    Just logLevel -> do
-      logEntries <- liftIO $ readTVarIO runTreeLogs
-      withBumpIndent $
-        forM_ logEntries $ \entry ->
-          when (logEntryLevel entry >= logLevel) $ printLogEntry entry
+-- printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
+-- printLogs runTreeLogs = do
+--   (asks (printFormatterLogLevel . fst3)) >>= \case
+--     Nothing -> return ()
+--     Just logLevel -> do
+--       logEntries <- liftIO $ readTVarIO runTreeLogs
+--       withBumpIndent $
+--         forM_ logEntries $ \entry ->
+--           when (logEntryLevel entry >= logLevel) $ printLogEntry entry
 
 
 printLogEntry :: (
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index f6b22169..55d806be 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -309,7 +309,7 @@ runInAsync node ctx action = do
                 p "\n"
                 printCallStack cs
               p "\n"
-              printLogs runTreeLogs
+              -- printLogs runTreeLogs
 
       return result
   liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing Nothing myAsync

From 957cdbf59e05c87e4640e8ec5f125ec5edf9c2ac Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 17:27:55 -0800
Subject: [PATCH 16/41] Add trace markers for test events

---
 sandwich/src/Test/Sandwich/Instrumentation.hs | 1 +
 1 file changed, 1 insertion(+)

diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index a2928010..09e07a42 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -55,6 +55,7 @@ streamEventsToFile path broadcastChan = do
             EventDone DryRun -> "DONE:DRYRUN"
             EventDone Cancelled -> "DONE:CANCELLED"
           formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
+      traceMarkerIO [i|[#{nodeEventId}] #{nodeEventLabel}: #{typeStr}|]
       hPutStr h formatted
       hFlush h
 

From 4f2361011c9c0ec000f89b95824212ffe92807e7 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 17:31:08 -0800
Subject: [PATCH 17/41] Clearer name for all-logs

---
 sandwich/src/Test/Sandwich.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index eb3bf038..60661e99 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -229,7 +229,7 @@ runSandwich' maybeCommandLineOptions options spec' = do
     (Just clo, Just runRoot) -> fmap catMaybes $ sequence
       [ if optLogLogs clo
         then case optionsLogBroadcast options of
-          Just chan -> Just <$> async (streamLogsToFile (runRoot </> "logs.txt") chan)
+          Just chan -> Just <$> async (streamLogsToFile (runRoot </> "all-logs.txt") chan)
           Nothing -> return Nothing
         else return Nothing
       , if optLogEvents clo

From a175ba4ba7896fe8f4ffc48990d99ab0ec043134 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 17:31:40 -0800
Subject: [PATCH 18/41] Record log entry sizes

---
 sandwich/package.yaml                         |  1 +
 sandwich/sandwich.cabal                       |  5 ++
 sandwich/src/Test/Sandwich.hs                 |  1 -
 sandwich/src/Test/Sandwich/Instrumentation.hs | 42 +++++++++-----
 stack.yaml                                    |  2 +
 stack.yaml.lock                               | 57 +++++++++++--------
 6 files changed, 69 insertions(+), 39 deletions(-)

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index f08591c8..8df4f265 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -39,6 +39,7 @@ dependencies:
 - exceptions
 - filepath
 - free
+- ghc-datasize
 - microlens
 - microlens-th
 - monad-control
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index acea6bff..c9d57ccf 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -128,6 +128,7 @@ library
     , exceptions
     , filepath
     , free
+    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -191,6 +192,7 @@ executable sandwich-demo
     , exceptions
     , filepath
     , free
+    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -252,6 +254,7 @@ executable sandwich-discover
     , exceptions
     , filepath
     , free
+    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -319,6 +322,7 @@ executable sandwich-test
     , exceptions
     , filepath
     , free
+    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -387,6 +391,7 @@ test-suite sandwich-test-suite
     , exceptions
     , filepath
     , free
+    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 60661e99..1de08999 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -292,4 +292,3 @@ countItNodes (Free (IntroduceWith'' {..})) = countItNodes next + countItNodes su
 countItNodes (Free (Introduce'' {..})) = countItNodes next + countItNodes subspecAugmented
 countItNodes (Free x) = countItNodes (next x) + countItNodes (subspec x)
 countItNodes (Pure _) = 0
-
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index 09e07a42..9bc6e98c 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -8,34 +8,50 @@ import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Logger
 import qualified Data.ByteString.Char8 as BS8
+import Data.IORef
 import Data.String.Interpolate
 import Data.Time
 import Data.Word
+import Debug.Trace (traceMarkerIO)
+import GHC.DataSize (recursiveSize)
 import GHC.Stats
 import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import UnliftIO.Concurrent (threadDelay)
+import UnliftIO.Exception
 
 
--- | Stream all log entries from a broadcast channel to a file.
+-- | Stream all log entries from a broadcast channel to a file,
+-- including the recursive heap size of each LogEntry.
+-- When cancelled, writes a summary line with total bytes.
 streamLogsToFile :: FilePath -> TChan (Int, String, LogEntry) -> IO ()
 streamLogsToFile path broadcastChan = do
   chan <- atomically $ dupTChan broadcastChan
+  totalRef <- newIORef (0 :: Word)
+  countRef <- newIORef (0 :: Int)
   withFile path AppendMode $ \h -> do
     hSetBuffering h LineBuffering
-    forever $ do
-      (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan
-      let levelStr :: String
-          levelStr = case logEntryLevel of
-            LevelDebug -> "DEBUG"
-            LevelInfo -> "INFO"
-            LevelWarn -> "WARN"
-            LevelError -> "ERROR"
-            LevelOther t -> show t
-          msgStr = BS8.unpack logEntryStr
-          formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]
-      hPutStr h formatted
+    let loop = forever $ do
+          (nodeId, nodeLabel, entry@(LogEntry {..})) <- atomically $ readTChan chan
+          entrySize <- recursiveSize entry
+          modifyIORef' totalRef (+ entrySize)
+          modifyIORef' countRef (+ 1)
+          let levelStr :: String
+              levelStr = case logEntryLevel of
+                LevelDebug -> "DEBUG"
+                LevelInfo -> "INFO"
+                LevelWarn -> "WARN"
+                LevelError -> "ERROR"
+                LevelOther t -> show t
+              msgStr = BS8.unpack logEntryStr
+              formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr} (#{entrySize} bytes)\n|]
+          hPutStr h formatted
+          hFlush h
+    loop `finally` do
+      total <- readIORef totalRef
+      count <- readIORef countRef
+      hPutStr h [i|\nTotal: #{count} log entries, #{formatBytes (fromIntegral total)} recursive heap size\n|]
       hFlush h
 
 -- | Stream node lifecycle events from a broadcast channel to a file.
diff --git a/stack.yaml b/stack.yaml
index cf56ea31..d8a5ff04 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -60,6 +60,8 @@ packages:
 - ./demos/demo-webdriver-video
 
 extra-deps:
+- ghc-datasize-0.2.7
+
 # For sandwich-webdriver
 
 - webdriver-0.14.0.0
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 03f1d81d..227ae42f 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -1,89 +1,96 @@
 # This file was autogenerated by Stack.
 # You should not edit this file by hand.
 # For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
+#   https://docs.haskellstack.org/en/stable/topics/lock_files
 
 packages:
+- completed:
+    hackage: ghc-datasize-0.2.7@sha256:3397b0306f179836a0f5912e9888b5a0d2c40c2a6bba12965e82144a22de15a3,1132
+    pantry-tree:
+      sha256: 7855227e0065019e4d762705f011a1aa195e4389e8cd0870eea1f0f3b7e906ee
+      size: 216
+  original:
+    hackage: ghc-datasize-0.2.7
 - completed:
     hackage: webdriver-0.14.0.0@sha256:3a529a3520b3d9be4dcc0c51fabd96ee3e67661ac18e6d4417100ac187da4c15,6463
     pantry-tree:
-      size: 5522
       sha256: 2770f7329cc59c8c60cc639ec56d11904cf04fc245c4195039ec6fec328dc0fd
+      size: 5522
   original:
     hackage: webdriver-0.14.0.0
 - completed:
-    name: minio-hs
-    version: 1.7.0
+    commit: 3e665784228cba7261560c104b8f1d928e7b5bd4
     git: https://github.com/minio/minio-hs
+    name: minio-hs
     pantry-tree:
-      size: 4744
       sha256: b40b79fedd757eac8825f89eafc5ee13f3991898e407cb3d1c9b5a3b15bffdfc
-    commit: 3e665784228cba7261560c104b8f1d928e7b5bd4
+      size: 4744
+    version: 1.7.0
   original:
-    git: https://github.com/minio/minio-hs
     commit: 3e665784228cba7261560c104b8f1d928e7b5bd4
+    git: https://github.com/minio/minio-hs
 - completed:
-    subdir: v1.44
-    name: docker-engine
-    version: 144.0.0
+    commit: 58535cd46712dff421f2148e438c49c2700ea20e
     git: https://github.com/codedownio/docker-engine.git
+    name: docker-engine
     pantry-tree:
-      size: 2451
       sha256: cc9ed672084a86834dff2ff143002e988142864b51bd620ea8d4180e6f1041b8
-    commit: 58535cd46712dff421f2148e438c49c2700ea20e
-  original:
+      size: 2451
     subdir: v1.44
-    git: https://github.com/codedownio/docker-engine.git
+    version: 144.0.0
+  original:
     commit: 58535cd46712dff421f2148e438c49c2700ea20e
+    git: https://github.com/codedownio/docker-engine.git
+    subdir: v1.44
 - completed:
     hackage: kubernetes-api-130.0.0@sha256:aa2d91343a2639efbb3cbb1256ba7eaa43d3476e6e35a50770ecb4b19bf8c114,5635
     pantry-tree:
-      size: 6518
       sha256: a94bf97a25641331d46db1e4243aaf11e8b193f7f6dcd890cb6364ad5ec3c320
+      size: 6518
   original:
     hackage: kubernetes-api-130.0.0
 - completed:
     hackage: kubernetes-api-client-0.6.1.2@sha256:1e8fc7d53511f08380b54cea92ab85c50c88e7ba97552d10e8712ee918976015,5034
     pantry-tree:
-      size: 2026
       sha256: f339c3ef1e14988806ba79fb885f6802be06510ae9bb2a6ae1809a5adceeea0c
+      size: 2026
   original:
     hackage: kubernetes-api-client-0.6.1.2
 - completed:
-    name: oidc-client
-    version: 0.8.0.0
+    commit: 2d19db09bf13f02f49248f7b21703b2c59e06ecc
     git: https://github.com/krdlab/haskell-oidc-client
+    name: oidc-client
     pantry-tree:
-      size: 1846
       sha256: 1ba8f7b134dffd636721d4cebc4c52721b8cb628bc332eed3088443cd2cc969c
-    commit: 2d19db09bf13f02f49248f7b21703b2c59e06ecc
+      size: 1846
+    version: 0.8.0.0
   original:
-    git: https://github.com/krdlab/haskell-oidc-client
     commit: 2d19db09bf13f02f49248f7b21703b2c59e06ecc
+    git: https://github.com/krdlab/haskell-oidc-client
 - completed:
     hackage: HaskellNet-0.6.2@sha256:afc178bd40f0e8d8368bef8308881f73985ccbe3ce8f4c68ba5d7db3ca18cc36,2478
     pantry-tree:
-      size: 1689
       sha256: 6c69d25f62ce5ecb49b87546d052b67fa8e548f7c161dd87274c696c563f9314
+      size: 1689
   original:
     hackage: HaskellNet-0.6.2
 - completed:
     hackage: cryptonite-0.30@sha256:12c85dea7be63e5ad90bcb487eb3846bf3c413347f94336fa1dede7b28f9936a,18301
     pantry-tree:
-      size: 23323
       sha256: df1cbe4cc40d569cc75ffed40bc5deac43cb085653980b42b9b6a5d4b745a30a
+      size: 23323
   original:
     hackage: cryptonite-0.30@sha256:12c85dea7be63e5ad90bcb487eb3846bf3c413347f94336fa1dede7b28f9936a,18301
 - completed:
     hackage: cryptonite-conduit-0.2.2@sha256:bfbae677a44f3a5cf3bf7f36271682979a402825f3d1e8767cfd62f2ddb702c2,1984
     pantry-tree:
-      size: 595
       sha256: 251e4a1b3d382e4cbf9d378a5550cf617bb2650d61339db93253f2189bbfa918
+      size: 595
   original:
     hackage: cryptonite-conduit-0.2.2@sha256:bfbae677a44f3a5cf3bf7f36271682979a402825f3d1e8767cfd62f2ddb702c2,1984
 snapshots:
 - completed:
+    sha256: 89f1083d6c74b5b78ace9ca630e015f016d4a8d2ffcace7ae02bad57289ba9e9
     size: 690943
     url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2025/9/6.yaml
-    sha256: 89f1083d6c74b5b78ace9ca630e015f016d4a8d2ffcace7ae02bad57289ba9e9
   original: nightly-2025-09-06

From d67ecc8e64f58068c74a02354d50aa0fdb1efdf7 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 20:27:00 -0800
Subject: [PATCH 19/41] Write events tree to file when --log-events passed

---
 sandwich/src/Test/Sandwich.hs                 |  8 +++++---
 sandwich/src/Test/Sandwich/Instrumentation.hs | 20 +++++++++++++++++++
 2 files changed, 25 insertions(+), 3 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 1de08999..c1e603e3 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -233,9 +233,11 @@ runSandwich' maybeCommandLineOptions options spec' = do
           Nothing -> return Nothing
         else return Nothing
       , if optLogEvents clo
-        then case optionsEventBroadcast options of
-          Just chan -> Just <$> async (streamEventsToFile (runRoot </> "events.txt") chan)
-          Nothing -> return Nothing
+        then do
+          writeTreeFile (runRoot </> "events-tree.txt") rts
+          case optionsEventBroadcast options of
+            Just chan -> Just <$> async (streamEventsToFile (runRoot </> "events.txt") chan)
+            Nothing -> return Nothing
         else return Nothing
       , if optLogRtsStats clo
         then Just <$> async (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index 9bc6e98c..a9b20b38 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -2,6 +2,7 @@ module Test.Sandwich.Instrumentation (
   streamLogsToFile
   , streamEventsToFile
   , streamRtsStatsToFile
+  , writeTreeFile
   ) where
 
 import Control.Concurrent.STM
@@ -122,3 +123,22 @@ formatBytes b
   | b < 1024 * 1024 = [i|#{b `div` 1024} KiB (#{b})|]
   | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]
   | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
+
+-- | Write a tree of node IDs and labels to a file for cross-referencing with events.
+writeTreeFile :: FilePath -> [RunNodeWithStatus context s l t] -> IO ()
+writeTreeFile path rts =
+  writeFile path $ unlines $ concatMap (renderTree 0) rts
+
+renderTree :: Int -> RunNodeWithStatus context s l t -> [String]
+renderTree depth node = line : children
+  where
+    c = runNodeCommon node
+    indent = replicate (depth * 2) ' '
+    label = runTreeLabel c
+    nid = runTreeId c
+    line = [i|#{indent}[#{nid}] #{label}|]
+    children = case node of
+      RunNodeIt {} -> []
+      RunNodeIntroduce {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented
+      RunNodeIntroduceWith {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented
+      _ -> concatMap (renderTree (depth + 1)) (runNodeChildren node)

From 41314968bf982491c5a209462d4a1affb4710f5d Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Mon, 2 Mar 2026 22:40:57 -0800
Subject: [PATCH 20/41] Add more events around introduce/introduceWith/around

---
 .../Test/Sandwich/Formatters/Socket/Server.hs |  4 ++++
 sandwich/src/Test/Sandwich/Instrumentation.hs |  4 ++++
 .../Test/Sandwich/Interpreters/StartTree.hs   | 20 +++++++++++++++++--
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  4 ++++
 4 files changed, 30 insertions(+), 2 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index 20d44909..655254b2 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -92,6 +92,10 @@ streamEvents conn broadcastChan = do
           EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]
           EventDone DryRun -> "DONE:DRYRUN"
           EventDone Cancelled -> "DONE:CANCELLED"
+          EventSetupStarted -> "SETUP:STARTED"
+          EventSetupFinished -> "SETUP:FINISHED"
+          EventTeardownStarted -> "TEARDOWN:STARTED"
+          EventTeardownFinished -> "TEARDOWN:FINISHED"
         formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
     sendAll conn (BS8.pack formatted)
 
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index a9b20b38..a1450dc9 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -71,6 +71,10 @@ streamEventsToFile path broadcastChan = do
             EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]
             EventDone DryRun -> "DONE:DRYRUN"
             EventDone Cancelled -> "DONE:CANCELLED"
+            EventSetupStarted -> "SETUP:STARTED"
+            EventSetupFinished -> "SETUP:FINISHED"
+            EventTeardownStarted -> "TEARDOWN:STARTED"
+            EventTeardownFinished -> "TEARDOWN:FINISHED"
           formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
       traceMarkerIO [i|[#{nodeEventId}] #{nodeEventLabel}: #{typeStr}|]
       hPutStr h formatted
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 55d806be..3419d4c9 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -97,22 +97,28 @@ startTree node@(RunNodeIntroduce {..}) ctx' = do
     -- 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
+    let opts = baseContextOptions (getBaseContext ctx)
     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 $
+          getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventSetupStarted
+          flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ do
+            ret <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $
               runExampleM' runNodeCommon label runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])
+            getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventSetupFinished
+            return ret
       )
       (\(ret, setupStartTime, setupFinishTime) -> case ret of
           Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime)
           Right intro -> do
             teardownStartTime <- getCurrentTime
             addTeardownStartTimeToStatus runTreeStatus teardownStartTime
+            emitEvent opts teardownStartTime runTreeId runTreeLabel EventTeardownStarted
             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|])
+            getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventTeardownFinished
             writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime))
       )
       (\(ret, _setupStartTime, setupFinishTime) -> do
@@ -166,6 +172,8 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
             -- let teardownLabel = runTreeLabel <> " (teardown)"
             -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel)
 
+            let opts = baseContextOptions (getBaseContext ctx)
+            liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventSetupStarted
             results <- runNodeIntroduceAction $ \intro -> do
               -- Record the end event in the test timing
               -- TODO: do we need to deal with exceptions here and in teardown? I think we we fail to emit the
@@ -173,6 +181,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
               -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel)
               setupFinishTime <- liftIO getCurrentTime
               addSetupFinishTimeToStatus runTreeStatus setupFinishTime
+              liftIO $ emitEvent opts setupFinishTime runTreeId runTreeLabel EventSetupFinished
 
               liftIO $ writeIORef didAllocateVar True
 
@@ -181,6 +190,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
 
               teardownStartTime <- liftIO getCurrentTime
               addTeardownStartTimeToStatus runTreeStatus teardownStartTime
+              liftIO $ emitEvent opts teardownStartTime runTreeId runTreeLabel EventTeardownStarted
 
               liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime)
               -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel)
@@ -191,6 +201,7 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
               Nothing -> return ()
               Just teardownStartTime -> do
                 -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel)
+                liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownFinished
                 liftIO $ modifyIORef' didRunWrappedAction $ \(ret, timingInfo) ->
                   (ret, timingInfo { teardownStartTime = Just teardownStartTime })
 
@@ -207,15 +218,20 @@ startTree node@(RunNodeAround {..}) ctx' = do
   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon
   didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo)
   runInAsync node ctx $ do
+    let opts = baseContextOptions (getBaseContext ctx)
     let wrappedAction = do
           flip withException (\e -> recordExceptionInStatus runTreeStatus e) $ do
+            liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventSetupStarted
             runNodeActionWith $ do
               setupFinishTime <- liftIO getCurrentTime
               addSetupFinishTimeToStatus runTreeStatus setupFinishTime
+              liftIO $ emitEvent opts setupFinishTime runTreeId runTreeLabel EventSetupFinished
               results <- liftIO $ runNodesSequentially runNodeChildren ctx
+              liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownStarted
               liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime)
               return results
 
+          liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownFinished
           (liftIO $ readIORef didRunWrappedAction) >>= \case
             (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|], timingInfo)
             (Right _, timingInfo) -> return (Success, timingInfo)
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 95797a94..80bec9c8 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -128,6 +128,10 @@ data NodeEvent = NodeEvent {
 data NodeEventType
   = EventStarted
   | EventDone !Result
+  | EventSetupStarted
+  | EventSetupFinished
+  | EventTeardownStarted
+  | EventTeardownFinished
   deriving (Show, Eq)
 
 -- | Context passed around through the evaluation of a RunTree

From 2d18ebbc51559fc469999edc22096db5725687d4 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 3 Mar 2026 01:22:02 -0800
Subject: [PATCH 21/41] Add milestone logging

---
 sandwich/src/Test/Sandwich.hs                 | 20 +++++++++++++++++++
 .../Test/Sandwich/Formatters/Socket/Server.hs |  1 +
 sandwich/src/Test/Sandwich/Instrumentation.hs |  1 +
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  1 +
 4 files changed, 23 insertions(+)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index c1e603e3..bc53252b 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -84,6 +84,8 @@ import qualified Data.Map as M
 import Data.Maybe
 import Data.String.Interpolate
 import qualified Data.Text as T
+import Data.Time (getCurrentTime)
+import Debug.Trace (traceMarkerIO)
 import GHC.IO.Encoding
 import Options.Applicative
 import qualified Options.Applicative as OA
@@ -196,6 +198,13 @@ runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (Exit
 runSandwich' maybeCommandLineOptions options spec' = do
   baseContext <- baseContextFromOptions options
 
+  let milestone msg = do
+        traceMarkerIO [i|sandwich: #{msg}|]
+        now <- getCurrentTime
+        case optionsEventBroadcast options of
+          Just chan -> atomically $ writeTChan chan (NodeEvent now 0 "sandwich" (EventMilestone msg))
+          Nothing -> return ()
+
   -- To prevent weird errors saving files like "commitAndReleaseBuffer: invalid argument (invalid character)",
   -- especially on Windows
   -- See https://gitlab.haskell.org/ghc/ghc/issues/8118
@@ -214,8 +223,10 @@ runSandwich' maybeCommandLineOptions options spec' = do
                         , nodeOptionsCreateFolder = False
                         }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec'
 
+  milestone "startSandwichTree'"
   rts <- startSandwichTree' baseContext options spec
 
+  milestone "spawning formatters"
   formatterAsyncs <- forM (optionsFormatters options) $ \(SomeFormatter f) -> async $ do
     let loggingFn = case baseContextRunRoot baseContext of
           Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
@@ -225,6 +236,7 @@ runSandwich' maybeCommandLineOptions options spec' = do
       runFormatter f rts maybeCommandLineOptions baseContext
 
   -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats
+  milestone "spawning file stream asyncs"
   fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
     (Just clo, Just runRoot) -> fmap catMaybes $ sequence
       [ if optLogLogs clo
@@ -260,15 +272,20 @@ runSandwich' maybeCommandLineOptions options spec' = do
   _ <- installHandler sigTERM shutdown
 
   -- Wait for the tree to finish
+  milestone "waiting for tree"
   mapM_ waitForTree rts
+  milestone "tree finished"
 
   -- Wait for all formatters to finish
+  milestone "waiting for formatters"
   finalResults :: [Either E.SomeException ()] <- forM formatterAsyncs $ E.try . wait
   let failures = lefts finalResults
   unless (null failures) $
     putStrLn [i|Some formatters failed: '#{failures}'|]
+  milestone "formatters finished"
 
   -- Run finalizeFormatter method on formatters
+  milestone "finalizing formatters"
   forM_ (optionsFormatters options) $ \(SomeFormatter f) -> do
     let loggingFn = case baseContextRunRoot baseContext of
           Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
@@ -276,11 +293,14 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
     loggingFn $ finalizeFormatter f rts baseContext
 
+  milestone "fixing tree"
   fixedTree <- atomically $ mapM fixRunTree rts
 
   -- Cancel file stream asyncs
+  milestone "cancelling file stream asyncs"
   mapM_ cancel fileStreamAsyncs
 
+  milestone "done"
   exitReason <- readIORef exitReasonRef
   let failedItBlocks = countWhere isFailedItBlock fixedTree
   let failedBlocks = countWhere isFailedBlock fixedTree
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index 655254b2..e9694635 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -96,6 +96,7 @@ streamEvents conn broadcastChan = do
           EventSetupFinished -> "SETUP:FINISHED"
           EventTeardownStarted -> "TEARDOWN:STARTED"
           EventTeardownFinished -> "TEARDOWN:FINISHED"
+          EventMilestone msg -> [i|MILESTONE: #{msg}|]
         formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
     sendAll conn (BS8.pack formatted)
 
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index a1450dc9..1468b440 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -75,6 +75,7 @@ streamEventsToFile path broadcastChan = do
             EventSetupFinished -> "SETUP:FINISHED"
             EventTeardownStarted -> "TEARDOWN:STARTED"
             EventTeardownFinished -> "TEARDOWN:FINISHED"
+            EventMilestone msg -> [i|MILESTONE: #{msg}|]
           formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]
       traceMarkerIO [i|[#{nodeEventId}] #{nodeEventLabel}: #{typeStr}|]
       hPutStr h formatted
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 80bec9c8..7256a1a5 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -132,6 +132,7 @@ data NodeEventType
   | EventSetupFinished
   | EventTeardownStarted
   | EventTeardownFinished
+  | EventMilestone !String
   deriving (Show, Eq)
 
 -- | Context passed around through the evaluation of a RunTree

From 117619515f6369489594abfa2975eaf4cd104d7b Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 3 Mar 2026 04:58:43 -0800
Subject: [PATCH 22/41] Disable logToMemory* again

---
 .../Sandwich/Interpreters/RunTree/Logging.hs  | 40 ++++++++++---------
 1 file changed, 21 insertions(+), 19 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index 4929f587..80de6246 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -21,26 +21,28 @@ forceSeq s = foldl' (\_ e -> e `seq` ()) () s `seq` s
 
 logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemory Nothing _ _ _ _ _ = return ()
-logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
-  when (logLevel >= minLevel) $ do
-    ts <- getCurrentTime
-    let !bs = fromLogStr logStr
-    let !entry = LogEntry ts loc logSrc logLevel bs
-    atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
+logToMemory (Just minLevel) logs loc logSrc logLevel logStr = do
+  return ()
+  -- when (logLevel >= minLevel) $ do
+  --   ts <- getCurrentTime
+  --   let !bs = fromLogStr logStr
+  --   let !entry = LogEntry ts loc logSrc logLevel bs
+  --   atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
-  let !bs = fromLogStr logStr
-  maybeTs <- case maybeMemLogLevel of
-    Just x | x <= logLevel -> do
-      ts <- getCurrentTime
-      let !entry = LogEntry ts loc logSrc logLevel bs
-      atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
-      return $ Just ts
-    _ -> return Nothing
+  return ()
+  -- let !bs = fromLogStr logStr
+  -- maybeTs <- case maybeMemLogLevel of
+  --   Just x | x <= logLevel -> do
+  --     ts <- getCurrentTime
+  --     let !entry = LogEntry ts loc logSrc logLevel bs
+  --     atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
+  --     return $ Just ts
+  --   _ -> return Nothing
 
-  case maybeSavedLogLevel of
-    Just x | x <= logLevel -> do
-      ts <- maybe getCurrentTime return maybeTs
-      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
-    _ -> return ()
+  -- case maybeSavedLogLevel of
+  --   Just x | x <= logLevel -> do
+  --     ts <- maybe getCurrentTime return maybeTs
+  --     BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
+  --   _ -> return ()

From 7702778900c9934623e37adec500af09ed9298fa Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 3 Mar 2026 14:07:47 -0800
Subject: [PATCH 23/41] Revert "Disable logToMemory* again"

This reverts commit 117619515f6369489594abfa2975eaf4cd104d7b.
---
 .../Sandwich/Interpreters/RunTree/Logging.hs  | 40 +++++++++----------
 1 file changed, 19 insertions(+), 21 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
index 80de6246..4929f587 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Logging.hs
@@ -21,28 +21,26 @@ forceSeq s = foldl' (\_ e -> e `seq` ()) () s `seq` s
 
 logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemory Nothing _ _ _ _ _ = return ()
-logToMemory (Just minLevel) logs loc logSrc logLevel logStr = do
-  return ()
-  -- when (logLevel >= minLevel) $ do
-  --   ts <- getCurrentTime
-  --   let !bs = fromLogStr logStr
-  --   let !entry = LogEntry ts loc logSrc logLevel bs
-  --   atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
+logToMemory (Just minLevel) logs loc logSrc logLevel logStr =
+  when (logLevel >= minLevel) $ do
+    ts <- getCurrentTime
+    let !bs = fromLogStr logStr
+    let !entry = LogEntry ts loc logSrc logLevel bs
+    atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
 
 logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
 logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do
-  return ()
-  -- let !bs = fromLogStr logStr
-  -- maybeTs <- case maybeMemLogLevel of
-  --   Just x | x <= logLevel -> do
-  --     ts <- getCurrentTime
-  --     let !entry = LogEntry ts loc logSrc logLevel bs
-  --     atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
-  --     return $ Just ts
-  --   _ -> return Nothing
+  let !bs = fromLogStr logStr
+  maybeTs <- case maybeMemLogLevel of
+    Just x | x <= logLevel -> do
+      ts <- getCurrentTime
+      let !entry = LogEntry ts loc logSrc logLevel bs
+      atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')
+      return $ Just ts
+    _ -> return Nothing
 
-  -- case maybeSavedLogLevel of
-  --   Just x | x <= logLevel -> do
-  --     ts <- maybe getCurrentTime return maybeTs
-  --     BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
-  --   _ -> return ()
+  case maybeSavedLogLevel of
+    Just x | x <= logLevel -> do
+      ts <- maybe getCurrentTime return maybeTs
+      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs
+    _ -> return ()

From bc448f760cf5bb12a22d83bce945ac4718927ae4 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 3 Mar 2026 14:54:56 -0800
Subject: [PATCH 24/41] Try adding check for late logs

---
 sandwich/src/Test/Sandwich.hs                 | 26 ++++++++++++++-----
 .../Test/Sandwich/Interpreters/StartTree.hs   | 23 +++++++++++++---
 sandwich/src/Test/Sandwich/Options.hs         |  1 +
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  3 +++
 4 files changed, 43 insertions(+), 10 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index bc53252b..24deb260 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -92,6 +92,7 @@ import qualified Options.Applicative as OA
 import System.Environment
 import System.Exit
 import System.FilePath
+import System.IO (hSetBuffering, BufferMode(..), IOMode(..), openFile, hClose)
 import Test.Sandwich.ArgParsing
 import Test.Sandwich.Contexts
 import Test.Sandwich.Expectations
@@ -198,10 +199,20 @@ runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (Exit
 runSandwich' maybeCommandLineOptions options spec' = do
   baseContext <- baseContextFromOptions options
 
+  -- Open late-log file if --log-logs is active
+  maybeLateLogHandle <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
+    (Just clo, Just runRoot) | optLogLogs clo -> do
+      h <- openFile (runRoot </> "late-logs.txt") AppendMode
+      hSetBuffering h LineBuffering
+      return (Just h)
+    _ -> return Nothing
+
+  let options' = options { optionsLateLogFile = maybeLateLogHandle }
+
   let milestone msg = do
         traceMarkerIO [i|sandwich: #{msg}|]
         now <- getCurrentTime
-        case optionsEventBroadcast options of
+        case optionsEventBroadcast options' of
           Just chan -> atomically $ writeTChan chan (NodeEvent now 0 "sandwich" (EventMilestone msg))
           Nothing -> return ()
 
@@ -224,10 +235,10 @@ runSandwich' maybeCommandLineOptions options spec' = do
                         }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec'
 
   milestone "startSandwichTree'"
-  rts <- startSandwichTree' baseContext options spec
+  rts <- startSandwichTree' baseContext options' spec
 
   milestone "spawning formatters"
-  formatterAsyncs <- forM (optionsFormatters options) $ \(SomeFormatter f) -> async $ do
+  formatterAsyncs <- forM (optionsFormatters options') $ \(SomeFormatter f) -> async $ do
     let loggingFn = case baseContextRunRoot baseContext of
           Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
           Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")
@@ -240,14 +251,14 @@ runSandwich' maybeCommandLineOptions options spec' = do
   fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
     (Just clo, Just runRoot) -> fmap catMaybes $ sequence
       [ if optLogLogs clo
-        then case optionsLogBroadcast options of
+        then case optionsLogBroadcast options' of
           Just chan -> Just <$> async (streamLogsToFile (runRoot </> "all-logs.txt") chan)
           Nothing -> return Nothing
         else return Nothing
       , if optLogEvents clo
         then do
           writeTreeFile (runRoot </> "events-tree.txt") rts
-          case optionsEventBroadcast options of
+          case optionsEventBroadcast options' of
             Just chan -> Just <$> async (streamEventsToFile (runRoot </> "events.txt") chan)
             Nothing -> return Nothing
         else return Nothing
@@ -286,7 +297,7 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
   -- Run finalizeFormatter method on formatters
   milestone "finalizing formatters"
-  forM_ (optionsFormatters options) $ \(SomeFormatter f) -> do
+  forM_ (optionsFormatters options') $ \(SomeFormatter f) -> do
     let loggingFn = case baseContextRunRoot baseContext of
           Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
           Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")
@@ -300,6 +311,9 @@ runSandwich' maybeCommandLineOptions options spec' = do
   milestone "cancelling file stream asyncs"
   mapM_ cancel fileStreamAsyncs
 
+  -- Close late-log file handle
+  mapM_ hClose maybeLateLogHandle
+
   milestone "done"
   exitReason <- readIORef exitReasonRef
   let failedItBlocks = countWhere isFailedItBlock fixedTree
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 3419d4c9..d84cb241 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -11,6 +11,7 @@ module Test.Sandwich.Interpreters.StartTree (
 import Control.Concurrent.MVar
 import qualified Control.Exception as E
 import Control.Monad
+import qualified Data.ByteString.Char8 as BS8
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
@@ -390,12 +391,12 @@ shouldRunChild' ctx common = case baseContextOnlyRunIds $ getBaseContext ctx of
 
 -- * Running examples
 
-runExampleM :: HasBaseContext r => RunNodeCommonWithStatus s l t -> String -> ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result
+runExampleM :: HasBaseContext r => RunNodeCommonWithStatus (TVar Status) 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 => RunNodeCommonWithStatus s l t -> String -> ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)
+runExampleM' :: HasBaseContext r => RunNodeCommonWithStatus (TVar Status) 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
@@ -411,10 +412,10 @@ runExampleM' rnc label ex ctx logs exceptionMessage = do
 
   where
     withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a
-    withLogFn Nothing (Options {..}) action = action (withBroadcast optionsLogBroadcast $ logToMemory optionsSavedLogLevel logs)
+    withLogFn Nothing (Options {..}) action = action (withLateLogCheck optionsLateLogFile $ withBroadcast optionsLogBroadcast $ logToMemory optionsSavedLogLevel logs)
     withLogFn (Just logPath) (Options {..}) action = withFile (logPath </> "test_logs.txt") AppendMode $ \h -> do
       hSetBuffering h LineBuffering
-      action (withBroadcast optionsLogBroadcast $ logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)
+      action (withLateLogCheck optionsLateLogFile $ withBroadcast optionsLogBroadcast $ logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)
 
     withBroadcast :: Maybe (TChan (Int, String, LogEntry)) -> LogFn -> LogFn
     withBroadcast Nothing logFn = logFn
@@ -423,6 +424,20 @@ runExampleM' rnc label ex ctx logs exceptionMessage = do
       ts <- getCurrentTime
       atomically $ writeTChan chan (runTreeId rnc, runTreeLabel rnc, LogEntry ts loc logSrc logLevel (fromLogStr logStr))
 
+    withLateLogCheck :: Maybe Handle -> LogFn -> LogFn
+    withLateLogCheck Nothing logFn = logFn
+    withLateLogCheck (Just lateH) logFn = \loc logSrc logLevel logStr -> do
+      logFn loc logSrc logLevel logStr
+      status <- readTVarIO (runTreeStatus rnc)
+      case status of
+        Done {} -> do
+          ts <- getCurrentTime
+          let bs = fromLogStr logStr
+          let line = [i|#{show ts} [LATE] [#{runTreeId rnc}] #{runTreeLabel rnc}: #{BS8.unpack bs}\n|]
+          BS8.hPutStr lateH (BS8.pack line)
+          hFlush lateH
+        _ -> return ()
+
     getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)
     getTestDirectory (getBaseContext -> (BaseContext {..})) = case baseContextPath of
       Nothing -> return Nothing
diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs
index 028b6140..f9102b08 100644
--- a/sandwich/src/Test/Sandwich/Options.hs
+++ b/sandwich/src/Test/Sandwich/Options.hs
@@ -59,6 +59,7 @@ defaultOptions = Options {
   , optionsCancelOnLongExecutionMs = Nothing
   , optionsLogBroadcast = Nothing
   , optionsEventBroadcast = Nothing
+  , optionsLateLogFile = Nothing
   }
 
 -- | Generate a test artifacts directory based on a timestamp.
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 7256a1a5..b27c3e1d 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -23,6 +23,7 @@ import qualified Data.Text as T
 import Data.Time
 import Data.Typeable
 import GHC.Stack
+import System.IO (Handle)
 import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.Spec
 import Test.Sandwich.Types.TestTimer
@@ -317,6 +318,8 @@ data Options = Options {
   -- Each entry is tagged with (nodeId, nodeLabel, logEntry).
   , optionsEventBroadcast :: Maybe (TChan NodeEvent)
   -- ^ Broadcast channel for streaming node lifecycle events (started, done) to external consumers.
+  , optionsLateLogFile :: Maybe Handle
+  -- ^ If set, log writes that occur after a node is already Done will be written to this file handle.
   }
 
 -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way

From 4a42300c9e5650fdcb09b0a45ff6368b8ed2c0f0 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 3 Mar 2026 22:20:54 -0800
Subject: [PATCH 25/41] Managed asyncs

---
 sandwich/package.yaml                         |  1 +
 sandwich/sandwich.cabal                       |  1 +
 sandwich/src/Test/Sandwich.hs                 | 48 +++++++----
 .../src/Test/Sandwich/Formatters/Socket.hs    |  6 +-
 .../Test/Sandwich/Formatters/Socket/Server.hs |  9 +-
 .../Test/Sandwich/Formatters/TerminalUI.hs    | 16 ++--
 .../Formatters/TerminalUI/DebugSocket.hs      |  9 +-
 sandwich/src/Test/Sandwich/Instrumentation.hs | 19 ++++
 .../src/Test/Sandwich/Internal/Running.hs     | 30 ++++---
 .../Test/Sandwich/Interpreters/StartTree.hs   |  7 +-
 sandwich/src/Test/Sandwich/ManagedAsync.hs    | 86 +++++++++++++++++++
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  1 +
 12 files changed, 186 insertions(+), 47 deletions(-)
 create mode 100644 sandwich/src/Test/Sandwich/ManagedAsync.hs

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index 8df4f265..631c31c8 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -91,6 +91,7 @@ library:
   - Test.Sandwich.Formatters.Socket
   - Test.Sandwich.Formatters.TerminalUI
   - Test.Sandwich.Internal
+  - Test.Sandwich.ManagedAsync
   - Test.Sandwich.TH
   - Test.Sandwich.Util.Process
   - Test.Sandwich.Waits
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index c9d57ccf..697c9fd2 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -41,6 +41,7 @@ library
       Test.Sandwich.Formatters.Socket
       Test.Sandwich.Formatters.TerminalUI
       Test.Sandwich.Internal
+      Test.Sandwich.ManagedAsync
       Test.Sandwich.TH
       Test.Sandwich.Util.Process
       Test.Sandwich.Waits
diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 24deb260..5f1834d7 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -104,6 +104,7 @@ import Test.Sandwich.Interpreters.FilterTreeModule
 import Test.Sandwich.Interpreters.RunTree
 import Test.Sandwich.Interpreters.RunTree.Util
 import Test.Sandwich.Logging
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Misc
 import Test.Sandwich.Nodes
 import Test.Sandwich.Options
@@ -127,7 +128,7 @@ import System.Win32.Console (setConsoleOutputCP)
 -- | Run the spec with the given 'Options'.
 runSandwich :: Options -> CoreSpec -> IO ()
 runSandwich options spec = do
-  (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' Nothing options spec
+  (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' "run" Nothing options spec
   when (0 < totalFailures) exitFailure
 
 -- | Run the spec, configuring the options from the command line.
@@ -173,12 +174,13 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
          let cliNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold
                                                  , nodeOptionsCreateFolder = False }
 
-         runWithRepeat repeatCount totalTests $
+         let mkRunId idx = if repeatCount == 1 then "run" else [i|repeat-#{idx}|]
+         runWithRepeat repeatCount totalTests $ \repeatIdx ->
            case optIndividualTestModule clo of
-             Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $
+             Nothing -> runSandwich' (mkRunId repeatIdx) (Just $ clo { optUserOptions = () }) options $
                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
                  $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec
-             Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $
+             Just (IndividualTestModuleName x) -> runSandwich' (mkRunId repeatIdx) (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $
                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
                  $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec
              Just (IndividualTestMainFn x) -> do
@@ -195,9 +197,9 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
 -- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason,
 -- the number of "it" nodes which failed, and the total failed nodes (which includes "it" nodes, and
 -- may also include other nodes like "introduce" nodes).
-runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int)
-runSandwich' maybeCommandLineOptions options spec' = do
-  baseContext <- baseContextFromOptions options
+runSandwich' :: T.Text -> Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int)
+runSandwich' runId maybeCommandLineOptions options spec' = do
+  baseContext <- baseContextFromOptionsWithRunId runId options
 
   -- Open late-log file if --log-logs is active
   maybeLateLogHandle <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
@@ -238,32 +240,35 @@ runSandwich' maybeCommandLineOptions options spec' = do
   rts <- startSandwichTree' baseContext options' spec
 
   milestone "spawning formatters"
-  formatterAsyncs <- forM (optionsFormatters options') $ \(SomeFormatter f) -> async $ do
-    let loggingFn = case baseContextRunRoot baseContext of
-          Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
-          Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")
+  formatterAsyncs <- forM (optionsFormatters options') $ \(SomeFormatter f) ->
+    managedAsync runId (T.pack [i|formatter:#{formatterName f}|]) $ do
+      let loggingFn = case baseContextRunRoot baseContext of
+            Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
+            Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")
 
-    loggingFn $
-      runFormatter f rts maybeCommandLineOptions baseContext
+      loggingFn $
+        runFormatter f rts maybeCommandLineOptions baseContext
 
-  -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats
+  -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats, --log-events (managed-asyncs)
   milestone "spawning file stream asyncs"
   fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
     (Just clo, Just runRoot) -> fmap catMaybes $ sequence
       [ if optLogLogs clo
         then case optionsLogBroadcast options' of
-          Just chan -> Just <$> async (streamLogsToFile (runRoot </> "all-logs.txt") chan)
+          Just chan -> Just <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.txt") chan)
           Nothing -> return Nothing
         else return Nothing
       , if optLogEvents clo
         then do
           writeTreeFile (runRoot </> "events-tree.txt") rts
           case optionsEventBroadcast options' of
-            Just chan -> Just <$> async (streamEventsToFile (runRoot </> "events.txt") chan)
+            Just chan -> do
+              _ <- managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.txt") asyncEventBroadcast)
+              Just <$> managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.txt") chan)
             Nothing -> return Nothing
         else return Nothing
       , if optLogRtsStats clo
-        then Just <$> async (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
+        then Just <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
         else return Nothing
       ]
     _ -> return []
@@ -311,6 +316,15 @@ runSandwich' maybeCommandLineOptions options spec' = do
   milestone "cancelling file stream asyncs"
   mapM_ cancel fileStreamAsyncs
 
+  -- Check for stale managed asyncs from this run
+  milestone "checking for stale asyncs"
+  allAsyncs <- getManagedAsyncInfos
+  let staleAsyncs = M.filter (\info -> asyncInfoRunId info == runId) allAsyncs
+  unless (M.null staleAsyncs) $ do
+    putStrLn [i|WARNING: #{M.size staleAsyncs} managed asyncs still running after tree finished:|]
+    forM_ (M.toList staleAsyncs) $ \(tid, info) ->
+      putStrLn [i|  #{tid}: #{asyncInfoName info}|]
+
   -- Close late-log file handle
   mapM_ hClose maybeLateLogHandle
 
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket.hs b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
index c7554c3a..c1453288 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
@@ -17,7 +17,6 @@ module Test.Sandwich.Formatters.Socket (
   , SocketFormatter(..)
   ) where
 
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad.IO.Class
 import Data.IORef
@@ -25,8 +24,10 @@ import Data.Typeable
 import System.FilePath
 import Test.Sandwich.Formatters.Socket.Server
 import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.RunTree
+import UnliftIO.Async (Async, cancel)
 
 
 data SocketFormatter = SocketFormatter {
@@ -67,10 +68,11 @@ instance Formatter SocketFormatter where
 
 run :: (MonadIO m) => SocketFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
 run (SocketFormatter {..}) rts _maybeCommandLineOptions bc = do
+  let runId = baseContextRunId bc
   case resolveSocketPath of
     Nothing -> return ()
     Just path -> liftIO $ do
-      a <- async (socketServer path rts socketFormatterLogBroadcast socketFormatterEventBroadcast)
+      a <- managedAsync runId "socket-server" (socketServer runId path rts socketFormatterLogBroadcast socketFormatterEventBroadcast)
       writeIORef socketFormatterServerAsync (Just a)
       -- Block until all tests complete
       mapM_ waitForTree rts
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index e9694635..9a39eefb 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -2,7 +2,6 @@ module Test.Sandwich.Formatters.Socket.Server (
   socketServer
   ) where
 
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Logger
@@ -10,6 +9,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import Data.String.Interpolate
+import qualified Data.Text as T
 import Data.Time
 import Data.Word
 import GHC.Stats
@@ -17,6 +17,7 @@ import Network.Socket
 import Network.Socket.ByteString (recv, sendAll)
 import System.Directory (removeFile)
 import Test.Sandwich.Formatters.Socket.Commands
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import UnliftIO.Concurrent (threadDelay)
@@ -25,8 +26,8 @@ import UnliftIO.Exception
 
 -- | Bidirectional Unix socket server. Each client connection reads line-based
 -- commands and sends back responses terminated by a line containing just ".".
-socketServer :: FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()
-socketServer socketPath rts logBroadcast eventBroadcast = do
+socketServer :: T.Text -> FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()
+socketServer runId socketPath rts logBroadcast eventBroadcast = do
   -- Clean up any existing socket file
   removeFile socketPath `catch` \(_ :: IOError) -> return ()
 
@@ -35,7 +36,7 @@ socketServer socketPath rts logBroadcast eventBroadcast = do
     listen sock 5
     forever $ do
       (conn, _) <- accept sock
-      void $ async $ handleConnection conn rts logBroadcast eventBroadcast
+      void $ managedAsync runId "socket-connection" $ handleConnection conn rts logBroadcast eventBroadcast
 
 handleConnection :: Socket -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()
 handleConnection conn rts logBroadcast eventBroadcast = do
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
index ee5af616..a9debd19 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -30,7 +30,6 @@ import Brick as B
 import Brick.BChan
 import Brick.Widgets.List
 import Control.Concurrent
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.IO.Class
@@ -64,12 +63,14 @@ import Test.Sandwich.Formatters.TerminalUI.Types
 import Test.Sandwich.Interpreters.RunTree.Util
 import Test.Sandwich.Interpreters.StartTree
 import Test.Sandwich.Logging
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.RunTree
 import Test.Sandwich.Shutdown
 import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import Test.Sandwich.Util
+import UnliftIO.Async (Async, cancel)
 import UnliftIO.Exception
 
 
@@ -155,14 +156,15 @@ runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do
         threadDelay period
 
   -- Optionally start the debug socket server in the test tree root
+  let runId = baseContextRunId baseContext
   let withDebugSocket = case (terminalUIDebugSocket, baseContextRunRoot baseContext) of
-        (True, Just runRoot) -> \action -> withAsync (debugSocketServer (runRoot </> "tui-debug.sock") debugChan) (\_ -> action)
+        (True, Just runRoot) -> \action -> managedWithAsync_ runId "tui-debug-socket" (debugSocketServer runId (runRoot </> "tui-debug.sock") debugChan) action
         _ -> id
 
   liftIO $
     withDebugSocket $
-    (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> withAsync (updateCurrentTimeForever ts) (\_ -> action)) $
-    withAsync eventAsync $ \_ ->
+    (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> managedWithAsync_ runId "tui-clock-update" (updateCurrentTimeForever ts) action) $
+    managedWithAsync_ runId "tui-event-async" eventAsync $
     void $ customMain initialVty buildVty (Just eventChan) app initialState
 
 app :: App AppState AppEvent ClickableName
@@ -290,9 +292,10 @@ appEvent s (VtyEvent e) =
           _ -> return ()
     V.EvKey c [] | c == runAllKey -> do
       now <- liftIO getCurrentTime
+      let appRunId = baseContextRunId (s ^. appBaseContext)
       when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do
         mapM_ clearRecursively (s ^. appRunTreeBase)
-        void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)
+        void $ managedAsync appRunId "tui-run-all" $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)
       continue $ s
         & appStartTime .~ now
         & appCurrentTime .~ now
@@ -302,6 +305,7 @@ appEvent s (VtyEvent e) =
         _ -> do
           -- Get the set of IDs for only this node's ancestors and children
           let ancestorIds = S.fromList $ toList $ runTreeAncestors node
+          let appRunId = baseContextRunId (s ^. appBaseContext)
           case findRunNodeChildrenById ident (s ^. appRunTree) of
             Nothing -> continue s
             Just childIds -> do
@@ -311,7 +315,7 @@ appEvent s (VtyEvent e) =
               -- Start a run for all affected nodes
               now <- liftIO getCurrentTime
               let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }
-              void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc
+              void $ liftIO $ managedAsync appRunId "tui-run-selected" $ void $ runNodesSequentially (s ^. appRunTreeBase) bc
               continue $ s
                 & appStartTime .~ now
                 & appCurrentTime .~ now
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs
index 74eed796..9c5bc01f 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs
@@ -2,20 +2,21 @@ module Test.Sandwich.Formatters.TerminalUI.DebugSocket (
   debugSocketServer
   ) where
 
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Data.ByteString (ByteString)
+import qualified Data.Text as T
 import Network.Socket
 import Network.Socket.ByteString (sendAll)
 import System.Directory (removeFile)
+import Test.Sandwich.ManagedAsync
 import UnliftIO.Exception
 
 
 -- | Debug socket server that accepts connections and broadcasts events.
 -- Connect with @nc -U \<path\>@ to receive line-oriented debug events.
-debugSocketServer :: FilePath -> TChan ByteString -> IO ()
-debugSocketServer socketPath chan = do
+debugSocketServer :: T.Text -> FilePath -> TChan ByteString -> IO ()
+debugSocketServer runId socketPath chan = do
   -- Clean up any existing socket file
   removeFile socketPath `catch` \(_ :: IOError) -> return ()
 
@@ -25,7 +26,7 @@ debugSocketServer socketPath chan = do
     forever $ do
       (conn, _) <- accept sock
       -- Spawn a thread to handle this connection
-      void $ async $ handleConnection conn
+      void $ managedAsync runId "tui-debug-connection" $ handleConnection conn
   where
     handleConnection conn = do
       -- Duplicate the channel so this client gets its own read position
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index 1468b440..bef6c4f5 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -2,6 +2,7 @@ module Test.Sandwich.Instrumentation (
   streamLogsToFile
   , streamEventsToFile
   , streamRtsStatsToFile
+  , streamManagedAsyncEventsToFile
   , writeTreeFile
   ) where
 
@@ -11,12 +12,14 @@ import Control.Monad.Logger
 import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import Data.String.Interpolate
+import qualified Data.Text as T
 import Data.Time
 import Data.Word
 import Debug.Trace (traceMarkerIO)
 import GHC.DataSize (recursiveSize)
 import GHC.Stats
 import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
+import Test.Sandwich.ManagedAsync (AsyncEvent(..), AsyncInfo(..))
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import UnliftIO.Concurrent (threadDelay)
@@ -129,6 +132,22 @@ formatBytes b
   | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]
   | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
 
+-- | Stream managed async lifecycle events (started/finished) from a broadcast channel to a file.
+streamManagedAsyncEventsToFile :: FilePath -> TChan AsyncEvent -> IO ()
+streamManagedAsyncEventsToFile path broadcastChan = do
+  chan <- atomically $ dupTChan broadcastChan
+  withFile path AppendMode $ \h -> do
+    hSetBuffering h LineBuffering
+    forever $ do
+      event <- atomically $ readTChan chan
+      now <- getCurrentTime
+      let line :: String
+          line = case event of
+            AsyncStarted info -> [i|#{show now} STARTED #{asyncInfoName info} (thread: #{asyncInfoThreadId info}, parent: #{asyncInfoParentThreadId info}, runId: #{asyncInfoRunId info})|]
+            AsyncFinished info -> [i|#{show now} FINISHED #{asyncInfoName info} (thread: #{asyncInfoThreadId info}, runId: #{asyncInfoRunId info})|]
+      hPutStr h (line <> "\n")
+      hFlush h
+
 -- | Write a tree of node IDs and labels to a file for cross-referencing with events.
 writeTreeFile :: FilePath -> [RunNodeWithStatus context s l t] -> IO ()
 writeTreeFile path rts =
diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs
index d95ecc72..1e664237 100644
--- a/sandwich/src/Test/Sandwich/Internal/Running.hs
+++ b/sandwich/src/Test/Sandwich/Internal/Running.hs
@@ -1,9 +1,9 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Test.Sandwich.Internal.Running where
 
-import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Free
@@ -22,6 +22,7 @@ import Test.Sandwich.Interpreters.PruneTree
 import Test.Sandwich.Interpreters.RunTree
 import Test.Sandwich.Interpreters.RunTree.Util
 import Test.Sandwich.Interpreters.StartTree
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Options
 import Test.Sandwich.TestTimer
 import Test.Sandwich.Types.General
@@ -38,13 +39,14 @@ startSandwichTree options spec = do
 
 startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]
 startSandwichTree' baseContext (Options {optionsPruneTree=(unwrapTreeFilter -> pruneOpts), optionsFilterTree=(unwrapTreeFilter -> filterOpts), optionsDryRun}) spec = do
+  let runId = baseContextRunId baseContext
   runTree <- spec
     & (\tree -> L.foldl' pruneTree tree pruneOpts)
     & (\tree -> L.foldl' filterTree tree filterOpts)
     & atomically . specToRunTreeVariable baseContext
 
   if | optionsDryRun -> markAllChildrenWithResult runTree baseContext DryRun
-     | otherwise -> void $ async $ void $ runNodesSequentially runTree baseContext
+     | otherwise -> void $ managedAsync runId [i|root-nodes:#{runId}|] $ void $ runNodesSequentially runTree baseContext
 
   return runTree
 
@@ -58,20 +60,22 @@ runSandwichTree options spec = do
   return rts
 
 -- | For 0 repeats, repeat until a failure
-runWithRepeat :: Int -> Int -> IO (ExitReason, Int, Int) -> IO ()
-runWithRepeat 0 totalTests action = do
-  (_, _itNodeFailures, totalFailures) <- action
-  if | totalFailures == 0 -> runWithRepeat 0 totalTests action
-     | otherwise -> exitFailure
+runWithRepeat :: Int -> Int -> (Int -> IO (ExitReason, Int, Int)) -> IO ()
+runWithRepeat 0 totalTests action = go 0
+  where
+    go !idx = do
+      (_, _itNodeFailures, totalFailures) <- action idx
+      if | totalFailures == 0 -> go (idx + 1)
+         | otherwise -> exitFailure
 -- | For 1 repeat, run once and return
 runWithRepeat n totalTests action = do
-  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do
-    (exitReason, _itNodeFailures, totalFailures) <- liftIO action
+  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (0 :: Int) $ \loop idx -> do
+    (exitReason, _itNodeFailures, totalFailures) <- liftIO $ action idx
 
     modify $ \(successes, total) -> (successes + (if totalFailures == 0 then 1 else 0), total + 1)
 
     if | exitReason == SignalExit -> return ()
-       | n' > 0 -> loop (n' - 1)
+       | idx < n - 1 -> loop (idx + 1)
        | otherwise -> return ()
 
   putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]
@@ -79,7 +83,10 @@ runWithRepeat n totalTests action = do
   when (successes /= total) $ exitFailure
 
 baseContextFromOptions :: Options -> IO BaseContext
-baseContextFromOptions options@(Options {..}) = do
+baseContextFromOptions = baseContextFromOptionsWithRunId "run"
+
+baseContextFromOptionsWithRunId :: T.Text -> Options -> IO BaseContext
+baseContextFromOptionsWithRunId runId options@(Options {..}) = do
   runRoot <- case optionsTestArtifactsDirectory of
     TestArtifactsNone -> return Nothing
     TestArtifactsFixedDirectory dir' -> do
@@ -117,6 +124,7 @@ baseContextFromOptions options@(Options {..}) = do
     , baseContextOnlyRunIds = Nothing
     , baseContextTestTimerProfile = defaultProfileName
     , baseContextTestTimer = testTimer
+    , baseContextRunId = runId
     }
 
 
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index d84cb241..7d4542e6 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -37,6 +37,7 @@ import Test.Sandwich.Formatters.Print.Logs
 import Test.Sandwich.Formatters.Print.Printing
 import Test.Sandwich.Interpreters.RunTree.Logging
 import Test.Sandwich.Interpreters.RunTree.Util
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.RunTree
 import Test.Sandwich.TestTimer
 import Test.Sandwich.Types.RunTree
@@ -267,9 +268,10 @@ runInAsync node ctx action = do
   let RunNodeCommonWithStatus {..} = runNodeCommon node
   let bc@(BaseContext {..}) = getBaseContext ctx
   let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id
+  let asyncName = T.pack [i|node:#{runTreeId}:#{runTreeLabel}|]
   startTime <- liftIO getCurrentTime
   mvar <- liftIO newEmptyMVar
-  myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do
+  myAsync <- liftIO $ managedAsyncWithUnmask baseContextRunId asyncName $ \unmask -> do
     flip withException (recordExceptionInStatus runTreeStatus) $ unmask $ do
       readMVar mvar
       (result, extraTimingInfo) <- timerFn action
@@ -494,8 +496,7 @@ withMaybeWarnOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommo
 withMaybeWarnOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsWarnOnLongExecutionMs baseContextOptions of
   Nothing -> inner
   Just maxTimeMs -> do
-    withAsync (waiter maxTimeMs) $ \_ -> do
-      inner
+    managedWithAsync_ baseContextRunId (T.pack [i|warn-long:#{runTreeId}:#{label}|]) (waiter maxTimeMs) inner
 
   where
     waiter maxTimeMs = do
diff --git a/sandwich/src/Test/Sandwich/ManagedAsync.hs b/sandwich/src/Test/Sandwich/ManagedAsync.hs
new file mode 100644
index 00000000..551be870
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/ManagedAsync.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Test.Sandwich.ManagedAsync (
+  managedAsync
+  , managedAsyncWithUnmask
+  , managedWithAsync
+  , managedWithAsync_
+  , AsyncInfo(..)
+  , AsyncEvent(..)
+  , asyncEventBroadcast
+  , getManagedAsyncInfos
+  ) where
+
+import Control.Concurrent (ThreadId, myThreadId)
+import Control.Concurrent.STM
+import Control.Monad.IO.Unlift
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Data.IORef
+import System.IO.Unsafe (unsafePerformIO)
+import UnliftIO.Async
+import UnliftIO.Exception
+
+
+data AsyncInfo = AsyncInfo {
+  asyncInfoThreadId :: !T.Text
+  , asyncInfoParentThreadId :: !T.Text
+  , asyncInfoName :: !T.Text
+  , asyncInfoRunId :: !T.Text
+  } deriving (Show, Eq)
+
+data AsyncEvent = AsyncStarted !AsyncInfo | AsyncFinished !AsyncInfo
+
+{-# NOINLINE allManagedAsyncs #-}
+allManagedAsyncs :: IORef (M.Map ThreadId AsyncInfo)
+allManagedAsyncs = unsafePerformIO $ newIORef M.empty
+
+{-# NOINLINE asyncEventBroadcast #-}
+asyncEventBroadcast :: TChan AsyncEvent
+asyncEventBroadcast = unsafePerformIO newBroadcastTChanIO
+
+getManagedAsyncInfos :: IO (M.Map T.Text AsyncInfo)
+getManagedAsyncInfos = M.mapKeys (T.pack . show) <$> readIORef allManagedAsyncs
+
+managedAsync :: MonadUnliftIO m => T.Text -> T.Text -> m a -> m (Async a)
+managedAsync runId name action = do
+  parentThreadId <- liftIO myThreadId
+  async $ bracketedAction parentThreadId runId name action
+
+managedAsyncWithUnmask :: MonadUnliftIO m => T.Text -> T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)
+managedAsyncWithUnmask runId name action = do
+  parentThreadId <- liftIO myThreadId
+  asyncWithUnmask $ \unmask -> bracketedAction parentThreadId runId name (action unmask)
+
+managedWithAsync :: MonadUnliftIO m => T.Text -> T.Text -> m a -> (Async a -> m b) -> m b
+managedWithAsync runId name action cb = do
+  parentThreadId <- liftIO myThreadId
+  withAsync (bracketedAction parentThreadId runId name action) cb
+
+managedWithAsync_ :: MonadUnliftIO m => T.Text -> T.Text -> m a -> m b -> m b
+managedWithAsync_ runId name f g = managedWithAsync runId name f (const g)
+
+-- * Internal
+
+bracketedAction :: MonadUnliftIO m => ThreadId -> T.Text -> T.Text -> m a -> m a
+bracketedAction parentThreadId runId name action = bracket record unrecord (const action)
+  where
+    record :: MonadUnliftIO m => m ThreadId
+    record = do
+      asyncThreadId <- liftIO myThreadId
+      let info = AsyncInfo {
+            asyncInfoThreadId = T.pack (show asyncThreadId)
+            , asyncInfoParentThreadId = T.pack (show parentThreadId)
+            , asyncInfoName = name
+            , asyncInfoRunId = runId
+            }
+      liftIO $ atomicModifyIORef' allManagedAsyncs (\m -> (M.insert asyncThreadId info m, ()))
+      liftIO $ atomically $ writeTChan asyncEventBroadcast (AsyncStarted info)
+      return asyncThreadId
+
+    unrecord :: MonadUnliftIO m => ThreadId -> m ()
+    unrecord asyncThreadId = liftIO $ do
+      mInfo <- atomicModifyIORef' allManagedAsyncs (\m -> (M.delete asyncThreadId m, M.lookup asyncThreadId m))
+      case mInfo of
+        Just info -> atomically $ writeTChan asyncEventBroadcast (AsyncFinished info)
+        Nothing -> return ()
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index b27c3e1d..8d76e84b 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -154,6 +154,7 @@ data BaseContext = BaseContext {
   , baseContextOnlyRunIds :: Maybe (S.Set Int)
   , baseContextTestTimerProfile :: T.Text
   , baseContextTestTimer :: TestTimer
+  , baseContextRunId :: T.Text
   }
 
 -- | Has-* class for asserting a 'BaseContext' is available.

From 26203d4757e8f334c418de040df792ba3ba17ba3 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 00:05:10 -0800
Subject: [PATCH 26/41] Use managed asyncs in other packages

---
 .../Contexts/Kubernetes/KubectlPortForward.hs |  5 +-
 .../Kubernetes/MinikubeCluster/Forwards.hs    | 63 +++++++++++++++++--
 .../lib/Test/Sandwich/Contexts/MinIO.hs       |  5 +-
 .../lib/Test/Sandwich/Contexts/Nix.hs         |  9 ++-
 .../Sandwich/Contexts/ReverseProxy/TCP.hs     |  5 +-
 .../Sandwich/WebDriver/Internal/OnDemand.hs   |  5 +-
 sandwich/src/Test/Sandwich/Misc.hs            |  3 +-
 7 files changed, 79 insertions(+), 16 deletions(-)

diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
index f1d02bb1..bdd88363 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
@@ -21,8 +21,8 @@ import Test.Sandwich.Contexts.Files
 import Test.Sandwich.Contexts.Kubernetes.Types
 import Test.Sandwich.Contexts.Kubernetes.Util.Ports
 import Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Util.Process (gracefullyStopProcess)
-import UnliftIO.Async
 import UnliftIO.Concurrent
 import UnliftIO.Directory
 import UnliftIO.Exception
@@ -110,7 +110,8 @@ withKubectlPortForward' kubectlBinary kubeConfigFile namespace isAcceptablePort
                   )
           threadDelay 1_000_000  -- 1 second delay between restarts to ensure we don't spin here
 
-    withAsync restarterThread $ \_ -> do
+    runId <- baseContextRunId <$> asks getBaseContext
+    managedWithAsync_ runId "kubectl-port-forward-restarter" restarterThread $ do
       let policy = constantDelay 100000 <> limitRetries 100
       void $ liftIO $ retrying policy (\_ ret -> return ret) $ \_ -> do
         not <$> isPortOpen (simpleSockAddr (127, 0, 0, 1) port)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
index 5ba25818..4f149215 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
@@ -11,14 +11,17 @@ import Control.Monad.Logger
 import qualified Data.List as L
 import Data.String.Interpolate
 import Data.Text as T
+import qualified Data.Text.IO as T
 import Network.URI
 import Relude hiding (withFile)
-import System.IO (hGetLine)
+import System.FilePath
+import System.IO (hClose, hGetLine, openTempFile)
 import System.Process (getPid)
 import Test.Sandwich
 import Test.Sandwich.Contexts.Kubernetes.Types
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Util.Process
-import UnliftIO.Async
+import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Environment
 import UnliftIO.Exception
 import UnliftIO.Process
@@ -53,7 +56,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
           line <- liftIO $ hGetLine stderrRead
           info [i|minikube service stderr: #{line}|]
 
-  withAsync forwardStderr $ \_ -> do
+  managedWithAsync_ "" "minikube-service-stderr" forwardStderr $ do
     let cp = (proc kubernetesClusterTypeMinikubeBinary args) {
           env = Just env
           , std_out = UseHandle stdoutWrite
@@ -73,5 +76,57 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
       action =<< case parseURI (toString (T.strip (toText raw))) of
         Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesService': #{raw}|]
         Just x -> pure x
-
 withForwardKubernetesService' _ _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"
+
+withForwardKubernetesServiceFileLogging' :: (
+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
+  ) => KubernetesClusterContext -> Text -> Text -> Text -> Text -> (URI -> m a) -> m a
+withForwardKubernetesServiceFileLogging' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) fileName profile namespace service action = do
+  baseEnv <- liftIO getEnvironment
+  let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
+
+  let extraFlags = case "--rootless" `L.elem` kubernetesClusterTypeMinikubeFlags of
+        True -> ["--rootless"]
+        False -> []
+
+  let args = extraFlags <> [
+        "--profile", toString profile
+        , "--namespace", toString namespace
+        , "--logtostderr"
+        , "service"
+        , toString service
+        , "--url"]
+  info [i|#{kubernetesClusterTypeMinikubeBinary} #{T.unwords $ fmap toText args}|]
+
+  let cp = (proc kubernetesClusterTypeMinikubeBinary args) {
+        env = Just env
+        , create_group = True
+        }
+
+  getCurrentFolder >>= \case
+    Nothing -> expectationFailure [i|withForwardKubernetesServiceFileLogging': no current folder.|]
+    Just dir ->
+      bracket (liftIO $ openTempFile dir (toString fileName <.> "out")) (\(_outFile, hOut) -> liftIO $ hClose hOut) $ \(outFile, hOut) ->
+      bracket (liftIO $ openTempFile dir (toString fileName <.> "err")) (\(_errFile, hErr) -> liftIO $ hClose hErr) $ \(_errFile, hErr) -> do
+        let stop (_, _, _, p) = liftIO (getPid p) >>= \case
+              Nothing -> return ()
+              Just _pid -> gracefullyStopProcess p 120_000_000
+
+        bracket (createProcess (cp { std_out = UseHandle hOut, std_err = UseHandle hErr })) stop $ \_ -> do
+          raw <- readFirstLine outFile
+
+          info [i|withForwardKubernetesServiceFileLogging': (#{namespace}) #{service} -> #{raw}|]
+
+          action =<< case parseURI (toString (T.strip raw)) of
+            Nothing -> expectationFailure [i|Couldn't parse URI in withForwardKubernetesServiceFileLogging': #{raw}|]
+            Just x -> pure x
+  where
+    readFirstLine :: MonadIO m => FilePath -> m Text
+    readFirstLine fp = liftIO loop
+      where
+        loop = do
+          contents <- T.readFile fp
+          case T.lines contents of
+            (x:_) -> pure x
+            [] -> threadDelay 50_000 >> loop
+withForwardKubernetesServiceFileLogging' _ _fileName _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"
diff --git a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
index fdd78e70..2a263132 100644
--- a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
+++ b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
@@ -70,7 +70,7 @@ import Test.Sandwich.Contexts.MinIO.Util
 import Test.Sandwich.Contexts.Nix
 import Test.Sandwich.Contexts.Types.Network
 import Test.Sandwich.Contexts.Types.S3
-import UnliftIO.Async
+import Test.Sandwich.ManagedAsync
 import UnliftIO.Directory
 import UnliftIO.Exception
 import UnliftIO.Process
@@ -193,7 +193,8 @@ withMinIOViaBinary' minioPath (MinIOContextOptions {..}) action = do
           line <- liftIO $ T.hGetLine hRead
           debug [i|minio: #{line}|]
 
-    withAsync forwardOutput $ \_ -> do
+    runId <- baseContextRunId <$> asks getBaseContext
+    managedWithAsync_ runId "minio-output-forward" forwardOutput $ do
       (hostname, port) <- case uriToUse of
         Nothing -> expectationFailure [i|Couldn't find MinIO URI to use.|]
         Just (URI { uriAuthority=(Just URIAuth {..}) }) -> case readMaybe (L.drop 1 uriPort) of
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
index 06b3c628..0dd7a37a 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
@@ -82,8 +82,9 @@ import System.IO.Temp (createTempDirectory)
 import Test.Sandwich
 import Test.Sandwich.Contexts.Files.Types
 import Test.Sandwich.Contexts.Util.Aeson
+import Test.Sandwich.ManagedAsync
 import qualified Text.Show
-import UnliftIO.Async
+import UnliftIO.Async (Async, wait)
 import UnliftIO.Directory
 import UnliftIO.Environment
 import UnliftIO.MVar (modifyMVar)
@@ -355,11 +356,12 @@ buildNixCallPackageDerivation' :: forall context m. (
   -> Text
   -> m FilePath
 buildNixCallPackageDerivation' nc@(NixContext {..}) derivation = do
+  runId <- baseContextRunId <$> asks getBaseContext
   wait =<< modifyMVar nixContextBuildCache (\m ->
     case M.lookup derivation m of
       Just x -> return (m, x)
       Nothing -> do
-        asy <- async $ do
+        asy <- managedAsync runId "nix-build-call-package" $ do
           maybeNixExpressionDir <- getCurrentFolder >>= \case
             Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"
             Nothing -> return Nothing
@@ -395,11 +397,12 @@ buildNixExpression' :: (
   -- | Nix expression
   => NixContext -> Text -> m FilePath
 buildNixExpression' nc@(NixContext {..}) expr = do
+  runId <- baseContextRunId <$> asks getBaseContext
   wait =<< modifyMVar nixContextBuildCache (\m ->
     case M.lookup expr m of
       Just x -> return (m, x)
       Nothing -> do
-        asy <- async $ do
+        asy <- managedAsync runId "nix-build-expression" $ do
           maybeNixExpressionDir <- getCurrentFolder >>= \case
             Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"
             Nothing -> pure Nothing
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
index 38722433..535a66eb 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
@@ -15,7 +15,8 @@ import Data.String.Interpolate
 import Network.Socket
 import Relude
 import Test.Sandwich (expectationFailure)
-import UnliftIO.Async
+import Test.Sandwich.ManagedAsync
+import UnliftIO.Async (concurrently_)
 import UnliftIO.Exception
 import UnliftIO.Timeout
 
@@ -30,7 +31,7 @@ withProxyToUnixSocket socketPath f = do
                SockAddrInet6 port _ _ _ -> putMVar portVar port
                x -> expectationFailure [i|withProxyToUnixSocket: expected to bind a TCP socket, but got other addr: #{x}|]
            )
-  withAsync (liftIO $ DCN.runTCPServer ss app `onException` (tryPutMVar portVar (-1))) $ \_ ->
+  managedWithAsync_ "" "tcp-reverse-proxy" (liftIO $ DCN.runTCPServer ss app `onException` (tryPutMVar portVar (-1))) $
     timeout 60_000_000 (readMVar portVar) >>= \case
       Nothing -> expectationFailure [i|withProxyToUnixSocket: didn't get port within 60s|]
       Just (-1) -> expectationFailure [i|withProxyToUnixSocket: TCP server threw exception|]
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
index 18cb8f3a..2fec83be 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
@@ -6,8 +6,9 @@ import Control.Monad.Logger
 import Data.String.Interpolate
 import Data.Text as T
 import Test.Sandwich
+import Test.Sandwich.ManagedAsync
 import Test.Sandwich.WebDriver.Internal.Types
-import UnliftIO.Async
+import UnliftIO.Async (wait)
 import UnliftIO.Exception
 import UnliftIO.MVar
 
@@ -19,7 +20,7 @@ getOnDemand onDemandVar doObtain = do
   result <- modifyMVar onDemandVar $ \case
     OnDemandErrored msg -> expectationFailure (T.unpack msg)
     OnDemandNotStarted -> do
-      asy <- async $ do
+      asy <- managedAsync "" "webdriver-on-demand" $ do
         let handler :: SomeException -> m a
             handler e = do
               modifyMVar_ onDemandVar (const $ return $ OnDemandErrored [i|Got exception: #{e}|])
diff --git a/sandwich/src/Test/Sandwich/Misc.hs b/sandwich/src/Test/Sandwich/Misc.hs
index 15578f63..58b5e108 100644
--- a/sandwich/src/Test/Sandwich/Misc.hs
+++ b/sandwich/src/Test/Sandwich/Misc.hs
@@ -34,7 +34,8 @@ module Test.Sandwich.Misc (
 
   -- * Context classes
   , BaseContext
-  , HasBaseContext
+  , baseContextRunId
+  , HasBaseContext(..)
   , HasBaseContextMonad
   , HasCommandLineOptions
   , SomeCommandLineOptions(..)

From 79e4e2fc38c0e2f7d7357e09000bc75abcd864aa Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 00:09:24 -0800
Subject: [PATCH 27/41] Clean up stream managed asyncs thread properly

---
 sandwich/src/Test/Sandwich.hs | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 5f1834d7..42619130 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -252,10 +252,10 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
   -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats, --log-events (managed-asyncs)
   milestone "spawning file stream asyncs"
   fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
-    (Just clo, Just runRoot) -> fmap catMaybes $ sequence
+    (Just clo, Just runRoot) -> fmap (concat . catMaybes) $ sequence
       [ if optLogLogs clo
         then case optionsLogBroadcast options' of
-          Just chan -> Just <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.txt") chan)
+          Just chan -> Just . (:[]) <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.txt") chan)
           Nothing -> return Nothing
         else return Nothing
       , if optLogEvents clo
@@ -263,12 +263,13 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
           writeTreeFile (runRoot </> "events-tree.txt") rts
           case optionsEventBroadcast options' of
             Just chan -> do
-              _ <- managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.txt") asyncEventBroadcast)
-              Just <$> managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.txt") chan)
+              asyncManagedEvents <- managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.txt") asyncEventBroadcast)
+              asyncEvents <- managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.txt") chan)
+              return (Just [asyncManagedEvents, asyncEvents])
             Nothing -> return Nothing
         else return Nothing
       , if optLogRtsStats clo
-        then Just <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
+        then Just . (:[]) <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
         else return Nothing
       ]
     _ -> return []

From ef83b33a28cf533f97b3cb4bc1f71c44f063d3f4 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 01:09:48 -0800
Subject: [PATCH 28/41] Lighter demo-stress

---
 demos/demo-stress/app/Main.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/demos/demo-stress/app/Main.hs b/demos/demo-stress/app/Main.hs
index 2d10d5b8..24897547 100644
--- a/demos/demo-stress/app/Main.hs
+++ b/demos/demo-stress/app/Main.hs
@@ -17,7 +17,7 @@ import Test.Sandwich
 -- when all tests finish and statuses stabilize.
 stressSpec :: TopSpec
 stressSpec = parallel $ do
-  forM_ [(1 :: Int)..400] $ \nodeId ->
+  forM_ [(1 :: Int)..20] $ \nodeId ->
     it [i|test #{nodeId}|] $ stressTest nodeId
 
 stressTest :: Int -> ExampleM context ()
@@ -27,7 +27,7 @@ stressTest nodeId = do
   let logCount = 100 + (nodeId * 47 `mod` 200)
   -- Spread the work over the 5-minute window.
   -- Total run time per test: ~4-5 minutes with jitter.
-  let baseSleepUs = (5 * 60 * 1000000) `div` logCount
+  let baseSleepUs = (5 * 60 * 100000) `div` logCount
   go gen logCount baseSleepUs (1 :: Int)
   where
     go _ 0 _ _ = return ()

From b80f64865a1329206d497aff257de4d0e5d3ea2e Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 01:09:59 -0800
Subject: [PATCH 29/41] More on asyncs logging

---
 sandwich/src/Test/Sandwich.hs                 | 50 +++++++++++--------
 sandwich/src/Test/Sandwich/Instrumentation.hs | 25 +++++++---
 .../Test/Sandwich/Interpreters/StartTree.hs   |  4 +-
 3 files changed, 47 insertions(+), 32 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 42619130..3e1b71a4 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -204,7 +204,7 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
   -- Open late-log file if --log-logs is active
   maybeLateLogHandle <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
     (Just clo, Just runRoot) | optLogLogs clo -> do
-      h <- openFile (runRoot </> "late-logs.txt") AppendMode
+      h <- openFile (runRoot </> "late-logs.log") AppendMode
       hSetBuffering h LineBuffering
       return (Just h)
     _ -> return Nothing
@@ -251,28 +251,31 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
 
   -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats, --log-events (managed-asyncs)
   milestone "spawning file stream asyncs"
-  fileStreamAsyncs <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
-    (Just clo, Just runRoot) -> fmap (concat . catMaybes) $ sequence
-      [ if optLogLogs clo
-        then case optionsLogBroadcast options' of
-          Just chan -> Just . (:[]) <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.txt") chan)
-          Nothing -> return Nothing
-        else return Nothing
-      , if optLogEvents clo
-        then do
-          writeTreeFile (runRoot </> "events-tree.txt") rts
-          case optionsEventBroadcast options' of
-            Just chan -> do
-              asyncManagedEvents <- managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.txt") asyncEventBroadcast)
-              asyncEvents <- managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.txt") chan)
-              return (Just [asyncManagedEvents, asyncEvents])
+  (fileStreamAsyncs, maybeManagedAsyncStreamAsync) <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
+    (Just clo, Just runRoot) -> do
+      others <- fmap catMaybes $ sequence
+        [ if optLogLogs clo
+          then case optionsLogBroadcast options' of
+            Just chan -> Just <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.log") chan)
             Nothing -> return Nothing
+          else return Nothing
+        , if optLogEvents clo
+          then do
+            writeTreeFile (runRoot </> "events-tree.txt") rts
+            case optionsEventBroadcast options' of
+              Just chan -> Just <$> managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.log") chan)
+              Nothing -> return Nothing
+          else return Nothing
+        , if optLogRtsStats clo
+          then Just <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.log"))
+          else return Nothing
+        ]
+      -- Spawn the managed-async event stream separately so we can cancel it last
+      maybeManagedAsync <- if optLogEvents clo
+        then Just <$> managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.log") asyncEventBroadcast)
         else return Nothing
-      , if optLogRtsStats clo
-        then Just . (:[]) <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.txt"))
-        else return Nothing
-      ]
-    _ -> return []
+      return (others, maybeManagedAsync)
+    _ -> return ([], Nothing)
 
   exitReasonRef <- newIORef NormalExit
 
@@ -313,10 +316,13 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
   milestone "fixing tree"
   fixedTree <- atomically $ mapM fixRunTree rts
 
-  -- Cancel file stream asyncs
+  -- Cancel file stream asyncs (but not the managed-async stream yet)
   milestone "cancelling file stream asyncs"
   mapM_ cancel fileStreamAsyncs
 
+  -- Cancel the managed-async stream last, so its finally block captures the final state
+  mapM_ cancel maybeManagedAsyncStreamAsync
+
   -- Check for stale managed asyncs from this run
   milestone "checking for stale asyncs"
   allAsyncs <- getManagedAsyncInfos
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index bef6c4f5..fe3ba436 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -11,6 +11,7 @@ import Control.Monad
 import Control.Monad.Logger
 import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
+import qualified Data.Map.Strict as M
 import Data.String.Interpolate
 import qualified Data.Text as T
 import Data.Time
@@ -19,7 +20,7 @@ import Debug.Trace (traceMarkerIO)
 import GHC.DataSize (recursiveSize)
 import GHC.Stats
 import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
-import Test.Sandwich.ManagedAsync (AsyncEvent(..), AsyncInfo(..))
+import Test.Sandwich.ManagedAsync (AsyncEvent(..), AsyncInfo(..), getManagedAsyncInfos)
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import UnliftIO.Concurrent (threadDelay)
@@ -133,19 +134,27 @@ formatBytes b
   | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
 
 -- | Stream managed async lifecycle events (started/finished) from a broadcast channel to a file.
+-- When cancelled, writes a summary of all asyncs still alive at that point.
 streamManagedAsyncEventsToFile :: FilePath -> TChan AsyncEvent -> IO ()
 streamManagedAsyncEventsToFile path broadcastChan = do
   chan <- atomically $ dupTChan broadcastChan
   withFile path AppendMode $ \h -> do
     hSetBuffering h LineBuffering
-    forever $ do
-      event <- atomically $ readTChan chan
+    let loop = forever $ do
+          event <- atomically $ readTChan chan
+          now <- getCurrentTime
+          let line :: String
+              line = case event of
+                AsyncStarted info -> [i|#{show now} STARTED (#{asyncInfoThreadId info}, parent #{asyncInfoParentThreadId info}, #{asyncInfoRunId info}) "#{asyncInfoName info}" |]
+                AsyncFinished info -> [i|#{show now} FINISHED (#{asyncInfoThreadId info}, #{asyncInfoRunId info}) "#{asyncInfoName info}"|]
+          hPutStr h (line <> "\n")
+          hFlush h
+    loop `finally` do
       now <- getCurrentTime
-      let line :: String
-          line = case event of
-            AsyncStarted info -> [i|#{show now} STARTED #{asyncInfoName info} (thread: #{asyncInfoThreadId info}, parent: #{asyncInfoParentThreadId info}, runId: #{asyncInfoRunId info})|]
-            AsyncFinished info -> [i|#{show now} FINISHED #{asyncInfoName info} (thread: #{asyncInfoThreadId info}, runId: #{asyncInfoRunId info})|]
-      hPutStr h (line <> "\n")
+      remaining <- getManagedAsyncInfos
+      hPutStr h [i|\n#{show now} === Remaining managed asyncs: #{M.size remaining} ===\n|]
+      forM_ (M.toList remaining) $ \(tid, info) ->
+        hPutStr h [i|  #{tid}: #{asyncInfoName info} (runId: #{asyncInfoRunId info})\n|]
       hFlush h
 
 -- | Write a tree of node IDs and labels to a file for cross-referencing with events.
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index 7d4542e6..c3f1cf42 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -11,11 +11,11 @@ module Test.Sandwich.Interpreters.StartTree (
 import Control.Concurrent.MVar
 import qualified Control.Exception as E
 import Control.Monad
-import qualified Data.ByteString.Char8 as BS8
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Control.Monad.Trans.Reader
+import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import qualified Data.List as L
 import Data.Sequence hiding ((:>))
@@ -268,7 +268,7 @@ runInAsync node ctx action = do
   let RunNodeCommonWithStatus {..} = runNodeCommon node
   let bc@(BaseContext {..}) = getBaseContext ctx
   let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id
-  let asyncName = T.pack [i|node:#{runTreeId}:#{runTreeLabel}|]
+  let asyncName = T.pack [i|node #{runTreeId}, #{runTreeLabel}|]
   startTime <- liftIO getCurrentTime
   mvar <- liftIO newEmptyMVar
   myAsync <- liftIO $ managedAsyncWithUnmask baseContextRunId asyncName $ \unmask -> do

From 7c09c02c69b706a8c2f2b321e8a4f11e30bfde75 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 01:13:27 -0800
Subject: [PATCH 30/41] Add separate --log-asyncs flag

---
 sandwich/src/Test/Sandwich.hs                  | 4 ++--
 sandwich/src/Test/Sandwich/ArgParsing.hs       | 1 +
 sandwich/src/Test/Sandwich/Types/ArgParsing.hs | 1 +
 3 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 3e1b71a4..15b10227 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -271,8 +271,8 @@ runSandwich' runId maybeCommandLineOptions options spec' = do
           else return Nothing
         ]
       -- Spawn the managed-async event stream separately so we can cancel it last
-      maybeManagedAsync <- if optLogEvents clo
-        then Just <$> managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "managed-asyncs.log") asyncEventBroadcast)
+      maybeManagedAsync <- if optLogAsyncs clo
+        then Just <$> managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "asyncs.log") asyncEventBroadcast)
         else return Nothing
       return (others, maybeManagedAsync)
     _ -> return ([], Nothing)
diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs
index 2029f5e1..ec04844e 100644
--- a/sandwich/src/Test/Sandwich/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/ArgParsing.hs
@@ -101,6 +101,7 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptio
   <*> switch (long "log-logs" <> help "Stream all test logs to <run-root>/logs.txt (for debugging)")
   <*> switch (long "log-events" <> help "Stream node lifecycle events to <run-root>/events.txt (for debugging)")
   <*> switch (long "log-rts-stats" <> help "Stream RTS memory stats to <run-root>/rts-stats.txt (for debugging)")
+  <*> switch (long "log-asyncs" <> help "Stream managed async lifecycle events to <run-root>/managed-asyncs.log (for debugging)")
 
   <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))
   <*> optional (flag False True (long "list-tests-json" <> help "List individual test modules in JSON format"))
diff --git a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
index 6a42d49d..f2f6bf27 100644
--- a/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
+++ b/sandwich/src/Test/Sandwich/Types/ArgParsing.hs
@@ -64,6 +64,7 @@ data CommandLineOptions a = CommandLineOptions {
   , optLogLogs :: Bool
   , optLogEvents :: Bool
   , optLogRtsStats :: Bool
+  , optLogAsyncs :: Bool
 
   , optListAvailableTests :: Maybe Bool
   , optListAvailableTestsJson :: Maybe Bool

From c91163c47984f0356058c4d432a0d444d6202ad9 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 03:33:25 -0800
Subject: [PATCH 31/41] Export withForwardKubernetesServiceFileLogging'

---
 .../lib/Test/Sandwich/Contexts/Kubernetes.hs  | 22 +++++++++++++++++++
 .../KindCluster/ServiceForwardPortForward.hs  |  6 +++++
 .../Kubernetes/MinikubeCluster/Forwards.hs    |  8 ++++---
 3 files changed, 33 insertions(+), 3 deletions(-)

diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes.hs
index fa310ea8..aae43105 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes.hs
@@ -41,6 +41,7 @@ module Test.Sandwich.Contexts.Kubernetes (
   -- * Forward services
   , withForwardKubernetesService
   , withForwardKubernetesService'
+  , withForwardKubernetesServiceFileLogging'
 
   -- * Logs
   , module Test.Sandwich.Contexts.Kubernetes.KubectlLogs
@@ -119,3 +120,24 @@ withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterTy
   Minikube.withForwardKubernetesService' kcc kubernetesClusterTypeMinikubeProfileName
 withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =
   Kind.withForwardKubernetesService' kcc kubectlBinary
+
+-- | Same as 'withForwardKubernetesService', but allows you to pass in the 'KubernetesClusterContext' and @kubectl@ binary.
+withForwardKubernetesServiceFileLogging' :: (
+  MonadLoggerIO m, MonadUnliftIO m
+  , HasBaseContextMonad context m
+  )
+  -- | Kubernetes cluster context
+  => KubernetesClusterContext
+  -- | Binary path for kubectl
+  -> FilePath
+  -- | Namespace
+  -> Text
+  -- | Service name
+  -> Text
+  -- | Callback receiving the service 'URL'.
+  -> (URI -> m a)
+  -> m a
+withForwardKubernetesServiceFileLogging' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) _kubectlBinary =
+  Minikube.withForwardKubernetesServiceFileLogging' kcc kubernetesClusterTypeMinikubeProfileName
+withForwardKubernetesServiceFileLogging' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {})}) kubectlBinary =
+  Kind.withForwardKubernetesServiceFileLogging' kcc kubectlBinary
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs
index 51d52db6..fbc91f45 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs
@@ -51,3 +51,9 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
       }
 
 withForwardKubernetesService' _ _ _ _ _ = error "withForwardKubernetesService' must be called with a kind KubernetesClusterContext"
+
+withForwardKubernetesServiceFileLogging' :: (
+  MonadUnliftIO m, MonadLoggerIO m
+  , HasBaseContextMonad context m
+  ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
+withForwardKubernetesServiceFileLogging' = withForwardKubernetesService'
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
index 4f149215..b6a3a3b2 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
@@ -80,8 +80,8 @@ withForwardKubernetesService' _ _profile _namespace _service _action = error "Ex
 
 withForwardKubernetesServiceFileLogging' :: (
   HasCallStack, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
-  ) => KubernetesClusterContext -> Text -> Text -> Text -> Text -> (URI -> m a) -> m a
-withForwardKubernetesServiceFileLogging' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) fileName profile namespace service action = do
+  ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a
+withForwardKubernetesServiceFileLogging' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do
   baseEnv <- liftIO getEnvironment
   let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
 
@@ -103,6 +103,8 @@ withForwardKubernetesServiceFileLogging' (KubernetesClusterContext {kubernetesCl
         , create_group = True
         }
 
+  let fileName = namespace <> "-" <> "service"
+
   getCurrentFolder >>= \case
     Nothing -> expectationFailure [i|withForwardKubernetesServiceFileLogging': no current folder.|]
     Just dir ->
@@ -129,4 +131,4 @@ withForwardKubernetesServiceFileLogging' (KubernetesClusterContext {kubernetesCl
           case T.lines contents of
             (x:_) -> pure x
             [] -> threadDelay 50_000 >> loop
-withForwardKubernetesServiceFileLogging' _ _fileName _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"
+withForwardKubernetesServiceFileLogging' _ _profile _namespace _service _action = error "Expected Minikube KubernetesClusterContext"

From 3d04619bad71eb3786724191d587a0204673bc4b Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 18:04:43 -0800
Subject: [PATCH 32/41] Use run ID from base context

---
 .../Test/Sandwich/Contexts/Docker/Registry.hs |  8 ++---
 .../Sandwich/Contexts/Kubernetes/Images.hs    |  2 +-
 .../Kubernetes/KataContainers/HelmChart.hs    |  4 +--
 .../Contexts/Kubernetes/KindCluster.hs        |  2 +-
 .../Contexts/Kubernetes/KindCluster/Images.hs |  6 ++--
 .../KindCluster/ServiceForwardIngress.hs      |  2 +-
 .../Contexts/Kubernetes/KindCluster/Setup.hs  |  2 +-
 .../Sandwich/Contexts/Kubernetes/Longhorn.hs  |  4 +--
 .../Kubernetes/MinikubeCluster/Images.hs      | 11 ++++---
 .../Sandwich/Contexts/Kubernetes/Typesense.hs |  2 +-
 .../Contexts/Kubernetes/Util/Images.hs        | 16 +++++-----
 .../Sandwich/Contexts/Kubernetes/Waits.hs     |  2 +-
 .../lib/Test/Sandwich/Contexts/Nix.hs         |  2 +-
 .../WebDriver/Internal/Binaries/Chrome.hs     |  7 +++--
 .../WebDriver/Internal/Binaries/Common.hs     |  7 +++--
 .../WebDriver/Internal/Binaries/Selenium.hs   |  7 +++--
 sandwich/src/Test/Sandwich.hs                 | 16 +++++-----
 .../src/Test/Sandwich/Internal/Running.hs     |  6 ++--
 sandwich/src/Test/Sandwich/Logging.hs         | 31 +++++++++++--------
 sandwich/src/Test/Sandwich/Options.hs         |  1 +
 sandwich/src/Test/Sandwich/Types/RunTree.hs   |  2 ++
 21 files changed, 76 insertions(+), 64 deletions(-)

diff --git a/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs b/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
index 643782ec..f43d40b5 100644
--- a/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
+++ b/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
@@ -50,7 +50,7 @@ type HasDockerRegistryContext context = HasLabel context "dockerRegistry" Docker
 -- * Introduce
 
 introduceDockerRegistry :: (
-  HasCallStack, MonadUnliftIO m
+  HasCallStack, MonadUnliftIO m, HasBaseContext context
   ) => SpecFree (LabelValue "dockerRegistry" DockerRegistryContext :> context) m () -> SpecFree context m ()
 introduceDockerRegistry = introduceWith "introduce Docker registry" dockerRegistry $ \action -> do
   void $ withDockerRegistry Nothing action
@@ -65,7 +65,7 @@ pushDockerImages images = before "push Docker images" $ do
 -- * Implementation
 
 withDockerRegistry :: (
-  MonadUnliftIO m, MonadLoggerIO m
+  MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m
   ) => Maybe (HostName, PortNumber) -> (DockerRegistryContext -> m a) -> m a
 withDockerRegistry optExternalDockerRegistry action = do
   case optExternalDockerRegistry of
@@ -74,7 +74,7 @@ withDockerRegistry optExternalDockerRegistry action = do
                                      , dockerRegistryPort = port }
     Nothing -> withNewDockerRegistry action
 
-withNewDockerRegistry :: (MonadUnliftIO m, MonadLoggerIO m) => (DockerRegistryContext -> m a) -> m a
+withNewDockerRegistry :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => (DockerRegistryContext -> m a) -> m a
 withNewDockerRegistry action = do
   registryID <- makeUUID' 5
 
@@ -122,7 +122,7 @@ pushContainerToRegistryTimed imageName drc = timeAction [i|Pushing docker image
   pushContainerToRegistry imageName drc
 
 pushContainerToRegistry :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   ) => Text -> DockerRegistryContext -> m Text
 pushContainerToRegistry imageName (DockerRegistryContext {..}) = do
   imageNamePart <- case splitOn "/" imageName of
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
index ef278d54..d6ee3d82 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Images.hs
@@ -100,7 +100,7 @@ clusterContainsImage image = do
 
 -- | Same as 'clusterContainsImage', but allows you to pass in the 'KubernetesClusterContext'.
 clusterContainsImage' :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   -- | Cluster context
   => KubernetesClusterContext
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
index 90fc8651..b8c95754 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
@@ -22,7 +22,7 @@ import UnliftIO.Process
 
 withKataContainers :: (
   MonadFail m, MonadLoggerIO m, MonadUnliftIO m
-  , MonadReader context m, HasFile context "helm"
+  , HasBaseContextMonad context m, HasFile context "helm"
   )
   => KubernetesClusterContext
   -> KataContainersOptions
@@ -33,7 +33,7 @@ withKataContainers kcc options action = do
   withKataContainers' helmBinary kcc options action
 
 withKataContainers' :: (
-  MonadFail m, MonadLoggerIO m, MonadUnliftIO m
+  MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   )
   => FilePath
   -> KubernetesClusterContext
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
index f93d78e7..644d579e 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
@@ -227,7 +227,7 @@ withKindCluster' kindBinary kubectlBinary opts@(KindClusterOptions {..}) action
            )
 
 startKindCluster :: (
-  MonadLoggerIO m, MonadUnliftIO m
+  MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => FilePath -> KindClusterOptions -> Text -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m KubernetesClusterContext
 startKindCluster kindBinary (KindClusterOptions {..}) clusterName kindConfigFile kindKubeConfigFile environmentToUse driver = do
   ps <- createProcessWithLogging ((proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
index 967d0e27..3bf5c3a5 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
@@ -30,7 +30,7 @@ import UnliftIO.Temporary
 
 -- | Load an image into a Kind cluster.
 loadImageKind :: (
-  HasCallStack, MonadUnliftIO m, MonadLoggerIO m
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m
   )
   -- | Path to @kind@ binary
   => FilePath
@@ -93,7 +93,7 @@ loadImageKind kindBinary clusterName imageLoadSpec env = do
 
 -- | Get the set of loaded images on the given Kind cluster.
 getLoadedImagesKind :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   => KubernetesClusterContext
   -- | Driver (should be "docker" or "podman")
@@ -128,7 +128,7 @@ getLoadedImagesKind kcc driver kindBinary env = do
 
 -- | Test if the Kind cluster contains a given image.
 clusterContainsImageKind :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   => KubernetesClusterContext
   -- | Driver (should be "docker" or "podman")
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
index a738f392..bc828c21 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
@@ -34,7 +34,7 @@ import UnliftIO.Timeout
 
 
 withForwardKubernetesService' :: (
-  MonadUnliftIO m, MonadLoggerIO m
+  MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m
   ) => KubernetesClusterContext -> FilePath -> Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) kubectlBinary namespace service action = do
   baseEnv <- maybe getEnvironment return kubernetesClusterTypeKindClusterEnvironment
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
index b62c2900..6938f4a2 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
@@ -25,7 +25,7 @@ import UnliftIO.Process
 
 
 setUpKindCluster :: (
-  MonadLoggerIO m, MonadUnliftIO m
+  MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => KubernetesClusterContext -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m ()
 setUpKindCluster kcc@(KubernetesClusterContext {..}) kindBinary kubectlBinary environmentToUse driver = do
   baseEnv <- maybe getEnvironment return environmentToUse
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
index a42038d1..f3700a05 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
@@ -71,8 +71,8 @@ withLonghorn options action = do
   kubectlBinary <- askFile @"kubectl"
   withLonghorn' kcc kubectlBinary options action
 
-withLonghorn' :: forall m a. (
-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m
+withLonghorn' :: forall context m a. (
+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => KubernetesClusterContext -> String -> LonghornOptions -> (LonghornContext -> m a) -> m a
 withLonghorn' (KubernetesClusterContext {kubernetesClusterKubeConfigPath}) kubectlBinary options@(LonghornOptions {..}) action = do
   baseEnv <- getEnvironment
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
index 6e66b704..0f214396 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
@@ -32,7 +32,7 @@ import UnliftIO.Temporary
 
 -- | Load an image onto a cluster. This image can come from a variety of sources, as specified by the 'ImageLoadSpec'.
 loadImageMinikube :: (
-  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadFail m, HasBaseContextMonad context m
   )
   -- | Path to @minikube@ binary
   => FilePath
@@ -84,7 +84,7 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
       imageLoad (toString image) True >> return image
 
   where
-    imageLoad :: (MonadLoggerIO m, HasCallStack) => String -> Bool -> m ()
+    imageLoad :: (MonadLoggerIO m, HasBaseContextMonad context m, HasCallStack) => String -> Bool -> m ()
     imageLoad toLoad daemon = do
       let extraFlags = case "--rootless" `L.elem` minikubeFlags of
                          True -> ["--rootless"]
@@ -100,12 +100,13 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
 
       -- Gather stderr output while also logging it
       logFn <- askLoggerIO
+      ctx <- ask
       stderrOutputVar <- newIORef mempty
       let customLogFn loc src level str = do
             modifyIORef' stderrOutputVar (<> str)
             logFn loc src level str
 
-      liftIO $ flip runLoggingT customLogFn $
+      liftIO $ flip runLoggingT customLogFn $ flip runReaderT ctx $
         createProcessWithLogging (proc minikubeBinary args)
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
@@ -132,7 +133,7 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
 
 -- | Get the loaded images on a cluster, by cluster name.
 getLoadedImagesMinikube :: (
-  MonadUnliftIO m, MonadLogger m
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   -- | Path to @minikube@ binary
   => FilePath
@@ -150,7 +151,7 @@ getLoadedImagesMinikube minikubeBinary clusterName minikubeFlags = do
 
 -- | Test if the cluster contains a given image, by cluster name.
 clusterContainsImageMinikube :: (
-  MonadUnliftIO m, MonadLogger m
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   -- | Path to @minikube@ binary
   => FilePath
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
index 13f3a05b..970af8fb 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
@@ -184,7 +184,7 @@ withTypesense' kcc _kubectlBinary namespace options@(TypesenseOptions {..}) acti
       , typesenseNamespace = namespace
       }
 
-cleanupTypesense :: (MonadLoggerIO m, MonadUnliftIO m) => FilePath -> [(String, String)] -> Text -> Text -> m ()
+cleanupTypesense :: (MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m) => FilePath -> [(String, String)] -> Text -> Text -> m ()
 cleanupTypesense helmBinary env namespace releaseName = do
   info [i|Cleaning up Typesense release '#{releaseName}' in namespace '#{namespace}'...|]
   createProcessWithLogging ((proc helmBinary [
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
index a6b8fa09..c16327bc 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
@@ -38,25 +38,25 @@ import UnliftIO.Temporary
 
 -- | Pull an image using Docker if it isn't already present.
 -- Returns 'True' if a pull was done.
-dockerPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> ImagePullPolicy -> m Bool
+dockerPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> ImagePullPolicy -> m Bool
 dockerPullIfNecessary = commonPullIfNecessary "docker"
 
-isDockerImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool
+isDockerImagePresent :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> m Bool
 isDockerImagePresent = isImagePresentCommon "docker"
 
 -- * Podman
 
 -- | Pull an image using Docker if it isn't already present.
 -- Returns 'True' if a pull was done.
-podmanPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> ImagePullPolicy -> m Bool
+podmanPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> ImagePullPolicy -> m Bool
 podmanPullIfNecessary = commonPullIfNecessary "podman"
 
-isPodmanImagePresent :: (MonadUnliftIO m, MonadLoggerIO m) => Text -> m Bool
+isPodmanImagePresent :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => Text -> m Bool
 isPodmanImagePresent = isImagePresentCommon "podman"
 
 -- * Common
 
-commonPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> ImagePullPolicy -> m Bool
+commonPullIfNecessary :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => String -> Text -> ImagePullPolicy -> m Bool
 commonPullIfNecessary binary image pullPolicy = isImagePresentCommon binary image >>= \case
   True ->
     if | pullPolicy == Always -> doPull
@@ -70,7 +70,7 @@ commonPullIfNecessary binary image pullPolicy = isImagePresentCommon binary imag
         >>= waitForProcess >>= (`shouldBe` ExitSuccess)
       return True
 
-isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m) => String -> Text -> m Bool
+isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => String -> Text -> m Bool
 isImagePresentCommon binary image = do
   createProcessWithLogging (proc binary ["inspect", "--type=image", toString image]) >>= waitForProcess >>= \case
     ExitSuccess -> return True
@@ -78,7 +78,7 @@ isImagePresentCommon binary image = do
 
 -- * Image name reading
 
-readImageName :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => FilePath -> m Text
+readImageName :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => FilePath -> m Text
 readImageName path = doesDirectoryExist path >>= \case
   True -> readUncompressedImageName path
   False -> case takeExtension path of
@@ -113,7 +113,7 @@ getImageNameFromManifestJson path contents = do
     getRepoTags (A.Object (aesonLookup "RepoTags" -> Just (A.Array repoItems))) = [t | A.String t <- V.toList repoItems]
     getRepoTags _ = []
 
-imageLoadSpecToImageName :: (MonadUnliftIO m, MonadLogger m) => ImageLoadSpec -> m Text
+imageLoadSpecToImageName :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => ImageLoadSpec -> m Text
 imageLoadSpecToImageName (ImageLoadSpecTarball image) = readImageName image
 imageLoadSpecToImageName (ImageLoadSpecDocker image _) = pure image
 imageLoadSpecToImageName (ImageLoadSpecPodman image _) = pure image
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
index d3f23d2b..f7e85800 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
@@ -109,7 +109,7 @@ listPods namespace labels =
 -- | Wait for a set of pods to be in the Ready condition, specified by a set of labels.
 waitForPodsToBeReady :: (
   MonadUnliftIO m, MonadLogger m
-  , MonadReader context m, HasKubernetesClusterContext context, HasFile context "kubectl"
+  , MonadReader context m, HasBaseContext context, HasKubernetesClusterContext context, HasFile context "kubectl"
   )
   -- | Namespace
   => Text
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
index 0dd7a37a..574e95dd 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
@@ -416,7 +416,7 @@ buildNixExpression' nc@(NixContext {..}) expr = do
 --   nc <- getContext nixContext
 --   runNixBuild' nc expr outputPath
 
-runNixBuild' :: (MonadUnliftIO m, MonadLogger m) => NixContext -> Text -> Maybe String -> m String
+runNixBuild' :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => NixContext -> Text -> Maybe String -> m String
 runNixBuild' (NixContext {nixContextNixpkgsDerivation}) expr maybeOutputPath = do
   maybeEnv <- case nixpkgsDerivationAllowUnfree nixContextNixpkgsDerivation of
     False -> pure Nothing
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs
index ec26fe52..ef88a820 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs
@@ -32,10 +32,11 @@ import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
 import UnliftIO.Directory
 
 
-type Constraints m = (
+type Constraints context m = (
   HasCallStack
   , MonadLogger m
   , MonadUnliftIO m
+  , HasBaseContextMonad context m
   )
 
 -- | Manually obtain a chrome binary, according to the 'ChromeToUse' policy,
@@ -108,7 +109,7 @@ obtainChromeDriver (UseChromeDriverFromNixpkgs nixContext) = do
   debug [i|Built chromedriver: #{ret}|]
   return $ Right ret
 
-downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)
+downloadChromeDriverIfNecessary' :: Constraints context m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)
 downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do
   let chromeDriverPath = getChromeDriverPath toolsDir chromeDriverVersion
 
@@ -118,7 +119,7 @@ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do
 
   return chromeDriverPath
 
-downloadChromeDriverIfNecessary :: Constraints m => FilePath -> FilePath -> m (Either T.Text FilePath)
+downloadChromeDriverIfNecessary :: Constraints context m => FilePath -> FilePath -> m (Either T.Text FilePath)
 downloadChromeDriverIfNecessary chromePath toolsDir = runExceptT $ do
   chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion chromePath
   ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
index 642c14f3..73c94b1c 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
@@ -14,11 +14,12 @@ import System.FilePath
 import System.Process
 import Test.Sandwich.Expectations
 import Test.Sandwich.Logging
+import Test.Sandwich.Misc (HasBaseContextMonad)
 import Test.Sandwich.WebDriver.Internal.Util
 import UnliftIO.Temporary
 
 
-downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
@@ -38,7 +39,7 @@ downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
           >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
       xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
 
-downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
+downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
@@ -47,7 +48,7 @@ downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
     >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
 
-curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m ()
+curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> FilePath -> m ()
 curlDownloadToPath downloadPath localPath = do
   info [i|Downloading #{downloadPath} to #{localPath}|]
   liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs
index c17bfdf4..93923f0a 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs
@@ -24,10 +24,11 @@ import Test.Sandwich.WebDriver.Internal.Util
 import UnliftIO.Directory
 
 
-type Constraints m = (
+type Constraints context m = (
   HasCallStack
   , MonadLogger m
   , MonadUnliftIO m
+  , HasBaseContextMonad context m
   )
 
 -- * Obtaining binaries
@@ -76,13 +77,13 @@ obtainSelenium (UseSeleniumFromNixpkgs nc) = do
 
 -- * Lower level helpers
 
-downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath)
+downloadSeleniumIfNecessary :: Constraints context m => FilePath -> m (Either T.Text FilePath)
 downloadSeleniumIfNecessary toolsDir = leftOnException' $ do
   let seleniumPath = [i|#{toolsDir}/selenium-server.jar|]
   liftIO (doesFileExist seleniumPath) >>= flip unless (downloadSelenium seleniumPath)
   return seleniumPath
   where
-    downloadSelenium :: Constraints m => FilePath -> m ()
+    downloadSelenium :: Constraints context m => FilePath -> m ()
     downloadSelenium seleniumPath = void $ do
       info [i|Downloading selenium-server.jar to #{seleniumPath}|]
       curlDownloadToPath defaultSeleniumJarUrl seleniumPath
diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 15b10227..1c448217 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -128,7 +128,7 @@ import System.Win32.Console (setConsoleOutputCP)
 -- | Run the spec with the given 'Options'.
 runSandwich :: Options -> CoreSpec -> IO ()
 runSandwich options spec = do
-  (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' "run" Nothing options spec
+  (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' Nothing options spec
   when (0 < totalFailures) exitFailure
 
 -- | Run the spec, configuring the options from the command line.
@@ -175,12 +175,13 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
                                                  , nodeOptionsCreateFolder = False }
 
          let mkRunId idx = if repeatCount == 1 then "run" else [i|repeat-#{idx}|]
-         runWithRepeat repeatCount totalTests $ \repeatIdx ->
+         runWithRepeat repeatCount totalTests $ \repeatIdx -> do
+           let opts = options { optionsRunId = mkRunId repeatIdx }
            case optIndividualTestModule clo of
-             Nothing -> runSandwich' (mkRunId repeatIdx) (Just $ clo { optUserOptions = () }) options $
+             Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) opts $
                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
                  $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec
-             Just (IndividualTestModuleName x) -> runSandwich' (mkRunId repeatIdx) (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $
+             Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) opts $ filterTreeToModule x $
                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
                  $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec
              Just (IndividualTestMainFn x) -> do
@@ -197,9 +198,10 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
 -- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason,
 -- the number of "it" nodes which failed, and the total failed nodes (which includes "it" nodes, and
 -- may also include other nodes like "introduce" nodes).
-runSandwich' :: T.Text -> Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int)
-runSandwich' runId maybeCommandLineOptions options spec' = do
-  baseContext <- baseContextFromOptionsWithRunId runId options
+runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int)
+runSandwich' maybeCommandLineOptions options spec' = do
+  let runId = optionsRunId options
+  baseContext <- baseContextFromOptions options
 
   -- Open late-log file if --log-logs is active
   maybeLateLogHandle <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of
diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs
index 1e664237..25414826 100644
--- a/sandwich/src/Test/Sandwich/Internal/Running.hs
+++ b/sandwich/src/Test/Sandwich/Internal/Running.hs
@@ -83,10 +83,8 @@ runWithRepeat n totalTests action = do
   when (successes /= total) $ exitFailure
 
 baseContextFromOptions :: Options -> IO BaseContext
-baseContextFromOptions = baseContextFromOptionsWithRunId "run"
-
-baseContextFromOptionsWithRunId :: T.Text -> Options -> IO BaseContext
-baseContextFromOptionsWithRunId runId options@(Options {..}) = do
+baseContextFromOptions options@(Options {..}) = do
+  let runId = optionsRunId
   runRoot <- case optionsTestArtifactsDirectory of
     TestArtifactsNone -> return Nothing
     TestArtifactsFixedDirectory dir' -> do
diff --git a/sandwich/src/Test/Sandwich/Logging.hs b/sandwich/src/Test/Sandwich/Logging.hs
index c50a4b6e..e27ed723 100644
--- a/sandwich/src/Test/Sandwich/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Logging.hs
@@ -31,6 +31,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logOther)
+import Control.Monad.Reader
 import Data.String.Interpolate
 import Data.Text (Text)
 import Foreign.C.Error
@@ -43,7 +44,7 @@ import System.Process
 import Test.Sandwich.Contexts
 import Test.Sandwich.Expectations
 import Test.Sandwich.Types.RunTree
-import UnliftIO.Async hiding (wait)
+import Test.Sandwich.ManagedAsync
 import UnliftIO.Exception
 
 #if !MIN_VERSION_base(4,13,0)
@@ -81,19 +82,20 @@ logOther = logOtherCS callStack
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> m ProcessHandle
+createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
 createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m ProcessHandle
 createProcessWithLogging' logLevel cp = do
+  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   let name = case cmdspec cp of
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- async $ forever $ do
+  _ <- managedAsync runId "process-logging" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -113,19 +115,20 @@ createProcessWithFileLogging name cp = withFrozenCallStack $ do
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
 -- Every line output by the process will be fed to a 'debug' call.
-readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> String -> m String
+readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String
 readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
-readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
+readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m String
 readCreateProcessWithLogging' logLevel cp input = do
+  runId <- baseContextRunId <$> asks getBaseContext
   (hReadErr, hWriteErr) <- liftIO createPipe
 
   let name = case cmdspec cp of
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- async $ forever $ do
+  _ <- managedAsync runId "process-stderr-logging" $ forever $ do
     line <- liftIO $ hGetLine hReadErr
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -167,19 +170,20 @@ readCreateProcessWithLogging' logLevel cp input = do
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle
 createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
 createProcessWithLoggingAndStdin' logLevel cp input = do
+  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   let name = case cmdspec cp of
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- async $ forever $ do
+  _ <- managedAsync runId "process-logging-stdin" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -197,12 +201,13 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
   return p
 
 -- | Higher level version of 'createProcessWithLogging', accepting a shell command.
-callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()
+callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()
 callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
 
 -- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
-callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
+callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> String -> m ()
 callCommandWithLogging' logLevel cmd = do
+  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   (_, _, _, p) <- liftIO $ createProcess (shell cmd) {
@@ -211,7 +216,7 @@ callCommandWithLogging' logLevel cmd = do
     , std_err = UseHandle hWrite
     }
 
-  _ <- async $ forever $ do
+  _ <- managedAsync runId "command-logging" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
 
diff --git a/sandwich/src/Test/Sandwich/Options.hs b/sandwich/src/Test/Sandwich/Options.hs
index f9102b08..ffdff1a7 100644
--- a/sandwich/src/Test/Sandwich/Options.hs
+++ b/sandwich/src/Test/Sandwich/Options.hs
@@ -60,6 +60,7 @@ defaultOptions = Options {
   , optionsLogBroadcast = Nothing
   , optionsEventBroadcast = Nothing
   , optionsLateLogFile = Nothing
+  , optionsRunId = "run0"
   }
 
 -- | Generate a test artifacts directory based on a timestamp.
diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs
index 8d76e84b..b6d5a286 100644
--- a/sandwich/src/Test/Sandwich/Types/RunTree.hs
+++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs
@@ -321,6 +321,8 @@ data Options = Options {
   -- ^ Broadcast channel for streaming node lifecycle events (started, done) to external consumers.
   , optionsLateLogFile :: Maybe Handle
   -- ^ If set, log writes that occur after a node is already Done will be written to this file handle.
+  , optionsRunId :: T.Text
+  -- ^ An identifier for this test run, used to track managed async threads.
   }
 
 -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way

From 4e00d07a28923c5ca143f63a304ac610581bc999 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 18:37:16 -0800
Subject: [PATCH 33/41] Split out logging process functions + fill in other
 file based ones

---
 sandwich/sandwich.cabal                       |   2 +
 sandwich/src/Test/Sandwich/Logging.hs         | 203 +-----------------
 sandwich/src/Test/Sandwich/Logging/Process.hs | 199 +++++++++++++++++
 .../Sandwich/Logging/ProcessFileLogging.hs    | 138 ++++++++++++
 4 files changed, 344 insertions(+), 198 deletions(-)
 create mode 100644 sandwich/src/Test/Sandwich/Logging/Process.hs
 create mode 100644 sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs

diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index 697c9fd2..71b9d2d9 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -87,6 +87,8 @@ library
       Test.Sandwich.Interpreters.RunTree.Logging
       Test.Sandwich.Interpreters.RunTree.Util
       Test.Sandwich.Interpreters.StartTree
+      Test.Sandwich.Logging.Process
+      Test.Sandwich.Logging.ProcessFileLogging
       Test.Sandwich.ParallelN
       Test.Sandwich.RunTree
       Test.Sandwich.Shutdown
diff --git a/sandwich/src/Test/Sandwich/Logging.hs b/sandwich/src/Test/Sandwich/Logging.hs
index e27ed723..742d9153 100644
--- a/sandwich/src/Test/Sandwich/Logging.hs
+++ b/sandwich/src/Test/Sandwich/Logging.hs
@@ -22,34 +22,16 @@ module Test.Sandwich.Logging (
 
   -- * Process functions with file logging
   , createProcessWithFileLogging
+  , readCreateProcessWithFileLogging
+  , createProcessWithFileLoggingAndStdin
+  , callCommandWithFileLogging
   ) where
 
-import Control.Concurrent
-import Control.DeepSeq (rnf)
-import qualified Control.Exception as C
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logOther)
-import Control.Monad.Reader
-import Data.String.Interpolate
 import Data.Text (Text)
-import Foreign.C.Error
-import GHC.IO.Exception
 import GHC.Stack
-import System.FilePath
-import System.IO
-import System.IO.Error (mkIOError)
-import System.Process
-import Test.Sandwich.Contexts
-import Test.Sandwich.Expectations
-import Test.Sandwich.Types.RunTree
-import Test.Sandwich.ManagedAsync
-import UnliftIO.Exception
-
-#if !MIN_VERSION_base(4,13,0)
-import Control.Monad.Fail
-#endif
+import Test.Sandwich.Logging.Process
+import Test.Sandwich.Logging.ProcessFileLogging
 
 
 -- * Basic logging functions
@@ -74,178 +56,3 @@ logError = logErrorCS callStack
 -- | Log with a custom 'LogLevel'.
 logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Text -> m ()
 logOther = logOtherCS callStack
-
-
--- * System.Process helpers
---
--- | Functions for launching processes while capturing their output in the logs.
-
--- | Spawn a process with its stdout and stderr connected to the logging system.
--- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
-createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
-
--- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m ProcessHandle
-createProcessWithLogging' logLevel cp = do
-  runId <- baseContextRunId <$> asks getBaseContext
-  (hRead, hWrite) <- liftIO createPipe
-
-  let name = case cmdspec cp of
-        ShellCommand {} -> "shell"
-        RawCommand path _ -> path
-
-  _ <- managedAsync runId "process-logging" $ forever $ do
-    line <- liftIO $ hGetLine hRead
-    logOtherCS callStack logLevel [i|#{name}: #{line}|]
-
-  (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })
-  return p
-
--- | Spawn a process with its stdout and stderr logged to a file in the test tree.
-createProcessWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => FilePath -> CreateProcess -> m ProcessHandle
-createProcessWithFileLogging name cp = withFrozenCallStack $ do
-  getCurrentFolder >>= \case
-    Nothing -> expectationFailure [i|createProcessWithFileLogging': no current folder, so unable to log for name '#{name}'.|]
-    Just dir ->
-      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->
-      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do
-        (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hOut, std_err = UseHandle hErr })
-        return p
-
--- | Like 'readCreateProcess', but capture the stderr output in the logs.
--- Every line output by the process will be fed to a 'debug' call.
-readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String
-readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
-
--- | Like 'readCreateProcess', but capture the stderr output in the logs.
-readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m String
-readCreateProcessWithLogging' logLevel cp input = do
-  runId <- baseContextRunId <$> asks getBaseContext
-  (hReadErr, hWriteErr) <- liftIO createPipe
-
-  let name = case cmdspec cp of
-        ShellCommand {} -> "shell"
-        RawCommand path _ -> path
-
-  _ <- managedAsync runId "process-stderr-logging" $ forever $ do
-    line <- liftIO $ hGetLine hReadErr
-    logOtherCS callStack logLevel [i|#{name}: #{line}|]
-
-  -- Do this just like 'readCreateProcess'
-  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
-  (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p -> do
-    case (sin', sout) of
-      (Just hIn, Just hOut) -> do
-        output  <- hGetContents hOut
-        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
-          -- now write any input
-          unless (Prelude.null input) $
-            ignoreSigPipe $ hPutStr hIn input
-          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-          ignoreSigPipe $ hClose hIn
-
-          -- wait on the output
-          waitOut
-          hClose hOut
-
-        -- wait on the process
-        ex <- waitForProcess p
-        return (ex, output)
-      (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
-      (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
-
-  case ex of
-    ExitSuccess -> return output
-    ExitFailure r -> liftIO $ processFailedException "readCreateProcessWithLogging" cmd args r
-
-  where
-    cmd = case cp of
-            CreateProcess { cmdspec = ShellCommand sc } -> sc
-            CreateProcess { cmdspec = RawCommand fp _ } -> fp
-    args = case cp of
-             CreateProcess { cmdspec = ShellCommand _ } -> []
-             CreateProcess { cmdspec = RawCommand _ args' } -> args'
-
-
--- | Spawn a process with its stdout and stderr connected to the logging system.
--- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle
-createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
-
--- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
-createProcessWithLoggingAndStdin' logLevel cp input = do
-  runId <- baseContextRunId <$> asks getBaseContext
-  (hRead, hWrite) <- liftIO createPipe
-
-  let name = case cmdspec cp of
-        ShellCommand {} -> "shell"
-        RawCommand path _ -> path
-
-  _ <- managedAsync runId "process-logging-stdin" $ forever $ do
-    line <- liftIO $ hGetLine hRead
-    logOtherCS callStack logLevel [i|#{name}: #{line}|]
-
-  (Just inh, _, _, p) <- liftIO $ createProcess (
-    cp { std_out = UseHandle hWrite
-       , std_err = UseHandle hWrite
-       , std_in = CreatePipe }
-    )
-
-  unless (Prelude.null input) $
-    liftIO $ ignoreSigPipe $ hPutStr inh input
-  -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-  liftIO $ ignoreSigPipe $ hClose inh
-
-  return p
-
--- | Higher level version of 'createProcessWithLogging', accepting a shell command.
-callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()
-callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
-
--- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
-callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> String -> m ()
-callCommandWithLogging' logLevel cmd = do
-  runId <- baseContextRunId <$> asks getBaseContext
-  (hRead, hWrite) <- liftIO createPipe
-
-  (_, _, _, p) <- liftIO $ createProcess (shell cmd) {
-    delegate_ctlc = True
-    , std_out = UseHandle hWrite
-    , std_err = UseHandle hWrite
-    }
-
-  _ <- managedAsync runId "command-logging" $ forever $ do
-    line <- liftIO $ hGetLine hRead
-    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
-
-  liftIO (waitForProcess p) >>= \case
-    ExitSuccess -> return ()
-    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
-
-
--- * Util
-
--- Copied from System.Process
-withForkWait :: IO () -> (IO () ->  IO a) -> IO a
-withForkWait asy body = do
-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
-  mask $ \restore -> do
-    tid <- forkIO $ try (restore asy) >>= putMVar waitVar
-    let wait = takeMVar waitVar >>= either throwIO return
-    restore (body wait) `C.onException` killThread tid
-
--- Copied from System.Process
-ignoreSigPipe :: IO () -> IO ()
-ignoreSigPipe = C.handle $ \case
-  IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()
-  e -> throwIO e
-
--- Copied from System.Process
-processFailedException :: String -> String -> [String] -> Int -> IO a
-processFailedException fun cmd args exit_code =
-  ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++
-                                 Prelude.concatMap ((' ':) . show) args ++
-                                 " (exit " ++ show exit_code ++ ")")
-            Nothing Nothing)
diff --git a/sandwich/src/Test/Sandwich/Logging/Process.hs b/sandwich/src/Test/Sandwich/Logging/Process.hs
new file mode 100644
index 00000000..cc56b998
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Logging/Process.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE CPP #-}
+
+-- | Functions for launching processes while capturing their output in the test logs.
+
+module Test.Sandwich.Logging.Process (
+  -- * Process functions with direct logging
+  createProcessWithLogging
+  , readCreateProcessWithLogging
+  , createProcessWithLoggingAndStdin
+  , callCommandWithLogging
+
+  , createProcessWithLogging'
+  , readCreateProcessWithLogging'
+  , createProcessWithLoggingAndStdin'
+  , callCommandWithLogging'
+  ) where
+
+import Control.Concurrent
+import Control.DeepSeq (rnf)
+import qualified Control.Exception as C
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger hiding (logOther)
+import Control.Monad.Reader
+import Data.String.Interpolate
+import Foreign.C.Error
+import GHC.IO.Exception
+import GHC.Stack
+import System.IO
+import System.IO.Error (mkIOError)
+import System.Process
+import Test.Sandwich.Types.RunTree
+import Test.Sandwich.ManagedAsync
+import UnliftIO.Exception
+
+#if !MIN_VERSION_base(4,13,0)
+import Control.Monad.Fail
+#endif
+
+
+-- | Spawn a process with its stdout and stderr connected to the logging system.
+-- Every line output by the process will be fed to a 'debug' call.
+createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
+createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
+
+-- | Spawn a process with its stdout and stderr connected to the logging system.
+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m ProcessHandle
+createProcessWithLogging' logLevel cp = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  (hRead, hWrite) <- liftIO createPipe
+
+  let name = case cmdspec cp of
+        ShellCommand {} -> "shell"
+        RawCommand path _ -> path
+
+  _ <- managedAsync runId "process-logging" $ forever $ do
+    line <- liftIO $ hGetLine hRead
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
+
+  (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })
+  return p
+
+-- | Like 'readCreateProcess', but capture the stderr output in the logs.
+-- Every line output by the process will be fed to a 'debug' call.
+readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String
+readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
+
+-- | Like 'readCreateProcess', but capture the stderr output in the logs.
+readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m String
+readCreateProcessWithLogging' logLevel cp input = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  (hReadErr, hWriteErr) <- liftIO createPipe
+
+  let name = case cmdspec cp of
+        ShellCommand {} -> "shell"
+        RawCommand path _ -> path
+
+  _ <- managedAsync runId "process-stderr-logging" $ forever $ do
+    line <- liftIO $ hGetLine hReadErr
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
+
+  -- Do this just like 'readCreateProcess'
+  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
+  (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p -> do
+    case (sin', sout) of
+      (Just hIn, Just hOut) -> do
+        output  <- hGetContents hOut
+        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
+          -- now write any input
+          unless (Prelude.null input) $
+            ignoreSigPipe $ hPutStr hIn input
+          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+          ignoreSigPipe $ hClose hIn
+
+          -- wait on the output
+          waitOut
+          hClose hOut
+
+        -- wait on the process
+        ex <- waitForProcess p
+        return (ex, output)
+      (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
+      (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
+
+  case ex of
+    ExitSuccess -> return output
+    ExitFailure r -> liftIO $ processFailedException "readCreateProcessWithLogging" cmd args r
+
+  where
+    cmd = case cp of
+            CreateProcess { cmdspec = ShellCommand sc } -> sc
+            CreateProcess { cmdspec = RawCommand fp _ } -> fp
+    args = case cp of
+             CreateProcess { cmdspec = ShellCommand _ } -> []
+             CreateProcess { cmdspec = RawCommand _ args' } -> args'
+
+
+-- | Spawn a process with its stdout and stderr connected to the logging system.
+-- Every line output by the process will be fed to a 'debug' call.
+createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
+
+-- | Spawn a process with its stdout and stderr connected to the logging system.
+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin' logLevel cp input = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  (hRead, hWrite) <- liftIO createPipe
+
+  let name = case cmdspec cp of
+        ShellCommand {} -> "shell"
+        RawCommand path _ -> path
+
+  _ <- managedAsync runId "process-logging-stdin" $ forever $ do
+    line <- liftIO $ hGetLine hRead
+    logOtherCS callStack logLevel [i|#{name}: #{line}|]
+
+  (Just inh, _, _, p) <- liftIO $ createProcess (
+    cp { std_out = UseHandle hWrite
+       , std_err = UseHandle hWrite
+       , std_in = CreatePipe }
+    )
+
+  unless (Prelude.null input) $
+    liftIO $ ignoreSigPipe $ hPutStr inh input
+  -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+  liftIO $ ignoreSigPipe $ hClose inh
+
+  return p
+
+-- | Higher level version of 'createProcessWithLogging', accepting a shell command.
+callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()
+callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
+
+-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
+callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> String -> m ()
+callCommandWithLogging' logLevel cmd = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  (hRead, hWrite) <- liftIO createPipe
+
+  (_, _, _, p) <- liftIO $ createProcess (shell cmd) {
+    delegate_ctlc = True
+    , std_out = UseHandle hWrite
+    , std_err = UseHandle hWrite
+    }
+
+  _ <- managedAsync runId "command-logging" $ forever $ do
+    line <- liftIO $ hGetLine hRead
+    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
+
+  liftIO (waitForProcess p) >>= \case
+    ExitSuccess -> return ()
+    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
+
+
+-- * Util
+
+-- Copied from System.Process
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait asy body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore asy) >>= putMVar waitVar
+    let wait = takeMVar waitVar >>= either throwIO return
+    restore (body wait) `C.onException` killThread tid
+
+-- Copied from System.Process
+ignoreSigPipe :: IO () -> IO ()
+ignoreSigPipe = C.handle $ \case
+  IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()
+  e -> throwIO e
+
+-- Copied from System.Process
+processFailedException :: String -> String -> [String] -> Int -> IO a
+processFailedException fun cmd args exit_code =
+  ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++
+                                 Prelude.concatMap ((' ':) . show) args ++
+                                 " (exit " ++ show exit_code ++ ")")
+            Nothing Nothing)
diff --git a/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs b/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs
new file mode 100644
index 00000000..de5fd15f
--- /dev/null
+++ b/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP #-}
+
+-- | Functions for launching processes while capturing their output to files in the test tree.
+
+module Test.Sandwich.Logging.ProcessFileLogging (
+  createProcessWithFileLogging
+  , readCreateProcessWithFileLogging
+  , createProcessWithFileLoggingAndStdin
+  , callCommandWithFileLogging
+  ) where
+
+import Control.Concurrent
+import Control.DeepSeq (rnf)
+import qualified Control.Exception as C
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Data.String.Interpolate
+import Foreign.C.Error
+import GHC.IO.Exception
+import GHC.Stack
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Process
+import Test.Sandwich.Contexts
+import Test.Sandwich.Expectations
+import Test.Sandwich.Types.RunTree
+import UnliftIO.Exception
+
+#if !MIN_VERSION_base(4,13,0)
+import Control.Monad.Fail
+#endif
+
+
+-- | Derive a short name from a 'CreateProcess' for use in log file names.
+-- For 'RawCommand', takes the base filename of the executable.
+-- For 'ShellCommand', takes the first word of the command string.
+processName :: CreateProcess -> String
+processName cp = case cmdspec cp of
+  RawCommand path _ -> takeFileName path
+  ShellCommand cmd -> case words cmd of
+    (w:_) -> takeFileName w
+    [] -> "shell"
+
+-- | Spawn a process with its stdout and stderr logged to files in the test tree.
+createProcessWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
+createProcessWithFileLogging cp = withFrozenCallStack $ do
+  let name = processName cp
+  getCurrentFolder >>= \case
+    Nothing -> expectationFailure [i|createProcessWithFileLogging: no current folder, so unable to log for '#{name}'.|]
+    Just dir ->
+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->
+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do
+        (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hOut, std_err = UseHandle hErr })
+        return p
+
+-- | Like 'readCreateProcess', but capture the stderr output to a file in the test tree.
+-- Returns the stdout output as a 'String'.
+readCreateProcessWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String
+readCreateProcessWithFileLogging cp input = withFrozenCallStack $ do
+  let name = processName cp
+  getCurrentFolder >>= \case
+    Nothing -> expectationFailure [i|readCreateProcessWithFileLogging: no current folder, so unable to log for '#{name}'.|]
+    Just dir ->
+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do
+        (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hErr }) $ \sin' sout _ p -> do
+          case (sin', sout) of
+            (Just hIn, Just hOut) -> do
+              output <- hGetContents hOut
+              withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
+                unless (Prelude.null input) $
+                  ignoreSigPipe $ hPutStr hIn input
+                ignoreSigPipe $ hClose hIn
+                waitOut
+                hClose hOut
+              ex <- waitForProcess p
+              return (ex, output)
+            (Nothing, _) -> throwIO $ userError "readCreateProcessWithFileLogging: Failed to get a stdin handle."
+            (_, Nothing) -> throwIO $ userError "readCreateProcessWithFileLogging: Failed to get a stdout handle."
+        case ex of
+          ExitSuccess -> return output
+          ExitFailure r -> liftIO $ throwIO $ userError [i|readCreateProcessWithFileLogging failed for '#{name}': exit code #{r}|]
+
+-- | Spawn a process with its stdout and stderr logged to files in the test tree,
+-- passing the given string as stdin.
+createProcessWithFileLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithFileLoggingAndStdin cp input = withFrozenCallStack $ do
+  let name = processName cp
+  getCurrentFolder >>= \case
+    Nothing -> expectationFailure [i|createProcessWithFileLoggingAndStdin: no current folder, so unable to log for '#{name}'.|]
+    Just dir ->
+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->
+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do
+        (Just inh, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hOut
+                                                           , std_err = UseHandle hErr
+                                                           , std_in = CreatePipe })
+        unless (Prelude.null input) $
+          liftIO $ ignoreSigPipe $ hPutStr inh input
+        liftIO $ ignoreSigPipe $ hClose inh
+        return p
+
+-- | Higher level version of 'createProcessWithFileLogging', accepting a shell command.
+callCommandWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()
+callCommandWithFileLogging cmd = withFrozenCallStack $ do
+  let name = processName (shell cmd)
+  getCurrentFolder >>= \case
+    Nothing -> expectationFailure [i|callCommandWithFileLogging: no current folder, so unable to log for '#{name}'.|]
+    Just dir ->
+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->
+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do
+        (_, _, _, p) <- liftIO $ createProcess (shell cmd) {
+          delegate_ctlc = True
+          , std_out = UseHandle hOut
+          , std_err = UseHandle hErr
+          }
+        liftIO (waitForProcess p) >>= \case
+          ExitSuccess -> return ()
+          ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithFileLogging failed for '#{cmd}': '#{r}'|]
+
+
+-- * Util
+
+-- Copied from System.Process
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait asy body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore asy) >>= putMVar waitVar
+    let wait = takeMVar waitVar >>= either throwIO return
+    restore (body wait) `C.onException` killThread tid
+
+-- Copied from System.Process
+ignoreSigPipe :: IO () -> IO ()
+ignoreSigPipe = C.handle $ \case
+  IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()
+  e -> throwIO e

From 03ef8e3b77d38a981cc16d0cdf764ab843f66410 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 18:48:36 -0800
Subject: [PATCH 34/41] Better cleaning up of process logging asyncs + fix some
 warnings

---
 sandwich/src/Test/Sandwich.hs                 |  6 +-
 .../Test/Sandwich/Formatters/Print/Logs.hs    |  1 +
 .../src/Test/Sandwich/Formatters/Socket.hs    |  3 +-
 .../Sandwich/Formatters/Socket/Commands.hs    |  2 +-
 .../Test/Sandwich/Formatters/TerminalUI.hs    |  4 +-
 sandwich/src/Test/Sandwich/Instrumentation.hs |  1 -
 .../src/Test/Sandwich/Internal/Running.hs     |  2 +-
 .../Sandwich/Interpreters/RunTree/Util.hs     |  3 -
 sandwich/src/Test/Sandwich/Logging/Process.hs | 92 ++++++++++---------
 .../Sandwich/Logging/ProcessFileLogging.hs    |  9 +-
 10 files changed, 63 insertions(+), 60 deletions(-)

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 1c448217..50f9f119 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -328,11 +328,11 @@ runSandwich' maybeCommandLineOptions options spec' = do
   -- Check for stale managed asyncs from this run
   milestone "checking for stale asyncs"
   allAsyncs <- getManagedAsyncInfos
-  let staleAsyncs = M.filter (\info -> asyncInfoRunId info == runId) allAsyncs
+  let staleAsyncs = M.filter (\x -> asyncInfoRunId x == runId) allAsyncs
   unless (M.null staleAsyncs) $ do
     putStrLn [i|WARNING: #{M.size staleAsyncs} managed asyncs still running after tree finished:|]
-    forM_ (M.toList staleAsyncs) $ \(tid, info) ->
-      putStrLn [i|  #{tid}: #{asyncInfoName info}|]
+    forM_ (M.toList staleAsyncs) $ \(tid, x) ->
+      putStrLn [i|  #{tid}: #{asyncInfoName x}|]
 
   -- Close late-log file handle
   mapM_ hClose maybeLateLogHandle
diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
index bb7f0877..b24892ba 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
@@ -21,6 +21,7 @@ import Control.Monad
 #endif
 
 
+-- TODO: bring this back
 -- printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
 -- printLogs runTreeLogs = do
 --   (asks (printFormatterLogLevel . fst3)) >>= \case
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket.hs b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
index c1453288..1da1b0de 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket.hs
@@ -20,7 +20,6 @@ module Test.Sandwich.Formatters.Socket (
 import Control.Concurrent.STM
 import Control.Monad.IO.Class
 import Data.IORef
-import Data.Typeable
 import System.FilePath
 import Test.Sandwich.Formatters.Socket.Server
 import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)
@@ -39,7 +38,7 @@ data SocketFormatter = SocketFormatter {
   -- ^ Broadcast channel for streaming logs to connected clients.
   , socketFormatterEventBroadcast :: TChan NodeEvent
   -- ^ Broadcast channel for streaming node lifecycle events to connected clients.
-  } deriving (Typeable)
+  }
 
 instance Show SocketFormatter where
   show (SocketFormatter {socketFormatterPath}) =
diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
index 26716177..f36607b4 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Commands.hs
@@ -110,7 +110,7 @@ cmdFailures rts = do
   where
     getFailureInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, FailureReason)
     getFailureInfo node = case runTreeStatus (runNodeCommon node) of
-      Done {statusResult = Failure reason@(Pending {})} -> Nothing
+      Done {statusResult = Failure (Pending {})} -> Nothing
       Done {statusResult = Failure reason} ->
         let c = runNodeCommon node
         in Just (runTreeLabel c, runTreeId c, reason)
diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
index a9debd19..8c945852 100644
--- a/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -54,8 +54,8 @@ import Lens.Micro
 import Safe
 import System.FilePath
 import Test.Sandwich.Formatters.TerminalUI.AttrMap
-import Test.Sandwich.Formatters.TerminalUI.DebugSocket
 import Test.Sandwich.Formatters.TerminalUI.CrossPlatform
+import Test.Sandwich.Formatters.TerminalUI.DebugSocket
 import Test.Sandwich.Formatters.TerminalUI.Draw
 import Test.Sandwich.Formatters.TerminalUI.Filter
 import Test.Sandwich.Formatters.TerminalUI.Keys
@@ -70,7 +70,7 @@ import Test.Sandwich.Types.ArgParsing
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import Test.Sandwich.Util
-import UnliftIO.Async (Async, cancel)
+import UnliftIO.Async (cancel)
 import UnliftIO.Exception
 
 
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index fe3ba436..e08028da 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -13,7 +13,6 @@ import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import qualified Data.Map.Strict as M
 import Data.String.Interpolate
-import qualified Data.Text as T
 import Data.Time
 import Data.Word
 import Debug.Trace (traceMarkerIO)
diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs
index 25414826..199b5635 100644
--- a/sandwich/src/Test/Sandwich/Internal/Running.hs
+++ b/sandwich/src/Test/Sandwich/Internal/Running.hs
@@ -61,7 +61,7 @@ runSandwichTree options spec = do
 
 -- | For 0 repeats, repeat until a failure
 runWithRepeat :: Int -> Int -> (Int -> IO (ExitReason, Int, Int)) -> IO ()
-runWithRepeat 0 totalTests action = go 0
+runWithRepeat 0 _totalTests action = go 0
   where
     go !idx = do
       (_, _itNodeFailures, totalFailures) <- action idx
diff --git a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
index 7dab7eb8..57df417e 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/RunTree/Util.hs
@@ -5,11 +5,8 @@ module Test.Sandwich.Interpreters.RunTree.Util where
 
 import Control.Concurrent.STM
 import Control.Monad.Free
-import Control.Monad.Logger
 import qualified Data.List as L
-import Data.Sequence as Seq hiding ((:>))
 import Data.String.Interpolate
-import Data.Time.Clock
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import Text.Printf
diff --git a/sandwich/src/Test/Sandwich/Logging/Process.hs b/sandwich/src/Test/Sandwich/Logging/Process.hs
index cc56b998..fcdf05be 100644
--- a/sandwich/src/Test/Sandwich/Logging/Process.hs
+++ b/sandwich/src/Test/Sandwich/Logging/Process.hs
@@ -29,10 +29,11 @@ import GHC.IO.Exception
 import GHC.Stack
 import System.IO
 import System.IO.Error (mkIOError)
-import System.Process
-import Test.Sandwich.Types.RunTree
 import Test.Sandwich.ManagedAsync
+import Test.Sandwich.Types.RunTree
+import UnliftIO.Async
 import UnliftIO.Exception
+import UnliftIO.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import Control.Monad.Fail
@@ -41,11 +42,11 @@ import Control.Monad.Fail
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
+createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m (ProcessHandle, Async ())
 createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m ProcessHandle
+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m (ProcessHandle, Async ())
 createProcessWithLogging' logLevel cp = do
   runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
@@ -54,12 +55,12 @@ createProcessWithLogging' logLevel cp = do
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- managedAsync runId "process-logging" $ forever $ do
+  streamsReaderAsy <- managedAsync runId "streams-reader" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
   (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })
-  return p
+  return (p, streamsReaderAsy)
 
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
 -- Every line output by the process will be fed to a 'debug' call.
@@ -76,32 +77,34 @@ readCreateProcessWithLogging' logLevel cp input = do
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- managedAsync runId "process-stderr-logging" $ forever $ do
-    line <- liftIO $ hGetLine hReadErr
-    logOtherCS callStack logLevel [i|#{name}: #{line}|]
-
-  -- Do this just like 'readCreateProcess'
-  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
-  (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p -> do
-    case (sin', sout) of
-      (Just hIn, Just hOut) -> do
-        output  <- hGetContents hOut
-        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
-          -- now write any input
-          unless (Prelude.null input) $
-            ignoreSigPipe $ hPutStr hIn input
-          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-          ignoreSigPipe $ hClose hIn
-
-          -- wait on the output
-          waitOut
-          hClose hOut
-
-        -- wait on the process
-        ex <- waitForProcess p
-        return (ex, output)
-      (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
-      (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
+  let stderrReader = forever $ do
+        line <- liftIO $ hGetLine hReadErr
+        logOtherCS callStack logLevel [i|#{name}: #{line}|]
+
+  (ex, output) <-
+    managedWithAsync_ runId "stderr-reader" stderrReader $
+    withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p ->
+      -- Do this just like 'readCreateProcess'
+      -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
+      case (sin', sout) of
+        (Just hIn, Just hOut) -> liftIO $ do
+          output  <- hGetContents hOut
+          withForkWait (C.evaluate $ rnf output) $ \waitOut -> do
+            -- now write any input
+            unless (Prelude.null input) $
+              ignoreSigPipe $ hPutStr hIn input
+            -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+            ignoreSigPipe $ hClose hIn
+
+            -- wait on the output
+            waitOut
+            hClose hOut
+
+          -- wait on the process
+          ex <- waitForProcess p
+          return (ex, output)
+        (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
+        (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
 
   case ex of
     ExitSuccess -> return output
@@ -118,11 +121,11 @@ readCreateProcessWithLogging' logLevel cp input = do
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 -- Every line output by the process will be fed to a 'debug' call.
-createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m (ProcessHandle, Async ())
 createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
 
 -- | Spawn a process with its stdout and stderr connected to the logging system.
-createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m (ProcessHandle, Async ())
 createProcessWithLoggingAndStdin' logLevel cp input = do
   runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
@@ -131,7 +134,7 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  _ <- managedAsync runId "process-logging-stdin" $ forever $ do
+  readAsy <- managedAsync runId "read-process-streams" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -146,7 +149,7 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
   -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
   liftIO $ ignoreSigPipe $ hClose inh
 
-  return p
+  return (p, readAsy)
 
 -- | Higher level version of 'createProcessWithLogging', accepting a shell command.
 callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()
@@ -164,13 +167,14 @@ callCommandWithLogging' logLevel cmd = do
     , std_err = UseHandle hWrite
     }
 
-  _ <- managedAsync runId "command-logging" $ forever $ do
-    line <- liftIO $ hGetLine hRead
-    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
+  let streamsReader = forever $ do
+        line <- liftIO $ hGetLine hRead
+        logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
 
-  liftIO (waitForProcess p) >>= \case
-    ExitSuccess -> return ()
-    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
+  managedWithAsync_ runId "stderr-reader" streamsReader $
+    liftIO (waitForProcess p) >>= \case
+      ExitSuccess -> return ()
+      ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
 
 
 -- * Util
@@ -181,8 +185,8 @@ withForkWait asy body = do
   waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
   mask $ \restore -> do
     tid <- forkIO $ try (restore asy) >>= putMVar waitVar
-    let wait = takeMVar waitVar >>= either throwIO return
-    restore (body wait) `C.onException` killThread tid
+    let wait' = takeMVar waitVar >>= either throwIO return
+    restore (body wait') `C.onException` killThread tid
 
 -- Copied from System.Process
 ignoreSigPipe :: IO () -> IO ()
diff --git a/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs b/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs
index de5fd15f..377dd5ca 100644
--- a/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs
+++ b/sandwich/src/Test/Sandwich/Logging/ProcessFileLogging.hs
@@ -20,7 +20,6 @@ import Data.String.Interpolate
 import Foreign.C.Error
 import GHC.IO.Exception
 import GHC.Stack
-import System.Exit
 import System.FilePath
 import System.IO
 import System.Process
@@ -45,7 +44,9 @@ processName cp = case cmdspec cp of
     [] -> "shell"
 
 -- | Spawn a process with its stdout and stderr logged to files in the test tree.
-createProcessWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m ProcessHandle
+createProcessWithFileLogging :: (
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
+  ) => CreateProcess -> m ProcessHandle
 createProcessWithFileLogging cp = withFrozenCallStack $ do
   let name = processName cp
   getCurrentFolder >>= \case
@@ -58,7 +59,9 @@ createProcessWithFileLogging cp = withFrozenCallStack $ do
 
 -- | Like 'readCreateProcess', but capture the stderr output to a file in the test tree.
 -- Returns the stdout output as a 'String'.
-readCreateProcessWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String
+readCreateProcessWithFileLogging :: (
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
+  ) => CreateProcess -> String -> m String
 readCreateProcessWithFileLogging cp input = withFrozenCallStack $ do
   let name = processName cp
   getCurrentFolder >>= \case

From f2009035835e2697787e1d04e04801dddf20d1d3 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Wed, 4 Mar 2026 19:12:46 -0800
Subject: [PATCH 35/41] Clean up process asyncs + mostly use file logging for
 K8S stuff

---
 .../Test/Sandwich/Contexts/Docker/Registry.hs | 25 ++++++----
 .../Kubernetes/KataContainers/HelmChart.hs    |  2 +-
 .../Contexts/Kubernetes/KindCluster.hs        | 21 ++++----
 .../Contexts/Kubernetes/KindCluster/Images.hs |  6 +--
 .../KindCluster/ServiceForwardIngress.hs      | 11 +++--
 .../Contexts/Kubernetes/KindCluster/Setup.hs  |  2 +-
 .../Sandwich/Contexts/Kubernetes/Longhorn.hs  |  2 +-
 .../Kubernetes/MinikubeCluster/Images.hs      |  6 +--
 .../Contexts/Kubernetes/MinioOperator.hs      | 12 +++--
 .../Contexts/Kubernetes/MinioS3Server.hs      | 36 +++++++-------
 .../Sandwich/Contexts/Kubernetes/Namespace.hs |  4 +-
 .../Sandwich/Contexts/Kubernetes/SeaweedFS.hs |  4 +-
 .../Sandwich/Contexts/Kubernetes/Typesense.hs |  8 ++--
 .../Contexts/Kubernetes/Util/Images.hs        |  4 +-
 .../Sandwich/Contexts/Kubernetes/Waits.hs     | 24 +++++-----
 .../lib/Test/Sandwich/Contexts/MinIO.hs       |  4 +-
 .../Test/Sandwich/Contexts/FakeSmtpServer.hs  |  6 ++-
 .../lib/Test/Sandwich/Contexts/PostgreSQL.hs  | 48 +++++++++++--------
 .../WebDriver/Internal/Binaries/Common.hs     | 36 ++++++++------
 .../WebDriver/Internal/StartWebDriver.hs      |  6 +--
 .../src/Test/Sandwich/WebDriver/Video.hs      |  9 ++--
 .../src/Test/Sandwich/WebDriver/Windows.hs    |  2 +-
 .../WebDriver/Internal/StartWebDriver/Xvfb.hs |  2 +-
 23 files changed, 156 insertions(+), 124 deletions(-)

diff --git a/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs b/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
index f43d40b5..51af3aae 100644
--- a/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
+++ b/sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs
@@ -32,6 +32,7 @@ import qualified System.Random as R
 import Test.Sandwich
 import Test.Sandwich.Contexts.Docker (createNetwork, doesNetworkExist, getDockerState)
 import Test.Sandwich.Contexts.Docker.Container (isInContainer)
+import UnliftIO.Async
 import UnliftIO.Exception
 import UnliftIO.Process
 
@@ -89,12 +90,14 @@ withNewDockerRegistry action = do
                   Right _ -> return ()
                   Left err -> warn [i|Creating Docker network "kind" failed: '#{err}'|]
 
-              ps <- createProcessWithLogging (proc "docker" ["run", "-d", "--restart=always"
-                                                            , "-p", [i|5000|]
-                                                            ,  "--name", containerName
-                                                            ,  "--net=kind"
-                                                            , "registry:2"])
-              waitForProcess ps
+              (ps, asy) <- createProcessWithLogging (
+                proc "docker" ["run", "-d", "--restart=always"
+                              , "-p", [i|5000|]
+                                  ,  "--name", containerName
+                                  ,  "--net=kind"
+                                  , "registry:2"]
+                )
+              finally (waitForProcess ps) (cancel asy)
           )
           (\_ -> do
               info [i|Deleting registry '#{containerName}'|]
@@ -138,12 +141,14 @@ pushContainerToRegistry imageName (DockerRegistryContext {..}) = do
       -- We need to push to our local registry, but we'll get an insecure Docker registry error unless
       -- we're pushing to localhost. To accomplish this, we'll launch a new Docker container with host networking
       -- to do the push
-      ps <- createProcessWithLogging (shell [i|docker run --rm --network host -v /var/run/docker.sock:/var/run/docker.sock docker:stable docker push #{pushedName}|])
-      void $ liftIO $ waitForProcess ps
+      (ps, asy) <- createProcessWithLogging (shell [i|docker run --rm --network host -v /var/run/docker.sock:/var/run/docker.sock docker:stable docker push #{pushedName}|])
+      finally (void $ liftIO $ waitForProcess ps)
+              (cancel asy)
 
     False -> do
-      ps <- createProcessWithLogging (shell [i|docker push #{pushedName}|])
-      void $ liftIO $ waitForProcess ps
+      (ps, asy) <- createProcessWithLogging (shell [i|docker push #{pushedName}|])
+      finally (void $ liftIO $ waitForProcess ps)
+              (cancel asy)
 
   debug [i|finished pushing.|]
 
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
index b8c95754..16a1cf9b 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KataContainers/HelmChart.hs
@@ -54,7 +54,7 @@ withKataContainers' helmBinary kcc options@(KataContainersOptions {..}) action =
 
   env <- getKubectlEnvironment kcc
 
-  createProcessWithLogging ((proc helmBinary args) { env = Just env })
+  createProcessWithFileLogging ((proc helmBinary args) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   action (KataContainersContext options)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
index 644d579e..30445123 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs
@@ -216,9 +216,10 @@ withKindCluster' kindBinary kubectlBinary opts@(KindClusterOptions {..}) action
 
   (bracket (startKindCluster kindBinary opts clusterName kindConfigFile kindKubeConfigFile environmentToUse driver)
            (\_ -> do
-               ps <- createProcessWithLogging ((proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {
-                                                  env = environmentToUse
-                                                  })
+               ps <- createProcessWithFileLogging (
+                 (proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {
+                     env = environmentToUse
+                     })
                void $ waitForProcess ps
            ))
            (\kcc -> bracket_ (setUpKindCluster kcc kindBinary kubectlBinary environmentToUse driver)
@@ -230,12 +231,14 @@ startKindCluster :: (
   MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => FilePath -> KindClusterOptions -> Text -> FilePath -> FilePath -> Maybe [(String, String)] -> Text -> m KubernetesClusterContext
 startKindCluster kindBinary (KindClusterOptions {..}) clusterName kindConfigFile kindKubeConfigFile environmentToUse driver = do
-  ps <- createProcessWithLogging ((proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName
-                                                   , "--config", kindConfigFile
-                                                   , "--kubeconfig", kindKubeConfigFile]) {
-                                     delegate_ctlc = True
-                                     , env = environmentToUse
-                                     })
+  ps <- createProcessWithFileLogging (
+    (proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName
+                     , "--config", kindConfigFile
+                     , "--kubeconfig", kindKubeConfigFile]) {
+        delegate_ctlc = True
+        , env = environmentToUse
+        }
+    )
   void $ waitForProcess ps
 
   whenM isInContainer $
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
index 3bf5c3a5..fdea9a20 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs
@@ -63,7 +63,7 @@ loadImageKind kindBinary clusterName imageLoadSpec env = do
             withSystemTempDirectory "image-tarball" $ \tempDir -> do
               let tarFile = tempDir </> "image.tar"
               -- TODO: don't depend on external gzip binary
-              createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
+              createProcessWithFileLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
                 >>= waitForProcess >>= (`shouldBe` ExitSuccess)
               imageLoad tarFile
               readImageName (toString image)
@@ -72,7 +72,7 @@ loadImageKind kindBinary clusterName imageLoadSpec env = do
     ImageLoadSpecDocker image pullPolicy -> do
       _ <- dockerPullIfNecessary image pullPolicy
 
-      createProcessWithLogging (
+      createProcessWithFileLogging (
         (shell [i|#{kindBinary} load docker-image #{image} --name #{clusterName}|]) {
             env = env
             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
@@ -86,7 +86,7 @@ loadImageKind kindBinary clusterName imageLoadSpec env = do
       return image
   where
     imageLoad tarFile =
-      createProcessWithLogging (
+      createProcessWithFileLogging (
         (shell [i|#{kindBinary} load image-archive #{tarFile} --name #{clusterName}|]) {
             env = env
             }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
index bc828c21..326b92d6 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardIngress.hs
@@ -46,11 +46,12 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
     let configFile = dir </> "ingress.yaml"
     liftIO $ T.writeFile configFile (ingressConfig service randomHost)
 
-    createProcessWithLogging ((proc kubectlBinary ["create"
-                                                  , "--namespace", toString namespace
-                                                  , "-f", configFile]) {
-                                 env = Just env
-                                 }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+    createProcessWithFileLogging (
+      (proc kubectlBinary ["create"
+                          , "--namespace", toString namespace
+                          , "-f", configFile]) {
+          env = Just env
+          }) >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   -- TODO: wait for ingress to be ready?
   -- Possibly not necessary since the server context waits for 200 after this
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
index 6938f4a2..7fbbf79d 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Setup.hs
@@ -30,7 +30,7 @@ setUpKindCluster :: (
 setUpKindCluster kcc@(KubernetesClusterContext {..}) kindBinary kubectlBinary environmentToUse driver = do
   baseEnv <- maybe getEnvironment return environmentToUse
   let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
-  let runWithKubeConfig cmd = createProcessWithLogging ((shell cmd) { env = Just env, delegate_ctlc = True })
+  let runWithKubeConfig cmd = createProcessWithFileLogging ((shell cmd) { env = Just env, delegate_ctlc = True })
 
   info [i|Installing ingress-nginx|]
   runWithKubeConfig [i|#{kubectlBinary} apply -f https://raw.githubusercontent.com/kubernetes/ingress-nginx/main/deploy/static/provider/kind/deploy.yaml|]
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
index f3700a05..516f3106 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Longhorn.hs
@@ -78,7 +78,7 @@ withLonghorn' (KubernetesClusterContext {kubernetesClusterKubeConfigPath}) kubec
   baseEnv <- getEnvironment
   let env = L.nubBy (\x y -> fst x == fst y) (("KUBECONFIG", kubernetesClusterKubeConfigPath) : baseEnv)
 
-  createProcessWithLogging ((proc kubectlBinary ["apply", "-f", longhornYaml]) { env = Just env })
+  createProcessWithFileLogging ((proc kubectlBinary ["apply", "-f", longhornYaml]) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   action $ LonghornContext options
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
index 0f214396..6bcd019c 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs
@@ -57,7 +57,7 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
           withSystemTempDirectory "image-tarball" $ \tempDir -> do
             let tarFile = tempDir </> "image.tar"
             -- TODO: don't depend on external tar file
-            createProcessWithLogging (shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])
+            createProcessWithFileLogging (shell [i|tar -C "#{image}" --dereference --hard-dereference --xform s:'^./':: -c . > "#{tarFile}"|])
               >>= waitForProcess >>= (`shouldBe` ExitSuccess)
             imageLoad tarFile False
             readImageName (toString image)
@@ -69,7 +69,7 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
             withSystemTempDirectory "image-tarball" $ \tempDir -> do
               let tarFile = tempDir </> "image.tar"
               -- TODO: don't depend on external gzip file
-              createProcessWithLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
+              createProcessWithFileLogging (shell [i|cat "#{image}" | gzip -d > "#{tarFile}"|])
                 >>= waitForProcess >>= (`shouldBe` ExitSuccess)
               imageLoad tarFile False
               readImageName (toString image)
@@ -107,7 +107,7 @@ loadImageMinikube minikubeBinary clusterName minikubeFlags imageLoadSpec = do
             logFn loc src level str
 
       liftIO $ flip runLoggingT customLogFn $ flip runReaderT ctx $
-        createProcessWithLogging (proc minikubeBinary args)
+        createProcessWithFileLogging (proc minikubeBinary args)
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
       stderrOutput <- fromLogStr <$> readIORef stderrOutputVar
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs
index e7ef3572..63d8cf63 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioOperator.hs
@@ -197,7 +197,7 @@ withMinioOperator'' kubectlBinary kcc preloadImages allYaml action = do
     forM_ images $ \image ->
       loadImageIfNecessary' kcc (ImageLoadSpecDocker image IfNotPresent)
 
-  let create = createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString allYaml)
+  let create = createProcessWithFileLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString allYaml)
                  >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   let namespaceToDestroy = fromMaybe "minio-operator" (findNamespace (toText allYaml))
@@ -209,10 +209,12 @@ withMinioOperator'' kubectlBinary kcc preloadImages allYaml action = do
         -- gets deleted first and then subsequent deletes encounter missing objects.
         -- If this doesn't work, we can fall back to just deleting the namespace below.
         -- But I think this will be better because it should pick up CRDs?
-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["delete", "-f", "-"
-                                                              , "--ignore-not-found", "--wait=false", "--all=true"
-                                                              ]) {
-                                             env = Just env, delegate_ctlc = True }) (toString allYaml)
+        createProcessWithFileLoggingAndStdin (
+          (proc kubectlBinary ["delete", "-f", "-"
+                              , "--ignore-not-found", "--wait=false", "--all=true"
+                              ]) {
+              env = Just env, delegate_ctlc = True
+              }) (toString allYaml)
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
         -- createProcessWithLogging ((proc kubectlBinary ["delete", "namespace", toString namespaceToDestroy, "-f"]) {
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs
index 24d1809b..e15a0333 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs
@@ -142,7 +142,7 @@ withK8SMinioS3Server' kubectlBinary kcc@(KubernetesClusterContext {..}) MinioOpe
   env <- getKubectlEnvironment kcc
   let runWithKubeConfig :: (HasCallStack) => String -> [String] -> m ()
       runWithKubeConfig prog args = do
-        createProcessWithLogging ((proc prog args) { env = Just env, delegate_ctlc = True })
+        createProcessWithFileLogging ((proc prog args) { env = Just env, delegate_ctlc = True })
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   deploymentName <- ("minio-" <>) <$> makeUUID' 5
@@ -179,21 +179,21 @@ withK8SMinioS3Server' kubectlBinary kcc@(KubernetesClusterContext {..}) MinioOpe
 
         info [i|Got username and password: #{(username, password)}|]
 
-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)
+        createProcessWithFileLoggingAndStdin ((proc kubectlBinary ["apply", "-f", "-"]) { env = Just env }) (toString finalYaml)
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
         return (userAndPassword, finalYaml)
 
   let destroy (_, finalYaml) = do
         info [i|-------------------------- DESTROYING --------------------------|]
-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["delete", "-f", "-"]) { env = Just env }) (toString finalYaml)
+        createProcessWithFileLoggingAndStdin ((proc kubectlBinary ["delete", "-f", "-"]) { env = Just env }) (toString finalYaml)
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
 
   -- Create network policy allowing ingress/egress for v1.min.io/tenant = deploymentName
   let createNetworkPolicy = do
         let NetworkPolicies policyNames yaml = fromMaybe (defaultNetworkPolicies deploymentName) minioS3ServerNetworkPolicies
-        createProcessWithLoggingAndStdin ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml
+        createProcessWithFileLoggingAndStdin ((proc kubectlBinary ["create", "--namespace", toString minioS3ServerNamespace, "-f", "-"]) { env = Just env, delegate_ctlc = True }) yaml
           >>= waitForProcess >>= (`shouldBe` ExitSuccess)
         pure policyNames
   let destroyNetworkPolicy policyNames = do
@@ -203,19 +203,21 @@ withK8SMinioS3Server' kubectlBinary kcc@(KubernetesClusterContext {..}) MinioOpe
   bracket createNetworkPolicy destroyNetworkPolicy $ \_ -> bracket create destroy $ \((username, password), _) -> do
     do
       uuid <- makeUUID
-      p <- createProcessWithLogging ((proc kubectlBinary [
-                                         "run", "discoverer-" <> toString uuid
-                                         , "--rm", "-i"
-                                         , "--attach"
-                                         , [i|--image=#{busyboxImage}|]
-                                         , "--image-pull-policy=IfNotPresent"
-                                         , "--restart=Never"
-                                         , "--command"
-                                         , "--namespace", toString minioS3ServerNamespace
-                                         , "--labels=app=discover-pod"
-                                         , "--"
-                                         , "sh", "-c", [i|until nc -vz minio 80; do echo "Waiting for minio..."; sleep 3; done;|]
-                                         ]) { env = Just env })
+      p <- createProcessWithFileLogging (
+        (proc kubectlBinary [
+            "run", "discoverer-" <> toString uuid
+            , "--rm", "-i"
+            , "--attach"
+            , [i|--image=#{busyboxImage}|]
+            , "--image-pull-policy=IfNotPresent"
+            , "--restart=Never"
+            , "--command"
+            , "--namespace", toString minioS3ServerNamespace
+            , "--labels=app=discover-pod"
+            , "--"
+            , "sh", "-c", [i|until nc -vz minio 80; do echo "Waiting for minio..."; sleep 3; done;|]
+            ]) { env = Just env }
+        )
       timeout 300_000_000 (waitForProcess p >>= (`shouldBe` ExitSuccess)) >>= \case
         Just () -> return ()
         Nothing -> expectationFailure [i|Failed to wait for minio to come online.|]
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs
index 439a7f57..5b9bde06 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Namespace.hs
@@ -151,7 +151,7 @@ createKubernetesNamespace'' :: (
 createKubernetesNamespace'' kcc kubectl namespace = do
   let args = ["create", "namespace", toString namespace]
   env <- getKubectlEnvironment kcc
-  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })
+  createProcessWithFileLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
 -- | Destroy a Kubernetes namespace.
@@ -171,5 +171,5 @@ destroyKubernetesNamespace'' kcc kubectl force namespace = do
   let args = ["delete", "namespace", toString namespace]
            <> if force then ["--force"] else []
   env <- getKubectlEnvironment kcc
-  createProcessWithLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })
+  createProcessWithFileLogging ((proc kubectl args) { env = Just env, delegate_ctlc = True })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs
index 7744c345..7c5778a0 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs
@@ -166,7 +166,7 @@ withSeaweedFS' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath})
     _ <- readCreateProcess (proc "cp" ["-r", toString operatorPath, target]) ""
     _ <- readCreateProcess (proc "chmod" ["-R", "u+w", target]) ""
 
-    let runOperatorCmd cmd extraEnv = createProcessWithLogging (
+    let runOperatorCmd cmd extraEnv = createProcessWithFileLogging (
           (shell cmd) {
               env = Just (env <> extraEnv)
               , cwd = Just target
@@ -193,7 +193,7 @@ withSeaweedFS' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath})
     info [i|------------------ Creating SeaweedFS deployment ------------------|]
 
     let val = decodeUtf8 $ A.encode $ example namespace options
-    createProcessWithLoggingAndStdin ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val
+    createProcessWithFileLoggingAndStdin ((shell [i|#{kubectlBinary} create -f -|]) { env = Just env }) val
       >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
     action $ SeaweedFSContext {
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
index 970af8fb..a88ab051 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Typesense.hs
@@ -143,12 +143,12 @@ withTypesense' kcc _kubectlBinary namespace options@(TypesenseOptions {..}) acti
 
   -- Add the Helm repository
   info [i|Adding Typesense Helm repository...|]
-  createProcessWithLogging ((proc helmBinary [
+  createProcessWithFileLogging ((proc helmBinary [
     "repo", "add", "springboard", "https://helm-charts.springboardvr.com"
     ]) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
-  createProcessWithLogging ((proc helmBinary ["repo", "update"]) { env = Just env })
+  createProcessWithFileLogging ((proc helmBinary ["repo", "update"]) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   -- Install Typesense via Helm
@@ -170,7 +170,7 @@ withTypesense' kcc _kubectlBinary namespace options@(TypesenseOptions {..}) acti
 
   info [i|helm #{T.intercalate " " (fmap toText helmArgs)}|]
 
-  createProcessWithLogging ((proc helmBinary helmArgs) { env = Just env })
+  createProcessWithFileLogging ((proc helmBinary helmArgs) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   let serviceName = typesenseReleaseName
@@ -187,7 +187,7 @@ withTypesense' kcc _kubectlBinary namespace options@(TypesenseOptions {..}) acti
 cleanupTypesense :: (MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m) => FilePath -> [(String, String)] -> Text -> Text -> m ()
 cleanupTypesense helmBinary env namespace releaseName = do
   info [i|Cleaning up Typesense release '#{releaseName}' in namespace '#{namespace}'...|]
-  createProcessWithLogging ((proc helmBinary [
+  createProcessWithFileLogging ((proc helmBinary [
     "uninstall", toString releaseName
     , "--namespace", toString namespace
     ]) { env = Just env })
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
index c16327bc..8781fdc2 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Util/Images.hs
@@ -66,13 +66,13 @@ commonPullIfNecessary binary image pullPolicy = isImagePresentCommon binary imag
        | otherwise -> doPull
   where
     doPull = do
-      createProcessWithLogging (proc binary ["pull", toString image])
+      createProcessWithFileLogging (proc binary ["pull", toString image])
         >>= waitForProcess >>= (`shouldBe` ExitSuccess)
       return True
 
 isImagePresentCommon :: (MonadUnliftIO m, MonadLoggerIO m, HasBaseContextMonad context m) => String -> Text -> m Bool
 isImagePresentCommon binary image = do
-  createProcessWithLogging (proc binary ["inspect", "--type=image", toString image]) >>= waitForProcess >>= \case
+  createProcessWithFileLogging (proc binary ["inspect", "--type=image", toString image]) >>= waitForProcess >>= \case
     ExitSuccess -> return True
     ExitFailure _ -> return False
 
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
index f7e85800..88625776 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Waits.hs
@@ -123,17 +123,19 @@ waitForPodsToBeReady namespace labels timeInSeconds = do
   kubeConfigFile <- kubernetesClusterKubeConfigPath <$> getContext kubernetesCluster
 
   let labelArgs = [[i|-l #{k}=#{v}|] | (k, v) <- M.toList labels]
-  p <- createProcessWithLogging (proc kubectlBinary (
-                                  ["wait", "pods"
-                                  , "--kubeconfig", kubeConfigFile
-                                  , "-n", toString namespace
-                                  ]
-                                  <> labelArgs
-                                  <> [
-                                    "--for", "condition=Ready"
-                                    , "--timeout=" <> show timeInSeconds <> "s"
-                                    ]
-                                ))
+  p <- createProcessWithFileLogging (
+    proc kubectlBinary (
+        ["wait", "pods"
+        , "--kubeconfig", kubeConfigFile
+        , "-n", toString namespace
+        ]
+        <> labelArgs
+        <> [
+            "--for", "condition=Ready"
+           , "--timeout=" <> show timeInSeconds <> "s"
+           ]
+        )
+    )
   waitForProcess p >>= \case
     ExitSuccess -> return ()
     ExitFailure n -> expectationFailure [i|Failed to wait for pods to exist (code #{n})|]
diff --git a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
index 2a263132..21d3201d 100644
--- a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
+++ b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
@@ -287,9 +287,9 @@ withMinIOViaContainer (MinIOContextOptions {..}) (ContainerOptions {..}) action
 
               info [i|Got command: #{cp}"|]
 
-              createProcessWithLogging cp
+              createProcessWithFileLogging cp
           )
-          (\_ -> do
+          (\_ ->
               void $ liftIO $ readCreateProcess (shell [i|#{containerOptionsSystem} rm -f --volumes #{containerName}|]) ""
           )
           (\p -> do
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs
index f3392379..5e098e6e 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs
@@ -54,6 +54,7 @@ import Test.Sandwich.Contexts.Files
 import Test.Sandwich.Contexts.HttpWaits
 import Test.Sandwich.Contexts.Nix
 import Test.Sandwich.Contexts.Util.Aeson
+import UnliftIO.Async
 import UnliftIO.Directory
 import UnliftIO.Exception
 
@@ -178,8 +179,9 @@ withFakeSMTPServer (FakeSmtpServerOptions {..}) action = do
                                            create_group = True
                                            })
           )
-          (\p -> do
-              void $ liftIO (interruptProcessGroupOf p >> waitForProcess p)
+          (\(p, asy) -> do
+              finally (void $ liftIO (interruptProcessGroupOf p >> waitForProcess p))
+                      (cancel asy)
           )
           (\_ -> do
               let hostname = "localhost"
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs
index ffcf33a9..afdb1c30 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/PostgreSQL.hs
@@ -69,6 +69,7 @@ import Test.Sandwich.Contexts.ReverseProxy.TCP
 import Test.Sandwich.Contexts.Types.Network
 import Test.Sandwich.Contexts.UnixSocketPath
 import Test.Sandwich.Contexts.Util.UUID (makeUUID)
+import UnliftIO.Async
 import UnliftIO.Directory
 import UnliftIO.Environment
 import UnliftIO.Exception
@@ -261,15 +262,17 @@ withPostgresUnixSocket postgresBinDir username password database extraLines acti
         withTempFile baseDir "pwfile" $ \pwfile h -> do
           liftIO $ T.hPutStrLn h password
           hClose h
-          createProcessWithLogging ((proc (postgresBinDir </> "initdb") [dbDirName
-                                                                          , "--username", toString username
-                                                                          , "-A", "md5"
-                                                                          , "--pwfile", pwfile
-                                                                          ]) {
-                                       cwd = Just dir
-                                       , env = Just env
-                                       })
-            >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+          (ps, asy) <- createProcessWithLogging (
+            (proc (postgresBinDir </> "initdb") [dbDirName
+                                                , "--username", toString username
+                                                , "-A", "md5"
+                                                , "--pwfile", pwfile
+                                                ]) {
+                cwd = Just dir
+                , env = Just env
+                })
+          finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                  (cancel asy)
 
         -- Turn off the TCP interface; we'll have it listen solely on a Unix socket
         withFile (dir </> dbDirName </> "postgresql.conf") AppendMode $ \h -> liftIO $ do
@@ -287,7 +290,8 @@ withPostgresUnixSocket postgresBinDir username password database extraLines acti
                                       , "-o", [i|--unix_socket_directories='#{unixSockDir}'|]
                                       , "start" , "--wait"
                                       ]) { cwd = Just dir })
-          >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+          >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                    (cancel asy)
 
         -- Create the default db
         createProcessWithLogging ((proc (postgresBinDir </> "psql") [
@@ -296,7 +300,8 @@ withPostgresUnixSocket postgresBinDir username password database extraLines acti
                                       [i|postgresql://#{username}:#{password}@/?host=#{unixSockDir}|]
                                       , "-c", [i|CREATE DATABASE #{database};|]
                                       ]) { cwd = Just dir })
-          >>= waitForProcess >>= (`shouldBe` ExitSuccess)
+          >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                    (cancel asy)
 
 
         files <- listDirectory unixSockDir
@@ -356,17 +361,18 @@ withPostgresContainer :: (
   -> m a
 withPostgresContainer options action = do
   bracket (createPostgresDatabase options)
-          (\(containerName, _p) -> timeAction "cleanup Postgres database" $ do
-              info [i|Doing #{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]
-              (exitCode, sout, serr) <-  liftIO $ readCreateProcessWithExitCode (shell [i|#{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]) ""
-              when (exitCode /= ExitSuccess) $
-                expectationFailure [i|Failed to destroy Postgres container. Stdout: '#{sout}'. Stderr: '#{serr}'|]
+          (\(containerName, _p, asy) -> timeAction "cleanup Postgres database" $ do
+              flip finally (cancel asy) $ do
+                info [i|Doing #{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]
+                (exitCode, sout, serr) <-  liftIO $ readCreateProcessWithExitCode (shell [i|#{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]) ""
+                when (exitCode /= ExitSuccess) $
+                  expectationFailure [i|Failed to destroy Postgres container. Stdout: '#{sout}'. Stderr: '#{serr}'|]
           )
           (waitForPostgresDatabase options >=> action)
 
 createPostgresDatabase :: (
   HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
-  ) => PostgresContainerOptions -> m (Text, ProcessHandle)
+  ) => PostgresContainerOptions -> m (Text, ProcessHandle, Async ())
 createPostgresDatabase (PostgresContainerOptions {..}) = timeAction "create Postgres database" $ do
   containerName <- maybe (("postgres-" <>) <$> makeUUID) return postgresContainerContainerName
 
@@ -386,13 +392,13 @@ createPostgresDatabase (PostgresContainerOptions {..}) = timeAction "create Post
 
   info [i|cmd: #{containerSystem} #{T.unwords args}|]
 
-  p <- createProcessWithLogging (proc (show containerSystem) (fmap toString args))
-  return (containerName, p)
+  (p, asy) <- createProcessWithLogging (proc (show containerSystem) (fmap toString args))
+  return (containerName, p, asy)
 
 waitForPostgresDatabase :: (
   MonadUnliftIO m, MonadLoggerIO m, MonadMask m
-  ) => PostgresContainerOptions -> (Text, ProcessHandle) -> m PostgresContext
-waitForPostgresDatabase (PostgresContainerOptions {..}) (containerName, p) = do
+  ) => PostgresContainerOptions -> (Text, ProcessHandle, Async ()) -> m PostgresContext
+waitForPostgresDatabase (PostgresContainerOptions {..}) (containerName, p, _) = do
   containerID <- waitForProcess p >>= \case
     ExitSuccess -> containerNameToContainerId postgresContainerContainerSystem containerName
     _ -> expectationFailure [i|Failed to start Postgres container.|]
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
index 73c94b1c..e75fb3bf 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs
@@ -1,59 +1,65 @@
 
 module Test.Sandwich.WebDriver.Internal.Binaries.Common where
 
-import Control.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Data.String.Interpolate
 import qualified Data.Text as T
-import System.Directory
 import System.Exit
 import System.FilePath
-import System.Process
 import Test.Sandwich.Expectations
 import Test.Sandwich.Logging
 import Test.Sandwich.Misc (HasBaseContextMonad)
 import Test.Sandwich.WebDriver.Internal.Util
+import UnliftIO.Async
+import UnliftIO.Directory
+import UnliftIO.Exception
+import UnliftIO.Process
 import UnliftIO.Temporary
 
 
 downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
+  createDirectoryIfMissing True (takeDirectory localPath)
   withSystemTempDirectory "sandwich-webdriver-tool-download" $ \dir -> do
     curlDownloadToPath (T.unpack downloadPath) (dir </> "temp.zip")
 
     createProcessWithLogging ((proc "unzip" ["temp.zip", "-d", "unzipped"]) { cwd = Just dir })
-      >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+      >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                (cancel asy)
     let unzipped = dir </> "unzipped"
 
     executables <- (filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (proc "find" [unzipped, "-executable", "-type", "f"]) ""
     case executables of
-      [] -> liftIO $ throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]
+      [] -> throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]
       [x] -> do
-        liftIO $ copyFile (T.unpack x) localPath
+        copyFile (T.unpack x) localPath
         createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
-          >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
-      xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
+          >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                                    (cancel asy)
+      xs -> throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
 
 downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ())
 downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
+  createDirectoryIfMissing True (takeDirectory localPath)
   createProcessWithLogging (shell [i|wget -qO- #{downloadPath} | tar xvz  -C #{takeDirectory localPath}|])
-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+    >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                              (cancel asy)
   createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
+    >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess))
+                              (cancel asy)
 
 curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> FilePath -> m ()
 curlDownloadToPath downloadPath localPath = do
   info [i|Downloading #{downloadPath} to #{localPath}|]
-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
-  p <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])
-  liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
+  createDirectoryIfMissing True (takeDirectory localPath)
+  (p, asy) <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])
+  finally (liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess))
+          (cancel asy)
 
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM b s = b >>= (\t -> unless t s)
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs
index 2c3b3592..e1f1fb77 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs
@@ -17,9 +17,9 @@ import GHC.Stack
 import Test.Sandwich.WebDriver.Internal.Types
 import qualified Test.WebDriver as W
 
-#ifndef mingw32_HOST_OS
-import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
-#endif
+-- #ifndef mingw32_HOST_OS
+-- import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
+-- #endif
 
 
 type Constraints m = (
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
index 79370a57..35ff3f63 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
@@ -48,6 +48,7 @@ import Test.Sandwich.WebDriver.Video.Internal
 import Test.Sandwich.WebDriver.Video.Types
 import Test.Sandwich.WebDriver.Windows
 import Test.WebDriver
+import UnliftIO.Async
 import UnliftIO.Directory
 import UnliftIO.Exception
 
@@ -61,6 +62,7 @@ type BaseVideoConstraints context m = (
 data VideoProcess = VideoProcess {
   -- | The process handle
   videoProcessProcess :: ProcessHandle
+  , videoProcessAsync :: Async ()
   , videoProcessCreatedFiles :: [FilePath]
   }
 -- defaultVideoProcess :: ProcessHandle -> VideoProcess
@@ -122,15 +124,16 @@ startVideoRecording path (width, height, x, y) vs = do
 
   case logToDisk vs of
     False -> do
-      p <- createProcessWithLogging cp
-      return $ VideoProcess p [videoPath]
+      (p, asy) <- createProcessWithLogging cp
+      return $ VideoProcess p asy [videoPath]
     True -> do
       let stdoutPath = path <.> "stdout" <.> "log"
       let stderrPath = path <.> "stderr" <.> "log"
       liftIO $ bracket (openFile stdoutPath AppendMode) hClose $ \hout ->
         bracket (openFile stderrPath AppendMode) hClose $ \herr -> do
           (_, _, _, p) <- createProcess (cp { std_out = UseHandle hout, std_err = UseHandle herr })
-          return $ VideoProcess p [videoPath, stdoutPath, stderrPath]
+          asy <- async $ return ()
+          return $ VideoProcess p asy [videoPath, stdoutPath, stderrPath]
 
 -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
 endVideoRecording :: (
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs
index 262865fb..ee05ac9e 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs
@@ -69,7 +69,7 @@ getScreenResolution :: (MonadIO m) => TestWebDriverContext -> m (Int, Int, Int,
 -- getScreenResolution (TestWebDriverContext {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of
 --   Nothing -> liftIO getResolution
 --   Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum
-getScreenResolution twdc = liftIO getResolution
+getScreenResolution _twdc = liftIO getResolution
 
 getScreenPixelDimensions :: (WebDriver m) => Int -> Int -> m (Double, Double)
 getScreenPixelDimensions width height = do
diff --git a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs b/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs
index 71f12b62..50b92d8c 100644
--- a/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs
+++ b/sandwich-webdriver/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs
@@ -101,7 +101,7 @@ createXvfbSession webdriverRoot w h (Fd fd) xvfbToUse xvfbOnDemand = do
 
   -- Start the Xvfb session
   authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" ""
-  p <- createProcessWithLogging $ (
+  p <- createProcessWithFileLogging $ (
     proc xvfb [":" <> show serverNum
               , "-screen", "0", [i|#{w}x#{h}x24|]
               , "-displayfd", [i|#{fd}|]

From 29266ae0f1023277e5a73fbeb7a438801a98c5f1 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 5 Mar 2026 01:11:50 -0800
Subject: [PATCH 36/41] Update demo-processes

---
 demos/demo-processes/app/Main.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/demos/demo-processes/app/Main.hs b/demos/demo-processes/app/Main.hs
index 81080c2f..e0d17a9f 100644
--- a/demos/demo-processes/app/Main.hs
+++ b/demos/demo-processes/app/Main.hs
@@ -17,19 +17,19 @@ import Test.Sandwich
 parallelNDemo :: TopSpec
 parallelNDemo = describe "Creating processes with logging" $ do
   it "createProcessWithLogging" $ do
-    p <- createProcessWithLogging (shell "echo hiiiiii")
+    (p, _) <- createProcessWithLogging (shell "echo hiiiiii")
     liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
 
   it "createProcessWithLogging'" $ do
-    p <- createProcessWithLogging' LevelDebug (shell "echo hiiiiii")
+    (p, _) <- createProcessWithLogging' LevelDebug (shell "echo hiiiiii")
     liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
 
   it "createProcessWithLoggingAndStdin" $ do
-    p <- createProcessWithLoggingAndStdin (shell "echo hiiiiii") ""
+    (p, _) <- createProcessWithLoggingAndStdin (shell "echo hiiiiii") ""
     liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
 
   it "createProcessWithLoggingAndStdin'" $ do
-    p <- createProcessWithLoggingAndStdin' LevelDebug (shell "echo hiiiiii") ""
+    (p, _) <- createProcessWithLoggingAndStdin' LevelDebug (shell "echo hiiiiii") ""
     liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)
 
   it "readCreateProcessWithLogging" $ do

From 1564e10903caa6cbfbfb691d6df1df1bd75fc761 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 5 Mar 2026 03:57:48 -0800
Subject: [PATCH 37/41] Cleaning up API of managed asyncs

---
 .../Contexts/Kubernetes/KubectlPortForward.hs |  4 +-
 .../Kubernetes/MinikubeCluster/Forwards.hs    |  6 +--
 .../lib/Test/Sandwich/Contexts/MinIO.hs       |  5 +-
 .../lib/Test/Sandwich/Contexts/Nix.hs         |  7 +--
 .../Sandwich/Contexts/ReverseProxy/TCP.hs     |  7 ++-
 .../Sandwich/WebDriver/Internal/OnDemand.hs   |  7 ++-
 sandwich/src/Test/Sandwich.hs                 | 46 +++++++++++++++----
 sandwich/src/Test/Sandwich/Logging/Process.hs | 13 ++----
 sandwich/src/Test/Sandwich/ManagedAsync.hs    | 35 ++++++++++++++
 9 files changed, 90 insertions(+), 40 deletions(-)

diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
index bdd88363..9c03c58c 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs
@@ -21,7 +21,6 @@ import Test.Sandwich.Contexts.Files
 import Test.Sandwich.Contexts.Kubernetes.Types
 import Test.Sandwich.Contexts.Kubernetes.Util.Ports
 import Test.Sandwich.Contexts.Kubernetes.Util.SocketUtil
-import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Util.Process (gracefullyStopProcess)
 import UnliftIO.Concurrent
 import UnliftIO.Directory
@@ -110,8 +109,7 @@ withKubectlPortForward' kubectlBinary kubeConfigFile namespace isAcceptablePort
                   )
           threadDelay 1_000_000  -- 1 second delay between restarts to ensure we don't spin here
 
-    runId <- baseContextRunId <$> asks getBaseContext
-    managedWithAsync_ runId "kubectl-port-forward-restarter" restarterThread $ do
+    managedWithAsync_ "kubectl-port-forward-restarter" restarterThread $ do
       let policy = constantDelay 100000 <> limitRetries 100
       void $ liftIO $ retrying policy (\_ ret -> return ret) $ \_ -> do
         not <$> isPortOpen (simpleSockAddr (127, 0, 0, 1) port)
diff --git a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
index b6a3a3b2..ef883320 100644
--- a/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
+++ b/sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Forwards.hs
@@ -19,7 +19,7 @@ import System.IO (hClose, hGetLine, openTempFile)
 import System.Process (getPid)
 import Test.Sandwich
 import Test.Sandwich.Contexts.Kubernetes.Types
-import Test.Sandwich.ManagedAsync
+
 import Test.Sandwich.Util.Process
 import UnliftIO.Concurrent (threadDelay)
 import UnliftIO.Environment
@@ -28,7 +28,7 @@ import UnliftIO.Process
 
 
 withForwardKubernetesService' :: (
-  HasCallStack, MonadLoggerIO m, MonadUnliftIO m
+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => KubernetesClusterContext -> Text -> Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..}), ..}) profile namespace service action = do
   baseEnv <- liftIO getEnvironment
@@ -56,7 +56,7 @@ withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(
           line <- liftIO $ hGetLine stderrRead
           info [i|minikube service stderr: #{line}|]
 
-  managedWithAsync_ "" "minikube-service-stderr" forwardStderr $ do
+  managedWithAsync_ "minikube-service-stderr" forwardStderr $ do
     let cp = (proc kubernetesClusterTypeMinikubeBinary args) {
           env = Just env
           , std_out = UseHandle stdoutWrite
diff --git a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
index 21d3201d..a1797928 100644
--- a/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
+++ b/sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs
@@ -70,7 +70,7 @@ import Test.Sandwich.Contexts.MinIO.Util
 import Test.Sandwich.Contexts.Nix
 import Test.Sandwich.Contexts.Types.Network
 import Test.Sandwich.Contexts.Types.S3
-import Test.Sandwich.ManagedAsync
+
 import UnliftIO.Directory
 import UnliftIO.Exception
 import UnliftIO.Process
@@ -193,8 +193,7 @@ withMinIOViaBinary' minioPath (MinIOContextOptions {..}) action = do
           line <- liftIO $ T.hGetLine hRead
           debug [i|minio: #{line}|]
 
-    runId <- baseContextRunId <$> asks getBaseContext
-    managedWithAsync_ runId "minio-output-forward" forwardOutput $ do
+    managedWithAsync_ "minio-output-forward" forwardOutput $ do
       (hostname, port) <- case uriToUse of
         Nothing -> expectationFailure [i|Couldn't find MinIO URI to use.|]
         Just (URI { uriAuthority=(Just URIAuth {..}) }) -> case readMaybe (L.drop 1 uriPort) of
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
index 574e95dd..42fbfcbd 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/Nix.hs
@@ -82,7 +82,6 @@ import System.IO.Temp (createTempDirectory)
 import Test.Sandwich
 import Test.Sandwich.Contexts.Files.Types
 import Test.Sandwich.Contexts.Util.Aeson
-import Test.Sandwich.ManagedAsync
 import qualified Text.Show
 import UnliftIO.Async (Async, wait)
 import UnliftIO.Directory
@@ -356,12 +355,11 @@ buildNixCallPackageDerivation' :: forall context m. (
   -> Text
   -> m FilePath
 buildNixCallPackageDerivation' nc@(NixContext {..}) derivation = do
-  runId <- baseContextRunId <$> asks getBaseContext
   wait =<< modifyMVar nixContextBuildCache (\m ->
     case M.lookup derivation m of
       Just x -> return (m, x)
       Nothing -> do
-        asy <- managedAsync runId "nix-build-call-package" $ do
+        asy <- managedAsync "nix-build-call-package" $ do
           maybeNixExpressionDir <- getCurrentFolder >>= \case
             Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"
             Nothing -> return Nothing
@@ -397,12 +395,11 @@ buildNixExpression' :: (
   -- | Nix expression
   => NixContext -> Text -> m FilePath
 buildNixExpression' nc@(NixContext {..}) expr = do
-  runId <- baseContextRunId <$> asks getBaseContext
   wait =<< modifyMVar nixContextBuildCache (\m ->
     case M.lookup expr m of
       Just x -> return (m, x)
       Nothing -> do
-        asy <- managedAsync runId "nix-build-expression" $ do
+        asy <- managedAsync "nix-build-expression" $ do
           maybeNixExpressionDir <- getCurrentFolder >>= \case
             Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"
             Nothing -> pure Nothing
diff --git a/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs b/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
index 535a66eb..cb75f630 100644
--- a/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
+++ b/sandwich-contexts/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs
@@ -14,14 +14,13 @@ import Data.Streaming.Network (setAfterBind)
 import Data.String.Interpolate
 import Network.Socket
 import Relude
-import Test.Sandwich (expectationFailure)
-import Test.Sandwich.ManagedAsync
+import Test.Sandwich (expectationFailure, HasBaseContextMonad, managedWithAsync_)
 import UnliftIO.Async (concurrently_)
 import UnliftIO.Exception
 import UnliftIO.Timeout
 
 
-withProxyToUnixSocket :: MonadUnliftIO m => FilePath -> (PortNumber -> m a) -> m a
+withProxyToUnixSocket :: (MonadUnliftIO m, HasBaseContextMonad context m) => FilePath -> (PortNumber -> m a) -> m a
 withProxyToUnixSocket socketPath f = do
   portVar <- newEmptyMVar
   let ss = DCN.serverSettings 0 "*"
@@ -31,7 +30,7 @@ withProxyToUnixSocket socketPath f = do
                SockAddrInet6 port _ _ _ -> putMVar portVar port
                x -> expectationFailure [i|withProxyToUnixSocket: expected to bind a TCP socket, but got other addr: #{x}|]
            )
-  managedWithAsync_ "" "tcp-reverse-proxy" (liftIO $ DCN.runTCPServer ss app `onException` (tryPutMVar portVar (-1))) $
+  managedWithAsync_ "tcp-reverse-proxy" (liftIO $ DCN.runTCPServer ss app `onException` (tryPutMVar portVar (-1))) $
     timeout 60_000_000 (readMVar portVar) >>= \case
       Nothing -> expectationFailure [i|withProxyToUnixSocket: didn't get port within 60s|]
       Just (-1) -> expectationFailure [i|withProxyToUnixSocket: TCP server threw exception|]
diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
index 2fec83be..c93fb4a6 100644
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
+++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs
@@ -6,21 +6,20 @@ import Control.Monad.Logger
 import Data.String.Interpolate
 import Data.Text as T
 import Test.Sandwich
-import Test.Sandwich.ManagedAsync
 import Test.Sandwich.WebDriver.Internal.Types
 import UnliftIO.Async (wait)
 import UnliftIO.Exception
 import UnliftIO.MVar
 
 
-getOnDemand :: forall m a. (
-  MonadUnliftIO m, MonadLogger m
+getOnDemand :: forall context m a. (
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   ) => MVar (OnDemand a) -> m (Either Text a) -> m a
 getOnDemand onDemandVar doObtain = do
   result <- modifyMVar onDemandVar $ \case
     OnDemandErrored msg -> expectationFailure (T.unpack msg)
     OnDemandNotStarted -> do
-      asy <- managedAsync "" "webdriver-on-demand" $ do
+      asy <- managedAsync "webdriver-on-demand" $ do
         let handler :: SomeException -> m a
             handler e = do
               modifyMVar_ onDemandVar (const $ return $ OnDemandErrored [i|Got exception: #{e}|])
diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
index 50f9f119..b3ef909a 100644
--- a/sandwich/src/Test/Sandwich.hs
+++ b/sandwich/src/Test/Sandwich.hs
@@ -56,6 +56,15 @@ module Test.Sandwich (
   , withTimingProfile
   , withTimingProfile'
 
+  -- * Managed async
+  --
+  -- | If you want to run asyncs within your tests, we can help keep track of
+  -- them and make sure they get cleaned up.
+  , managedAsync
+  , managedAsyncWithUnmask
+  , managedWithAsync
+  , managedWithAsync_
+
   -- * Exports
   , module Test.Sandwich.Contexts
   , module Test.Sandwich.Expectations
@@ -72,6 +81,7 @@ import qualified Control.Exception as E
 import Control.Monad
 import Control.Monad.Free
 import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift (MonadUnliftIO)
 import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Aeson as A
@@ -104,7 +114,7 @@ import Test.Sandwich.Interpreters.FilterTreeModule
 import Test.Sandwich.Interpreters.RunTree
 import Test.Sandwich.Interpreters.RunTree.Util
 import Test.Sandwich.Logging
-import Test.Sandwich.ManagedAsync
+import qualified Test.Sandwich.ManagedAsync as MA
 import Test.Sandwich.Misc
 import Test.Sandwich.Nodes
 import Test.Sandwich.Options
@@ -243,7 +253,7 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
   milestone "spawning formatters"
   formatterAsyncs <- forM (optionsFormatters options') $ \(SomeFormatter f) ->
-    managedAsync runId (T.pack [i|formatter:#{formatterName f}|]) $ do
+    MA.managedAsync runId (T.pack [i|formatter:#{formatterName f}|]) $ do
       let loggingFn = case baseContextRunRoot baseContext of
             Nothing -> flip runLoggingT (\_ _ _ _ -> return ())
             Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")
@@ -258,23 +268,23 @@ runSandwich' maybeCommandLineOptions options spec' = do
       others <- fmap catMaybes $ sequence
         [ if optLogLogs clo
           then case optionsLogBroadcast options' of
-            Just chan -> Just <$> managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.log") chan)
+            Just chan -> Just <$> MA.managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.log") chan)
             Nothing -> return Nothing
           else return Nothing
         , if optLogEvents clo
           then do
             writeTreeFile (runRoot </> "events-tree.txt") rts
             case optionsEventBroadcast options' of
-              Just chan -> Just <$> managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.log") chan)
+              Just chan -> Just <$> MA.managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.log") chan)
               Nothing -> return Nothing
           else return Nothing
         , if optLogRtsStats clo
-          then Just <$> managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.log"))
+          then Just <$> MA.managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.log"))
           else return Nothing
         ]
       -- Spawn the managed-async event stream separately so we can cancel it last
       maybeManagedAsync <- if optLogAsyncs clo
-        then Just <$> managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "asyncs.log") asyncEventBroadcast)
+        then Just <$> MA.managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "asyncs.log") MA.asyncEventBroadcast)
         else return Nothing
       return (others, maybeManagedAsync)
     _ -> return ([], Nothing)
@@ -327,12 +337,12 @@ runSandwich' maybeCommandLineOptions options spec' = do
 
   -- Check for stale managed asyncs from this run
   milestone "checking for stale asyncs"
-  allAsyncs <- getManagedAsyncInfos
-  let staleAsyncs = M.filter (\x -> asyncInfoRunId x == runId) allAsyncs
+  allAsyncs <- MA.getManagedAsyncInfos
+  let staleAsyncs = M.filter (\x -> MA.asyncInfoRunId x == runId) allAsyncs
   unless (M.null staleAsyncs) $ do
     putStrLn [i|WARNING: #{M.size staleAsyncs} managed asyncs still running after tree finished:|]
     forM_ (M.toList staleAsyncs) $ \(tid, x) ->
-      putStrLn [i|  #{tid}: #{asyncInfoName x}|]
+      putStrLn [i|  #{tid}: #{MA.asyncInfoName x}|]
 
   -- Close late-log file handle
   mapM_ hClose maybeLateLogHandle
@@ -351,3 +361,21 @@ countItNodes (Free (IntroduceWith'' {..})) = countItNodes next + countItNodes su
 countItNodes (Free (Introduce'' {..})) = countItNodes next + countItNodes subspecAugmented
 countItNodes (Free x) = countItNodes (next x) + countItNodes (subspec x)
 countItNodes (Pure _) = 0
+
+-- * Managed async (context-aware aliases)
+
+-- | Launch a managed async thread, tracking it with the run ID from 'BaseContext'.
+managedAsync :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m (Async a)
+managedAsync = MA.managedAsyncContext
+
+-- | Like 'managedAsync', but the action receives an unmask function.
+managedAsyncWithUnmask :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)
+managedAsyncWithUnmask = MA.managedAsyncWithUnmaskContext
+
+-- | Run a managed async thread scoped to a callback.
+managedWithAsync :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> (Async a -> m b) -> m b
+managedWithAsync = MA.managedWithAsyncContext
+
+-- | Like 'managedWithAsync', but ignores the 'Async' handle.
+managedWithAsync_ :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m b -> m b
+managedWithAsync_ = MA.managedWithAsyncContext_
diff --git a/sandwich/src/Test/Sandwich/Logging/Process.hs b/sandwich/src/Test/Sandwich/Logging/Process.hs
index fcdf05be..36cd45e2 100644
--- a/sandwich/src/Test/Sandwich/Logging/Process.hs
+++ b/sandwich/src/Test/Sandwich/Logging/Process.hs
@@ -22,7 +22,6 @@ import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger hiding (logOther)
-import Control.Monad.Reader
 import Data.String.Interpolate
 import Foreign.C.Error
 import GHC.IO.Exception
@@ -48,14 +47,13 @@ createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelD
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m (ProcessHandle, Async ())
 createProcessWithLogging' logLevel cp = do
-  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   let name = case cmdspec cp of
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  streamsReaderAsy <- managedAsync runId "streams-reader" $ forever $ do
+  streamsReaderAsy <- managedAsyncContext "streams-reader" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -70,7 +68,6 @@ readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging
 -- | Like 'readCreateProcess', but capture the stderr output in the logs.
 readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m String
 readCreateProcessWithLogging' logLevel cp input = do
-  runId <- baseContextRunId <$> asks getBaseContext
   (hReadErr, hWriteErr) <- liftIO createPipe
 
   let name = case cmdspec cp of
@@ -82,7 +79,7 @@ readCreateProcessWithLogging' logLevel cp input = do
         logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
   (ex, output) <-
-    managedWithAsync_ runId "stderr-reader" stderrReader $
+    managedWithAsyncContext_ "stderr-reader" stderrReader $
     withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p ->
       -- Do this just like 'readCreateProcess'
       -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess
@@ -127,14 +124,13 @@ createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLogging
 -- | Spawn a process with its stdout and stderr connected to the logging system.
 createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m (ProcessHandle, Async ())
 createProcessWithLoggingAndStdin' logLevel cp input = do
-  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   let name = case cmdspec cp of
         ShellCommand {} -> "shell"
         RawCommand path _ -> path
 
-  readAsy <- managedAsync runId "read-process-streams" $ forever $ do
+  readAsy <- managedAsyncContext "read-process-streams" $ forever $ do
     line <- liftIO $ hGetLine hRead
     logOtherCS callStack logLevel [i|#{name}: #{line}|]
 
@@ -158,7 +154,6 @@ callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug
 -- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
 callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> String -> m ()
 callCommandWithLogging' logLevel cmd = do
-  runId <- baseContextRunId <$> asks getBaseContext
   (hRead, hWrite) <- liftIO createPipe
 
   (_, _, _, p) <- liftIO $ createProcess (shell cmd) {
@@ -171,7 +166,7 @@ callCommandWithLogging' logLevel cmd = do
         line <- liftIO $ hGetLine hRead
         logOtherCS callStack logLevel [i|#{cmd}: #{line}|]
 
-  managedWithAsync_ runId "stderr-reader" streamsReader $
+  managedWithAsyncContext_ "stderr-reader" streamsReader $
     liftIO (waitForProcess p) >>= \case
       ExitSuccess -> return ()
       ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
diff --git a/sandwich/src/Test/Sandwich/ManagedAsync.hs b/sandwich/src/Test/Sandwich/ManagedAsync.hs
index 551be870..1b57969c 100644
--- a/sandwich/src/Test/Sandwich/ManagedAsync.hs
+++ b/sandwich/src/Test/Sandwich/ManagedAsync.hs
@@ -1,10 +1,19 @@
 {-# LANGUAGE RankNTypes #-}
 
 module Test.Sandwich.ManagedAsync (
+  -- * With explicit run ID
   managedAsync
   , managedAsyncWithUnmask
   , managedWithAsync
   , managedWithAsync_
+
+  -- * With run ID from BaseContext
+  , managedAsyncContext
+  , managedAsyncWithUnmaskContext
+  , managedWithAsyncContext
+  , managedWithAsyncContext_
+
+  -- * Types and utilities
   , AsyncInfo(..)
   , AsyncEvent(..)
   , asyncEventBroadcast
@@ -14,10 +23,12 @@ module Test.Sandwich.ManagedAsync (
 import Control.Concurrent (ThreadId, myThreadId)
 import Control.Concurrent.STM
 import Control.Monad.IO.Unlift
+import Control.Monad.Reader
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.IORef
 import System.IO.Unsafe (unsafePerformIO)
+import Test.Sandwich.Types.RunTree (HasBaseContextMonad, HasBaseContext, BaseContext(..), getBaseContext)
 import UnliftIO.Async
 import UnliftIO.Exception
 
@@ -60,6 +71,30 @@ managedWithAsync runId name action cb = do
 managedWithAsync_ :: MonadUnliftIO m => T.Text -> T.Text -> m a -> m b -> m b
 managedWithAsync_ runId name f g = managedWithAsync runId name f (const g)
 
+-- * With run ID from BaseContext
+
+-- | Like 'managedAsync', but extracts the run ID from 'BaseContext'.
+managedAsyncContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m (Async a)
+managedAsyncContext name action = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  managedAsync runId name action
+
+-- | Like 'managedAsyncWithUnmask', but extracts the run ID from 'BaseContext'.
+managedAsyncWithUnmaskContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)
+managedAsyncWithUnmaskContext name action = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  managedAsyncWithUnmask runId name action
+
+-- | Like 'managedWithAsync', but extracts the run ID from 'BaseContext'.
+managedWithAsyncContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> (Async a -> m b) -> m b
+managedWithAsyncContext name action cb = do
+  runId <- baseContextRunId <$> asks getBaseContext
+  managedWithAsync runId name action cb
+
+-- | Like 'managedWithAsync_', but extracts the run ID from 'BaseContext'.
+managedWithAsyncContext_ :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m b -> m b
+managedWithAsyncContext_ name f g = managedWithAsyncContext name f (const g)
+
 -- * Internal
 
 bracketedAction :: MonadUnliftIO m => ThreadId -> T.Text -> T.Text -> m a -> m a

From c53a62ba3955096a19631cfec18c42f0f2d6560b Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 5 Mar 2026 04:02:20 -0800
Subject: [PATCH 38/41] Get rid of ghc-datasize

---
 sandwich/package.yaml                         | 1 -
 sandwich/sandwich.cabal                       | 5 -----
 sandwich/src/Test/Sandwich/Instrumentation.hs | 9 ++++-----
 stack.yaml                                    | 1 -
 stack.yaml.lock                               | 7 -------
 5 files changed, 4 insertions(+), 19 deletions(-)

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index 631c31c8..edd46d11 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -39,7 +39,6 @@ dependencies:
 - exceptions
 - filepath
 - free
-- ghc-datasize
 - microlens
 - microlens-th
 - monad-control
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index 71b9d2d9..ba08a498 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -131,7 +131,6 @@ library
     , exceptions
     , filepath
     , free
-    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -195,7 +194,6 @@ executable sandwich-demo
     , exceptions
     , filepath
     , free
-    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -257,7 +255,6 @@ executable sandwich-discover
     , exceptions
     , filepath
     , free
-    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -325,7 +322,6 @@ executable sandwich-test
     , exceptions
     , filepath
     , free
-    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
@@ -394,7 +390,6 @@ test-suite sandwich-test-suite
     , exceptions
     , filepath
     , free
-    , ghc-datasize
     , microlens
     , microlens-th
     , monad-control
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index e08028da..b5b85729 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -16,7 +16,6 @@ import Data.String.Interpolate
 import Data.Time
 import Data.Word
 import Debug.Trace (traceMarkerIO)
-import GHC.DataSize (recursiveSize)
 import GHC.Stats
 import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)
 import Test.Sandwich.ManagedAsync (AsyncEvent(..), AsyncInfo(..), getManagedAsyncInfos)
@@ -32,13 +31,13 @@ import UnliftIO.Exception
 streamLogsToFile :: FilePath -> TChan (Int, String, LogEntry) -> IO ()
 streamLogsToFile path broadcastChan = do
   chan <- atomically $ dupTChan broadcastChan
-  totalRef <- newIORef (0 :: Word)
+  totalRef <- newIORef (0 :: Word64)
   countRef <- newIORef (0 :: Int)
   withFile path AppendMode $ \h -> do
     hSetBuffering h LineBuffering
     let loop = forever $ do
-          (nodeId, nodeLabel, entry@(LogEntry {..})) <- atomically $ readTChan chan
-          entrySize <- recursiveSize entry
+          (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan
+          let entrySize = fromIntegral (BS8.length logEntryStr) :: Word64
           modifyIORef' totalRef (+ entrySize)
           modifyIORef' countRef (+ 1)
           let levelStr :: String
@@ -55,7 +54,7 @@ streamLogsToFile path broadcastChan = do
     loop `finally` do
       total <- readIORef totalRef
       count <- readIORef countRef
-      hPutStr h [i|\nTotal: #{count} log entries, #{formatBytes (fromIntegral total)} recursive heap size\n|]
+      hPutStr h [i|\nTotal: #{count} log entries, #{formatBytes total} total log bytes\n|]
       hFlush h
 
 -- | Stream node lifecycle events from a broadcast channel to a file.
diff --git a/stack.yaml b/stack.yaml
index d8a5ff04..581c3367 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -60,7 +60,6 @@ packages:
 - ./demos/demo-webdriver-video
 
 extra-deps:
-- ghc-datasize-0.2.7
 
 # For sandwich-webdriver
 
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 227ae42f..758424af 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -4,13 +4,6 @@
 #   https://docs.haskellstack.org/en/stable/topics/lock_files
 
 packages:
-- completed:
-    hackage: ghc-datasize-0.2.7@sha256:3397b0306f179836a0f5912e9888b5a0d2c40c2a6bba12965e82144a22de15a3,1132
-    pantry-tree:
-      sha256: 7855227e0065019e4d762705f011a1aa195e4389e8cd0870eea1f0f3b7e906ee
-      size: 216
-  original:
-    hackage: ghc-datasize-0.2.7
 - completed:
     hackage: webdriver-0.14.0.0@sha256:3a529a3520b3d9be4dcc0c51fabd96ee3e67661ac18e6d4417100ac187da4c15,6463
     pantry-tree:

From ed72efdd00731a9b04c06cb6cfba09041f20ca53 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 5 Mar 2026 17:35:02 -0800
Subject: [PATCH 39/41] Remove duplicated formatRtsStats

---
 .../Test/Sandwich/Formatters/Socket/Server.hs | 37 ++++--------------
 sandwich/src/Test/Sandwich/Instrumentation.hs | 38 ++++++++++---------
 sandwich/src/Test/Sandwich/ManagedAsync.hs    |  4 +-
 3 files changed, 30 insertions(+), 49 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
index 9a39eefb..fc979ad2 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Socket/Server.hs
@@ -10,13 +10,14 @@ import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import Data.String.Interpolate
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import Data.Time
-import Data.Word
 import GHC.Stats
 import Network.Socket
 import Network.Socket.ByteString (recv, sendAll)
 import System.Directory (removeFile)
 import Test.Sandwich.Formatters.Socket.Commands
+import Test.Sandwich.Instrumentation (formatRtsStats)
 import Test.Sandwich.ManagedAsync
 import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
@@ -118,35 +119,11 @@ streamRtsStats conn = do
       handle (\(_ :: IOError) -> return ()) $ forever $ do
         stats <- getRTSStats
         let gc' = gc stats
-            line = formatRtsStats stats gc'
-        sendAll conn (BS8.pack line)
-        threadDelay 1000000
-
-formatRtsStats :: RTSStats -> GCDetails -> String
-formatRtsStats stats gc' = unlines
-  [ [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
-  , [i|heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}|]
-  , [i|allocated_bytes:    #{formatBytes (allocated_bytes stats)}|]
-  , [i|max_live_bytes:     #{formatBytes (max_live_bytes stats)}|]
-  , [i|large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}|]
-  , [i|compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}|]
-  , [i|slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}|]
-  , [i|gcs:                #{gcs stats}|]
-  , [i|major_gcs:          #{major_gcs stats}|]
-  , [i|gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms|]
-  , [i|mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms|]
-  , ""
-  ]
-  where
-    nsToMs :: RtsTime -> RtsTime
-    nsToMs ns = ns `div` 1000000
-
-formatBytes :: Word64 -> String
-formatBytes b
-  | b < 1024 = [i|#{b} B|]
-  | b < 1024 * 1024 = [i|#{b `div` 1024} KiB (#{b})|]
-  | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]
-  | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]
+        now <- getCurrentTime
+        let line = formatRtsStats now stats gc'
+        sendAll conn "\n\n"
+        sendAll conn (T.encodeUtf8 line)
+        threadDelay 1_000_000
 
 -- | Read a single line from the socket, buffering leftover bytes.
 -- Returns the line without the trailing newline.
diff --git a/sandwich/src/Test/Sandwich/Instrumentation.hs b/sandwich/src/Test/Sandwich/Instrumentation.hs
index b5b85729..076ed61c 100644
--- a/sandwich/src/Test/Sandwich/Instrumentation.hs
+++ b/sandwich/src/Test/Sandwich/Instrumentation.hs
@@ -4,6 +4,8 @@ module Test.Sandwich.Instrumentation (
   , streamRtsStatsToFile
   , streamManagedAsyncEventsToFile
   , writeTreeFile
+
+  , formatRtsStats
   ) where
 
 import Control.Concurrent.STM
@@ -13,6 +15,8 @@ import qualified Data.ByteString.Char8 as BS8
 import Data.IORef
 import qualified Data.Map.Strict as M
 import Data.String.Interpolate
+import Data.Text (Text)
+import qualified Data.Text.IO as T
 import Data.Time
 import Data.Word
 import Debug.Trace (traceMarkerIO)
@@ -95,7 +99,8 @@ streamRtsStatsToFile path = do
         now <- getCurrentTime
         stats <- getRTSStats
         let gc' = gc stats
-        hPutStr h (formatRtsStats now stats gc')
+        T.hPutStr h "\n\n"
+        T.hPutStr h $ formatRtsStats now stats gc'
         hFlush h
         threadDelay 1000000
 
@@ -104,22 +109,21 @@ showFailureReasonBrief (Reason {failureReason}) = failureReason
 showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]
 showFailureReasonBrief _ = "(see node detail)"
 
-formatRtsStats :: UTCTime -> RTSStats -> GCDetails -> String
-formatRtsStats now stats gc' = unlines
-  [ [i|#{show now}|]
-  , [i|live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}|]
-  , [i|heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}|]
-  , [i|allocated_bytes:    #{formatBytes (allocated_bytes stats)}|]
-  , [i|max_live_bytes:     #{formatBytes (max_live_bytes stats)}|]
-  , [i|large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}|]
-  , [i|compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}|]
-  , [i|slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}|]
-  , [i|gcs:                #{gcs stats}|]
-  , [i|major_gcs:          #{major_gcs stats}|]
-  , [i|gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms|]
-  , [i|mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms|]
-  , ""
-  ]
+formatRtsStats :: UTCTime -> RTSStats -> GCDetails -> Text
+formatRtsStats now stats gc' = [__i|
+  #{now}
+  live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}
+  heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}
+  allocated_bytes:    #{formatBytes (allocated_bytes stats)}
+  max_live_bytes:     #{formatBytes (max_live_bytes stats)}
+  large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}
+  compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}
+  slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}
+  gcs:                #{gcs stats}
+  major_gcs:          #{major_gcs stats}
+  gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms
+  mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms
+  |]
   where
     nsToMs :: RtsTime -> RtsTime
     nsToMs ns = ns `div` 1000000
diff --git a/sandwich/src/Test/Sandwich/ManagedAsync.hs b/sandwich/src/Test/Sandwich/ManagedAsync.hs
index 1b57969c..c0e1fa3d 100644
--- a/sandwich/src/Test/Sandwich/ManagedAsync.hs
+++ b/sandwich/src/Test/Sandwich/ManagedAsync.hs
@@ -24,11 +24,11 @@ import Control.Concurrent (ThreadId, myThreadId)
 import Control.Concurrent.STM
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
+import Data.IORef
 import qualified Data.Map.Strict as M
 import qualified Data.Text as T
-import Data.IORef
 import System.IO.Unsafe (unsafePerformIO)
-import Test.Sandwich.Types.RunTree (HasBaseContextMonad, HasBaseContext, BaseContext(..), getBaseContext)
+import Test.Sandwich.Types.RunTree (HasBaseContextMonad, BaseContext(..), getBaseContext)
 import UnliftIO.Async
 import UnliftIO.Exception
 

From f1655c4d322208b0f64d82d12f9f88cdc288bf4f Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Thu, 5 Mar 2026 17:35:51 -0800
Subject: [PATCH 40/41] Bring back printLogs

---
 .../Test/Sandwich/Formatters/Print/Common.hs  |  2 +-
 .../Test/Sandwich/Formatters/Print/Logs.hs    | 20 +++++++++----------
 .../Test/Sandwich/Interpreters/StartTree.hs   |  2 +-
 3 files changed, 11 insertions(+), 13 deletions(-)

diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
index 2026f1d5..4dea89b7 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Common.hs
@@ -30,4 +30,4 @@ finishPrinting (RunNodeCommonWithStatus {..}) result = do
       _ -> return ()
 
   -- Print the logs, if configured
-  -- printLogs runTreeLogs
+  printLogs runTreeLogs
diff --git a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
index b24892ba..d0dbc8ab 100644
--- a/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
+++ b/sandwich/src/Test/Sandwich/Formatters/Print/Logs.hs
@@ -21,17 +21,15 @@ import Control.Monad
 #endif
 
 
--- TODO: bring this back
--- printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
--- printLogs runTreeLogs = do
---   (asks (printFormatterLogLevel . fst3)) >>= \case
---     Nothing -> return ()
---     Just logLevel -> do
---       logEntries <- liftIO $ readTVarIO runTreeLogs
---       withBumpIndent $
---         forM_ logEntries $ \entry ->
---           when (logEntryLevel entry >= logLevel) $ printLogEntry entry
-
+printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()
+printLogs runTreeLogs = do
+  (asks (printFormatterLogLevel . fst3)) >>= \case
+    Nothing -> return ()
+    Just logLevel -> do
+      logEntries <- liftIO $ readTVarIO runTreeLogs
+      withBumpIndent $
+        forM_ logEntries $ \entry ->
+          when (logEntryLevel entry >= logLevel) $ printLogEntry entry
 
 printLogEntry :: (
   MonadReader (PrintFormatter, Int, Handle) m, MonadIO m
diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
index c3f1cf42..85f5baae 100644
--- a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
+++ b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -328,7 +328,7 @@ runInAsync node ctx action = do
                 p "\n"
                 printCallStack cs
               p "\n"
-              -- printLogs runTreeLogs
+              printLogs runTreeLogs
 
       return result
   liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing Nothing myAsync

From 136b87468f6dfdd906eed3132a71d1df18d68a01 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Fri, 6 Mar 2026 15:51:27 -0800
Subject: [PATCH 41/41] Don't export ManagedAsync

---
 sandwich/package.yaml   | 1 -
 sandwich/sandwich.cabal | 2 +-
 2 files changed, 1 insertion(+), 2 deletions(-)

diff --git a/sandwich/package.yaml b/sandwich/package.yaml
index edd46d11..f08591c8 100644
--- a/sandwich/package.yaml
+++ b/sandwich/package.yaml
@@ -90,7 +90,6 @@ library:
   - Test.Sandwich.Formatters.Socket
   - Test.Sandwich.Formatters.TerminalUI
   - Test.Sandwich.Internal
-  - Test.Sandwich.ManagedAsync
   - Test.Sandwich.TH
   - Test.Sandwich.Util.Process
   - Test.Sandwich.Waits
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
index ba08a498..5e55166e 100644
--- a/sandwich/sandwich.cabal
+++ b/sandwich/sandwich.cabal
@@ -41,7 +41,6 @@ library
       Test.Sandwich.Formatters.Socket
       Test.Sandwich.Formatters.TerminalUI
       Test.Sandwich.Internal
-      Test.Sandwich.ManagedAsync
       Test.Sandwich.TH
       Test.Sandwich.Util.Process
       Test.Sandwich.Waits
@@ -89,6 +88,7 @@ library
       Test.Sandwich.Interpreters.StartTree
       Test.Sandwich.Logging.Process
       Test.Sandwich.Logging.ProcessFileLogging
+      Test.Sandwich.ManagedAsync
       Test.Sandwich.ParallelN
       Test.Sandwich.RunTree
       Test.Sandwich.Shutdown