server/tests: Structured logging in tests

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6805
GitOrigin-RevId: 4e4d3c12bad20948b5ad58b3ad6d1e882f4ceddb

server/lib/api-tests/api-tests.cabal

@@ -15,6 +15,7 @@ executable api-tests
     , graphql-parser
     , hasura-prelude
     , hspec
+    , hspec-core
     , http-conduit
     , http-types
     , lens

server/lib/api-tests/test/SpecHook.hs

@@ -8,11 +8,17 @@ where
 import Control.Exception.Safe (bracket)
 import Data.UUID.V4 (nextRandom)
 import Harness.GraphqlEngine (startServerThread)
-import Harness.TestEnvironment (BackendSettings (..), TestEnvironment (..), stopServer)
+import Harness.Logging
+import Harness.TestEnvironment
+  ( BackendSettings (..),
+    TestEnvironment (..),
+    stopServer,
+  )
 import Hasura.Prelude
 import System.Environment (lookupEnv)
 import System.Log.FastLogger qualified as FL
-import Test.Hspec (Spec, SpecWith, aroundAllWith)
+import Test.Hspec (Spec, SpecWith, aroundAllWith, runIO)
+import Test.Hspec.Core.Spec (modifyConfig)
 
 setupBackendSettings :: IO BackendSettings
 setupBackendSettings = do
@@ -26,14 +32,14 @@ setupBackendSettings = do
         }
     )
 
-setupTestEnvironment :: IO TestEnvironment
-setupTestEnvironment = do
+setupTestEnvironment ::
+  (Logger, IO ()) ->
+  IO TestEnvironment
+setupTestEnvironment (logger, loggerCleanup) = do
   murlPrefix <- lookupEnv "HASURA_TEST_URLPREFIX"
   mport <- fmap (>>= readMaybe) (lookupEnv "HASURA_TEST_PORT")
   backendSettings <- setupBackendSettings
   server <- startServerThread backendSettings ((,) <$> murlPrefix <*> mport)
-  let logType = FL.LogFileNoRotate "tests-hspec.log" 1024
-  (logger, loggerCleanup) <- FL.newFastLogger logType
   uniqueTestId <- nextRandom
   pure
     TestEnvironment
@@ -48,7 +54,14 @@ setupTestEnvironment = do
 teardownTestEnvironment :: TestEnvironment -> IO ()
 teardownTestEnvironment TestEnvironment {..} = do
   stopServer server
-  loggerCleanup
 
 hook :: SpecWith TestEnvironment -> Spec
-hook = aroundAllWith (const . bracket setupTestEnvironment teardownTestEnvironment)
+hook specs = do
+  let logType = FL.LogFileNoRotate "tests-hspec.log" 1024
+  (logger', cleanup) <- runIO $ FL.newFastLogger logType
+  let logger = flLogger logger'
+
+  modifyConfig (addLoggingFormatter logger)
+  aroundAllWith
+    (const . bracket (setupTestEnvironment (logger, cleanup)) teardownTestEnvironment)
+    (contextualizeLogger specs)

server/lib/api-tests/test/Test/HelloWorldSpec.hs

@@ -10,7 +10,7 @@ import Harness.Backend.Postgres qualified as Postgres
 import Harness.Quoter.Yaml (yaml)
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema qualified as Schema
-import Harness.TestEnvironment (TestEnvironment (..))
+import Harness.TestEnvironment (TestEnvironment (..), testLogTrace)
 import Harness.Yaml (shouldReturnYaml)
 import Hasura.Prelude
 import Test.Hspec (SpecWith, describe, it)
@@ -64,5 +64,5 @@ tests opts = do
           actual :: IO Value
           actual = pure Null
 
-      logger testEnvironment "A log message\n"
+      testLogTrace testEnvironment ("A log message" :: Text)
       actual `shouldBe` expected

server/lib/test-harness/src/Harness/Backend/Cockroach.hs

@@ -47,7 +47,7 @@ import Harness.Test.Permissions qualified as Permissions
 import Harness.Test.Schema (BackendScalarType (..), BackendScalarValue (..), ScalarValue (..), SchemaName (..))
 import Harness.Test.Schema qualified as Schema
 import Harness.Test.SetupAction (SetupAction (..))
-import Harness.TestEnvironment (TestEnvironment (..), testLog)
+import Harness.TestEnvironment (TestEnvironment (..), testLogHarness)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -86,7 +86,7 @@ run_ testEnvironment =
 -- On error, print something useful for debugging.
 runInternal :: HasCallStack => TestEnvironment -> String -> String -> IO ()
 runInternal testEnvironment connectionString query = do
-  testLog
+  testLogHarness
     testEnvironment
     ( "Executing connection string: "
         <> connectionString

server/lib/test-harness/src/Harness/Backend/Postgres.hs

@@ -56,7 +56,7 @@ import Harness.Test.Schema
   )
 import Harness.Test.Schema qualified as Schema
 import Harness.Test.SetupAction (SetupAction (..))
-import Harness.TestEnvironment (TestEnvironment (..), testLog)
+import Harness.TestEnvironment (TestEnvironment (..), testLogHarness)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -102,7 +102,7 @@ run_ testEnvironment =
 -- On error, print something useful for debugging.
 runInternal :: HasCallStack => TestEnvironment -> String -> String -> IO ()
 runInternal testEnvironment connectionString query = do
-  testLog
+  testLogHarness
     testEnvironment
     ( "Executing connection string: "
         <> connectionString
@@ -139,7 +139,7 @@ queryWithInitialDb testEnvironment =
 -- On error, print something useful for debugging.
 queryInternal :: (Postgres.FromRow a) => HasCallStack => TestEnvironment -> String -> String -> IO [a]
 queryInternal testEnvironment connectionString query = do
-  testLog
+  testLogHarness
     testEnvironment
     ( "Querying connection string: "
         <> connectionString
@@ -425,7 +425,7 @@ setupTablesActionDiscardingTeardownErrors :: [Schema.Table] -> TestEnvironment -
 setupTablesActionDiscardingTeardownErrors ts env =
   SetupAction
     (setup ts (env, ()))
-    (const $ teardown ts (env, ()) `catchAny` \ex -> testLog env ("Teardown failed: " <> show ex))
+    (const $ teardown ts (env, ()) `catchAny` \ex -> testLogHarness env ("Teardown failed: " <> show ex))
 
 setupPermissionsAction :: [Permissions.Permission] -> TestEnvironment -> SetupAction
 setupPermissionsAction permissions env =

server/lib/test-harness/src/Harness/Backend/Sqlserver.hs

@@ -35,7 +35,7 @@ import Harness.Test.Fixture (SetupAction (..))
 import Harness.Test.Permissions qualified as Permissions
 import Harness.Test.Schema (BackendScalarType (..), BackendScalarValue (..), ScalarValue (..))
 import Harness.Test.Schema qualified as Schema
-import Harness.TestEnvironment (TestEnvironment, testLog)
+import Harness.TestEnvironment (TestEnvironment, testLogHarness)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -278,7 +278,7 @@ setupTablesActionDiscardingTeardownErrors :: [Schema.Table] -> TestEnvironment -
 setupTablesActionDiscardingTeardownErrors ts env =
   SetupAction
     (setup ts (env, ()))
-    (const $ teardown ts (env, ()) `catchAny` \ex -> testLog env ("Teardown failed: " <> show ex))
+    (const $ teardown ts (env, ()) `catchAny` \ex -> testLogHarness env ("Teardown failed: " <> show ex))
 
 setupPermissionsAction :: [Permissions.Permission] -> TestEnvironment -> SetupAction
 setupPermissionsAction permissions env =

server/lib/test-harness/src/Harness/GraphqlEngine.hs

@@ -54,7 +54,14 @@ import Harness.Constants qualified as Constants
 import Harness.Exceptions (bracket, withFrozenCallStack)
 import Harness.Http qualified as Http
 import Harness.Quoter.Yaml (yaml)
-import Harness.TestEnvironment (BackendSettings (..), Server (..), TestEnvironment (..), getServer, serverUrl, testLog, testLogBytestring)
+import Harness.TestEnvironment
+  ( BackendSettings (..),
+    Server (..),
+    TestEnvironment (..),
+    getServer,
+    serverUrl,
+    testLogHarness,
+  )
 import Hasura.App (Loggers (..), ServeCtx (..))
 import Hasura.App qualified as App
 import Hasura.Logging (Hasura)
@@ -111,10 +118,10 @@ postWithHeaders =
 postWithHeadersStatus ::
   HasCallStack => Int -> TestEnvironment -> String -> Http.RequestHeaders -> Value -> IO Value
 postWithHeadersStatus statusCode testEnv@(getServer -> Server {urlPrefix, port}) path headers requestBody = do
-  testLog testEnv $ "Posting to " <> path
-  testLogBytestring testEnv $ "Request body: " <> AP.encodePretty requestBody
+  testLogHarness testEnv $ "Posting to " <> T.pack path
+  testLogHarness testEnv $ "Request body: " <> AP.encodePretty requestBody
   responseBody <- withFrozenCallStack $ Http.postValueWithStatus statusCode (urlPrefix ++ ":" ++ show port ++ path) headers requestBody
-  testLogBytestring testEnv $ "Response body: " <> AP.encodePretty responseBody
+  testLogHarness testEnv $ "Response body: " <> AP.encodePretty responseBody
   pure responseBody
 
 -- | Post some JSON to graphql-engine, getting back more JSON.

server/lib/test-harness/src/Harness/Logging.hs

@@ -0,0 +1,73 @@
+module Harness.Logging
+  ( addLoggingFormatter,
+    loggingFormatter,
+    contextualizeLogger,
+    module Messages,
+  )
+where
+
+import Data.Text qualified as T
+import Harness.Logging.Messages as Messages
+import Harness.TestEnvironment
+import Hasura.Prelude
+import Test.Hspec.Core.Format qualified as Hspec
+import Test.Hspec.Core.Runner
+import Test.Hspec.Core.Spec
+
+-- | Make the logger in the 'TestEnvironment' add context about the specs that use it.
+contextualizeLogger :: SpecWith TestEnvironment -> SpecWith TestEnvironment
+contextualizeLogger = mapSpecForest (map contextualizeTree)
+
+contextualizeTree :: SpecTree TestEnvironment -> SpecTree TestEnvironment
+contextualizeTree spectree = go [] spectree
+  where
+    go :: [Text] -> SpecTree TestEnvironment -> SpecTree TestEnvironment
+    go ps (Node path children) = Node path (map (go (T.pack path : ps)) children)
+    go ps (NodeWithCleanup loc action children) =
+      NodeWithCleanup
+        loc
+        action
+        (map (go ps) children)
+    go ps (Leaf item) =
+      Leaf $
+        item
+          { itemExample =
+              \params actionRunner progressCallback ->
+                itemExample
+                  item
+                  params
+                  (actionRunner . (\action -> action . attachPrefix ps))
+                  progressCallback
+          }
+
+    attachPrefix :: [Text] -> TestEnvironment -> TestEnvironment
+    attachPrefix prefixes te =
+      te
+        { logger = Logger $ \msg -> runLogger (logger te) $ LogWithContext prefixes (fromLoggableMessage msg)
+        }
+
+-- | A Hspec 'Formatter' that outputs to a 'Logger'.
+loggingFormatter :: Logger -> Hspec.FormatConfig -> IO Hspec.Format
+loggingFormatter logger _formatConfig =
+  return $ liftIO . runLogger logger . LogHspecEvent
+
+-- Add the logging Hspec 'Formatter' on top of the existing formatter.
+addLoggingFormatter :: Logger -> Config -> Config
+addLoggingFormatter logger config =
+  config
+    { configFormat =
+        Just $ \formatConfig -> do
+          logFmt <- loggingFormatter logger formatConfig
+          originalFmt <- firstOrChosenFormatter $ formatConfig
+          return $ \event -> do
+            logFmt event
+            originalFmt event
+    }
+  where
+    emptyFormatter :: Hspec.FormatConfig -> IO Hspec.Format
+    emptyFormatter _ = return $ const (return ())
+
+    firstOrChosenFormatter
+      | Just f <- configFormat config = f -- The formatter chosen via cmdline args
+      | (_, f) : _ <- configAvailableFormatters config = f -- The first of the predefined formatters
+      | otherwise = emptyFormatter

server/lib/test-harness/src/Harness/Logging/Messages.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Harness.Logging.Messages
+  ( Logger (..),
+    TraceString,
+    LoggableMessage (..),
+    LogTrace (..),
+    logTrace,
+    LogHspecEvent (..),
+    LogWithContext (..),
+    LogHarness (..),
+    logHarness,
+    -- FastLogger integration
+    flLogger,
+  )
+where
+
+import Data.Aeson hiding (Error, Result, Success)
+import Data.Aeson.Types (Pair)
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as LBS
+import Data.Text qualified as T
+import Data.Text.Encoding
+import Data.Text.Lazy qualified as LT
+import GHC.TypeLits (ErrorMessage (..), TypeError)
+import Hasura.Prelude hiding (Seconds)
+import System.Log.FastLogger qualified as FL
+import Test.Hspec.Core.Format
+
+-- | Newtype wrapper around logging action to encapsulate existential type.
+newtype Logger = Logger {runLogger :: forall a. LoggableMessage a => a -> IO ()}
+
+-- | Type class to make it convenient to construct trace messages from various
+-- text string types. You should likely not define new instances of this class.
+class TraceString a where
+  toTraceString :: a -> Text
+
+instance TraceString String where
+  toTraceString = T.pack
+
+instance TraceString Text where
+  toTraceString = id
+
+instance TraceString LT.Text where
+  toTraceString = LT.toStrict
+
+instance TraceString LBS.ByteString where
+  toTraceString = decodeUtf8 . LBS.toStrict
+
+instance TraceString BS.ByteString where
+  toTraceString = decodeUtf8
+
+-- | Type class for message types which are loggable.
+-- This module defines most instances which we expect to have, but it's
+-- conceivable that certain spec or harness modules could legitimately define
+-- their own.
+--
+-- Expectations of message format stability may differ from instance to
+-- instance.
+class LoggableMessage a where
+  fromLoggableMessage :: a -> Value
+
+-- | We want the code to deliberately give _some_ semantics to the messages
+-- that are being logged, so we do not permit logging raw JSON values.
+--
+-- If you find yourself wanting to do this, consider defining a new, bespoke
+-- message type that describes what you want to log.
+instance TypeError ('Text "Please define a custom message type rather than logging raw JSON values") => LoggableMessage Value where
+  fromLoggableMessage = undefined
+
+newtype LogTrace = LogTrace Text
+
+instance LoggableMessage LogTrace where
+  fromLoggableMessage (LogTrace msg) =
+    object [("type", String "LogTrace"), ("message", String msg)]
+
+logTrace :: TraceString a => a -> LogTrace
+logTrace = LogTrace . toTraceString
+
+newtype LogHspecEvent = LogHspecEvent {unLogHspecEvent :: Event}
+
+instance LoggableMessage LogHspecEvent where
+  fromLoggableMessage (LogHspecEvent event) =
+    case event of
+      Started -> encEvent "Started" []
+      GroupStarted path -> encEvent "GroupStarted" (encPath path)
+      GroupDone path -> encEvent "GroupDone" (encPath path)
+      Progress path progress -> encEvent "Progress" (encPath path <> encProgress progress)
+      ItemStarted path -> encEvent "ItemStarted" (encPath path)
+      ItemDone path item -> encEvent "ItemDone" (encPath path <> encItem item)
+      Done items -> encEvent "Done" ([("no_items", toJSON (length items))])
+    where
+      encEvent :: Text -> [Pair] -> Value
+      encEvent eventTag eventFields =
+        object $
+          [ ("type", String "Hspec Event"),
+            ("event_tag", toJSON eventTag)
+          ]
+            <> eventFields
+
+      encPath :: ([String], String) -> [Pair]
+      encPath (groups, req) =
+        [ ("groups", toJSON groups),
+          ("requirement", toJSON req)
+        ]
+
+      encProgress :: Progress -> [Pair]
+      encProgress progress = [("progress", toJSON progress)]
+
+      encLocation :: Maybe Location -> Value
+      encLocation Nothing = Null
+      encLocation (Just Location {locationFile, locationLine, locationColumn}) =
+        object
+          [ ("file", toJSON locationFile),
+            ("line", toJSON locationLine),
+            ("column", toJSON locationColumn)
+          ]
+
+      encSeconds :: Seconds -> Value
+      encSeconds (Seconds secs) = toJSON secs
+
+      encResult :: Result -> Value
+      encResult result = case result of
+        Success -> object [("result", String "Success")]
+        Pending loc msg ->
+          object
+            [ ("result", String "Pending"),
+              ("location", encLocation loc),
+              ("message", toJSON msg)
+            ]
+        Failure loc failureReason ->
+          object
+            [ ("result", String "Failure"),
+              ("location", encLocation loc),
+              ("reason", encFailureReason failureReason)
+            ]
+
+      encFailureReason :: FailureReason -> Value
+      encFailureReason = \case
+        NoReason -> object [("failure_reason", String "NoReason")]
+        Reason reason ->
+          object
+            [ ("failure_reason", String "Reason"),
+              ("reason", toJSON reason)
+            ]
+        ExpectedButGot msg expected actual ->
+          object
+            [ ("failure_reason", String "ExpectedButGot"),
+              ("message", toJSON msg),
+              ("expected", toJSON expected),
+              ("actual", toJSON actual)
+            ]
+        Error msg exn ->
+          object
+            [ ("failure_reason", String "Error"),
+              ("message", toJSON msg),
+              ("exception", toJSON (show exn))
+            ]
+
+      encItem :: Item -> [Pair]
+      encItem Item {itemLocation, itemDuration, itemInfo, itemResult} =
+        [ ( "item",
+            object
+              [ ("location", encLocation itemLocation),
+                ("duration", encSeconds itemDuration),
+                ("info", toJSON itemInfo),
+                ("result", encResult itemResult)
+              ]
+          )
+        ]
+
+data LogWithContext = LogWithContext
+  { lwcContext :: [Text],
+    lwcLog :: Value
+  }
+
+instance LoggableMessage LogWithContext where
+  fromLoggableMessage LogWithContext {..} =
+    object
+      [ ("type", String "LogWithContext"),
+        ("context", toJSON lwcContext),
+        ("log", lwcLog)
+      ]
+
+-- | Temporary message type for messages logged from within the Harness modules.
+-- Ideally these should have more bespoke message types to make the logs easier
+-- to sort through.
+newtype LogHarness = LogHarness {unLogHarness :: Text}
+
+logHarness :: TraceString a => a -> LogHarness
+logHarness = LogHarness . toTraceString
+
+instance LoggableMessage LogHarness where
+  fromLoggableMessage (LogHarness msg) =
+    object
+      [ ("type", String "LogHarness"),
+        ("message", String msg)
+      ]
+
+-- | 'fast-logger' integration.
+flLogger :: (FL.LogStr -> IO ()) -> Logger
+flLogger logAction = Logger (logAction . msgToLogStr)
+
+msgToLogStr :: LoggableMessage a => a -> FL.LogStr
+msgToLogStr = FL.toLogStr . (<> "\n") . encode . fromLoggableMessage

server/lib/test-harness/src/Harness/Subscriptions.hs

@@ -34,7 +34,11 @@ import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import Harness.Exceptions (throw, withFrozenCallStack)
-import Harness.TestEnvironment (Server (..), TestEnvironment (..), testLog, testLogBytestring)
+import Harness.TestEnvironment
+  ( Server (..),
+    TestEnvironment (..),
+    testLogHarness,
+  )
 import Hasura.Prelude
 import Network.WebSockets qualified as WS
 import System.Timeout (timeout)
@@ -137,12 +141,12 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
           msgBytes <- WS.receiveData conn
           case eitherDecode msgBytes of
             Left err -> do
-              testLog testEnvironment $ "Subscription decode failed: " ++ err
-              testLogBytestring testEnvironment $ "Payload was: " <> msgBytes
+              testLogHarness testEnvironment $ "Subscription decode failed: " ++ err
+              testLogHarness testEnvironment $ "Payload was: " <> msgBytes
               throw $ userError (unlines ["Subscription decode failed: " <> err, "Payload: " <> show msgBytes])
             Right msg -> do
               when (isInteresting msg) do
-                testLog testEnvironment $ "subscriptions message: " ++ jsonToString msg
+                testLogHarness testEnvironment $ "subscriptions message: " ++ jsonToString msg
 
                 let maybePayload :: Maybe Value
                     maybePayload = preview (key "payload") msg
@@ -152,7 +156,7 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
 
                 case liftA2 (,) maybePayload maybeIdentifier of
                   Nothing -> do
-                    testLog testEnvironment "Unable to parse message"
+                    testLogHarness testEnvironment ("Unable to parse message" :: Text)
                     throw $ userError ("Unable to parse message: " ++ show msg)
                   Just (payload, identifier) ->
                     readIORef handlers >>= \mvars ->
@@ -179,8 +183,8 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
           atomicModify handlers (Map.insert (tshow subId) messageBox)
 
           -- initialize a connection.
-          testLog testEnvironment ("Initialising websocket connection")
-          testLogBytestring testEnvironment (encode query)
+          testLogHarness testEnvironment ("Initialising websocket connection" :: Text)
+          testLogHarness testEnvironment (encode query)
           WS.sendTextData conn (encode $ startQueryMessage subId query extras)
           pure $ SubscriptionHandle messageBox
 

server/lib/test-harness/src/Harness/Test/Fixture.hs

@@ -37,7 +37,7 @@ import Harness.Exceptions
 import Harness.Test.BackendType
 import Harness.Test.CustomOptions
 import Harness.Test.SetupAction (SetupAction (..))
-import Harness.TestEnvironment (TestEnvironment (..), testLog)
+import Harness.TestEnvironment (TestEnvironment (..), testLogHarness)
 import Hasura.Prelude
 import Test.Hspec
   ( ActionWith,
@@ -124,7 +124,7 @@ fixtureBracket :: Fixture b -> (ActionWith (TestEnvironment, b)) -> ActionWith T
 fixtureBracket Fixture {name, mkLocalTestEnvironment, setupTeardown} actionWith globalTestEnvironment =
   mask \restore -> do
     -- log DB of test
-    testLog globalTestEnvironment $ "Testing " <> show name <> "..."
+    testLogHarness globalTestEnvironment $ "Testing " <> show name <> "..."
 
     localTestEnvironment <- mkLocalTestEnvironment globalTestEnvironment
 
@@ -215,20 +215,20 @@ runSetupActions testEnv acts = go acts []
         -- commented out.
         case a of
           Left (exn :: SomeException) -> do
-            testLog testEnv $ "Setup failed for step " ++ show (length cleanupAcc) ++ "."
+            testLogHarness testEnv $ "Setup failed for step " ++ show (length cleanupAcc) ++ "."
             rethrowAll
               ( throwIO exn
-                  : ( testLog testEnv ("Teardown failed for step " ++ show (length cleanupAcc) ++ ".")
+                  : ( testLogHarness testEnv ("Teardown failed for step " ++ show (length cleanupAcc) ++ ".")
                         >> teardownAction Nothing
                     )
                   : cleanupAcc
               )
             return (return ())
           Right x -> do
-            testLog testEnv $ "Setup for step " ++ show (length cleanupAcc) ++ " succeeded."
+            testLogHarness testEnv $ "Setup for step " ++ show (length cleanupAcc) ++ " succeeded."
             go
               rest
-              ( ( testLog testEnv ("Teardown for step " ++ show (length cleanupAcc) ++ " succeeded.")
+              ( ( testLogHarness testEnv ("Teardown for step " ++ show (length cleanupAcc) ++ " succeeded.")
                     >> teardownAction (Just x)
                 )
                   : cleanupAcc

server/lib/test-harness/src/Harness/TestEnvironment.hs

@@ -9,30 +9,28 @@ module Harness.TestEnvironment
     getServer,
     serverUrl,
     stopServer,
-    testLog,
+    testLogTrace,
+    testLogMessage,
     testLogShow,
-    testLogBytestring,
+    testLogHarness,
   )
 where
 
 import Control.Concurrent.Async (Async)
 import Control.Concurrent.Async qualified as Async
-import Data.ByteString.Lazy qualified as LBS
-import Data.String (fromString)
-import Data.Text qualified as T
-import Data.Text.Encoding
 import Data.UUID (UUID)
 import Data.Word
+import Harness.Logging.Messages
 import Harness.Test.BackendType
 import Hasura.Prelude
-import System.Log.FastLogger qualified as FL
+import Text.Pretty.Simple
 
 -- | A testEnvironment that's passed to all tests.
 data TestEnvironment = TestEnvironment
   { -- | connection details for the instance of HGE we're connecting to
     server :: Server,
     -- | shared function to log information from tests
-    logger :: FL.LogStr -> IO (),
+    logger :: Logger,
     -- | action to clean up logger
     loggerCleanup :: IO (),
     -- | a uuid generated for each test suite used to generate a unique
@@ -83,17 +81,25 @@ serverUrl Server {urlPrefix, port} = urlPrefix ++ ":" ++ show port
 stopServer :: Server -> IO ()
 stopServer Server {thread} = Async.cancel thread
 
--- | log a string out in tests
-testLog :: TestEnvironment -> String -> IO ()
-testLog testEnv =
-  logger testEnv . fromString . (<>) "\n"
+-- | Log a structured message in tests
+testLogMessage :: LoggableMessage a => TestEnvironment -> a -> IO ()
+testLogMessage testEnv = runLogger (logger testEnv)
 
--- | log a Show-able value in tests
+-- | Log an unstructured trace string. Should only be used directly in specs,
+-- not in the Harness modules.
+testLogTrace :: TraceString a => TestEnvironment -> a -> IO ()
+testLogTrace testEnv =
+  testLogMessage testEnv . logTrace
+
+-- | Log a Show-able value trace string in tests. Should only be used directly
+-- in specs, not in the Harness modules.
 testLogShow :: (Show a) => TestEnvironment -> a -> IO ()
 testLogShow testEnv =
-  testLog testEnv . show
+  testLogTrace testEnv . pShowNoColor
 
--- | log a UTF-8 Bytestring. Forgive me Padre for converting through String
-testLogBytestring :: TestEnvironment -> LBS.ByteString -> IO ()
-testLogBytestring testEnv =
-  testLog testEnv . T.unpack . decodeUtf8 . LBS.toStrict
+-- | log a trace message happening in the Harness modules. Should only be used
+-- in the Harness modules, not in Specs.
+--
+-- This should ideally be replaced with more specific logging functions.
+testLogHarness :: TraceString a => TestEnvironment -> a -> IO ()
+testLogHarness testEnv = testLogMessage testEnv . logHarness

server/lib/test-harness/test-harness.cabal

@@ -35,6 +35,7 @@ library
     , parsec
     , pg-client
     , postgresql-simple
+    , pretty-simple
     , refined
     , resourcet
     , safe-exceptions
@@ -100,6 +101,8 @@ library
     Harness.Exceptions
     Harness.GraphqlEngine
     Harness.Http
+    Harness.Logging
+    Harness.Logging.Messages
     Harness.Quoter.Graphql
     Harness.Quoter.Yaml
     Harness.Quoter.Yaml.InterpolateYaml