mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-09-11 10:46:25 +03:00
Structured logging in test-harness
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/7092 GitOrigin-RevId: 201ee3ddc205bfc9d55c167e0b70b6606dbe4aa7
This commit is contained in:
parent
e084126c73
commit
9bc1ff1d8e
32
.hlint.yaml
32
.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"
|
||||
|
@ -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 ()
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
@ -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 ()
|
||||
|
@ -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
|
||||
|
@ -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 ()
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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 ())
|
||||
}
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user