From 44a64ed983569069c6d24ed8fb38ff8acb53090d Mon Sep 17 00:00:00 2001 From: Samir Talwar Date: Thu, 10 Nov 2022 09:36:36 +0100 Subject: [PATCH] server/test-harness: Wrap test resource setup/teardown. When setting up a resource (typically some kind of web server) for use in tests, we need to remember to tear it down afterwards. This moves this logic into one place, under the `TestResource` module. Like `SetupAction`, it encapsulates setup and teardown, and also separates out waiting for the resource to be ready, so we don't accidentally leave it lying around in the case of a healthcheck failure. Unlike `SetupAction`, it is monadic, and can be composed with other resources. In the future, we may want to adopt this logic for `SetupAction` too rather than using lists. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6806 GitOrigin-RevId: 74e2d76c5c09b8e0fe1cad84c9e77011f5a4d3db --- cabal.project.freeze | 20 +++-- server/lib/api-tests/api-tests.cabal | 1 + .../MSSQL/EventTiggersUniqueNameSpec.hs | 8 +- .../EventTriggerDropSourceCleanupSpec.hs | 8 +- .../EventTriggersUntrackTableCleanupSpec.hs | 8 +- .../PG/EventTriggersExtensionSchemaSpec.hs | 8 +- .../PG/EventTriggersRecreationSpec.hs | 10 +-- ...EventTriggersReplaceMetadataCleanupSpec.hs | 8 +- .../PG/EventTriggersRunSQLSpec.hs | 8 +- .../PG/EventTriggersUniqueNameSpec.hs | 8 +- .../EventTriggersUntrackTableCleanupSpec.hs | 8 +- .../NullRemoteRelationship8345Spec.hs | 18 ++-- .../RemoteRelationship/MetadataAPI/Common.hs | 19 ++--- .../XToDBArrayRelationshipSpec.hs | 16 ++-- .../XToDBObjectRelationshipSpec.hs | 16 ++-- .../XToRemoteSchemaRelationshipSpec.hs | 21 ++--- .../src/Harness/Backend/DataConnector/Mock.hs | 13 ++- .../test-harness/src/Harness/RemoteServer.hs | 12 ++- .../test-harness/src/Harness/Test/Fixture.hs | 85 ++++++++++--------- .../src/Harness/Test/TestResource.hs | 71 ++++++++++++++++ .../lib/test-harness/src/Harness/Webhook.hs | 13 ++- server/lib/test-harness/test-harness.cabal | 2 + 22 files changed, 218 insertions(+), 163 deletions(-) create mode 100644 server/lib/test-harness/src/Harness/Test/TestResource.hs diff --git a/cabal.project.freeze b/cabal.project.freeze index 1db10223ab4..5e0c7010a48 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -38,6 +38,7 @@ constraints: any.Cabal ==3.6.3.0, any.base-compat ==0.12.1, any.base-compat-batteries ==0.12.1, any.base-orphans ==0.8.6, + any.base-prelude ==1.6.1, any.base16-bytestring ==1.0.2.0, any.base64-bytestring ==1.2.1.0, any.basement ==0.0.14, @@ -54,6 +55,7 @@ constraints: any.Cabal ==3.6.3.0, any.bytestring-builder ==0.10.8.2.0, any.bytestring-lexing ==0.5.0.8, any.bytestring-strict-builder ==0.4.5.5, + any.bytestring-tree-builder ==0.2.7.10, any.cabal-doctest ==1.0.9, any.call-stack ==0.4.0, any.case-insensitive ==1.2.1.0, @@ -73,6 +75,7 @@ constraints: any.Cabal ==3.6.3.0, any.constraints-extras ==0.3.2.1, any.containers ==0.6.5.1, any.contravariant ==1.5.5, + any.contravariant-extras ==0.3.5.3, any.cookie ==0.4.5, any.cron ==0.7.0, any.crypto-api ==0.13.3, @@ -131,17 +134,20 @@ constraints: any.Cabal ==3.6.3.0, any.ghc-heap-view ==0.6.3, any.ghc-prim ==0.8.0, any.ghci ==9.2.*, - any.graphql-parser ==0.2.0.0, any.happy ==1.20.0, any.hashable ==1.3.5.0, any.hashtables ==1.2.4.2, any.haskell-lexer ==1.1, any.haskell-src-exts ==1.23.1, any.haskell-src-meta ==0.8.9, + any.hasql ==1.5.0.5, + any.hasql-pool ==0.5.2.2, + any.hasql-transaction ==1.0.1.1, any.hedgehog ==1.1.1, any.hedis ==0.15.1, any.hourglass ==0.2.12, any.hpc ==0.6.1.0, + any.hs-opentelemetry-otlp ==0.0.1.0, any.hsc2hs ==0.68.8, any.hspec ==2.10.6, any.hspec-core ==2.10.6, @@ -150,7 +156,6 @@ constraints: any.Cabal ==3.6.3.0, any.hspec-expectations-json ==1.0.0.7, any.hspec-expectations-lifted ==0.10.0, any.hspec-hedgehog ==0.0.1.2, - any.hs-opentelemetry-otlp ==0.0.1.0, any.http-api-data ==0.4.3, any.http-client ==0.7.13.1, any.http-client-tls ==0.3.6.1, @@ -168,7 +173,6 @@ constraints: any.Cabal ==3.6.3.0, any.inspection-testing ==0.4.6.1, any.integer-gmp ==1.1, any.integer-logarithms ==1.0.3.1, - any.string-interpolate ==0.3.1.2, any.invariant ==0.5.5, any.iproute ==1.7.12, any.jose ==0.9, @@ -184,12 +188,12 @@ constraints: any.Cabal ==3.6.3.0, any.lifted-base ==0.2.3.12, any.list-t ==1.0.5.1, any.logict ==0.7.0.3, + any.managed ==1.0.9, any.megaparsec ==9.2.0, any.memory ==0.17.0, any.mime-types ==0.1.0.9, any.mmorph ==1.2.0, any.monad-control ==1.0.3.1, - any.monad-logger ==0.3.36, any.monad-loops ==0.4.3, any.monad-time ==0.3.1.0, any.monad-validate ==1.2.0.1, @@ -227,7 +231,6 @@ constraints: any.Cabal ==3.6.3.0, any.parsers ==0.12.10, any.pcre-light ==0.4.1.0, any.pem ==0.2.4, - any.pg-client ==0.1.0, any.pointed ==5.0.3, any.postgresql-binary ==0.12.4.2, any.postgresql-libpq ==0.9.4.3, @@ -281,17 +284,20 @@ constraints: any.Cabal ==3.6.3.0, any.split ==0.2.3.4, any.splitmix ==0.1.0.4, any.stm ==2.5.0.2, - any.stm-chans ==3.0.0.6, any.stm-containers ==1.2, any.stm-hamt ==1.2.0.7, any.streaming-commons ==0.2.2.4, any.strict ==0.4.0.1, any.string-conversions ==0.4.0.1, + any.string-interpolate ==0.3.1.2, any.superbuffer ==0.3.1.2, any.syb ==0.7.2.1, any.system-filepath ==0.4.14, any.tagged ==0.8.6.1, + any.tasty ==1.4.2.3, + any.tasty-bench ==0.3.2, any.template-haskell ==2.18.0.0, + any.template-haskell-compat-v0208 ==0.1.9.1, any.terminal-size ==0.3.2.1, any.terminfo ==0.4.1.5, any.text ==1.2.5.0, @@ -323,6 +329,7 @@ constraints: any.Cabal ==3.6.3.0, any.type-hint ==0.1, any.typed-process ==0.2.8.0, any.unagi-chan ==0.4.1.4, + any.unbounded-delays ==0.1.1.1, any.unix ==2.7.2.2, any.unix-compat ==0.5.4, any.unix-time ==0.4.7, @@ -347,6 +354,7 @@ constraints: any.Cabal ==3.6.3.0, any.wai-extra ==3.1.8, any.wai-logger ==2.4.0, any.warp ==3.3.19, + any.wcwidth ==0.0.2, any.websockets ==0.12.7.3, any.wide-word ==0.1.1.2, any.witch ==1.0.0.1, diff --git a/server/lib/api-tests/api-tests.cabal b/server/lib/api-tests/api-tests.cabal index e72266c67ca..d490fa5c8c8 100644 --- a/server/lib/api-tests/api-tests.cabal +++ b/server/lib/api-tests/api-tests.cabal @@ -20,6 +20,7 @@ executable api-tests , http-types , lens , lens-aeson + , managed , morpheus-graphql , pg-client , postgresql-simple diff --git a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTiggersUniqueNameSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTiggersUniqueNameSpec.hs index ed872c818eb..4a1c6ac1db0 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTiggersUniqueNameSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTiggersUniqueNameSpec.hs @@ -14,7 +14,7 @@ import Harness.Test.BackendType import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..), table) import Harness.Test.Schema qualified as Schema -import Harness.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -34,11 +34,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Sqlserver.setupTablesAction (schema "authors" "articles") testEnvironment, + [ Sqlserver.setupTablesAction (schema "authors" "articles") testEnvironment, Fixture.SetupAction { Fixture.setupAction = mssqlSetupWithEventTriggers testEnvironment webhookServer, Fixture.teardownAction = \_ -> mssqlTeardown testEnvironment diff --git a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggerDropSourceCleanupSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggerDropSourceCleanupSpec.hs index 128d21eb140..c3127af57e2 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggerDropSourceCleanupSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggerDropSourceCleanupSpec.hs @@ -14,7 +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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -34,11 +34,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, + [ Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, Fixture.SetupAction { Fixture.setupAction = mssqlSetupWithEventTriggers testEnvironment webhookServer, Fixture.teardownAction = \_ -> pure () diff --git a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggersUntrackTableCleanupSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggersUntrackTableCleanupSpec.hs index 480d9a578b1..acc8c867881 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggersUntrackTableCleanupSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggersUntrackTableCleanupSpec.hs @@ -13,7 +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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -33,11 +33,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, + [ Sqlserver.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, Fixture.SetupAction { Fixture.setupAction = mssqlSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> pure () diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersExtensionSchemaSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersExtensionSchemaSpec.hs index 75e7c35c83f..1f516fc30e6 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersExtensionSchemaSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersExtensionSchemaSpec.hs @@ -16,7 +16,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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -36,11 +36,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesActionDiscardingTeardownErrors schema testEnvironment, + [ Postgres.setupTablesActionDiscardingTeardownErrors schema testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> postgresTeardown testEnvironment diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRecreationSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRecreationSpec.hs index 75182e72e9f..9fdd68168ca 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRecreationSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRecreationSpec.hs @@ -14,7 +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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldReturnYaml) import Hasura.Prelude @@ -29,12 +29,8 @@ spec = ( NE.fromList [ (Fixture.fixture $ Fixture.Backend Fixture.Postgres) { Fixture.mkLocalTestEnvironment = const Webhook.run, - Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesAction schema testEnvironment, + Fixture.setupTeardown = \(testEnvironment, _) -> + [ Postgres.setupTablesAction schema testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment, Fixture.teardownAction = \_ -> postgresTeardown testEnvironment diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersReplaceMetadataCleanupSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersReplaceMetadataCleanupSpec.hs index 9a8e063e764..bed2452e40b 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersReplaceMetadataCleanupSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersReplaceMetadataCleanupSpec.hs @@ -16,7 +16,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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldReturnYaml) import Hasura.Prelude @@ -34,11 +34,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, + [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> pure () diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRunSQLSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRunSQLSpec.hs index 199ccd71171..8f68587aed5 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRunSQLSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRunSQLSpec.hs @@ -17,7 +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.TestEnvironment (Server (..), TestEnvironment, getServer, stopServer) +import Harness.TestEnvironment (Server (..), TestEnvironment, getServer) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -38,11 +38,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, + [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> postgresTeardown testEnvironment diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUniqueNameSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUniqueNameSpec.hs index 0a53d066d5f..ea2853e7ff1 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUniqueNameSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUniqueNameSpec.hs @@ -14,7 +14,7 @@ import Harness.Test.BackendType import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..), table) import Harness.Test.Schema qualified as Schema -import Harness.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -34,11 +34,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesAction (schema "authors" "articles") testEnvironment, + [ Postgres.setupTablesAction (schema "authors" "articles") testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> postgresTeardown testEnvironment diff --git a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUntrackTableCleanupSpec.hs b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUntrackTableCleanupSpec.hs index 756fdbb8880..32991c8f28d 100644 --- a/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUntrackTableCleanupSpec.hs +++ b/server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUntrackTableCleanupSpec.hs @@ -13,7 +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.TestEnvironment (TestEnvironment, stopServer) +import Harness.TestEnvironment (TestEnvironment) import Harness.Webhook qualified as Webhook import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -33,11 +33,7 @@ spec = -- so that the server can be referenced while testing Fixture.mkLocalTestEnvironment = const Webhook.run, Fixture.setupTeardown = \(testEnvironment, (webhookServer, _)) -> - [ Fixture.SetupAction - { Fixture.setupAction = pure (), - Fixture.teardownAction = \_ -> stopServer webhookServer - }, - Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, + [ Postgres.setupTablesActionDiscardingTeardownErrors (schema "authors") testEnvironment, Fixture.SetupAction { Fixture.setupAction = postgresSetup testEnvironment webhookServer, Fixture.teardownAction = \_ -> pure () diff --git a/server/lib/api-tests/test/Test/Regression/NullRemoteRelationship8345Spec.hs b/server/lib/api-tests/test/Test/Regression/NullRemoteRelationship8345Spec.hs index bf7944a0360..ffc85d6c1e8 100644 --- a/server/lib/api-tests/test/Test/Regression/NullRemoteRelationship8345Spec.hs +++ b/server/lib/api-tests/test/Test/Regression/NullRemoteRelationship8345Spec.hs @@ -20,6 +20,7 @@ import Harness.RemoteServer qualified as RemoteServer import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..), table) import Harness.Test.Schema qualified as Schema +import Harness.Test.TestResource (Managed) import Harness.TestEnvironment (Server, TestEnvironment, stopServer) import Harness.Yaml (shouldReturnYaml) import Hasura.Prelude @@ -175,7 +176,7 @@ rhsArtist = -------------------------------------------------------------------------------- -- LHS Postgres -lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsPostgresMkLocalTestEnvironment _ = pure Nothing lhsPostgresSetup :: Aeson.Value -> Aeson.Value -> (TestEnvironment, Maybe Server) -> IO () @@ -225,7 +226,7 @@ lhsPostgresTeardown (_testEnvironment, _) = pure () -------------------------------------------------------------------------------- -- RHS Postgres -rhsPostgresMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +rhsPostgresMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) rhsPostgresMkLocalTestEnvironment _ = pure Nothing rhsPostgresSetup :: (TestEnvironment, Maybe Server) -> IO () @@ -352,12 +353,9 @@ input StringCompExp { |] -lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -lhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track}) - pure $ Just server +lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +lhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track})) where -- Implements the @hasura_track@ field of the @Query@ type. hasura_track (LHSHasuraTrackArgs {..}) = do @@ -480,9 +478,9 @@ type Query { |] -rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) rhsRemoteServerMkLocalTestEnvironment _ = - fmap Just $ RemoteServer.run $ RemoteServer.generateQueryInterpreter (Query {album, artist}) + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (Query {album, artist})) where albums = [(1, "album1")] artists = [(1, "artist1")] diff --git a/server/lib/api-tests/test/Test/RemoteRelationship/MetadataAPI/Common.hs b/server/lib/api-tests/test/Test/RemoteRelationship/MetadataAPI/Common.hs index ea8679e1e35..58274f5367f 100644 --- a/server/lib/api-tests/test/Test/RemoteRelationship/MetadataAPI/Common.hs +++ b/server/lib/api-tests/test/Test/RemoteRelationship/MetadataAPI/Common.hs @@ -48,6 +48,7 @@ import Harness.RemoteServer qualified as RemoteServer import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..), table) import Harness.Test.Schema qualified as Schema +import Harness.Test.TestResource (Managed) import Harness.TestEnvironment (Server, TestEnvironment, stopServer) import Hasura.Prelude @@ -381,12 +382,9 @@ type Query { |] -rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -rhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (Query {album}) - pure $ Just server +rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +rhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (Query {album})) where albums = [ (1, ("album1_artist1", Just 1)), @@ -516,12 +514,9 @@ input StringCompExp { |] -lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -lhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track}) - pure $ Just server +lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +lhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track})) where -- Implements the @hasura_track@ field of the @Query@ type. hasura_track (LHSHasuraTrackArgs {..}) = do diff --git a/server/lib/api-tests/test/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs b/server/lib/api-tests/test/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs index 3cc8e1f240b..71279c359e1 100644 --- a/server/lib/api-tests/test/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs +++ b/server/lib/api-tests/test/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs @@ -32,6 +32,7 @@ import Harness.Test.Fixture (Fixture (..)) import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..)) import Harness.Test.Schema qualified as Schema +import Harness.Test.TestResource (Managed) import Harness.TestEnvironment (Server, TestEnvironment, stopServer) import Harness.Yaml (shouldBeYaml, shouldReturnYaml) import Hasura.Prelude @@ -258,7 +259,7 @@ album = -------------------------------------------------------------------------------- -- LHS Postgres -lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsPostgresMkLocalTestEnvironment _ = pure Nothing lhsPostgresSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -328,7 +329,7 @@ lhsPostgresTeardown (_testEnvironment, _) = pure () -------------------------------------------------------------------------------- -- LHS Cockroach -lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsCockroachMkLocalTestEnvironment _ = pure Nothing lhsCockroachSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -398,7 +399,7 @@ lhsCockroachTeardown _ = pure () -------------------------------------------------------------------------------- -- LHS SQLServer -lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsSQLServerMkLocalTestEnvironment _ = pure Nothing lhsSQLServerSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -557,12 +558,9 @@ input StringCompExp { |] -lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -lhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (Query {hasura_artist}) - pure $ Just server +lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +lhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (Query {hasura_artist})) where -- Implements the @hasura_artist@ field of the @Query@ type. hasura_artist (HasuraArtistArgs {..}) = do diff --git a/server/lib/api-tests/test/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs b/server/lib/api-tests/test/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs index 7e7ec2d969e..90e860e939d 100644 --- a/server/lib/api-tests/test/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs +++ b/server/lib/api-tests/test/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs @@ -28,6 +28,7 @@ import Harness.RemoteServer qualified as RemoteServer import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..)) import Harness.Test.Schema qualified as Schema +import Harness.Test.TestResource (Managed) import Harness.TestEnvironment (Server, TestEnvironment, stopServer) import Harness.Yaml (shouldReturnYaml) import Hasura.Prelude @@ -255,7 +256,7 @@ album = -------------------------------------------------------------------------------- -- LHS Postgres -lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsPostgresMkLocalTestEnvironment _ = pure Nothing lhsPostgresSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -324,7 +325,7 @@ lhsPostgresTeardown (_testEnvironment, _) = -------------------------------------------------------------------------------- -- LHS Cockroach -lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsCockroachMkLocalTestEnvironment _ = pure Nothing lhsCockroachSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -392,7 +393,7 @@ lhsCockroachTeardown _ = pure () -------------------------------------------------------------------------------- -- LHS SQLServer -lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsSQLServerMkLocalTestEnvironment _ = pure Nothing lhsSQLServerSetup :: Value -> (TestEnvironment, Maybe Server) -> IO () @@ -553,12 +554,9 @@ input StringCompExp { |] -lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -lhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (Query {hasura_track}) - pure $ Just server +lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +lhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (Query {hasura_track})) where -- Implements the @hasura_track@ field of the @Query@ type. hasura_track (HasuraTrackArgs {..}) = do diff --git a/server/lib/api-tests/test/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs b/server/lib/api-tests/test/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs index fcfbad9571f..5efff00467c 100644 --- a/server/lib/api-tests/test/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs +++ b/server/lib/api-tests/test/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs @@ -27,6 +27,7 @@ import Harness.RemoteServer qualified as RemoteServer import Harness.Test.Fixture qualified as Fixture import Harness.Test.Schema (Table (..), table) import Harness.Test.Schema qualified as Schema +import Harness.Test.TestResource (Managed) import Harness.TestEnvironment (Server, TestEnvironment, stopServer) import Harness.Yaml (shouldReturnYaml) import Hasura.Prelude @@ -135,7 +136,7 @@ lhsPostgresSetupAction testEnv = (lhsPostgresSetup (testEnv, Nothing)) (const $ lhsPostgresTeardown (testEnv, Nothing)) -lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsPostgresMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsPostgresMkLocalTestEnvironment _ = pure Nothing lhsPostgresSetup :: (TestEnvironment, Maybe Server) -> IO () @@ -193,7 +194,7 @@ lhsCockroachSetupAction testEnv = (lhsCockroachSetup (testEnv, Nothing)) (const $ lhsCockroachTeardown (testEnv, Nothing)) -lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsCockroachMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsCockroachMkLocalTestEnvironment _ = pure Nothing lhsCockroachSetup :: (TestEnvironment, Maybe Server) -> IO () @@ -245,7 +246,7 @@ lhsCockroachTeardown (testEnvironment, _) = do -------------------------------------------------------------------------------- -- LHS SQLServer -lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) +lhsSQLServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) lhsSQLServerMkLocalTestEnvironment _ = pure Nothing lhsSQLServerSetupAction :: TestEnvironment -> Fixture.SetupAction @@ -399,12 +400,9 @@ input StringCompExp { |] -lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO (Maybe Server) -lhsRemoteServerMkLocalTestEnvironment _ = do - server <- - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track}) - pure $ Just server +lhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed (Maybe Server) +lhsRemoteServerMkLocalTestEnvironment _ = + Just <$> RemoteServer.run (RemoteServer.generateQueryInterpreter (LHSQuery {q_hasura_track = hasura_track})) where -- Implements the @hasura_track@ field of the @Query@ type. hasura_track (LHSHasuraTrackArgs {..}) = do @@ -529,10 +527,9 @@ type Query { |] -rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> IO Server +rhsRemoteServerMkLocalTestEnvironment :: TestEnvironment -> Managed Server rhsRemoteServerMkLocalTestEnvironment _ = - RemoteServer.run $ - RemoteServer.generateQueryInterpreter (Query {album}) + RemoteServer.run $ RemoteServer.generateQueryInterpreter (Query {album}) where albums = [ (1, ("album1_artist1", Just 1)), diff --git a/server/lib/test-harness/src/Harness/Backend/DataConnector/Mock.hs b/server/lib/test-harness/src/Harness/Backend/DataConnector/Mock.hs index a812791753f..08497974637 100644 --- a/server/lib/test-harness/src/Harness/Backend/DataConnector/Mock.hs +++ b/server/lib/test-harness/src/Harness/Backend/DataConnector/Mock.hs @@ -32,6 +32,7 @@ import Harness.GraphqlEngine qualified as GraphqlEngine import Harness.Http (RequestHeaders, healthCheck) import Harness.Quoter.Yaml (yaml) import Harness.Test.Fixture qualified as Fixture +import Harness.Test.TestResource (AcquiredResource (..), Managed, mkTestResource) import Harness.TestEnvironment (TestEnvironment (..)) import Harness.Yaml (shouldReturnYaml) import Hasura.Backends.DataConnector.API qualified as API @@ -113,14 +114,18 @@ data MockAgentEnvironment = MockAgentEnvironment } -- | Create the 'I.IORef's and launch the servant mock agent. -mkLocalTestEnvironment :: TestEnvironment -> IO MockAgentEnvironment -mkLocalTestEnvironment _ = do +mkLocalTestEnvironment :: TestEnvironment -> Managed MockAgentEnvironment +mkLocalTestEnvironment _ = mkTestResource do maeConfig <- I.newIORef chinookMock maeQuery <- I.newIORef Nothing maeQueryConfig <- I.newIORef Nothing maeThread <- Async.async $ runMockServer maeConfig maeQuery maeQueryConfig - healthCheck $ "http://127.0.0.1:" <> show mockAgentPort <> "/health" - pure $ MockAgentEnvironment {..} + pure $ + AcquiredResource + { resourceValue = MockAgentEnvironment {..}, + waitForResource = healthCheck $ "http://127.0.0.1:" <> show mockAgentPort <> "/health", + teardownResource = Async.cancel maeThread + } -- | Mock Agent test case input. data TestCase = TestCase diff --git a/server/lib/test-harness/src/Harness/RemoteServer.hs b/server/lib/test-harness/src/Harness/RemoteServer.hs index c006259e095..72cc0aa3f84 100644 --- a/server/lib/test-harness/src/Harness/RemoteServer.hs +++ b/server/lib/test-harness/src/Harness/RemoteServer.hs @@ -24,6 +24,7 @@ import Data.Morpheus.Types defaultRootResolver, ) import Harness.Http qualified as Http +import Harness.Test.TestResource (AcquiredResource (..), Managed, mkTestResource) import Harness.TestEnvironment (Server (..), serverUrl) import Hasura.Prelude import Network.Socket qualified as Socket @@ -54,8 +55,8 @@ run :: -- @/graphql@; the JSON value it returns will be the body of the server's -- response. Interpreter -> - IO Server -run (Interpreter interpreter) = do + Managed Server +run (Interpreter interpreter) = mkTestResource do let urlPrefix = "http://127.0.0.1" port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst) thread <- Async.async $ @@ -71,7 +72,12 @@ run (Interpreter interpreter) = do Spock.lazyBytes result let server = Server {port = fromIntegral port, urlPrefix, thread} Http.healthCheck $ serverUrl server - pure server + pure + AcquiredResource + { resourceValue = server, + waitForResource = Http.healthCheck $ serverUrl server, + teardownResource = Async.cancel thread + } -- | This function creates an 'Interpreter', able to handle incoming GraphQL -- requests. diff --git a/server/lib/test-harness/src/Harness/Test/Fixture.hs b/server/lib/test-harness/src/Harness/Test/Fixture.hs index 9b477b4b5d6..642f5d3bb13 100644 --- a/server/lib/test-harness/src/Harness/Test/Fixture.hs +++ b/server/lib/test-harness/src/Harness/Test/Fixture.hs @@ -28,6 +28,7 @@ module Harness.Test.Fixture ) where +import Control.Monad.Managed (Managed, runManaged, with) import Data.Set qualified as S import Data.Text qualified as T import Data.UUID.V4 (nextRandom) @@ -121,41 +122,47 @@ runWithLocalTestEnvironmentInternal aroundSomeWith fixtures tests = -- and at teardown, which is why we use a custom re-implementation of -- @bracket@. fixtureBracket :: Fixture b -> (ActionWith (TestEnvironment, b)) -> ActionWith TestEnvironment -fixtureBracket Fixture {name, mkLocalTestEnvironment, setupTeardown} actionWith globalTestEnvironment = - mask \restore -> do - -- log DB of test - testLogHarness globalTestEnvironment $ "Testing " <> show name <> "..." +fixtureBracket + Fixture + { name, + mkLocalTestEnvironment, + setupTeardown + } + actionWith + globalTestEnvironment = + mask \restore -> runManaged do + -- log DB of test + liftIO $ testLogHarness globalTestEnvironment $ "Testing " <> show name <> "..." + localTestEnvironment <- mkLocalTestEnvironment globalTestEnvironment + liftIO $ do + -- create a unique id to differentiate this set of tests + uniqueTestId <- nextRandom - localTestEnvironment <- mkLocalTestEnvironment globalTestEnvironment + let globalTestEnvWithUnique = + globalTestEnvironment + { backendType = case name of + Backend db -> Just db + _ -> Nothing, + uniqueTestId = uniqueTestId + } - -- create a unique id to differentiate this set of tests - uniqueTestId <- nextRandom + -- create databases we need for the tests + createDatabases name globalTestEnvWithUnique - let globalTestEnvWithUnique = - globalTestEnvironment - { backendType = case name of - Backend db -> Just db - _ -> Nothing, - uniqueTestId = uniqueTestId - } + let testEnvironment = (globalTestEnvWithUnique, localTestEnvironment) - -- create databases we need for the tests - createDatabases name globalTestEnvWithUnique + cleanup <- runSetupActions globalTestEnvironment (setupTeardown testEnvironment) - let testEnvironment = (globalTestEnvWithUnique, localTestEnvironment) + _ <- + catchRethrow + (restore $ actionWith testEnvironment) + cleanup - cleanup <- runSetupActions globalTestEnvironment (setupTeardown testEnvironment) - - _ <- - catchRethrow - (restore $ actionWith testEnvironment) + -- run test-specific clean up cleanup - -- run test-specific clean up - cleanup - - -- drop all DBs created for the tests - dropDatabases name globalTestEnvWithUnique + -- drop all DBs created for the tests + dropDatabases name globalTestEnvWithUnique -- | given the `FixtureName` and `uniqueTestId`, spin up all necessary -- databases for these tests @@ -190,11 +197,10 @@ fixtureRepl :: TestEnvironment -> IO (IO ()) fixtureRepl Fixture {mkLocalTestEnvironment, setupTeardown} globalTestEnvironment = do - localTestEnvironment <- mkLocalTestEnvironment globalTestEnvironment - let testEnvironment = (globalTestEnvironment, localTestEnvironment) - - cleanup <- runSetupActions globalTestEnvironment (setupTeardown testEnvironment) - return cleanup + with (mkLocalTestEnvironment globalTestEnvironment) \localTestEnvironment -> do + let testEnvironment = (globalTestEnvironment, localTestEnvironment) + cleanup <- runSetupActions globalTestEnvironment (setupTeardown testEnvironment) + return cleanup -- | Run a list of SetupActions. -- @@ -251,13 +257,14 @@ data Fixture a = Fixture -- e.g. @Postgres@ or @MySQL@ name :: FixtureName, -- | Setup actions associated with creating a local testEnvironment for this - -- 'Fixture'; for example: - -- - -- * starting remote servers + -- 'Fixture'; for example, starting remote servers. -- -- If any of those resources need to be threaded throughout the tests - -- themselves they should be returned here. Otherwise, a () - mkLocalTestEnvironment :: TestEnvironment -> IO a, + -- themselves they should be returned here. Otherwise, use 'noTestResource'. + -- + -- Intended to be used with the 'Harness.Test.TestResource' module. See + -- 'Harness.Webhook' for an example. + mkLocalTestEnvironment :: TestEnvironment -> Managed a, -- | Setup actions associated with this 'Fixture'; for example: -- -- * running SQL commands @@ -296,5 +303,5 @@ instance Show FixtureName where show (Combine name1 name2) = show name1 ++ "-" ++ show name2 -- | Default function for 'mkLocalTestEnvironment' when there's no local testEnvironment. -noLocalTestEnvironment :: TestEnvironment -> IO () -noLocalTestEnvironment _ = pure () +noLocalTestEnvironment :: TestEnvironment -> Managed () +noLocalTestEnvironment = const $ pure () diff --git a/server/lib/test-harness/src/Harness/Test/TestResource.hs b/server/lib/test-harness/src/Harness/Test/TestResource.hs new file mode 100644 index 00000000000..c90a1dd5974 --- /dev/null +++ b/server/lib/test-harness/src/Harness/Test/TestResource.hs @@ -0,0 +1,71 @@ +-- | A test resource, providing functionality to a test via a fixture. +-- +-- For example, this can be used to start a web server, and ensure it is shut +-- down cleanly when the test finishes. +-- +-- For usage instructions, take a look at 'mkTestResource' and +-- 'AcquiredResource'. +module Harness.Test.TestResource + ( Managed, + mkTestResource, + AcquiredResource (..), + ) +where + +import Control.Monad.Managed (Managed, managed) +import Harness.Exceptions (bracket) +import Hasura.Prelude + +-- | Constructs a test resource from an action setting up the resource. +-- +-- Intended to be used with 'Fixture.mkLocalTestEnvironment' like this: +-- +-- > mkLocalTestEnvironment = mkTestResource do +-- > server <- startServerOn port +-- > pure +-- > AcquiredResource +-- > { resourceValue = server, +-- > waitForResource = healthCheck (urlOf server), +-- > teardownResource = shutdown server +-- > } +-- +-- This returns a 'Managed a', which is monadic, and therefore can be composed +-- sequentially. This is especially useful when your setup step might fail. In +-- that case, consider composing two actions: +-- +-- > mkLocalTestEnvironment = do +-- > server <- mkTestResource do +-- > server <- startServerOn port +-- > pure +-- > AcquiredResource +-- > { resourceValue = server, +-- > waitForResource = healthCheck (urlOf server), +-- > teardownResource = shutdown server +-- > } +-- > client <- mkTestResource do +-- > client <- connectTo port +-- > pure +-- > AcquiredResource +-- > { resourceValue = client, +-- > waitForResource = pure (), +-- > teardownResource = shutdown client +-- > } +mkTestResource :: IO (AcquiredResource a) -> Managed a +mkTestResource setupResource = managed $ \action -> + bracket + setupResource + teardownResource + \resource -> do + waitForResource resource + action $ resourceValue resource + +-- | An 'AcquiredResource' represents a resource that takes up some space. +-- Typically, this is some kind of server, running on a port. +data AcquiredResource a = AcquiredResource + { -- | The value of the acquired resource. + resourceValue :: a, + -- | Waits for the resource to be "healthy", and then returns. + waitForResource :: IO (), + -- | Shuts down the resource, freeing anything it's using. + teardownResource :: IO () + } diff --git a/server/lib/test-harness/src/Harness/Webhook.hs b/server/lib/test-harness/src/Harness/Webhook.hs index 214f091708d..fe4c3394430 100644 --- a/server/lib/test-harness/src/Harness/Webhook.hs +++ b/server/lib/test-harness/src/Harness/Webhook.hs @@ -12,6 +12,7 @@ import Data.Aeson qualified as Aeson import Data.Parser.JSONPath (parseJSONPath) import Data.Text qualified as T import Harness.Http qualified as Http +import Harness.Test.TestResource (AcquiredResource (..), Managed, mkTestResource) import Harness.TestEnvironment (Server (..), serverUrl) import Hasura.Base.Error (iResultToMaybe) import Hasura.Prelude @@ -36,8 +37,8 @@ newtype EventsQueue = EventsQueue (Chan.Chan Aeson.Value) -- fails. This function does NOT attempt to kill the thread in such a case, -- which might result in a leak if the thread is still running but the server -- fails its health check. -run :: IO (Server, EventsQueue) -run = do +run :: Managed (Server, EventsQueue) +run = mkTestResource do let urlPrefix = "http://127.0.0.1" port <- bracket (Warp.openFreePort) (Socket.close . snd) (pure . fst) eventsQueueChan <- Chan.newChan @@ -66,5 +67,9 @@ run = do Spock.setHeader "Content-Type" "application/json; charset=utf-8" Spock.json $ Aeson.object ["success" Aeson..= True] let server = Server {port = fromIntegral port, urlPrefix, thread} - Http.healthCheck $ serverUrl server - pure (server, eventsQueue) + pure + AcquiredResource + { resourceValue = (server, eventsQueue), + waitForResource = Http.healthCheck $ serverUrl server, + teardownResource = Async.cancel thread + } diff --git a/server/lib/test-harness/test-harness.cabal b/server/lib/test-harness/test-harness.cabal index a0d4cdb18e5..63e31812d0c 100644 --- a/server/lib/test-harness/test-harness.cabal +++ b/server/lib/test-harness/test-harness.cabal @@ -26,6 +26,7 @@ library , libyaml , lens , lens-aeson + , managed , morpheus-graphql , mtl , mysql-simple @@ -116,6 +117,7 @@ library Harness.Test.Schema Harness.Test.SchemaName Harness.Test.SetupAction + Harness.Test.TestResource Harness.TestEnvironment Harness.Webhook Harness.Yaml