mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-09-20 06:58:39 +03:00
fixes remote relationships format in metadata (fixes graphql-engine-mono/issues/3108)
## Description This PR fixes two issues: - in [#2903](https://github.com/hasura/graphql-engine-mono/pull/2903), we introduced a new metadata representation of remote relationships, which broke parsing a metadata blob containing an old-style db-to-rs remote relationship - in [#1179](https://github.com/hasura/graphql-engine-mono/pull/1179), we silently and mistakenly deprecated `create_remote_relationship` in favour of `<backend>_create_remote_relationship` PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3124 Co-authored-by: jkachmar <8461423+jkachmar@users.noreply.github.com> Co-authored-by: Antoine Leblanc <1618949+nicuveo@users.noreply.github.com> GitOrigin-RevId: 45481db7a8d42c7612e938707cd2d652c4c81bf8
This commit is contained in:
Vamshi Surabhi
hasura-bot
parent
0c7e233125
commit
0728a9e60e
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) $
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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) =>
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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'
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user