integration: Print name of the test in logs from dynamic backends (#4383

)

integration/test/Testlib/Env.hs

@@ -130,8 +130,8 @@ mkGlobalEnv cfgFile = do
       pure $ Just sslContext
     createSSLContext Nothing = pure Nothing
 
-mkEnv :: GlobalEnv -> Codensity IO Env
-mkEnv ge = do
+mkEnv :: Maybe String -> GlobalEnv -> Codensity IO Env
+mkEnv currentTestName ge = do
   mls <- liftIO . newIORef =<< mkMLSState
   liftIO $ do
     pks <- newIORef (zip [1 ..] somePrekeys)
@@ -161,7 +161,8 @@ mkEnv ge = do
           mls = mls,
           resourcePool = ge.gBackendResourcePool,
           rabbitMQConfig = ge.gRabbitMQConfig,
-          timeOutSeconds = ge.gTimeOutSeconds
+          timeOutSeconds = ge.gTimeOutSeconds,
+          currentTestName
         }
 
 allCiphersuites :: [Ciphersuite]

integration/test/Testlib/ModService.hs

@@ -358,17 +358,17 @@ withProcess :: (HasCallStack) => BackendResource -> ServiceOverrides -> Service
 withProcess resource overrides service = do
   let domain = berDomain resource
   sm <- lift $ getServiceMap domain
+  env <- lift ask
   getConfig <-
     lift . appToIO $
       readServiceConfig service
         >>= updateServiceMapInConfig resource service
         >>= lookupConfigOverride overrides service
   let execName = configName service
-  (cwd, exe) <-
-    lift $ asks \env -> case env.servicesCwdBase of
-      Nothing -> (Nothing, execName)
-      Just dir ->
-        (Just (dir </> execName), "../../dist" </> execName)
+  let (cwd, exe) = case env.servicesCwdBase of
+        Nothing -> (Nothing, execName)
+        Just dir ->
+          (Just (dir </> execName), "../../dist" </> execName)
 
   startNginzLocalIO <- lift $ appToIO $ startNginzLocal resource
 
@@ -379,7 +379,7 @@ withProcess resource overrides service = do
           config <- getConfig
           tempFile <- writeTempFile "/tmp" (execName <> "-" <> domain <> "-" <> ".yaml") (cs $ Yaml.encode config)
           (_, Just stdoutHdl, Just stderrHdl, ph) <- createProcess (proc exe ["-c", tempFile]) {cwd = cwd, std_out = CreatePipe, std_err = CreatePipe}
-          let prefix = "[" <> execName <> "@" <> domain <> "] "
+          let prefix = "[" <> execName <> "@" <> domain <> maybe "" (":" <>) env.currentTestName <> "] "
           let colorize = fromMaybe id (lookup execName processColors)
           void $ forkIO $ logToConsole colorize prefix stdoutHdl
           void $ forkIO $ logToConsole colorize prefix stderrHdl

integration/test/Testlib/Run.hs

@@ -31,9 +31,9 @@ import Text.Printf
 import UnliftIO.Async
 import Prelude
 
-runTest :: GlobalEnv -> App a -> IO (Either String a)
-runTest ge action = lowerCodensity $ do
-  env <- mkEnv ge
+runTest :: String -> GlobalEnv -> App a -> IO (Either String a)
+runTest testName ge action = lowerCodensity $ do
+  env <- mkEnv (Just testName) ge
   liftIO $
     (Right <$> runAppWithEnv env action)
       `E.catches` [ E.Handler $ \(e :: SomeAsyncException) -> do
@@ -121,7 +121,7 @@ runTests tests mXMLOutput cfg = do
     withAsync displayOutput $ \displayThread -> do
       -- Currently 4 seems to be stable, more seems to create more timeouts.
       report <- fmap mconcat $ pooledForConcurrentlyN 4 tests $ \(qname, _, _, action) -> do
-        (mErr, tm) <- withTime (runTest genv action)
+        (mErr, tm) <- withTime (runTest qname genv action)
         case mErr of
           Left err -> do
             writeOutput $

integration/test/Testlib/RunServices.hs

@@ -71,7 +71,7 @@ main = do
           (_, _, _, ph) <- createProcess cp
           exitWith =<< waitForProcess ph
 
-  runCodensity (mkGlobalEnv cfg >>= mkEnv) $ \env ->
+  runCodensity (mkGlobalEnv cfg >>= mkEnv Nothing) $ \env ->
     runAppWithEnv env
       $ lowerCodensity
       $ do

integration/test/Testlib/Types.hs

@@ -228,7 +228,8 @@ data Env = Env
     mls :: IORef MLSState,
     resourcePool :: ResourcePool BackendResource,
     rabbitMQConfig :: RabbitMQConfig,
-    timeOutSeconds :: Int
+    timeOutSeconds :: Int,
+    currentTestName :: Maybe String
   }
 
 data Response = Response