1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-26 08:52:12 +03:00
graphql-engine/server/src-test/Hasura/RQL/MetadataSpec.hs
Brandon Simmons 6e8da71ece server: migrate to aeson-2 in preparation for ghc 9.2 upgrade
(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:


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
2022-06-08 15:32:27 +00:00

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