Perf work

.github/workflows/sandwich.yml

@@ -1,7 +1,7 @@
 name: sandwich
 
 on:
-  pull_request:
+  workflow_dispatch:
   push:
 
 jobs:
@@ -109,6 +109,17 @@ jobs:
         # https://gitlab.haskell.org/ghc/ghc/-/issues/20592#note_391266
         echo "C_INCLUDE_PATH=`xcrun --show-sdk-path`/usr/include/ffi" >> "$GITHUB_ENV"
 
+        echo "Current LDFLAGS: $LDFLAGS"
+        echo "Current CPPFLAGS: $CPPFLAGS"
+
+        echo "LDFLAGS=-L/opt/homebrew/opt/postgresql@18/lib" >> "$GITHUB_ENV"
+        echo "CPPFLAGS=-I/opt/homebrew/opt/postgresql@18/include" >> "$GITHUB_ENV"
+
+        echo "Original PATH: $PATH"
+        export PATH="/opt/homebrew/opt/postgresql@18/bin:$PATH"
+        echo "New PATH: $PATH"
+        echo "PATH=$PATH" >> "$GITHUB_ENV"
+
     - uses: haskell-actions/setup@v2
       id: setup-haskell-cabal
       name: Setup Haskell

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

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)..20] $ \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 * 100000) `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
+      }

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

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

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
 
@@ -50,7 +51,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 +66,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 +75,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
 
@@ -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}'|]
@@ -122,7 +125,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
@@ -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.|]
 

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

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

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
@@ -54,7 +54,7 @@ withKataContainers' helmBinary kcc options@(KataContainersOptions {..}) action =
 
   env <- getKubectlEnvironment kcc
 
-  createProcessWithLogging ((proc helmBinary args) { env = Just env })
+  createProcessWithFileLogging' "helm-install-kata-containers" ((proc helmBinary args) { env = Just env })
     >>= waitForProcess >>= (`shouldBe` ExitSuccess)
 
   action (KataContainersContext options)

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' "kind-delete-cluster" (
+                 (proc kindBinary ["delete", "cluster", "--name", toString clusterName]) {
+                     env = environmentToUse
+                     })
                void $ waitForProcess ps
            ))
            (\kcc -> bracket_ (setUpKindCluster kcc kindBinary kubectlBinary environmentToUse driver)
@@ -227,15 +228,17 @@ 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
-                                                   , "--config", kindConfigFile
-                                                   , "--kubeconfig", kindKubeConfigFile]) {
-                                     delegate_ctlc = True
-                                     , env = environmentToUse
-                                     })
+  ps <- createProcessWithFileLogging' "kind-create-cluster" (
+    (proc kindBinary ["create", "cluster", "-v", "1", "--name", toString clusterName
+                     , "--config", kindConfigFile
+                     , "--kubeconfig", kindKubeConfigFile]) {
+        delegate_ctlc = True
+        , env = environmentToUse
+        }
+    )
   void $ waitForProcess ps
 
   whenM isInContainer $