mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-26 08:52:12 +03:00
6e8da71ece
(Work here originally done by awjchen, rebased and fixed up for merge by jberryman) This is part of a merge train towards GHC 9.2 compatibility. The main issue is the use of the new abstract `KeyMap` in 2.0. See: https://hackage.haskell.org/package/aeson-2.0.3.0/changelog Alex's original work is here: #4305 BEHAVIOR CHANGE NOTE: This change causes a different arbitrary ordering of serialized Json, for example during metadata export. CLI users care about this in particular, and so we need to call it out as a _behavior change_ as we did in v2.5.0. The good news though is that after this change ordering should be more stable (alphabetical key order). See: https://hasurahq.slack.com/archives/C01M20G1YRW/p1654012632634389 PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4611 Co-authored-by: awjchen <13142944+awjchen@users.noreply.github.com> GitOrigin-RevId: 700265162c782739b2bb88300ee3cda3819b2e87
407 lines
13 KiB
Haskell
407 lines
13 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
module Hasura.RQL.MetadataSpec
|
|
( spec,
|
|
|
|
-- ** Test Helpers
|
|
trippingJSON,
|
|
trippingJSONValue,
|
|
trippingJSONEncoding,
|
|
)
|
|
where
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
import Control.Lens ((%~), (.~), (^?!))
|
|
import Data.Aeson (FromJSON, ToJSON)
|
|
import Data.Aeson qualified as Aeson
|
|
import Data.Aeson.KeyMap qualified as KM
|
|
import Data.Aeson.Lens (key, _Object)
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Proxy (Proxy (..))
|
|
import Data.Text qualified as T
|
|
import Data.Typeable (Typeable, typeRep)
|
|
import Data.Yaml.TH (yamlQQ)
|
|
import GHC.Stack (HasCallStack)
|
|
import Hasura.Prelude hiding ((%~))
|
|
import Hasura.RQL.DDL.RemoteRelationship
|
|
( CreateFromSourceRelationship,
|
|
)
|
|
import Hasura.RQL.Types.Metadata (Metadata)
|
|
import Hasura.SQL.Backend (BackendType (BigQuery, MSSQL, Postgres), PostgresKind (Vanilla))
|
|
import Hasura.Server.API.Metadata (RQLMetadataV1)
|
|
import Hasura.Server.API.Query qualified as V1 (RQLQuery)
|
|
import Hedgehog (MonadTest, evalEither, tripping)
|
|
import Test.Hspec (Spec, describe, expectationFailure, it, shouldContain)
|
|
import Test.Hspec.Hedgehog (hedgehog)
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec :: Spec
|
|
spec = describe "Remote Relationship Metadata" do
|
|
spec_roundtrip
|
|
spec_Metadata_examples
|
|
spec_RQLQuery_examples
|
|
spec_RQLMetadataV1_examples
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec_roundtrip :: Spec
|
|
spec_roundtrip = describe "JSON Roundtrip" do
|
|
describe "Metadata" do
|
|
it "example remote relationship fragment" $
|
|
hedgehog do
|
|
metadata :: Metadata <-
|
|
evalAesonResult $
|
|
Aeson.fromJSON remote_relationship_metadata_fragment
|
|
trippingJSONValue metadata
|
|
|
|
describe "CreateFromSourceRelationship" do
|
|
it "'pg_create_remote_relationship' query" $
|
|
hedgehog $ do
|
|
let argument = mk_pg_remote_relationship_argument "create" ^?! key "args"
|
|
cfsr :: (CreateFromSourceRelationship ('Postgres 'Vanilla)) <-
|
|
evalAesonResult $ Aeson.fromJSON argument
|
|
trippingJSON cfsr
|
|
|
|
it "'pg_create_remote_relationship' query with the 'old' schema" $
|
|
hedgehog $ do
|
|
let argument = mk_pg_remote_relationship_old_argument "create" ^?! key "args"
|
|
cfsr :: (CreateFromSourceRelationship ('Postgres 'Vanilla)) <-
|
|
evalAesonResult $ Aeson.fromJSON argument
|
|
trippingJSON cfsr
|
|
|
|
it "'mssql_create_remote_relationship' query" $
|
|
hedgehog $ do
|
|
let argument = mk_mssql_remote_relationship_argument "create" ^?! key "args"
|
|
cfsr :: (CreateFromSourceRelationship 'MSSQL) <-
|
|
evalAesonResult $ Aeson.fromJSON argument
|
|
trippingJSON cfsr
|
|
|
|
it "'bigquery_create_remote_relationship' query" $
|
|
hedgehog $ do
|
|
let argument = mk_bigquery_remote_relationship_argument "create" ^?! key "args"
|
|
cfsr :: (CreateFromSourceRelationship 'BigQuery) <-
|
|
evalAesonResult $ Aeson.fromJSON argument
|
|
trippingJSON cfsr
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec_Metadata_examples :: Spec
|
|
spec_Metadata_examples = describe "Metadata" $ do
|
|
it "parses an example remote relationship metadata fragment" do
|
|
decodesJSON @Metadata remote_relationship_metadata_fragment
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec_RQLQuery_examples :: Spec
|
|
spec_RQLQuery_examples = describe "V1 RQLQuery" do
|
|
it "parses a 'create_remote_relationship' query with the 'new' schema" do
|
|
decodesJSON @V1.RQLQuery
|
|
[yamlQQ|
|
|
type: create_remote_relationship
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
definition:
|
|
to_remote_schema:
|
|
lhs_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
it "parses a 'create_remote_relationship' query with the 'old' schema" do
|
|
decodesJSON @V1.RQLQuery
|
|
[yamlQQ|
|
|
type: create_remote_relationship
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
hasura_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
it "rejects a 'create_remote_relationship' query with the combination 'new+old' schema" do
|
|
rejectsJSON @V1.RQLQuery
|
|
"expects exactly one of: to_source, to_remote_schema"
|
|
[yamlQQ|
|
|
type: create_remote_relationship
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
# Note remote_schema nested under definition!
|
|
definition:
|
|
hasura_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
-------------------------------------------------------------------------------
|
|
|
|
spec_RQLMetadataV1_examples :: Spec
|
|
spec_RQLMetadataV1_examples = describe "RQLMetadataV1" do
|
|
describe "Success" do
|
|
for_ ["create", "update", "delete"] \action ->
|
|
it ("parses a 'pg_" <> T.unpack action <> "_remote_relationship query") do
|
|
decodesJSON @RQLMetadataV1 $ mk_pg_remote_relationship_argument action
|
|
|
|
for_ ["create", "update", "delete"] \action ->
|
|
it ("parses a 'pg_" <> T.unpack action <> "_remote_relationship query using the 'old' schema") do
|
|
decodesJSON @RQLMetadataV1 $ mk_pg_remote_relationship_old_argument action
|
|
|
|
for_ ["create", "update", "delete"] \action ->
|
|
it ("parses a 'citus_" <> T.unpack action <> "_remote_relationship query") do
|
|
decodesJSON @RQLMetadataV1 $ mk_citus_remote_relationship_argument action
|
|
|
|
for_ ["create", "update", "delete"] \action ->
|
|
it ("parses a 'bigquery_" <> T.unpack action <> "_remote_relationship query") do
|
|
decodesJSON @RQLMetadataV1 $ mk_bigquery_remote_relationship_argument action
|
|
|
|
for_ ["create", "update", "delete"] \action ->
|
|
it ("parses a 'mssql_" <> T.unpack action <> "_remote_relationship query") do
|
|
decodesJSON @RQLMetadataV1 $ mk_mssql_remote_relationship_argument action
|
|
|
|
describe "Failure" do
|
|
for_ ["create", "update"] \action ->
|
|
it ("fails to parse a 'pg_" <> T.unpack action <> "_remote_relationship query using the 'old+new' schema") do
|
|
rejectsJSON @RQLMetadataV1
|
|
"expects exactly one of: to_source, to_remote_schema"
|
|
$ mk_pg_remote_relationship_old_new_argument action
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Example YAML fragments for the metadata and query tests above.
|
|
|
|
remote_relationship_metadata_fragment :: Aeson.Value
|
|
remote_relationship_metadata_fragment =
|
|
[yamlQQ|
|
|
version: 3
|
|
sources:
|
|
- name: something
|
|
kind: postgres
|
|
configuration:
|
|
connection_info:
|
|
database_url: something
|
|
tables:
|
|
- table: test
|
|
remote_relationships:
|
|
- name: remote
|
|
definition:
|
|
hasura_fields: [id]
|
|
remote_field:
|
|
some_fiend_name:
|
|
arguments:
|
|
id: $id
|
|
remote_schema: some_remote_schema_name
|
|
|]
|
|
|
|
-- | Backend-agnostic @v1/metadata@ argument fragment which omits the @type@
|
|
-- field.
|
|
--
|
|
-- This should be used to construct backend-specific fragments by adding the
|
|
-- correct type and/or modifying any of the fields specified here as needed.
|
|
--
|
|
-- See 'mk_backend_remote_relationship_argument for example usage.
|
|
backend_create_remote_relationship_fragment :: Aeson.Value
|
|
backend_create_remote_relationship_fragment =
|
|
[yamlQQ|
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
definition:
|
|
to_remote_schema:
|
|
lhs_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
-- | Constructor for @v1/metadata@ @<backend>_(create|update|delete)_remote_relationship@
|
|
-- arguments using the new, unified schema.
|
|
--
|
|
-- See 'mk_pg_backend_remote_relationship_argument for example usage.
|
|
mk_backend_remote_relationship_argument :: Text -> Text -> Aeson.Value
|
|
mk_backend_remote_relationship_argument backend action =
|
|
backend_create_remote_relationship_fragment
|
|
& _Object
|
|
%~ HM.insert
|
|
("type" :: Text)
|
|
(Aeson.String $ backend <> "_" <> action <> "_remote_relationship")
|
|
|
|
-- | Constructor for @v1/metadata@ @mssql_(create|update|delete)_remote_relationship@
|
|
-- arguments using the new, unified schema.
|
|
mk_mssql_remote_relationship_argument :: Text -> Aeson.Value
|
|
mk_mssql_remote_relationship_argument action =
|
|
mk_backend_remote_relationship_argument "mssql" action
|
|
|
|
-- | Constructor for @v1/metadata@ @citus_(create|update|delete)_remote_relationship@
|
|
-- arguments using the new, unified schema.
|
|
mk_citus_remote_relationship_argument :: Text -> Aeson.Value
|
|
mk_citus_remote_relationship_argument action =
|
|
mk_backend_remote_relationship_argument "citus" action
|
|
|
|
-- | Constructor for @v1/metadata@ @pg_(create|update|delete)_remote_relationship@
|
|
-- arguments using the new, unified schema.
|
|
mk_pg_remote_relationship_argument :: Text -> Aeson.Value
|
|
mk_pg_remote_relationship_argument action =
|
|
mk_backend_remote_relationship_argument "pg" action
|
|
|
|
-- | Constructor for @v1/metadata@ @bigquery_(create|update|delete)_remote_relationship@
|
|
-- arguments using the new, unified schema.
|
|
--
|
|
-- NOTE: The 'BigQuery' backend expects its @table@ argument to be of type
|
|
-- 'Aeson.Object' (all of the other backends support 'Aeson.String').
|
|
mk_bigquery_remote_relationship_argument :: Text -> Aeson.Value
|
|
mk_bigquery_remote_relationship_argument action =
|
|
mk_backend_remote_relationship_argument "bigquery" action
|
|
& key "args" . key "table"
|
|
.~ Aeson.Object
|
|
( KM.fromList
|
|
[ ("name", "profiles"),
|
|
("dataset", "test")
|
|
]
|
|
)
|
|
|
|
-- | Constructor for @v1/metadata@ @pg_(create|update|delete)_remote_relationship@
|
|
-- arguments using the old, non-unified schema.
|
|
mk_pg_remote_relationship_old_argument :: Text -> Aeson.Value
|
|
mk_pg_remote_relationship_old_argument action =
|
|
fragment
|
|
& _Object
|
|
%~ HM.insert
|
|
("type" :: Text)
|
|
(Aeson.String $ "pg_" <> action <> "_remote_relationship")
|
|
where
|
|
fragment =
|
|
[yamlQQ|
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
hasura_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
-- | Constructor for @v1/metadata@ @pg_(create|update|delete)_remote_relationship@
|
|
-- arguments using a mix of the old and new schema.
|
|
mk_pg_remote_relationship_old_new_argument :: Text -> Aeson.Value
|
|
mk_pg_remote_relationship_old_new_argument action =
|
|
fragment
|
|
& _Object
|
|
%~ HM.insert
|
|
("type" :: Text)
|
|
(Aeson.String $ "pg_" <> action <> "_remote_relationship")
|
|
where
|
|
fragment =
|
|
[yamlQQ|
|
|
args:
|
|
name: message
|
|
table: profiles
|
|
definition:
|
|
hasura_fields:
|
|
- id
|
|
- name
|
|
remote_schema: my-remote-schema
|
|
remote_field:
|
|
message:
|
|
arguments:
|
|
id: "$id"
|
|
|]
|
|
|
|
-------------------------------------------------------------------------------
|
|
-- Utility functions.
|
|
--
|
|
-- NOTE(jkachmar): These are probably generally useful, and should be moved out
|
|
-- to some sort of test prelude.
|
|
|
|
-- | Fails the test if the 'Aeson.Result' is 'Aeson.Error', otherwise returns
|
|
-- the value in 'Aeson.Success'.
|
|
evalAesonResult ::
|
|
forall m a.
|
|
(MonadTest m, HasCallStack) =>
|
|
Aeson.Result a ->
|
|
m a
|
|
evalAesonResult x = evalEither $ case x of
|
|
Aeson.Success val -> Right val
|
|
Aeson.Error err -> Left err
|
|
|
|
-- | Test that the 'Aeson.toJSON' / 'Aeson.fromJSON' and 'Aeson.encode' /
|
|
-- 'Aeson.decode' functions are compatible with one another (respectively).
|
|
--
|
|
-- This is principally useful for validating manually implemented 'toEncoding'
|
|
-- methods (typically used to improve serialization performance).
|
|
trippingJSON ::
|
|
forall a m.
|
|
(FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
|
|
a ->
|
|
m ()
|
|
trippingJSON x = do
|
|
trippingJSONValue x
|
|
trippingJSONEncoding x
|
|
|
|
-- | Test that 'Aeson.toJSON' / 'Aeson.fromJSON' functions are compatible for a
|
|
-- given value.
|
|
--
|
|
-- This verifies that the 'parseJSON' and 'toJSON' instances agree with one
|
|
-- another.
|
|
trippingJSONValue ::
|
|
forall a m.
|
|
(FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
|
|
a ->
|
|
m ()
|
|
trippingJSONValue x = tripping x Aeson.toJSON Aeson.fromJSON
|
|
|
|
-- | Test that 'Aeson.encode' / 'Aeson.decode' functions are compatible for a
|
|
-- given value.
|
|
--
|
|
-- This verifies that the 'parseJSON' and 'toEncoding' instances agree with one
|
|
-- another.
|
|
trippingJSONEncoding ::
|
|
forall a m.
|
|
(FromJSON a, ToJSON a, Eq a, Show a, MonadTest m) =>
|
|
a ->
|
|
m ()
|
|
trippingJSONEncoding x = tripping x Aeson.encode Aeson.eitherDecode'
|
|
|
|
-- | Test that a specific JSON value can be parsed successfully.
|
|
decodesJSON :: forall a. (HasCallStack, FromJSON a) => Aeson.Value -> IO ()
|
|
decodesJSON value = case Aeson.fromJSON @a value of
|
|
Aeson.Success _ -> pure ()
|
|
Aeson.Error err -> expectationFailure err
|
|
|
|
-- | Test that a specific JSON value fails to parse.
|
|
rejectsJSON :: forall a. (HasCallStack, Typeable a, FromJSON a) => String -> Aeson.Value -> IO ()
|
|
rejectsJSON message value = case Aeson.fromJSON @a value of
|
|
Aeson.Error err -> err `shouldContain` message
|
|
Aeson.Success _ ->
|
|
expectationFailure $
|
|
mconcat
|
|
[ "expected parsing ",
|
|
show $ typeRep $ Proxy @a,
|
|
" to fail, but it succeeded"
|
|
]
|