hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 08:02:15 +03:00
Code Issues Projects Releases Wiki Activity

server/test-harness: Wrap test resource setup/teardown.

Browse Source 
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
This commit is contained in:
Samir Talwar 2022-11-10 09:36:36 +01:00 committed by hasura-bot
parent ef8ff76209
commit 44a64ed983
22 changed files with 218 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
cabal.project.freeze
View File

@ -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,

1
server/lib/api-tests/api-tests.cabal
View File

@ -20,6 +20,7 @@ executable api-tests
, http-types
, lens
, lens-aeson
, managed
, morpheus-graphql
, pg-client
, postgresql-simple

8
server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTiggersUniqueNameSpec.hs
View File

@ -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

8
server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggerDropSourceCleanupSpec.hs
View File

@ -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 ()

8
server/lib/api-tests/test/Test/EventTrigger/MSSQL/EventTriggersUntrackTableCleanupSpec.hs
View File

@ -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 ()

8
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersExtensionSchemaSpec.hs
View File

@ -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

10
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRecreationSpec.hs
View File

@ -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

8
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersReplaceMetadataCleanupSpec.hs
View File

@ -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 ()

8
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersRunSQLSpec.hs
View File

@ -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

8
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUniqueNameSpec.hs
View File

@ -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

8
server/lib/api-tests/test/Test/EventTrigger/PG/EventTriggersUntrackTableCleanupSpec.hs
View File

@ -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 ()

18
server/lib/api-tests/test/Test/Regression/NullRemoteRelationship8345Spec.hs
View File

@ -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")]

19
server/lib/api-tests/test/Test/RemoteRelationship/MetadataAPI/Common.hs
View File

@ -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

16
server/lib/api-tests/test/Test/RemoteRelationship/XToDBArrayRelationshipSpec.hs
View File

@ -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

16
server/lib/api-tests/test/Test/RemoteRelationship/XToDBObjectRelationshipSpec.hs
View File

@ -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

21
server/lib/api-tests/test/Test/RemoteRelationship/XToRemoteSchemaRelationshipSpec.hs
View File

@ -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)),

13
server/lib/test-harness/src/Harness/Backend/DataConnector/Mock.hs
View File

@ -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

12
server/lib/test-harness/src/Harness/RemoteServer.hs
View File

@ -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.

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

@ -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 ()

71
server/lib/test-harness/src/Harness/Test/TestResource.hs Normal file
View File

@ -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 ()
}

13
server/lib/test-harness/src/Harness/Webhook.hs
View File

@ -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
}

2
server/lib/test-harness/test-harness.cabal
View File

@ -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