diff --git a/CHANGELOG.md b/CHANGELOG.md index 393d0ba7caa..c183432a058 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,13 +8,14 @@ ### Bug fixes and improvements (Add entries below in the order of server, console, cli, docs, others) +- server: fixes JSON ser/de backwards incompatibility introduced for metadata parsing and 'create_remote_relationship' queries (#7906) - cli: `hasura metadata diff` shows diff with more context in directory mode - cli: revert change to split metadata related to remote schemas into seperate files (introduced in v2.1.0-beta.2) ## v2.1.0-beta.3 - server: allows the use of mock env vars in the `test_webhook_transform` metadata API action -- server: fix event invocation logs to include transformed request bodies (fix #2983) +- server: fix event invocation logs to include transformed request bodies - server: fix aggregate queries with nodes field in selection set for sql server (fix #7871) - server: fix permissions are not respected for aggregations in sql server (fix #7773) - server: the syntax for remote relationships in metadata is changed to be diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 278ec382930..686e43a2ef3 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -781,6 +781,7 @@ test-suite graphql-engine-tests , jose , kan-extensions , lens + , lens-aeson , lifted-base , mmorph , monad-control @@ -802,6 +803,7 @@ test-suite graphql-engine-tests , unordered-containers , utf8-string , vector + , yaml -- mssql support , odbc , resource-pool @@ -825,6 +827,7 @@ test-suite graphql-engine-tests Hasura.GraphQL.Schema.RemoteTest Hasura.IncrementalSpec Hasura.RQL.IR.Generator + Hasura.RQL.MetadataSpec Hasura.RQL.IR.Postgres Hasura.RQL.PermissionSpec Hasura.RQL.RequestTransformSpec diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs index 1e8735e54da..8aa26a3c44b 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE UndecidableInstances #-} + module Hasura.RQL.DDL.RemoteRelationship ( CreateFromSourceRelationship (..), + LegacyCreateRemoteRelationship (..), runCreateRemoteRelationship, runDeleteRemoteRelationship, runUpdateRemoteRelationship, @@ -10,18 +13,28 @@ module Hasura.RQL.DDL.RemoteRelationship ) where -import Data.Aeson +import Control.Lens (foldOf, to) +import Data.Aeson (FromJSON (..), ToJSON (..), (.!=), (.:), (.:?), (.=)) import Data.Aeson qualified as J +import Data.Aeson.Lens (_Object) import Data.HashMap.Strict qualified as Map import Data.HashMap.Strict.InsOrd qualified as OMap import Data.HashSet qualified as S -import Data.Text.Extended +import Data.Text.Extended ((<<>), (<>>)) import Hasura.Base.Error -import Hasura.EncJSON + ( Code (NotFound, NotSupported, RemoteSchemaError), + QErr, + QErrM, + runAesonParser, + throw400, + ) +import Hasura.EncJSON (EncJSON) import Hasura.Prelude import Hasura.RQL.DDL.RemoteRelationship.Validate + ( errorToText, + validateSourceToSchemaRelationship, + ) import Hasura.RQL.Types -import Hasura.SQL.AnyBackend (mkAnyBackend) import Hasura.SQL.AnyBackend qualified as AB -------------------------------------------------------------------------------- @@ -35,19 +48,78 @@ import Hasura.SQL.AnyBackend qualified as AB data CreateFromSourceRelationship (b :: BackendType) = CreateFromSourceRelationship { _crrSource :: SourceName, _crrTable :: TableName b, - _crrDefinition :: RemoteRelationship + _crrName :: RelName, + _crrDefinition :: RemoteRelationshipDefinition } - deriving (Generic) + +deriving stock instance (Eq (TableName b)) => Eq (CreateFromSourceRelationship b) + +deriving stock instance (Show (TableName b)) => Show (CreateFromSourceRelationship b) instance Backend b => FromJSON (CreateFromSourceRelationship b) where - parseJSON = withObject "CreateFromSourceRelationship" $ \o -> - CreateFromSourceRelationship - <$> o .:? "source" .!= defaultSource - <*> o .: "table" - <*> parseJSON (Object o) + parseJSON = J.withObject "CreateFromSourceRelationship" $ \o -> do + _crrSource <- o .:? "source" .!= defaultSource + _crrTable <- o .: "table" + _crrName <- o .: "name" + _crrDefinition <- o .: "definition" + pure $ CreateFromSourceRelationship {..} instance (Backend b) => ToJSON (CreateFromSourceRelationship b) where - toJSON = genericToJSON hasuraJSON + toJSON (CreateFromSourceRelationship {..}) = + J.toJSON . J.object $ + [ "source" .= _crrSource, + "table" .= _crrTable, + "name" .= _crrName, + "definition" .= _crrDefinition + ] + + toEncoding (CreateFromSourceRelationship {..}) = + J.pairs $ + "source" .= _crrSource + <> "table" .= _crrTable + <> "name" .= _crrName + <> "definition" .= _crrDefinition + +-- | Opaque type wrapper around 'CreateFromSourceRelationship' which exists +-- solely to provide customized 'FromJSON' and 'ToJSON' instances that +-- preserves legacy JSON ser/de behavior. +-- +-- See the associated 'FromJSON' and 'ToJSON' instances for details. +newtype LegacyCreateRemoteRelationship = LegacyCreateRemoteRelationship + { unLegacyCreateRemoteRelationship :: + CreateFromSourceRelationship ('Postgres 'Vanilla) + } + deriving newtype (Eq, Show) + +instance FromJSON LegacyCreateRemoteRelationship where + parseJSON = J.withObject "LegacyCreateRemoteRelationship" $ \o -> do + _crrSource <- o .:? "source" .!= defaultSource + _crrTable <- o .: "table" + _crrName <- o .: "name" + _crrDefinition <- parseJSON (J.Object o) + pure . LegacyCreateRemoteRelationship $ CreateFromSourceRelationship {..} + +instance ToJSON LegacyCreateRemoteRelationship where + toJSON (LegacyCreateRemoteRelationship (CreateFromSourceRelationship {..})) = + -- The "legacy" serialization logic included the fields that are now a part + -- of the nested '_crrDefinition'. + -- + -- To work around this, while sharing as much serialization logic with + -- 'RemoteRelationshipDefinition' as possible, '_crrDefinition' is + -- serialized to a 'J.Value' and then immediately converted back to a list + -- of key/value pairs. + -- + -- 'definitionKeyValues' will be an empty list if this conversion fails + -- (which it should _never_ do), in which case those fields will be omitted + -- from the serialized JSON. + let definitionKeyValues = + foldOf (_Object . to Map.toList) (J.toJSON _crrDefinition) + in J.toJSON . J.object $ + [ "source" .= _crrSource, + "table" .= _crrTable, + "name" .= _crrName + ] + <> definitionKeyValues runCreateRemoteRelationship :: forall b m. @@ -56,16 +128,15 @@ runCreateRemoteRelationship :: m EncJSON runCreateRemoteRelationship CreateFromSourceRelationship {..} = do void $ askTabInfo @b _crrSource _crrTable - let relName = _rrName _crrDefinition - metadataObj = + let metadataObj = MOSourceObjId _crrSource $ AB.mkAnyBackend $ SMOTableObj @b _crrTable $ - MTORemoteRelationship relName + MTORemoteRelationship _crrName buildSchemaCacheFor metadataObj $ MetadataModifier $ tableMetadataSetter @b _crrSource _crrTable . tmRemoteRelationships - %~ OMap.insert relName _crrDefinition + %~ OMap.insert _crrName (RemoteRelationship _crrName _crrDefinition) pure successMsg runUpdateRemoteRelationship :: @@ -75,17 +146,16 @@ runUpdateRemoteRelationship :: m EncJSON runUpdateRemoteRelationship CreateFromSourceRelationship {..} = do fieldInfoMap <- askFieldInfoMap @b _crrSource _crrTable - let relName = _rrName _crrDefinition - metadataObj = + let metadataObj = MOSourceObjId _crrSource $ AB.mkAnyBackend $ SMOTableObj @b _crrTable $ - MTORemoteRelationship relName - void $ askRemoteRel fieldInfoMap relName + MTORemoteRelationship _crrName + void $ askRemoteRel fieldInfoMap _crrName buildSchemaCacheFor metadataObj $ MetadataModifier $ tableMetadataSetter @b _crrSource _crrTable . tmRemoteRelationships - %~ OMap.insert relName _crrDefinition + %~ OMap.insert _crrName (RemoteRelationship _crrName _crrDefinition) pure successMsg -------------------------------------------------------------------------------- @@ -99,7 +169,7 @@ data DeleteFromSourceRelationship (b :: BackendType) = DeleteFromSourceRelations } instance Backend b => FromJSON (DeleteFromSourceRelationship b) where - parseJSON = withObject "DeleteFromSourceRelationship" $ \o -> + parseJSON = J.withObject "DeleteFromSourceRelationship" $ \o -> DeleteFromSourceRelationship <$> o .:? "source" .!= defaultSource <*> o .: "table" @@ -190,7 +260,7 @@ buildRemoteFieldInfo sourceSource sourceTable fields RemoteRelationship {..} all [ SchemaDependency (SOSourceObj sourceSource $ AB.mkAnyBackend $ SOITableObj @b sourceTable $ TOCol @b $ pgiColumn srcColumn) DRRemoteRelationship, SchemaDependency (SOSourceObj _tsrdSource $ AB.mkAnyBackend $ SOITableObj @b' targetTable $ TOCol @b' $ pgiColumn tgtColumn) DRRemoteRelationship ] - pure (RFISource $ mkAnyBackend @b' rsri, tableDependencies <> columnDependencies) + pure (RFISource $ AB.mkAnyBackend @b' rsri, tableDependencies <> columnDependencies) RelationshipToSchema _ remoteRelationship@ToSchemaRelationshipDef {..} -> do RemoteSchemaCtx {..} <- onNothing (Map.lookup _trrdRemoteSchema remoteSchemaMap) $ diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Fields.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Fields.hs index 446e316384e..523aff60519 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Fields.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Fields.hs @@ -291,7 +291,7 @@ mkRemoteRelationshipMetadataObject :: Backend b => (SourceName, TableName b, RemoteRelationship) -> MetadataObject -mkRemoteRelationshipMetadataObject (source, table, rr@RemoteRelationship {..}) = +mkRemoteRelationshipMetadataObject (source, table, RemoteRelationship {..}) = let objectId = MOSourceObjId source $ AB.mkAnyBackend $ @@ -299,7 +299,7 @@ mkRemoteRelationshipMetadataObject (source, table, rr@RemoteRelationship {..}) = MTORemoteRelationship _rrName in MetadataObject objectId $ toJSON $ - CreateFromSourceRelationship @b source table rr + CreateFromSourceRelationship @b source table _rrName _rrDefinition buildRemoteRelationship :: forall b arr m. diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs index a2231c714d2..ff4dabb42c7 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs @@ -63,9 +63,9 @@ saveMetadataToHdbTables -- Remote Relationships withPathK "remote_relationships" $ indexedForM_ _tmRemoteRelationships $ - \rr -> do + \RemoteRelationship {..} -> do addRemoteRelationshipToCatalog $ - CreateFromSourceRelationship defaultSource _tmTable rr + CreateFromSourceRelationship defaultSource _tmTable _rrName _rrDefinition -- Permissions withPathK "insert_permissions" $ processPerms _tmTable _tmInsertPermissions @@ -199,7 +199,7 @@ addComputedFieldToCatalog q = AddComputedField _ table computedField definition comment = q addRemoteRelationshipToCatalog :: MonadTx m => CreateFromSourceRelationship ('Postgres 'Vanilla) -> m () -addRemoteRelationshipToCatalog remoteRelationship = +addRemoteRelationshipToCatalog CreateFromSourceRelationship {..} = liftTx $ Q.unitQE defaultTxErrorHandler @@ -208,11 +208,10 @@ addRemoteRelationshipToCatalog remoteRelationship = (remote_relationship_name, table_schema, table_name, definition) VALUES ($1, $2, $3, $4::jsonb) |] - (_rrName definition, schemaName, tableName, Q.AltJ definition) + (_crrName, schemaName, tableName, Q.AltJ _crrDefinition) True where - QualifiedObject schemaName tableName = _crrTable remoteRelationship - definition = _crrDefinition remoteRelationship + QualifiedObject schemaName tableName = _crrTable addFunctionToCatalog :: (MonadTx m, HasSystemDefined m) => diff --git a/server/src-lib/Hasura/RQL/Types/Relationships/Remote.hs b/server/src-lib/Hasura/RQL/Types/Relationships/Remote.hs index 0120e236fc3..1bcf19ac4a2 100644 --- a/server/src-lib/Hasura/RQL/Types/Relationships/Remote.hs +++ b/server/src-lib/Hasura/RQL/Types/Relationships/Remote.hs @@ -11,6 +11,8 @@ where import Control.Lens (makeLenses, makePrisms) import Data.Aeson +import Data.Aeson qualified as J +import Data.Aeson.TH qualified as J import Hasura.Incremental (Cacheable) import Hasura.Prelude import Hasura.RQL.Types.Common @@ -55,43 +57,37 @@ data RemoteRelationshipDefinition instance Cacheable RemoteRelationshipDefinition -instance FromJSON RemoteRelationship where - parseJSON = withObject "RemoteRelationship" \obj -> do - relName <- obj .: "name" +instance FromJSON RemoteRelationshipDefinition where + parseJSON = withObject "RemoteRelationshipDefinition" \obj -> do oldRSName <- obj .:? "remote_schema" - newDefinition <- obj .:? "definition" - definition <- case (oldRSName, newDefinition) of - (Just rsName, Nothing) -> do + case oldRSName of + Just rsName -> do hFields <- obj .: "hasura_fields" rField <- obj .: "remote_field" pure $ RelationshipToSchema RRFOldDBToRemoteSchema $ ToSchemaRelationshipDef rsName hFields rField - (Nothing, Just def) -> do - toSource <- def .:? "to_source" - toSchema <- def .:? "to_remote_schema" + Nothing -> do + toSource <- obj .:? "to_source" + toSchema <- obj .:? "to_remote_schema" case (toSchema, toSource) of (Just schema, Nothing) -> RelationshipToSchema RRFUnifiedFormat <$> parseJSON schema (Nothing, Just source) -> RelationshipToSource <$> parseJSON source _ -> fail "remote relationship definition expects exactly one of: to_source, to_remote_schema" - _ -> fail "remote relationship definition expects exactly one of: definition, remote_schema" - pure $ RemoteRelationship relName definition -instance ToJSON RemoteRelationship where - toJSON RemoteRelationship {..} = - object $ - ("name" .= _rrName) : case _rrDefinition of - RelationshipToSource source -> definition ["to_source" .= toJSON source] - RelationshipToSchema format schema@ToSchemaRelationshipDef {..} -> case format of - RRFUnifiedFormat -> definition ["to_remote_schema" .= toJSON schema] - RRFOldDBToRemoteSchema -> - [ "remote_schema" .= toJSON _trrdRemoteSchema, - "hasura_fields" .= toJSON _trrdLhsFields, - "remote_field" .= toJSON _trrdRemoteField - ] - where - definition d = ["definition" .= object d] +instance ToJSON RemoteRelationshipDefinition where + toJSON = \case + RelationshipToSource source -> object ["to_source" .= toJSON source] + RelationshipToSchema format schema@ToSchemaRelationshipDef {..} -> case format of + RRFUnifiedFormat -> object ["to_remote_schema" .= toJSON schema] + RRFOldDBToRemoteSchema -> + object + [ "remote_schema" .= toJSON _trrdRemoteSchema, + "hasura_fields" .= toJSON _trrdLhsFields, + "remote_field" .= toJSON _trrdRemoteField + ] -------------------------------------------------------------------------------- -- template haskell generation $(makeLenses ''RemoteRelationship) +$(J.deriveJSON hasuraJSON {J.omitNothingFields = False} ''RemoteRelationship) $(makePrisms ''RemoteRelationshipDefinition) diff --git a/server/src-lib/Hasura/Server/API/Metadata.hs b/server/src-lib/Hasura/Server/API/Metadata.hs index a7714137fbf..3a6be668761 100644 --- a/server/src-lib/Hasura/Server/API/Metadata.hs +++ b/server/src-lib/Hasura/Server/API/Metadata.hs @@ -82,6 +82,7 @@ data RQLMetadataV1 | RMSetRelationshipComment !(AnyBackend SetRelComment) | RMRenameRelationship !(AnyBackend RenameRel) | -- Tables remote relationships + -- (backend)_create_remote_relationship, create_remote_relationship RMCreateRemoteRelationship !(AnyBackend CreateFromSourceRelationship) | RMUpdateRemoteRelationship !(AnyBackend CreateFromSourceRelationship) | RMDeleteRemoteRelationship !(DeleteFromSourceRelationship ('Postgres 'Vanilla)) @@ -221,6 +222,7 @@ instance FromJSON RQLMetadataV1 where "test_webhook_transform" -> RMTestWebhookTransform <$> args "set_query_tags" -> RMSetQueryTagsConfig <$> args "bulk" -> RMBulk <$> args + "create_remote_relationship" -> RMCreateRemoteRelationship . mkAnyBackend . unLegacyCreateRemoteRelationship <$> args -- backend specific _ -> do let (prefix, T.drop 1 -> cmd) = T.breakOn "_" queryType diff --git a/server/src-lib/Hasura/Server/API/Query.hs b/server/src-lib/Hasura/Server/API/Query.hs index 6ba831cb01e..8db5e8e2515 100644 --- a/server/src-lib/Hasura/Server/API/Query.hs +++ b/server/src-lib/Hasura/Server/API/Query.hs @@ -65,8 +65,8 @@ data RQLQueryV1 | -- computed fields related RQAddComputedField !(AddComputedField ('Postgres 'Vanilla)) | RQDropComputedField !(DropComputedField ('Postgres 'Vanilla)) - | RQCreateRemoteRelationship !(CreateFromSourceRelationship ('Postgres 'Vanilla)) - | RQUpdateRemoteRelationship !(CreateFromSourceRelationship ('Postgres 'Vanilla)) + | RQCreateRemoteRelationship !LegacyCreateRemoteRelationship + | RQUpdateRemoteRelationship !LegacyCreateRemoteRelationship | RQDeleteRemoteRelationship !(DeleteFromSourceRelationship ('Postgres 'Vanilla)) | RQCreateInsertPermission !(CreatePerm InsPerm ('Postgres 'Vanilla)) | RQCreateSelectPermission !(CreatePerm SelPerm ('Postgres 'Vanilla)) @@ -418,8 +418,8 @@ runQueryM env rq = withPathK "args" $ case rq of RQRemoveRemoteSchema q -> runRemoveRemoteSchema q RQReloadRemoteSchema q -> runReloadRemoteSchema q RQIntrospectRemoteSchema q -> runIntrospectRemoteSchema q - RQCreateRemoteRelationship q -> runCreateRemoteRelationship q - RQUpdateRemoteRelationship q -> runUpdateRemoteRelationship q + RQCreateRemoteRelationship q -> runCreateRemoteRelationship $ unLegacyCreateRemoteRelationship q + RQUpdateRemoteRelationship q -> runUpdateRemoteRelationship $ unLegacyCreateRemoteRelationship q RQDeleteRemoteRelationship q -> runDeleteRemoteRelationship q RQCreateEventTrigger q -> runCreateEventTriggerQuery q RQDeleteEventTrigger q -> runDeleteEventTriggerQuery q diff --git a/server/src-test/Hasura/RQL/MetadataSpec.hs b/server/src-test/Hasura/RQL/MetadataSpec.hs index c25e5d5c439..f6e7b2fbed6 100644 --- a/server/src-test/Hasura/RQL/MetadataSpec.hs +++ b/server/src-test/Hasura/RQL/MetadataSpec.hs @@ -1,19 +1,277 @@ -module Hasura.RQL.MetadataSpec (spec) where +module Hasura.RQL.MetadataSpec + ( spec, -import Data.Aeson (eitherDecodeStrict) -import Hasura.EncJSON -import Hasura.Prelude -import Hasura.RQL.DDL.Metadata.Generator (genMetadata) -import Hasura.RQL.Types.Metadata (Metadata, metadataToOrdJSON) -import Test.Hspec -import Test.QuickCheck + -- ** Test Helpers + trippingJSON, + trippingJSONValue, + trippingJSONEncoding, + ) +where + +------------------------------------------------------------------------------- + +import Control.Lens ((%~), (^?!)) +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as Aeson +import Data.Aeson.Lens (key, _Object) +import Data.HashMap.Strict qualified as HM +import Data.Yaml.TH (yamlQQ) +import GHC.Stack (HasCallStack) +import Hasura.Prelude hiding ((%~)) +import Hasura.RQL.DDL.RemoteRelationship + ( CreateFromSourceRelationship, + LegacyCreateRemoteRelationship, + ) +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) +import Test.Hspec.Hedgehog (hedgehog) + +------------------------------------------------------------------------------- spec :: Spec -spec = describe "metadataToOrdJSON" $ do - it "produces JSON that can be parsed by the FromJSON instance for Metadata" $ - withMaxSuccess 20 $ - forAll (resize 3 genMetadata) $ \metadata -> - let encodedString = encJToBS $ encJFromOrderedValue $ metadataToOrdJSON metadata - in case eitherDecodeStrict @Metadata encodedString of - Left err -> counterexample err False - Right _ -> property True +spec = describe "Remote Relationship Metadata" do + spec_roundtrip + spec_Metadata_examples + spec_RQLQuery_examples + spec_RQLMetadataV1_examples + +------------------------------------------------------------------------------- + +spec_roundtrip :: Spec +spec_roundtrip = describe "Roundtrip" do + describe "Metadata" do + it "passes JSON roundtrip tests for an example remote relationship fragment" $ + hedgehog do + metadata :: Metadata <- + evalAesonResult $ + Aeson.fromJSON remote_relationship_metadata_fragment + trippingJSONValue metadata + + describe "CreateFromSourceRelationship" do + it "passes JSON roundtrip tests for a 'pg_create_remote_relationship' query fragment" $ + hedgehog $ do + let fragment = pg_create_remote_relationship_fragment ^?! key "args" + cfsr :: (CreateFromSourceRelationship ('Postgres 'Vanilla)) <- + evalAesonResult $ Aeson.fromJSON fragment + trippingJSON cfsr + + it "passes JSON roundtrip tests for an 'mssql_create_remote_relationship' query fragment" $ + hedgehog $ do + let fragment = mssql_create_remote_relationship_fragment ^?! key "args" + cfsr :: (CreateFromSourceRelationship 'MSSQL) <- + evalAesonResult $ Aeson.fromJSON fragment + trippingJSON cfsr + + it "passes JSON roundtrip tests for a 'bigquery_create_remote_relationship' query fragment" $ + hedgehog $ do + let fragment = bigquery_create_remote_relationship_fragment ^?! key "args" + cfsr :: (CreateFromSourceRelationship 'BigQuery) <- + evalAesonResult $ Aeson.fromJSON fragment + trippingJSON cfsr + + describe "LegacyCreateRemoteRelationship" do + it "passes JSON roundtrip tests for a 'create_remote_relationship' query fragment" $ + hedgehog do + let fragment = create_remote_relationship_fragment ^?! key "args" + lcrr :: LegacyCreateRemoteRelationship <- + evalAesonResult $ Aeson.fromJSON fragment + trippingJSON lcrr + +------------------------------------------------------------------------------- + +spec_Metadata_examples :: Spec +spec_Metadata_examples = describe "Metadata" $ do + it "parses an example remote relationship metadata fragment" do + case Aeson.fromJSON @Metadata remote_relationship_metadata_fragment of + Aeson.Success _ -> pure () + Aeson.Error err -> expectationFailure err + +------------------------------------------------------------------------------- + +spec_RQLQuery_examples :: Spec +spec_RQLQuery_examples = describe "V1 RQLQuery" do + it "parses a 'create_remote_relationship' query fragment as a V1 'RQLQuery' type" do + case Aeson.fromJSON @V1.RQLQuery create_remote_relationship_fragment of + Aeson.Success _ -> pure () + Aeson.Error err -> expectationFailure err + +------------------------------------------------------------------------------- + +spec_RQLMetadataV1_examples :: Spec +spec_RQLMetadataV1_examples = describe "RQLMetadataV1" do + it "parses a 'create_remote_relationship' query fragment" do + case Aeson.fromJSON @RQLMetadataV1 create_remote_relationship_fragment of + Aeson.Success _ -> pure () + Aeson.Error err -> expectationFailure err + + it "parses a 'pg_create_remote_relationship' query fragment" do + case Aeson.fromJSON @RQLMetadataV1 pg_create_remote_relationship_fragment of + Aeson.Success _ -> pure () + Aeson.Error err -> expectationFailure err + + it "parses a 'bigquery_create_remote_relationship' query fragment" do + case Aeson.fromJSON @RQLMetadataV1 bigquery_create_remote_relationship_fragment of + Aeson.Success _ -> pure () + Aeson.Error err -> expectationFailure err + +------------------------------------------------------------------------------- +-- 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 + |] + +create_remote_relationship_fragment :: Aeson.Value +create_remote_relationship_fragment = + [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" +|] + +-- | Backend-agnostic query 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 'pg_create_remote_relationship_fragment' for details. +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" + |] + +pg_create_remote_relationship_fragment :: Aeson.Value +pg_create_remote_relationship_fragment = + backend_create_remote_relationship_fragment + & _Object %~ HM.insert ("type" :: Text) "pg_create_remote_relationship" + +mssql_create_remote_relationship_fragment :: Aeson.Value +mssql_create_remote_relationship_fragment = + backend_create_remote_relationship_fragment + & _Object %~ HM.insert ("type" :: Text) "mssql_create_remote_relationship" + +-- NOTE: The 'BigQuery' backend expects its @table@ argument to be of type +-- 'Aeson.Object' (all of the other backends support 'Aeson.String'). +-- +-- Rather than trying to wrangle even more of this with @lens-aeson@, it's +-- easier to just duplicate the structure in-place for the time being. +bigquery_create_remote_relationship_fragment :: Aeson.Value +bigquery_create_remote_relationship_fragment = + [yamlQQ| +type: bigquery_create_remote_relationship +args: + name: message + table: + name: profiles + dataset: test + definition: + to_remote_schema: + lhs_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' diff --git a/server/src-test/Main.hs b/server/src-test/Main.hs index 5ab5d62cc8b..575a8b91298 100644 --- a/server/src-test/Main.hs +++ b/server/src-test/Main.hs @@ -31,6 +31,7 @@ import Hasura.Metadata.Class import Hasura.Prelude import Hasura.RQL.DDL.Schema.Cache import Hasura.RQL.DDL.Schema.Cache.Common +import Hasura.RQL.MetadataSpec qualified as MetadataSpec import Hasura.RQL.PermissionSpec qualified as PermSpec import Hasura.RQL.RequestTransformSpec qualified as RequestTransformSpec import Hasura.RQL.Types @@ -95,6 +96,7 @@ unitSpecs = do describe "Hasura.Server.Auth" AuthSpec.spec describe "Hasura.Server.Telemetry" TelemetrySpec.spec describe "Hasura.RQL.PermissionSpec" PermSpec.spec + describe "Hasura.RQL.MetadataSpec" MetadataSpec.spec describe "Hasura.RQL.RequestTransformSpec" RequestTransformSpec.spec describe "Network.HTTP.Client.TransformableSpec" TransformableSpec.spec