Structured logging in test-harness

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7092
GitOrigin-RevId: 201ee3ddc205bfc9d55c167e0b70b6606dbe4aa7

.hlint.yaml

@@ -50,6 +50,38 @@
         within: []
         message: "Specs with focusing should only be used during development"
 
+      - name: "Harness.TestEnvironment.testLogHarness"
+        within: []
+        message: "testLogHarness should only be ad-hoc during development. Please define proper log message data types for published code"
+
+      - name: "Harness.Logging.LogHarness"
+        within: []
+        message: "LogHarness should only be ad-hoc during development. Please define proper log message data types for published code"
+
+      - name: "Harness.Logging.Messages.LogHarness"
+        within: []
+        message: "LogHarness should only be ad-hoc during development. Please define proper log message data types for published code"
+
+      - name: "Harness.TestEnvironment.testLogTrace"
+        within: ["Test.**"]
+        message: "testLogTrace should only be used outside the test-harness package"
+
+      - name: "Harness.Logging.LogTrace"
+        within: ["Test.**"]
+        message: "LogTrace should only be used outside the test-harness package"
+
+      - name: "Harness.Logging.Messages.LogTrace"
+        within: ["Test.**"]
+        message: "LogTrace should only be used outside the test-harness package"
+
+      - name: "Harness.Logging.logTrace"
+        within: ["Test.**"]
+        message: "logTrace should only be used outside the test-harness package"
+
+      - name: "Harness.Logging.Messages.logTrace"
+        within: ["Test.**"]
+        message: "logTrace should only be used outside the test-harness package"
+
 # Add custom hints for this project
 #
 # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

server/lib/api-tests/src/Test/EventTriggers/MSSQL/EventTriggerDropSourceCleanupSpec.hs

@@ -14,6 +14,7 @@ import Harness.Quoter.Yaml
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (TestEnvironment)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldBeYaml, shouldReturnYaml)
@@ -34,7 +35,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment,
+                [ permitTeardownFail (Sqlserver.setupTablesAction (schema "authors") testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = mssqlSetupWithEventTriggers testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> pure ()

server/lib/api-tests/src/Test/EventTriggers/MSSQL/EventTriggersUntrackTableCleanupSpec.hs

@@ -13,6 +13,7 @@ import Harness.Quoter.Yaml
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (TestEnvironment)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldBeYaml, shouldReturnYaml)
@@ -33,7 +34,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment,
+                [ permitTeardownFail (Sqlserver.setupTablesAction (schema "authors") testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = mssqlSetup testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> pure ()

server/lib/api-tests/src/Test/EventTriggers/PG/EventTriggersExtensionSchemaSpec.hs

@@ -15,6 +15,7 @@ import Harness.Test.BackendType qualified as BackendType
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (TestEnvironment)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldBeYaml, shouldReturnYaml)
@@ -35,7 +36,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Postgres.setupTablesActionDiscardingTeardownErrors schema testEnvironment,
+                [ permitTeardownFail (Postgres.setupTablesAction schema testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = postgresSetup testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> postgresTeardown testEnvironment

server/lib/api-tests/src/Test/EventTriggers/PG/EventTriggersReplaceMetadataCleanupSpec.hs

@@ -15,6 +15,7 @@ import Harness.Quoter.Yaml
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (TestEnvironment)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldReturnYaml)
@@ -33,7 +34,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment,
+                [ permitTeardownFail (Postgres.setupTablesAction (schema "authors") testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = postgresSetup testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> pure ()

server/lib/api-tests/src/Test/EventTriggers/PG/EventTriggersRunSQLSpec.hs

@@ -17,6 +17,7 @@ import Harness.Quoter.Yaml
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (Server (..), TestEnvironment, getServer)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldBeYaml, shouldReturnYaml)
@@ -38,7 +39,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment,
+                [ permitTeardownFail (Postgres.setupTablesAction (schema "authors") testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = postgresSetup testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> postgresTeardown testEnvironment

server/lib/api-tests/src/Test/EventTriggers/PG/EventTriggersUntrackTableCleanupSpec.hs

@@ -13,6 +13,7 @@ import Harness.Quoter.Yaml
 import Harness.Test.Fixture qualified as Fixture
 import Harness.Test.Schema (Table (..), table)
 import Harness.Test.Schema qualified as Schema
+import Harness.Test.SetupAction (permitTeardownFail)
 import Harness.TestEnvironment (TestEnvironment)
 import Harness.Webhook qualified as Webhook
 import Harness.Yaml (shouldBeYaml, shouldReturnYaml)
@@ -33,7 +34,7 @@ spec =
               -- so that the server can be referenced while testing
               Fixture.mkLocalTestEnvironment = const Webhook.run,
               Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) ->
-                [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment,
+                [ permitTeardownFail (Postgres.setupTablesAction (schema "authors") testEnvironment),
                   Fixture.SetupAction
                     { Fixture.setupAction = postgresSetup testEnvironment webhookServer,
                       Fixture.teardownAction = \_ -> pure ()

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

@@ -42,13 +42,14 @@ import Harness.Backend.Postgres qualified as Postgres
 import Harness.Constants as Constants
 import Harness.Exceptions
 import Harness.GraphqlEngine qualified as GraphqlEngine
+import Harness.Logging
 import Harness.Quoter.Yaml (interpolateYaml)
 import Harness.Test.BackendType (BackendType (Citus), defaultBackendTypeString, defaultSource)
 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 (..), testLogHarness)
+import Harness.TestEnvironment (TestEnvironment (..), testLogMessage)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -86,14 +87,7 @@ run_ testEnvironment =
 -- On error, print something useful for debugging.
 runInternal :: HasCallStack => TestEnvironment -> String -> String -> IO ()
 runInternal testEnvironment connectionString query = do
-  testLogHarness
-    testEnvironment
-    ( "Executing connection string: "
-        <> connectionString
-        <> "\n"
-        <> "Query: "
-        <> query
-    )
+  testLogMessage testEnvironment $ LogDBQuery (T.pack connectionString) (T.pack query)
   catch
     ( bracket
         ( Postgres.connectPostgreSQL
@@ -255,10 +249,11 @@ createDatabase testEnvironment = do
 -- up.
 dropDatabase :: TestEnvironment -> IO ()
 dropDatabase testEnvironment = do
+  let dbName = uniqueDbName (uniqueTestId testEnvironment)
   runWithInitialDb_
     testEnvironment
-    ("DROP DATABASE " <> uniqueDbName (uniqueTestId testEnvironment) <> " WITH (FORCE);")
-    `catch` \(ex :: SomeException) -> testLogHarness testEnvironment ("Failed to drop the database: " <> show ex)
+    ("DROP DATABASE " <> dbName <> " WITH (FORCE);")
+    `catch` \(ex :: SomeException) -> testLogMessage testEnvironment (LogDropDBFailedWarning (T.pack dbName) ex)
 
 -- | Setup the schema in the most expected way.
 -- NOTE: Certain test modules may warrant having their own local version.

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

@@ -41,13 +41,14 @@ import Harness.Backend.Postgres qualified as Postgres
 import Harness.Constants as Constants
 import Harness.Exceptions
 import Harness.GraphqlEngine qualified as GraphqlEngine
+import Harness.Logging
 import Harness.Quoter.Yaml (interpolateYaml)
 import Harness.Test.BackendType (BackendType (Cockroach), defaultBackendTypeString, defaultSource)
 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 (..), testLogHarness)
+import Harness.TestEnvironment (TestEnvironment (..), testLogMessage)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -86,14 +87,7 @@ run_ testEnvironment =
 -- On error, print something useful for debugging.
 runInternal :: HasCallStack => TestEnvironment -> String -> String -> IO ()
 runInternal testEnvironment connectionString query = do
-  testLogHarness
-    testEnvironment
-    ( "Executing connection string: "
-        <> connectionString
-        <> "\n"
-        <> "Query: "
-        <> query
-    )
+  testLogMessage testEnvironment $ LogDBQuery (T.pack connectionString) (T.pack query)
   catch
     ( bracket
         ( Postgres.connectPostgreSQL
@@ -261,7 +255,7 @@ dropDatabase testEnvironment = do
   runWithInitialDb_
     testEnvironment
     ("DROP DATABASE " <> dbName <> ";")
-    `catch` \(ex :: SomeException) -> testLogHarness testEnvironment ("Failed to drop the database: " <> show ex)
+    `catch` \(ex :: SomeException) -> testLogMessage testEnvironment (LogDropDBFailedWarning (T.pack dbName) ex)
 
 -- Because the test harness sets the schema name we use for testing, we need
 -- to make sure it exists before we run the tests.

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

@@ -20,7 +20,6 @@ module Harness.Backend.Postgres
     trackTable,
     untrackTable,
     setupTablesAction,
-    setupTablesActionDiscardingTeardownErrors,
     setupPermissionsAction,
     setupFunctionRootFieldAction,
     setupComputedFieldAction,
@@ -41,12 +40,14 @@ import Data.ByteString.Char8 qualified as S8
 import Data.String (fromString)
 import Data.String.Interpolate (i)
 import Data.Text qualified as T
+import Data.Text.Encoding (decodeUtf8)
 import Data.Text.Extended (commaSeparated)
 import Data.Time (defaultTimeLocale, formatTime)
 import Database.PostgreSQL.Simple qualified as Postgres
 import Harness.Constants as Constants
 import Harness.Exceptions
 import Harness.GraphqlEngine qualified as GraphqlEngine
+import Harness.Logging
 import Harness.Quoter.Yaml (interpolateYaml)
 import Harness.Test.BackendType (BackendType (Postgres), defaultBackendTypeString, defaultSource)
 import Harness.Test.Permissions qualified as Permissions
@@ -58,7 +59,7 @@ import Harness.Test.Schema
   )
 import Harness.Test.Schema qualified as Schema
 import Harness.Test.SetupAction (SetupAction (..))
-import Harness.TestEnvironment (TestEnvironment (..), TestingMode (..), testLogHarness)
+import Harness.TestEnvironment (TestEnvironment (..), TestingMode (..), testLogMessage)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -137,14 +138,7 @@ run_ testEnvironment =
 -- On error, print something useful for debugging.
 runInternal :: HasCallStack => TestEnvironment -> S8.ByteString -> String -> IO ()
 runInternal testEnvironment connectionString query = do
-  testLogHarness
-    testEnvironment
-    ( "Executing connection string: "
-        <> show connectionString
-        <> "\n"
-        <> "Query: "
-        <> query
-    )
+  testLogMessage testEnvironment $ LogDBQuery (decodeUtf8 connectionString) (T.pack query)
   catch
     ( bracket
         ( Postgres.connectPostgreSQL
@@ -174,14 +168,7 @@ queryWithInitialDb testEnvironment =
 -- On error, print something useful for debugging.
 queryInternal :: (Postgres.FromRow a) => HasCallStack => TestEnvironment -> S8.ByteString -> String -> IO [a]
 queryInternal testEnvironment connectionString query = do
-  testLogHarness
-    testEnvironment
-    ( "Querying connection string: "
-        <> show connectionString
-        <> "\n"
-        <> "Query: "
-        <> query
-    )
+  testLogMessage testEnvironment $ LogDBQuery (decodeUtf8 connectionString) (T.pack query)
   catch
     ( bracket
         ( Postgres.connectPostgreSQL
@@ -394,7 +381,7 @@ dropDatabase testEnvironment = do
   runWithInitialDb_
     testEnvironment
     ("DROP DATABASE " <> dbName <> ";")
-    `catch` \(ex :: SomeException) -> testLogHarness testEnvironment ("Failed to drop the database: " <> show ex)
+    `catch` \(ex :: SomeException) -> testLogMessage testEnvironment (LogDropDBFailedWarning (T.pack dbName) ex)
 
 -- Because the test harness sets the schema name we use for testing, we need
 -- to make sure it exists before we run the tests.
@@ -444,12 +431,6 @@ setupTablesAction ts env =
     (setup ts (env, ()))
     (const $ teardown ts (env, ()))
 
-setupTablesActionDiscardingTeardownErrors :: [Schema.Table] -> TestEnvironment -> SetupAction
-setupTablesActionDiscardingTeardownErrors ts env =
-  SetupAction
-    (setup ts (env, ()))
-    (const $ teardown ts (env, ()) `catchAny` \ex -> testLogHarness env ("Teardown failed: " <> show ex))
-
 setupPermissionsAction :: [Permissions.Permission] -> TestEnvironment -> SetupAction
 setupPermissionsAction permissions env =
   SetupAction

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

@@ -15,7 +15,6 @@ module Harness.Backend.Sqlserver
     dropTable,
     untrackTable,
     setupTablesAction,
-    setupTablesActionDiscardingTeardownErrors,
     setupPermissionsAction,
   )
 where
@@ -32,13 +31,14 @@ import Database.ODBC.SQLServer qualified as Sqlserver
 import Harness.Constants qualified as Constants
 import Harness.Exceptions
 import Harness.GraphqlEngine qualified as GraphqlEngine
+import Harness.Logging
 import Harness.Quoter.Yaml (yaml)
 import Harness.Test.BackendType (BackendType (SQLServer), defaultBackendTypeString, defaultSource)
 import Harness.Test.Permissions qualified as Permissions
 import Harness.Test.Schema (BackendScalarType (..), BackendScalarValue (..), ScalarValue (..))
 import Harness.Test.Schema qualified as Schema
 import Harness.Test.SetupAction (SetupAction (..))
-import Harness.TestEnvironment (TestEnvironment (..), testLogHarness)
+import Harness.TestEnvironment (TestEnvironment (..), testLogMessage)
 import Hasura.Prelude
 import System.Process.Typed
 
@@ -74,14 +74,7 @@ runWithInitialDb_ testEnvironment =
 -- result. Just checks for errors.
 runInternal :: HasCallStack => TestEnvironment -> Text -> String -> IO ()
 runInternal testEnvironment connectionString query' = do
-  testLogHarness
-    testEnvironment
-    ( "Executing with connection string: "
-        <> show connectionString
-        <> "\n"
-        <> "Query: "
-        <> query'
-    )
+  testLogMessage testEnvironment $ LogDBQuery connectionString (T.pack query')
   catch
     ( bracket
         (Sqlserver.connect connectionString)
@@ -279,7 +272,7 @@ dropDatabase testEnvironment = do
   runWithInitialDb_
     testEnvironment
     [i|DROP DATABASE #{dbName}|]
-    `catch` \(ex :: SomeException) -> testLogHarness testEnvironment ("Failed to drop the database: " <> show ex)
+    `catch` \(ex :: SomeException) -> testLogMessage testEnvironment (LogDropDBFailedWarning (T.pack dbName) ex)
 
 -- Because the test harness sets the schema name we use for testing, we need
 -- to make sure it exists before we run the tests.
@@ -330,12 +323,6 @@ setupTablesAction ts env =
     (setup ts (env, ()))
     (const $ teardown ts (env, ()))
 
-setupTablesActionDiscardingTeardownErrors :: [Schema.Table] -> TestEnvironment -> SetupAction
-setupTablesActionDiscardingTeardownErrors ts env =
-  SetupAction
-    (setup ts (env, ()))
-    (const $ teardown ts (env, ()) `catchAny` \ex -> testLogHarness env ("Teardown failed: " <> show ex))
-
 setupPermissionsAction :: [Permissions.Permission] -> TestEnvironment -> SetupAction
 setupPermissionsAction permissions env =
   SetupAction

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

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

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

@@ -9,6 +9,17 @@ module Harness.Logging.Messages
     logTrace,
     LogHspecEvent (..),
     LogWithContext (..),
+    LogHGERequest (..),
+    LogHGEResponse (..),
+    LogDBQuery (..),
+    LogDropDBFailedWarning (..),
+    LogSubscriptionInit (..),
+    LogSubscriptionResponse (..),
+    LogFixtureTestStart (..),
+    LogFixtureSetupFailed (..),
+    LogFixtureSetupSucceeded (..),
+    LogFixtureTeardownFailed (..),
+    LogFixtureTeardownSucceeded (..),
     LogHarness (..),
     logHarness,
     -- FastLogger integration
@@ -16,6 +27,7 @@ module Harness.Logging.Messages
   )
 where
 
+import Control.Exception.Safe
 import Data.Aeson hiding (Error, Result, Success)
 import Data.Aeson.Types (Pair)
 import Data.ByteString qualified as BS
@@ -183,6 +195,128 @@ instance LoggableMessage LogWithContext where
         ("log", lwcLog)
       ]
 
+data LogHGERequest = LogHGERequest
+  { lhRequestPath :: Text,
+    lhRequestBody :: Value
+  }
+
+instance LoggableMessage LogHGERequest where
+  fromLoggableMessage LogHGERequest {..} =
+    object
+      [ ("type", String "LogHGERequest"),
+        ("path", String lhRequestPath),
+        ("body", lhRequestBody)
+      ]
+
+data LogHGEResponse = LogHGEResponse
+  { lhResponsePath :: Text,
+    lhResponseBody :: Value
+  }
+
+instance LoggableMessage LogHGEResponse where
+  fromLoggableMessage LogHGEResponse {..} =
+    object
+      [ ("type", String "LogHGEResponse"),
+        ("path", String lhResponsePath),
+        ("body", lhResponseBody)
+      ]
+
+data LogDBQuery = LogDBQuery
+  { ldqConnectionString :: Text,
+    ldqQuery :: Text
+  }
+
+instance LoggableMessage LogDBQuery where
+  fromLoggableMessage LogDBQuery {..} =
+    object
+      [ ("type", String "LogDBQuery"),
+        ("connection_string", String ldqConnectionString),
+        ("query", String ldqQuery)
+      ]
+
+data LogDropDBFailedWarning = LogDropDBFailedWarning
+  { lddfwDatabaseName :: Text,
+    lddfwException :: SomeException
+  }
+
+instance LoggableMessage LogDropDBFailedWarning where
+  fromLoggableMessage LogDropDBFailedWarning {..} =
+    object
+      [ ("type", String "LogDropDBFailedWarning"),
+        ("database_name", String lddfwDatabaseName),
+        ("exception", String (tshow lddfwException))
+      ]
+
+data LogSubscriptionInit = LogSubscriptionInit
+  {lsiQuery :: Value}
+
+instance LoggableMessage LogSubscriptionInit where
+  fromLoggableMessage LogSubscriptionInit {..} =
+    object
+      [ ("type", String "LogSubscriptionInit"),
+        ("query", lsiQuery)
+      ]
+
+data LogSubscriptionResponse = LogSubscriptionResponse
+  {lsrBody :: Value}
+
+instance LoggableMessage LogSubscriptionResponse where
+  fromLoggableMessage LogSubscriptionResponse {..} =
+    object
+      [ ("type", String "LogSubscriptionResponse"),
+        ("body", lsrBody)
+      ]
+
+data LogFixtureTestStart = LogFixtureTestStart
+  {lftsFixtureName :: Text}
+
+instance LoggableMessage LogFixtureTestStart where
+  fromLoggableMessage LogFixtureTestStart {..} =
+    object
+      [ ("type", String "LogFixtureTestStart"),
+        ("fixture_name", String lftsFixtureName)
+      ]
+
+data LogFixtureSetupSucceeded = LogFixtureSetupSucceeded
+  {lfssStep :: Int}
+
+instance LoggableMessage LogFixtureSetupSucceeded where
+  fromLoggableMessage LogFixtureSetupSucceeded {..} =
+    object
+      [ ("type", String "LogFixtureSetupSucceeded"),
+        ("step", Number (fromIntegral lfssStep))
+      ]
+
+data LogFixtureSetupFailed = LogFixtureSetupFailed
+  {lfsfStep :: Int}
+
+instance LoggableMessage LogFixtureSetupFailed where
+  fromLoggableMessage LogFixtureSetupFailed {..} =
+    object
+      [ ("type", String "LogFixtureSetupFailed"),
+        ("step", Number (fromIntegral lfsfStep))
+      ]
+
+data LogFixtureTeardownSucceeded = LogFixtureTeardownSucceeded
+  {lftsStep :: Int}
+
+instance LoggableMessage LogFixtureTeardownSucceeded where
+  fromLoggableMessage LogFixtureTeardownSucceeded {..} =
+    object
+      [ ("type", String "LogFixtureTeardownSucceeded"),
+        ("step", Number (fromIntegral lftsStep))
+      ]
+
+data LogFixtureTeardownFailed = LogFixtureTeardownFailed
+  {lftfStep :: Int}
+
+instance LoggableMessage LogFixtureTeardownFailed where
+  fromLoggableMessage LogFixtureTeardownFailed {..} =
+    object
+      [ ("type", String "LogFixtureTeardownFailed"),
+        ("step", Number (fromIntegral lftfStep))
+      ]
+
 -- | 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.

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

@@ -32,12 +32,12 @@ import Data.Aeson.QQ.Simple
 import Data.Aeson.Types (Pair)
 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.Logging.Messages
 import Harness.TestEnvironment
   ( Server (..),
     TestEnvironment (..),
-    testLogHarness,
+    testLogMessage,
   )
 import Hasura.Prelude
 import Network.WebSockets qualified as WS
@@ -120,10 +120,6 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
         atomicModify :: IORef x -> (x -> x) -> IO ()
         atomicModify ref f = atomicModifyIORef' ref \x -> (f x, ())
 
-        -- Convenience function for converting JSON values to strings.
-        jsonToString :: Value -> String
-        jsonToString = T.unpack . WS.fromLazyByteString . encode
-
         -- Is this an actual message or client/server busywork?
         isInteresting :: Value -> Bool
         isInteresting res =
@@ -141,12 +137,10 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
           msgBytes <- WS.receiveData conn
           case eitherDecode msgBytes of
             Left err -> do
-              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
-                testLogHarness testEnvironment $ "subscriptions message: " ++ jsonToString msg
+                testLogMessage testEnvironment $ LogSubscriptionResponse msg
 
                 let maybePayload :: Maybe Value
                     maybePayload = preview (key "payload") msg
@@ -156,7 +150,6 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
 
                 case liftA2 (,) maybePayload maybeIdentifier of
                   Nothing -> do
-                    testLogHarness testEnvironment ("Unable to parse message" :: Text)
                     throw $ userError ("Unable to parse message: " ++ show msg)
                   Just (payload, identifier) ->
                     readIORef handlers >>= \mvars ->
@@ -183,8 +176,7 @@ withSubscriptions = aroundAllWith \actionWithSubAndTest testEnvironment -> do
           atomicModify handlers (Map.insert (tshow subId) messageBox)
 
           -- initialize a connection.
-          testLogHarness testEnvironment ("Initialising websocket connection" :: Text)
-          testLogHarness testEnvironment (encode query)
+          testLogMessage testEnvironment $ LogSubscriptionInit query
           WS.sendTextData conn (encode $ startQueryMessage subId query extras)
           pure $ SubscriptionHandle messageBox
 

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

@@ -47,7 +47,7 @@ import Harness.Test.BackendType
 import Harness.Test.CustomOptions
 import Harness.Test.SetupAction (SetupAction (..))
 import Harness.Test.SetupAction qualified as SetupAction
-import Harness.TestEnvironment (Server, TestEnvironment (..), TestingMode (..), testLogHarness)
+import Harness.TestEnvironment (Server, TestEnvironment (..), TestingMode (..), testLogMessage)
 import Hasura.Prelude hiding (log)
 import Test.Hspec
   ( ActionWith,
@@ -162,7 +162,7 @@ fixtureBracket
   globalTestEnvironment =
     mask \restore -> runManaged do
       -- log DB of test
-      liftIO $ testLogHarness globalTestEnvironment $ "Testing " <> show name <> "..."
+      liftIO $ testLogMessage globalTestEnvironment $ LogFixtureTestStart (tshow name)
       localTestEnvironment <- mkLocalTestEnvironment globalTestEnvironment
       liftIO $ do
         globalTestEnvWithUnique <- setupUniqueGlobalTestEnvironment name globalTestEnvironment
@@ -254,7 +254,8 @@ fixtureRepl Fixture {name, mkLocalTestEnvironment, setupTeardown} globalTestEnvi
 runSetupActions :: Logger -> [SetupAction] -> IO (IO ())
 runSetupActions logger acts = go acts []
   where
-    log = runLogger logger . LogHarness . T.pack
+    log :: forall a. LoggableMessage a => a -> IO ()
+    log = runLogger logger
 
     go :: [SetupAction] -> [IO ()] -> IO (IO ())
     go actions cleanupAcc = case actions of
@@ -267,20 +268,20 @@ runSetupActions logger acts = go acts []
         -- commented out.
         case a of
           Left (exn :: SomeException) -> do
-            log $ "Setup failed for step " ++ show (length cleanupAcc) ++ "."
+            log $ LogFixtureSetupFailed (length cleanupAcc)
             rethrowAll
               ( throwIO exn
-                  : ( log ("Teardown failed for step " ++ show (length cleanupAcc) ++ ".")
+                  : ( log (LogFixtureTeardownFailed (length cleanupAcc))
                         >> teardownAction Nothing
                     )
                   : cleanupAcc
               )
             return (return ())
           Right x -> do
-            log $ "Setup for step " ++ show (length cleanupAcc) ++ " succeeded."
+            log $ LogFixtureSetupSucceeded (length cleanupAcc)
             go
               rest
-              ( ( log ("Teardown for step " ++ show (length cleanupAcc) ++ " succeeded.")
+              ( ( log (LogFixtureTeardownSucceeded (length cleanupAcc))
                     >> teardownAction (Just x)
                 )
                   : cleanupAcc

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

@@ -2,9 +2,11 @@
 module Harness.Test.SetupAction
   ( SetupAction (..),
     clearMetadata,
+    permitTeardownFail,
   )
 where
 
+import Control.Exception.Safe (catchAny)
 import Harness.GraphqlEngine qualified as GraphqlEngine
 import Harness.TestEnvironment (TestEnvironment (..))
 import Hasura.Prelude
@@ -27,3 +29,10 @@ clearMetadata testEnv =
     { setupAction = GraphqlEngine.clearMetadata testEnv,
       teardownAction = \_ -> GraphqlEngine.clearMetadata testEnv
     }
+
+permitTeardownFail :: SetupAction -> SetupAction
+permitTeardownFail SetupAction {teardownAction = ta, setupAction = sa} =
+  SetupAction
+    { setupAction = sa,
+      teardownAction = (\a -> ta a `catchAny` \_ -> return ())
+    }

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

@@ -98,6 +98,7 @@ testLogMessage testEnv = runLogger (logger testEnv)
 
 -- | Log an unstructured trace string. Should only be used directly in specs,
 -- not in the Harness modules.
+{-# ANN testLogTrace ("HLINT: ignore" :: String) #-}
 testLogTrace :: TraceString a => TestEnvironment -> a -> IO ()
 testLogTrace testEnv =
   testLogMessage testEnv . logTrace