From a1886b372945b815b9e2eccabb9e52f24fd70866 Mon Sep 17 00:00:00 2001 From: Antoine Leblanc Date: Fri, 25 Feb 2022 20:37:32 +0000 Subject: [PATCH] Generalize remote schemas IR ### Description This PR is one further step towards remote joins from remote schemas. It introduces a custom partial AST to represent queries to remote schemas in the IR: we now need to augment what used to be a straightforward GraphQL AST with additional information for remote join fields. This PR does the minimal amount of work to adjust the rest of the code accordingly, using `Void` in all places that expect a type representing remote relationships. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3794 GitOrigin-RevId: 33fc317731aace71f82ad158a1951ea93350d6cc --- server/src-lib/Data/List/Extended.hs | 14 + .../Hasura/GraphQL/Execute/Mutation.hs | 8 +- .../src-lib/Hasura/GraphQL/Execute/Query.hs | 8 +- .../src-lib/Hasura/GraphQL/Execute/Remote.hs | 5 +- .../GraphQL/Execute/RemoteJoin/Collect.hs | 2 +- server/src-lib/Hasura/GraphQL/Schema.hs | 12 +- .../src-lib/Hasura/GraphQL/Schema/Remote.hs | 204 +++++------ .../GraphQL/Schema/RemoteRelationship.hs | 2 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 7 +- server/src-lib/Hasura/RQL/IR/Delete.hs | 8 +- server/src-lib/Hasura/RQL/IR/RemoteSchema.hs | 327 +++++++++++++++++- server/src-lib/Hasura/RQL/IR/Root.hs | 4 +- server/src-lib/Hasura/RQL/IR/Select.hs | 58 ++-- .../src-lib/Hasura/RQL/Types/RemoteSchema.hs | 17 - .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 7 +- .../Hasura/GraphQL/Schema/RemoteTest.hs | 3 +- 16 files changed, 479 insertions(+), 207 deletions(-) diff --git a/server/src-lib/Data/List/Extended.hs b/server/src-lib/Data/List/Extended.hs index ad2331f8b51..649038bef7c 100644 --- a/server/src-lib/Data/List/Extended.hs +++ b/server/src-lib/Data/List/Extended.hs @@ -5,6 +5,7 @@ module Data.List.Extended getDifferenceOn, getOverlapWith, hasNoDuplicates, + longestCommonPrefix, module L, ) where @@ -38,3 +39,16 @@ getOverlapWith getKey left right = hasNoDuplicates :: (Eq a, Hashable a) => [a] -> Bool hasNoDuplicates xs = Set.size (Set.fromList xs) == length xs + +-- | Returns the longest prefix common to all given lists. Returns an empty list on an empty list. +-- +-- >>> longestCommonPrefix ["abcd", "abce", "abgh"] +-- "ab" +-- +-- >>> longestCommonPrefix [] +-- [] +longestCommonPrefix :: Eq a => [[a]] -> [a] +longestCommonPrefix [] = [] +longestCommonPrefix (x : xs) = foldr prefix x xs + where + prefix l1 l2 = map fst $ takeWhile (uncurry (==)) $ zip l1 l2 diff --git a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs index 6a9dc1dfd7e..e3549b84430 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs @@ -122,13 +122,13 @@ convertMutationSelectionSet exists \(SourceConfigWith (sourceConfig :: SourceConfig b) queryTagsConfig (MDBR db)) -> do let mutationQueryTagsAttributes = encodeQueryTags $ QTMutation $ MutationMetadata reqId maybeOperationName rootFieldName parameterizedQueryHash - let queryTagsComment = Tagged.untag $ createQueryTags @m mutationQueryTagsAttributes queryTagsConfig - let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsMutationDB db + queryTagsComment = Tagged.untag $ createQueryTags @m mutationQueryTagsAttributes queryTagsConfig + (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsMutationDB db dbStepInfo <- flip runReaderT queryTagsComment $ mkDBMutationPlan @b userInfo stringifyNum sourceName sourceConfig noRelsDBAST pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins RFRemote remoteField -> do - RemoteFieldG remoteSchemaInfo resultCustomizer resolvedRemoteField <- runVariableCache $ resolveRemoteField userInfo remoteField - pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeMutation [G.SelectionField resolvedRemoteField] (GH._grOperationName gqlUnparsed) + RemoteSchemaRootField remoteSchemaInfo resultCustomizer resolvedRemoteField <- runVariableCache $ resolveRemoteField userInfo remoteField + pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeMutation [G.SelectionField $ convertGraphQLField resolvedRemoteField] (GH._grOperationName gqlUnparsed) RFAction action -> do let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionMutation action (actionName, _fch) <- pure $ case noRelsDBAST of diff --git a/server/src-lib/Hasura/GraphQL/Execute/Query.hs b/server/src-lib/Hasura/GraphQL/Execute/Query.hs index 97db50026f1..d3e43d57e5d 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Query.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Query.hs @@ -108,13 +108,13 @@ convertQuerySelSet exists \(SourceConfigWith (sourceConfig :: (SourceConfig b)) queryTagsConfig (QDBR db)) -> do let queryTagsAttributes = encodeQueryTags $ QTQuery $ QueryMetadata reqId maybeOperationName rootFieldName parameterizedQueryHash - let queryTagsComment = Tagged.untag $ createQueryTags @m queryTagsAttributes queryTagsConfig - let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoins db + queryTagsComment = Tagged.untag $ createQueryTags @m queryTagsAttributes queryTagsConfig + (noRelsDBAST, remoteJoins) = RJ.getRemoteJoins db dbStepInfo <- flip runReaderT queryTagsComment $ mkDBQueryPlan @b userInfo sourceName sourceConfig noRelsDBAST pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins RFRemote rf -> do - RemoteFieldG remoteSchemaInfo resultCustomizer remoteField <- runVariableCache $ for rf $ resolveRemoteVariable userInfo - pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeQuery [G.SelectionField remoteField] (GH._grOperationName gqlUnparsed) + RemoteSchemaRootField remoteSchemaInfo resultCustomizer remoteField <- runVariableCache $ for rf $ resolveRemoteVariable userInfo + pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeQuery [G.SelectionField $ convertGraphQLField remoteField] (GH._grOperationName gqlUnparsed) RFAction action -> do let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionQuery action (actionExecution, actionName, fch) <- pure $ case noRelsDBAST of diff --git a/server/src-lib/Hasura/GraphQL/Execute/Remote.hs b/server/src-lib/Hasura/GraphQL/Execute/Remote.hs index 56d042574f3..814f0a195dc 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Remote.hs @@ -21,6 +21,7 @@ import Hasura.GraphQL.Parser import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol qualified as GH import Hasura.Prelude +import Hasura.RQL.IR.RemoteSchema import Hasura.RQL.Types import Hasura.Session import Language.GraphQL.Draft.Syntax qualified as G @@ -222,8 +223,8 @@ resolveRemoteVariable userInfo = \case resolveRemoteField :: (MonadError QErr m) => UserInfo -> - RemoteFieldG RemoteSchemaVariable -> - StateT RemoteJSONVariableMap m (RemoteFieldG Variable) + RemoteSchemaRootField Void RemoteSchemaVariable -> + StateT RemoteJSONVariableMap m (RemoteSchemaRootField Void Variable) resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo) -- | TODO: Documentation. diff --git a/server/src-lib/Hasura/GraphQL/Execute/RemoteJoin/Collect.hs b/server/src-lib/Hasura/GraphQL/Execute/RemoteJoin/Collect.hs index deb47a9659b..be2ef5cc35b 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/RemoteJoin/Collect.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/RemoteJoin/Collect.hs @@ -281,7 +281,7 @@ createRemoteJoin joinColumnAliases remoteRelationship = RemoteSchemaJoin (inputArgsToMap _rselArgs) _rselResultCustomizer - _rselSelection + (convertSelectionSet _rselSelection) joinColumnAliases _rselFieldCall _rselRemoteSchema diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index cdc6dff3da6..79b1dd43535 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -232,12 +232,12 @@ buildRoleContext where getQueryRemotes :: [ParsedIntrospection] -> - [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] + [P.FieldParser (P.ParseT Identity) (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] getQueryRemotes = concatMap piQuery getMutationRemotes :: [ParsedIntrospection] -> - [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] + [P.FieldParser (P.ParseT Identity) (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] getMutationRemotes = concatMap (concat . piMutation) buildSource :: @@ -418,8 +418,8 @@ unauthenticatedContext :: ( MonadError QErr m, MonadIO m ) => - [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] -> - [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] -> + [P.FieldParser (P.ParseT Identity) (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] -> + [P.FieldParser (P.ParseT Identity) (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] -> RemoteSchemaPermsCtx -> m GQLContext unauthenticatedContext adminQueryRemotes adminMutationRemotes remoteSchemaPermsCtx = P.runSchemaT $ do @@ -602,7 +602,7 @@ buildQueryParser :: Has CustomizeRemoteFieldName r ) => [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] -> - [P.FieldParser n (NamespacedField RemoteField)] -> + [P.FieldParser n (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] -> [ActionInfo] -> AnnotatedCustomTypes -> Maybe (Parser 'Output n (RootFieldMap (MutationRootField UnpreparedValue))) -> @@ -700,7 +700,7 @@ buildMutationParser :: Has MkRootFieldName r, Has CustomizeRemoteFieldName r ) => - [P.FieldParser n (NamespacedField RemoteField)] -> + [P.FieldParser n (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] -> [ActionInfo] -> AnnotatedCustomTypes -> [P.FieldParser n (NamespacedField (MutationRootField UnpreparedValue))] -> diff --git a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs index 92ded9b2789..6fb11f82c4c 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs @@ -12,7 +12,7 @@ where import Data.Has import Data.HashMap.Strict qualified as Map import Data.HashMap.Strict.InsOrd qualified as OMap -import Data.HashMap.Strict.InsOrd.Extended qualified as OMap +import Data.HashSet qualified as Set import Data.List.NonEmpty qualified as NE import Data.Monoid (Any (..)) import Data.Text.Extended @@ -23,6 +23,7 @@ import Hasura.GraphQL.Parser as P import Hasura.GraphQL.Parser.Internal.Parser qualified as P import Hasura.GraphQL.Parser.Internal.TypeChecking qualified as P import Hasura.Prelude +import Hasura.RQL.IR.RemoteSchema qualified as IR import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.ResultCustomization import Hasura.RQL.Types.SchemaCache (IntrospectionResult (IntrospectionResult, irMutationRoot, irQueryRoot, irSubscriptionRoot), ParsedIntrospectionG (..)) @@ -49,17 +50,27 @@ buildRemoteParser introspectionResult remoteSchemaInfo@RemoteSchemaInfo {..} = d (customizeRemoteNamespace remoteSchemaInfo <$> irMutationRoot introspectionResult <*> rawMutationParsers) (customizeRemoteNamespace remoteSchemaInfo <$> irSubscriptionRoot introspectionResult <*> rawSubscriptionParsers) -makeResultCustomizer :: RemoteSchemaCustomizer -> G.Field G.NoFragments a -> ResultCustomizer -makeResultCustomizer remoteSchemaCustomizer G.Field {..} = - modifyFieldByName (fromMaybe _fName _fAlias) $ +makeResultCustomizer :: + RemoteSchemaCustomizer -> + IR.GraphQLField Void RemoteSchemaVariable -> + ResultCustomizer +makeResultCustomizer remoteSchemaCustomizer IR.GraphQLField {..} = + modifyFieldByName _fAlias $ if _fName == $$(G.litName "__typename") then customizeTypeNameString (_rscCustomizeTypeName remoteSchemaCustomizer) - else foldMap resultCustomizerFromSelection _fSelectionSet + else resultCustomizerFromSelection _fSelectionSet where - resultCustomizerFromSelection :: G.Selection G.NoFragments a -> ResultCustomizer + resultCustomizerFromSelection :: + IR.SelectionSet Void RemoteSchemaVariable -> ResultCustomizer resultCustomizerFromSelection = \case - G.SelectionField fld -> makeResultCustomizer remoteSchemaCustomizer fld - G.SelectionInlineFragment G.InlineFragment {..} -> foldMap resultCustomizerFromSelection _ifSelectionSet + IR.SelectionSetObject s -> foldMap customizeField s + IR.SelectionSetUnion s -> foldMap (foldMap customizeField) $ IR._atssMemberSelectionSets s + IR.SelectionSetInterface s -> foldMap (foldMap customizeField) $ IR._atssMemberSelectionSets s + IR.SelectionSetNone -> mempty + + customizeField :: IR.Field Void RemoteSchemaVariable -> ResultCustomizer + customizeField = \case + IR.FieldGraphQL f -> makeResultCustomizer remoteSchemaCustomizer f buildRawRemoteParser :: forall r m n. @@ -68,9 +79,9 @@ buildRawRemoteParser :: RemoteSchemaInfo -> -- | parsers for, respectively: queries, mutations, and subscriptions m - ( [P.FieldParser n RemoteField], - Maybe [P.FieldParser n RemoteField], - Maybe [P.FieldParser n RemoteField] + ( [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)], + Maybe [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)], + Maybe [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)] ) buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info = do queryT <- makeParsers queryRoot @@ -78,21 +89,21 @@ buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscripti subscriptionT <- makeNonQueryRootFieldParser subscriptionRoot $$(G.litName "Subscription") return (queryT, mutationT, subscriptionT) where - makeFieldParser :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RemoteField) + makeFieldParser :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)) makeFieldParser rootTypeName fieldDef = fmap makeRemoteField <$> remoteFieldFromDefinition sdoc rootTypeName fieldDef - makeRemoteField :: G.Field G.NoFragments RemoteSchemaVariable -> RemoteField - makeRemoteField fld = RemoteFieldG info (makeResultCustomizer (rsCustomizer info) fld) fld + makeRemoteField :: IR.GraphQLField Void RemoteSchemaVariable -> (IR.RemoteSchemaRootField Void RemoteSchemaVariable) + makeRemoteField fld = IR.RemoteSchemaRootField info (makeResultCustomizer (rsCustomizer info) fld) fld - makeParsers :: G.Name -> m [P.FieldParser n RemoteField] + makeParsers :: G.Name -> m [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)] makeParsers rootName = case lookupType sdoc rootName of Just (G.TypeDefinitionObject o) -> traverse (makeFieldParser rootName) $ G._otdFieldsDefinition o _ -> throw400 Unexpected $ rootName <<> " has to be an object type" - makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n RemoteField]) + makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)]) makeNonQueryRootFieldParser userProvidedRootName defaultRootName = case userProvidedRootName of Just _rootName -> traverse makeParsers userProvidedRootName @@ -539,7 +550,7 @@ remoteSchemaObject :: MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.ObjectTypeDefinition RemoteSchemaInputValueDefinition -> - m (Parser 'Output n [G.Field G.NoFragments RemoteSchemaVariable]) + m (Parser 'Output n (IR.ObjectSelectionSet Void RemoteSchemaVariable)) remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name interfaces _directives subFields) = P.memoizeOn 'remoteSchemaObject defn do subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) subFields @@ -548,13 +559,13 @@ remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name inter -- TODO: also check sub-interfaces, when these are supported in a future graphql spec traverse_ validateImplementsFields interfaceDefs typename <- mkTypename name + let allFields = map (fmap IR.FieldGraphQL) subFieldParsers -- <> map (fmap IR.FieldRemote) remoteJoinParsers pure $ - P.selectionSetObject typename description subFieldParsers implements - <&> toList - . OMap.mapWithKey - ( \alias -> handleTypename $ \_ -> - G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty - ) + P.selectionSetObject typename description allFields implements + <&> OMap.mapWithKey \alias -> + handleTypename $ + const $ + IR.FieldGraphQL $ IR.mkGraphQLField (Just alias) $$(G.litName "__typename") mempty mempty IR.SelectionSetNone where getInterface :: G.Name -> m (G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition) getInterface interfaceName = @@ -719,7 +730,7 @@ remoteSchemaInterface :: MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> - m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) + m (Parser 'Output n (IR.DeduplicatedSelectionSet Void RemoteSchemaVariable)) remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name _directives fields possibleTypes) = P.memoizeOn 'remoteSchemaObject defn do subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) fields @@ -734,7 +745,9 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name -- should have a check that expresses that that collection of objects is equal -- to 'possibleTypes'. typename <- mkTypename name - pure $ P.selectionSetInterface typename description subFieldParsers objs <&> constructInterfaceSelectionSet + pure $ + P.selectionSetInterface typename description subFieldParsers objs + <&> IR.mkInterfaceSelectionSet (Set.fromList $ map G._fldName fields) where getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject objectName = @@ -751,77 +764,20 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name <> " can only include object types. It cannot include " <> squote objectName - -- 'constructInterfaceQuery' constructs a remote interface query. - constructInterfaceSelectionSet :: - [(G.Name, [G.Field G.NoFragments RemoteSchemaVariable])] -> - G.SelectionSet G.NoFragments RemoteSchemaVariable - constructInterfaceSelectionSet objNameAndFields = - let -- common interface fields that exist in every - -- selection set provided - -- #1 of Note [Querying remote schema Interfaces] - commonInterfaceFields = - OMap.elems $ - OMap.mapMaybe (allTheSame . toList) $ - OMap.groupListWith G._fName $ - concatMap (filter ((`elem` interfaceFieldNames) . G._fName) . snd) $ - objNameAndFields - - interfaceFieldNames = map G._fldName fields - - allTheSame (x : xs) | all (== x) xs = Just x - allTheSame _ = Nothing - - -- #2 of Note [Querying remote schema interface fields] - nonCommonInterfaceFields = - catMaybes $ - flip map objNameAndFields $ \(objName, objFields) -> - let nonCommonFields = filter (not . flip elem commonInterfaceFields) objFields - in mkObjInlineFragment (objName, map G.SelectionField nonCommonFields) - - -- helper function for #4 of Note [Querying remote schema interface fields] - mkObjInlineFragment (_, []) = Nothing - mkObjInlineFragment (objName, selSet) = - Just $ - G.SelectionInlineFragment $ - G.InlineFragment (Just objName) mempty selSet - in -- #5 of Note [Querying remote schema interface fields] - fmap G.SelectionField commonInterfaceFields <> nonCommonInterfaceFields - -- | 'remoteSchemaUnion' returns a output parser for a given 'UnionTypeDefinition'. remoteSchemaUnion :: forall r m n. MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.UnionTypeDefinition -> - m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) + m (Parser 'Output n (IR.DeduplicatedSelectionSet Void RemoteSchemaVariable)) remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _directives objectNames) = P.memoizeOn 'remoteSchemaObject defn do objs <- traverse (getObjectParser schemaDoc getObject) objectNames when (null objs) $ throw400 RemoteSchemaError $ "List of member types cannot be empty for union type " <> squote name typename <- mkTypename name - pure $ - P.selectionSetUnion typename description objs - <&> ( \objNameAndFields -> - catMaybes $ - objNameAndFields <&> \(objName, fields) -> - case fields of - -- The return value obtained from the parsing of a union selection set - -- specifies, for each object in the union type, a fragment-free - -- selection set for that object type. In particular, if, for a given - -- object type, the selection set passed to the union type did not - -- specify any fields for that object type (i.e. if no inline fragment - -- applied to that object), the selection set resulting from the parsing - -- through that object type would be empty, i.e. []. We exclude such - -- object types from the reconstructed selection set for the union - -- type, as selection sets cannot be empty. - [] -> Nothing - _ -> - Just - ( G.SelectionInlineFragment $ - G.InlineFragment (Just objName) mempty $ fmap G.SelectionField fields - ) - ) + pure $ P.selectionSetUnion typename description objs <&> IR.mkUnionSelectionSet where getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject objectName = @@ -844,29 +800,31 @@ remoteFieldFromDefinition :: RemoteSchemaIntrospection -> G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> - m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) -remoteFieldFromDefinition schemaDoc parentTypeName (G.FieldDefinition description name argsDefinition gType _) = do - let addNullableList :: FieldParser n a -> FieldParser n a - addNullableList (P.FieldParser (Definition name' desc (FieldInfo args typ)) parser) = - P.FieldParser (Definition name' desc (FieldInfo args (TList Nullable typ))) parser - - addNonNullableList :: FieldParser n a -> FieldParser n a - addNonNullableList (P.FieldParser (Definition name' desc (FieldInfo args typ)) parser) = - P.FieldParser (Definition name' desc (FieldInfo args (TList NonNullable typ))) parser - - -- TODO add directives, deprecation - convertType :: G.GType -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) - convertType gType' = do - case gType' of - G.TypeNamed (G.Nullability True) fieldTypeName -> - P.nullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition - G.TypeList (G.Nullability True) gType'' -> - addNullableList <$> convertType gType'' - G.TypeNamed (G.Nullability False) fieldTypeName -> do - P.nonNullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition - G.TypeList (G.Nullability False) gType'' -> - addNonNullableList <$> convertType gType'' + m (FieldParser n (IR.GraphQLField Void RemoteSchemaVariable)) +remoteFieldFromDefinition schemaDoc parentTypeName (G.FieldDefinition description name argsDefinition gType _) = convertType gType + where + addNullableList :: FieldParser n a -> FieldParser n a + addNullableList (P.FieldParser (Definition name' desc (FieldInfo args typ)) parser) = + P.FieldParser (Definition name' desc (FieldInfo args (TList Nullable typ))) parser + + addNonNullableList :: FieldParser n a -> FieldParser n a + addNonNullableList (P.FieldParser (Definition name' desc (FieldInfo args typ)) parser) = + P.FieldParser (Definition name' desc (FieldInfo args (TList NonNullable typ))) parser + + -- TODO add directives, deprecation + convertType :: + G.GType -> + m (FieldParser n (IR.GraphQLField Void RemoteSchemaVariable)) + convertType = \case + G.TypeNamed (G.Nullability True) fieldTypeName -> + P.nullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition + G.TypeList (G.Nullability True) gType' -> + addNullableList <$> convertType gType' + G.TypeNamed (G.Nullability False) fieldTypeName -> do + P.nonNullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition + G.TypeList (G.Nullability False) gType' -> + addNonNullableList <$> convertType gType' -- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition -- in the 'RemoteSchemaIntrospection'. @@ -879,7 +837,7 @@ remoteFieldFromName :: Maybe G.Description -> G.Name -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> - m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) + m (FieldParser n (IR.GraphQLField Void RemoteSchemaVariable)) remoteFieldFromName sdoc parentTypeName fieldName description fieldTypeName argsDefns = case lookupType sdoc fieldTypeName of Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> fieldTypeName @@ -897,7 +855,7 @@ remoteField :: Maybe G.Description -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> - m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) + m (FieldParser n (IR.GraphQLField Void RemoteSchemaVariable)) remoteField sdoc parentTypeName fieldName description argsDefn typeDefn = do -- TODO add directives argsParser <- argumentsParser argsDefn sdoc @@ -908,44 +866,46 @@ remoteField sdoc parentTypeName fieldName description argsDefn typeDefn = do G.TypeDefinitionObject objTypeDefn -> do remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn -- converting [Field NoFragments Name] to (SelectionSet NoFragments G.Name) - let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields + let remoteSchemaObjSelSet = IR.SelectionSetObject <$> remoteSchemaObjFields pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet customizedFieldName argsParser G.TypeDefinitionScalar scalarTypeDefn -> pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldScalarParser customizeTypename scalarTypeDefn G.TypeDefinitionEnum enumTypeDefn -> pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldEnumParser customizeTypename enumTypeDefn G.TypeDefinitionInterface ifaceTypeDefn -> - remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser + remoteSchemaInterface sdoc ifaceTypeDefn + <&> (mkFieldParserWithSelectionSet customizedFieldName argsParser . fmap IR.SelectionSetInterface) G.TypeDefinitionUnion unionTypeDefn -> - remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser + remoteSchemaUnion sdoc unionTypeDefn + <&> (mkFieldParserWithSelectionSet customizedFieldName argsParser . fmap IR.SelectionSetUnion) _ -> throw400 RemoteSchemaError "expected output type, but got input type" where mkField :: Maybe G.Name -> G.Name -> HashMap G.Name (G.Value RemoteSchemaVariable) -> - G.SelectionSet G.NoFragments RemoteSchemaVariable -> - G.Field G.NoFragments RemoteSchemaVariable + IR.SelectionSet Void RemoteSchemaVariable -> + IR.GraphQLField Void RemoteSchemaVariable mkField alias customizedFieldName args selSet = -- If there's no alias then use customizedFieldName as the alias so the -- correctly customized field name will be returned from the remote server. let alias' = alias <|> guard (customizedFieldName /= fieldName) *> Just customizedFieldName - in G.Field alias' fieldName args mempty selSet + in IR.mkGraphQLField alias' fieldName args mempty selSet mkFieldParserWithoutSelectionSet :: G.Name -> InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> Parser 'Both n () -> - FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) + FieldParser n (IR.GraphQLField Void RemoteSchemaVariable) mkFieldParserWithoutSelectionSet customizedFieldName argsParser outputParser = P.rawSelection customizedFieldName description argsParser outputParser - <&> \(alias, _, (_, args)) -> mkField alias customizedFieldName args [] + <&> \(alias, _, (_, args)) -> mkField alias customizedFieldName args IR.SelectionSetNone mkFieldParserWithSelectionSet :: G.Name -> InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> - Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable) -> - FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) + Parser 'Output n (IR.SelectionSet Void RemoteSchemaVariable) -> + FieldParser n (IR.GraphQLField Void RemoteSchemaVariable) mkFieldParserWithSelectionSet customizedFieldName argsParser outputParser = P.rawSubselection customizedFieldName description argsParser outputParser <&> \(alias, _, (_, args), selSet) -> mkField alias customizedFieldName args selSet @@ -961,7 +921,7 @@ getObjectParser :: RemoteSchemaIntrospection -> (G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) -> G.Name -> - m (Parser 'Output n (G.Name, [G.Field G.NoFragments RemoteSchemaVariable])) + m (Parser 'Output n (G.Name, IR.ObjectSelectionSet Void RemoteSchemaVariable)) getObjectParser schemaDoc getObject objName = do obj <- remoteSchemaObject schemaDoc =<< getObject objName return $ (objName,) <$> obj @@ -971,8 +931,8 @@ customizeRemoteNamespace :: (MonadParse n) => RemoteSchemaInfo -> G.Name -> - [P.FieldParser n RemoteField] -> - [P.FieldParser n (NamespacedField RemoteField)] + [P.FieldParser n (IR.RemoteSchemaRootField Void RemoteSchemaVariable)] -> + [P.FieldParser n (NamespacedField (IR.RemoteSchemaRootField Void RemoteSchemaVariable))] customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers = customizeNamespace (_rscNamespaceFieldName rsCustomizer) fromParsedSelection mkNamespaceTypename fieldParsers where @@ -980,7 +940,7 @@ customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fie handleTypename . const $ -- In P.selectionSet we lose the resultCustomizer from __typename fields so we need to put it back let resultCustomizer = modifyFieldByName alias $ customizeTypeNameString $ _rscCustomizeTypeName rsCustomizer - in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty + in IR.RemoteSchemaRootField remoteSchemaInfo resultCustomizer $ IR.mkGraphQLField (Just alias) $$(G.litName "__typename") mempty mempty IR.SelectionSetNone mkNamespaceTypename = MkTypename $ const $ runMkTypename (remoteSchemaCustomizeTypeName rsCustomizer) rootTypeName type MonadBuildRemoteSchema r m n = (MonadSchema n m, MonadError QErr m, MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r) diff --git a/server/src-lib/Hasura/GraphQL/Schema/RemoteRelationship.hs b/server/src-lib/Hasura/GraphQL/Schema/RemoteRelationship.hs index 272c6918bdb..fb1a13381ba 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/RemoteRelationship.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/RemoteRelationship.hs @@ -115,7 +115,7 @@ remoteRelationshipToSchemaField lhsFields RemoteSchemaFieldInfo {..} = runMaybeT pure $ remoteFld - `P.bindField` \fld@G.Field {G._fArguments = args, G._fSelectionSet = selSet, G._fName = fname} -> do + `P.bindField` \fld@IR.GraphQLField {IR._fArguments = args, IR._fSelectionSet = selSet, IR._fName = fname} -> do let remoteArgs = Map.toList args <&> \(argName, argVal) -> IR.RemoteFieldArgument argName $ P.GraphQLValue argVal let resultCustomizer = diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index db6a588153c..b11807f1416 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -238,7 +238,12 @@ runSessVarPred = filterSessionVariables . unSessVarPred -- | Filter out only those session variables used by the query AST provided filterVariablesFromQuery :: Backend backend => - [RootField (QueryDBRoot (RemoteRelationshipField UnpreparedValue) UnpreparedValue) RemoteField (ActionQuery backend (RemoteRelationshipField UnpreparedValue) (UnpreparedValue backend)) d] -> + [ RootField + (QueryDBRoot (RemoteRelationshipField UnpreparedValue) UnpreparedValue) + (RemoteSchemaRootField Void RemoteSchemaVariable) + (ActionQuery backend (RemoteRelationshipField UnpreparedValue) (UnpreparedValue backend)) + d + ] -> SessVarPred filterVariablesFromQuery query = fold $ rootToSessVarPreds =<< query where diff --git a/server/src-lib/Hasura/RQL/IR/Delete.hs b/server/src-lib/Hasura/RQL/IR/Delete.hs index a25fd4dc132..1be22a30ff3 100644 --- a/server/src-lib/Hasura/RQL/IR/Delete.hs +++ b/server/src-lib/Hasura/RQL/IR/Delete.hs @@ -15,10 +15,10 @@ import Hasura.RQL.Types.Column import Hasura.SQL.Backend data AnnDelG (b :: BackendType) (r :: Type) v = AnnDel - { dqp1Table :: !(TableName b), - dqp1Where :: !(AnnBoolExp b v, AnnBoolExp b v), - dqp1Output :: !(MutationOutputG b r v), - dqp1AllCols :: ![ColumnInfo b] + { dqp1Table :: TableName b, + dqp1Where :: (AnnBoolExp b v, AnnBoolExp b v), + dqp1Output :: MutationOutputG b r v, + dqp1AllCols :: [ColumnInfo b] } deriving (Functor, Foldable, Traversable) diff --git a/server/src-lib/Hasura/RQL/IR/RemoteSchema.hs b/server/src-lib/Hasura/RQL/IR/RemoteSchema.hs index 8dfbe9699f9..b662fc83552 100644 --- a/server/src-lib/Hasura/RQL/IR/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/IR/RemoteSchema.hs @@ -1,26 +1,335 @@ +-- | Representation for queries going to remote schemas. Due to the existence of +-- remote relationships from remote schemas, we can't simply reuse the GraphQL +-- document AST we define in graphql-parser-hs, and instead redefine a custom +-- structure to represent such queries. module Hasura.RQL.IR.RemoteSchema - ( RemoteFieldArgument (..), + ( -- AST + SelectionSet (..), + DeduplicatedSelectionSet (..), + ObjectSelectionSet, + mkInterfaceSelectionSet, + mkUnionSelectionSet, + Field (..), + _FieldGraphQL, + _FieldRemote, + GraphQLField (..), + mkGraphQLField, + -- entry points + RemoteSchemaRootField (..), + SchemaRemoteRelationshipSelect (..), + RemoteFieldArgument (..), RemoteSchemaSelect (..), + -- AST conversion + convertSelectionSet, + convertGraphQLField, ) where -import Hasura.GraphQL.Parser.Schema (InputValue) +import Control.Lens.TH (makePrisms) +import Data.HashMap.Strict qualified as Map +import Data.HashMap.Strict.InsOrd.Extended qualified as OMap +import Data.HashSet qualified as Set +import Data.List.Extended (longestCommonPrefix) +import Hasura.GraphQL.Parser.Schema as G (InputValue) import Hasura.Prelude +import Hasura.RQL.Types.Common (FieldName) import Hasura.RQL.Types.Relationships.ToSchema import Hasura.RQL.Types.RemoteSchema +import Hasura.RQL.Types.RemoteSchema qualified as RQL import Hasura.RQL.Types.ResultCustomization +import Hasura.RQL.Types.ResultCustomization qualified as RQL import Language.GraphQL.Draft.Syntax qualified as G +------------------------------------------------------------------------------- +-- Custom AST + +-- | Custom representation of a selection set. +-- +-- Similarly to other parts of the IR, the @r@ argument is used for remote +-- relationships. +data SelectionSet r var + = SelectionSetObject !(ObjectSelectionSet r var) + | SelectionSetUnion !(DeduplicatedSelectionSet r var) + | SelectionSetInterface !(DeduplicatedSelectionSet r var) + | SelectionSetNone + deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | Representation of the normalized selection set of an interface/union type. +-- +-- This representation is used to attempt to minimize the size of the GraphQL +-- query that eventually gets sent to the GraphQL server by defining as many +-- fields as possible on the abstract type. +data DeduplicatedSelectionSet r var = DeduplicatedSelectionSet + { -- | Fields that aren't explicitly defined for member types + _atssCommonFields :: !(Set.HashSet G.Name), + -- | SelectionSets of individual member types + _atssMemberSelectionSets :: !(Map.HashMap G.Name (ObjectSelectionSet r var)) + } + deriving (Show, Eq, Functor, Foldable, Traversable, Generic) + +type ObjectSelectionSet r var = OMap.InsOrdHashMap G.Name (Field r var) + +-- | Constructs an 'InterfaceSelectionSet' from a set of interface fields and an +-- association list of the fields. This function ensures that @__typename@ is +-- present in the set of interface fields. +mkInterfaceSelectionSet :: + -- | Member fields of the interface + Set.HashSet G.Name -> + -- | Selection sets for all the member types + [(G.Name, ObjectSelectionSet r var)] -> + DeduplicatedSelectionSet r var +mkInterfaceSelectionSet interfaceFields selectionSets = + DeduplicatedSelectionSet + (Set.insert $$(G.litName "__typename") interfaceFields) + (Map.fromList selectionSets) + +-- | Constructs an 'UnionSelectionSet' from a list of the fields, using a +-- singleton set of @__typename@ for the set of common fields. +mkUnionSelectionSet :: + -- | Selection sets for all the member types + [(G.Name, ObjectSelectionSet r var)] -> + DeduplicatedSelectionSet r var +mkUnionSelectionSet selectionSets = + DeduplicatedSelectionSet + (Set.singleton $$(G.litName "__typename")) + (Map.fromList selectionSets) + +-- | Representation of one individual field. +-- +-- This particular type is the reason why we need a different representation +-- from the one in 'graphql-parser-hs': we differentiate between selection +-- fields that target the actual remote schema, and fields that, instead, are +-- remote from it and need to be treated differently. +data Field r var + = FieldGraphQL !(GraphQLField r var) + | FieldRemote !(SchemaRemoteRelationshipSelect r) + deriving (Show, Eq, Functor, Foldable, Traversable) + +-- | Normalized representation of a GraphQL field. +-- +-- This type is almost identical to 'G.Field', except for the fact that the +-- selection set is our annotated 'SelectionSet', instead of the original +-- 'G.SelectionSet'. We use this type to represent the fields of a selection +-- that do target the remote schema. +data GraphQLField r var = GraphQLField + { _fAlias :: G.Name, + _fName :: G.Name, + _fArguments :: HashMap G.Name (G.Value var), + _fDirectives :: [G.Directive var], + _fSelectionSet :: SelectionSet r var + } + deriving (Show, Eq, Functor, Foldable, Traversable) + +mkGraphQLField :: + Maybe G.Name -> + G.Name -> + HashMap G.Name (G.Value var) -> + [G.Directive var] -> + SelectionSet r var -> + GraphQLField r var +mkGraphQLField alias name = + GraphQLField (fromMaybe name alias) name + +------------------------------------------------------------------------------- +-- Remote schema entry points + +-- | Root entry point for a remote schema. +data RemoteSchemaRootField r var = RemoteSchemaRootField + { _rfRemoteSchemaInfo :: RQL.RemoteSchemaInfo, + _rfResultCustomizer :: RQL.ResultCustomizer, + _rfField :: GraphQLField r var + } + deriving (Functor, Foldable, Traversable) + +-- | A remote relationship's selection and fields required for its join condition. +data SchemaRemoteRelationshipSelect r = SchemaRemoteRelationshipSelect + { -- | The fields on the table that are required for the join condition + -- of the remote relationship + _srrsLHSJoinFields :: HashMap FieldName G.Name, + -- | The field that captures the relationship + -- r ~ (RemoteRelationshipField UnpreparedValue) when the AST is emitted by the parser. + -- r ~ Void when an execution tree is constructed so that a backend is + -- absolved of dealing with remote relationships. + _srrsRelationship :: r + } + deriving (Eq, Show, Functor, Foldable, Traversable) + data RemoteFieldArgument = RemoteFieldArgument - { _rfaArgument :: !G.Name, - _rfaValue :: !(InputValue RemoteSchemaVariable) + { _rfaArgument :: G.Name, + _rfaValue :: InputValue RemoteSchemaVariable } deriving (Eq, Show) data RemoteSchemaSelect = RemoteSchemaSelect - { _rselArgs :: ![RemoteFieldArgument], - _rselResultCustomizer :: !ResultCustomizer, - _rselSelection :: !(G.SelectionSet G.NoFragments RemoteSchemaVariable), - _rselFieldCall :: !(NonEmpty FieldCall), - _rselRemoteSchema :: !RemoteSchemaInfo + { _rselArgs :: [RemoteFieldArgument], + _rselResultCustomizer :: ResultCustomizer, + _rselSelection :: SelectionSet Void RemoteSchemaVariable, + _rselFieldCall :: NonEmpty FieldCall, + _rselRemoteSchema :: RemoteSchemaInfo } + +------------------------------------------------------------------------------- +-- Conversion back to a GraphQL document + +-- | Converts a normalized selection set back into a selection set as defined in +-- GraphQL spec, in order to send it to a remote server. +-- +-- This function expects a 'SelectionSet' for which @r@ is 'Void', which +-- guarantees that there is no longer any remote join field in the selection +-- set. +convertSelectionSet :: + forall var. + Eq var => + SelectionSet Void var -> + G.SelectionSet G.NoFragments var +convertSelectionSet = \case + SelectionSetObject s -> convertObjectSelectionSet s + SelectionSetUnion s -> convertAbstractTypeSelectionSet s + SelectionSetInterface s -> convertAbstractTypeSelectionSet s + SelectionSetNone -> mempty + where + convertField :: Field Void var -> G.Field G.NoFragments var + convertField = \case + FieldGraphQL f -> convertGraphQLField f + + convertObjectSelectionSet = + map (G.SelectionField . convertField . snd) . OMap.toList + + convertAbstractTypeSelectionSet abstractSelectionSet = + let (base, members) = reduceAbstractTypeSelectionSet abstractSelectionSet + commonFields = convertObjectSelectionSet base + concreteTypeSelectionSets = + Map.toList members <&> \(concreteType, selectionSet) -> + G.InlineFragment + { G._ifTypeCondition = Just concreteType, + G._ifDirectives = mempty, + G._ifSelectionSet = convertObjectSelectionSet selectionSet + } + in -- The base selection set first and then the more specific member + -- selection sets. Note that the rendering strategy here should be + -- inline with the strategy used in `mkAbstractTypeSelectionSet` + commonFields <> map G.SelectionInlineFragment concreteTypeSelectionSets + +convertGraphQLField :: Eq var => GraphQLField Void var -> G.Field G.NoFragments var +convertGraphQLField GraphQLField {..} = + G.Field + { -- add the alias only if it is different from the field name. This + -- keeps the outbound request more readable + G._fAlias = if _fAlias /= _fName then Just _fAlias else Nothing, + G._fName = _fName, + G._fArguments = _fArguments, + G._fDirectives = mempty, + G._fSelectionSet = convertSelectionSet _fSelectionSet + } + +-- | Builds the selection set for an abstract type. +-- +-- Let's consider this query on starwars API: +-- The type `Node` an interface is implemented by `Film`, `Species`, `Planet`, +-- `Person`, `Starship`, `Vehicle` +-- +-- query f { +-- node(id: "ZmlsbXM6MQ==") { +-- __typename +-- id +-- ... on Film { +-- title +-- } +-- ... on Species { +-- name +-- } +-- } +-- } +-- +-- When we parse this, it gets normalized into this query: +-- +-- query f { +-- node(id: "ZmlsbXM6MQ==") { +-- ... on Film { +-- __typename: __typename +-- id +-- title +-- } +-- ... on Species { +-- __typename: __typename +-- id +-- name +-- } +-- ... on Planet { +-- __typename: __typename +-- id +-- } +-- ... on Person { +-- __typename: __typename +-- id +-- } +-- ... on Starship { +-- __typename: __typename +-- id +-- } +-- ... on Vehicle { +-- __typename: __typename +-- id +-- } +-- } +-- } +-- +-- `__typename` and `id` get pushed to each of the member types. From the above +-- normalized selection set, we want to costruct a query as close to the +-- original as possible. We do this as follows: +-- +-- 1. find the longest common set of fields that each selection set starts with +-- (in the above case, they are `__typename` and `id`) +-- 2. from the above list of fields, find the first field that cannot be +-- defined on the abstract type. The fields that can be defined on the +-- abstract type are all the fields that occur before the first non abstract +-- type field (in the above case, both` __typename` and `id` can be defined +-- on the `Node` type) +-- 3. Strip the base selection set fields from all the member selection sets and +-- filter out the member type selection sets that are subsumed by the base +-- selection set +-- +-- The above query now translates to this: +-- +-- query f { +-- node(id: "ZmlsbXM6MQ==") { +-- __typename: __typename +-- id +-- ... on Film { +-- title +-- } +-- ... on Species { +-- name +-- } +-- } +-- } +-- +-- Note that it is not always possible to get the same shape as the original +-- query and there is more than one approach to this. For example, we could +-- have picked the selection set (that can be defined on the abstract type) +-- that is common across all the member selection sets and used that as the +-- base selection. +reduceAbstractTypeSelectionSet :: + (Eq var) => + DeduplicatedSelectionSet Void var -> + (ObjectSelectionSet Void var, Map.HashMap G.Name (ObjectSelectionSet Void var)) +reduceAbstractTypeSelectionSet (DeduplicatedSelectionSet baseMemberFields selectionSets) = + (baseSelectionSet, Map.fromList memberSelectionSets) + where + sharedSelectionSetPrefix = longestCommonPrefix $ map (OMap.toList . snd) $ Map.toList selectionSets + + baseSelectionSet = OMap.fromList $ takeWhile (shouldAddToBase . snd) sharedSelectionSetPrefix + + shouldAddToBase = \case + FieldGraphQL f -> Set.member (_fName f) baseMemberFields + + memberSelectionSets = + -- remove member selection sets that are subsumed by base selection set + filter (not . null . snd) $ + -- remove the common prefix from member selection sets + map (second (OMap.fromList . drop (OMap.size baseSelectionSet) . OMap.toList)) $ Map.toList selectionSets + +------------------------------------------------------------------------------- +-- Remote schema entry points + +$(makePrisms ''Field) diff --git a/server/src-lib/Hasura/RQL/IR/Root.hs b/server/src-lib/Hasura/RQL/IR/Root.hs index 6b237468584..b737aa4f80e 100644 --- a/server/src-lib/Hasura/RQL/IR/Root.hs +++ b/server/src-lib/Hasura/RQL/IR/Root.hs @@ -89,14 +89,14 @@ type MutationActionRoot v = type QueryRootField v = RootField (QueryDBRoot (RemoteRelationshipField v) v) - RQL.RemoteField + (RemoteSchemaRootField Void RQL.RemoteSchemaVariable) (QueryActionRoot v) JO.Value type MutationRootField v = RootField (MutationDBRoot (RemoteRelationshipField v) v) - RQL.RemoteField + (RemoteSchemaRootField Void RQL.RemoteSchemaVariable) (MutationActionRoot v) JO.Value diff --git a/server/src-lib/Hasura/RQL/IR/Select.hs b/server/src-lib/Hasura/RQL/IR/Select.hs index b7be48e56d1..2c9819cec08 100644 --- a/server/src-lib/Hasura/RQL/IR/Select.hs +++ b/server/src-lib/Hasura/RQL/IR/Select.hs @@ -160,10 +160,10 @@ data QueryDB (b :: BackendType) (r :: Type) v -- Select data AnnSelectG (b :: BackendType) (r :: Type) (f :: Type -> Type) (v :: Type) = AnnSelectG - { _asnFields :: (Fields (f v)), - _asnFrom :: (SelectFromG b v), - _asnPerm :: (TablePermG b v), - _asnArgs :: (SelectArgsG b v), + { _asnFields :: Fields (f v), + _asnFrom :: SelectFromG b v, + _asnPerm :: TablePermG b v, + _asnArgs :: SelectArgsG b v, _asnStrfyNum :: StringifyNumbers } deriving stock (Functor, Foldable, Traversable) @@ -195,10 +195,10 @@ type AnnAggregateSelect b = AnnAggregateSelectG b Void (SQLExpression b) -- Relay select data ConnectionSelect (b :: BackendType) (r :: Type) v = ConnectionSelect - { _csXRelay :: (XRelay b), - _csPrimaryKeyColumns :: (PrimaryKeyColumns b), - _csSplit :: (Maybe (NE.NonEmpty (ConnectionSplit b v))), - _csSlice :: (Maybe ConnectionSlice), + { _csXRelay :: XRelay b, + _csPrimaryKeyColumns :: PrimaryKeyColumns b, + _csSplit :: Maybe (NE.NonEmpty (ConnectionSplit b v)), + _csSlice :: Maybe ConnectionSlice, _csSelect :: (AnnSelectG b r (ConnectionField b r) v) } deriving stock (Functor, Foldable, Traversable) @@ -295,10 +295,10 @@ type SelectFrom b = SelectFromG b (SQLExpression b) -- Select arguments data SelectArgsG (b :: BackendType) v = SelectArgs - { _saWhere :: (Maybe (AnnBoolExp b v)), - _saOrderBy :: (Maybe (NE.NonEmpty (AnnotatedOrderByItemG b v))), - _saLimit :: (Maybe Int), - _saOffset :: (Maybe Int64), + { _saWhere :: Maybe (AnnBoolExp b v), + _saOrderBy :: Maybe (NE.NonEmpty (AnnotatedOrderByItemG b v)), + _saLimit :: Maybe Int, + _saOffset :: Maybe Int64, _saDistinct :: (Maybe (NE.NonEmpty (Column b))) } deriving stock (Generic, Functor, Foldable, Traversable) @@ -350,10 +350,10 @@ deriving stock instance (Backend b, Show v, Show (BooleanOperators b v)) => Show instance (Backend b, Hashable v, Hashable (BooleanOperators b v)) => Hashable (ComputedFieldOrderByElement b v) data ComputedFieldOrderBy (b :: BackendType) v = ComputedFieldOrderBy - { _cfobXField :: (XComputedField b), + { _cfobXField :: XComputedField b, _cfobName :: ComputedFieldName, - _cfobFunction :: (FunctionName b), - _cfobFunctionArgsExp :: (FunctionArgsExpTableRow v), + _cfobFunction :: FunctionName b, + _cfobFunctionArgsExp :: FunctionArgsExpTableRow v, _cfobOrderByElement :: (ComputedFieldOrderByElement b v) } deriving stock (Generic, Functor, Foldable, Traversable) @@ -581,17 +581,15 @@ type PageInfoFields = Fields PageInfoField type EdgeFields b r v = Fields (EdgeField b r v) --- Column - data AnnColumnField (b :: BackendType) v = AnnColumnField - { _acfColumn :: (Column b), - _acfType :: (ColumnType b), + { _acfColumn :: Column b, + _acfType :: ColumnType b, -- | If this field is 'True', columns are explicitly casted to @text@ when fetched, which avoids -- an issue that occurs because we don’t currently have proper support for array types. See -- https://github.com/hasura/graphql-engine/pull/3198 for more details. _acfAsText :: Bool, - _acfOp :: (Maybe (ColumnOp b)), - -- | This type is used to determine if whether the column + _acfOp :: Maybe (ColumnOp b), + -- | This type is used to determine whether the column -- should be nullified. When the value is `Nothing`, the column value -- will be outputted as computed and when the value is `Just c`, the -- column will be outputted when `c` evaluates to `true` and `null` @@ -626,9 +624,9 @@ deriving stock instance Backend b => Eq (ColumnOp b) -- Computed field data ComputedFieldScalarSelect (b :: BackendType) v = ComputedFieldScalarSelect - { _cfssFunction :: (FunctionName b), - _cfssArguments :: (FunctionArgsExpTableRow v), - _cfssType :: (ScalarType b), + { _cfssFunction :: FunctionName b, + _cfssArguments :: FunctionArgsExpTableRow v, + _cfssType :: ScalarType b, _cfssColumnOp :: (Maybe (ColumnOp b)) } deriving stock (Functor, Foldable, Traversable) @@ -670,7 +668,7 @@ deriving stock instance data AnnRelationSelectG (b :: BackendType) a = AnnRelationSelectG { aarRelationshipName :: RelName, -- Relationship name - aarColumnMapping :: (HashMap (Column b) (Column b)), -- Column of left table to join with + aarColumnMapping :: HashMap (Column b) (Column b), -- Column of left table to join with aarAnnSelect :: a -- Current table. Almost ~ to SQL Select } deriving stock (Functor, Foldable, Traversable) @@ -688,8 +686,8 @@ type ArrayConnectionSelect b r v = AnnRelationSelectG b (ConnectionSelect b r v) type ArrayAggregateSelect b = ArrayAggregateSelectG b Void (SQLExpression b) data AnnObjectSelectG (b :: BackendType) (r :: Type) v = AnnObjectSelectG - { _aosFields :: (AnnFieldsG b r v), - _aosTableFrom :: (TableName b), + { _aosFields :: AnnFieldsG b r v, + _aosTableFrom :: TableName b, _aosTableFilter :: (AnnBoolExp b v) } deriving stock (Functor, Foldable, Traversable) @@ -779,8 +777,8 @@ data (vf :: BackendType -> Type) (tgt :: BackendType) = RemoteSourceSelect { _rssName :: SourceName, - _rssConfig :: (SourceConfig tgt), - _rssSelection :: (SourceRelationshipSelection tgt r vf), + _rssConfig :: SourceConfig tgt, + _rssSelection :: SourceRelationshipSelection tgt r vf, -- | Additional information about the source's join columns: -- (ScalarType tgt) so that the remote can interpret the join values coming -- from src @@ -792,7 +790,7 @@ data -- Permissions data TablePermG (b :: BackendType) v = TablePerm - { _tpFilter :: (AnnBoolExp b v), + { _tpFilter :: AnnBoolExp b v, _tpLimit :: (Maybe Int) } deriving stock (Generic, Functor, Foldable, Traversable) diff --git a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs index 322a320a816..17b79f11328 100644 --- a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs @@ -3,9 +3,7 @@ module Hasura.RQL.Types.RemoteSchema AddRemoteSchemaQuery (..), AliasMapping, DropRemoteSchemaPermissions (..), - RemoteField, RemoteFieldCustomization (..), - RemoteFieldG (..), RemoteSchemaCustomization (..), RemoteSchemaCustomizer (..), RemoteSchemaDef (..), @@ -36,16 +34,12 @@ module Hasura.RQL.Types.RemoteSchema remoteSchemaCustomizeFieldName, getTypeName, remoteSchemaCustomizeTypeName, - rfField, - rfRemoteSchemaInfo, - rfResultCustomizer, singletonAliasMapping, validateRemoteSchemaCustomization, validateRemoteSchemaDef, ) where -import Control.Lens.TH (makeLenses) import Data.Aeson qualified as J import Data.Aeson.TH qualified as J import Data.Environment qualified as Env @@ -412,17 +406,6 @@ newtype RemoteSchemaIntrospection = RemoteSchemaIntrospection (HashMap G.Name (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)) deriving (Show, Eq, Generic, Hashable, Cacheable, Ord) -data RemoteFieldG var = RemoteFieldG - { _rfRemoteSchemaInfo :: !RemoteSchemaInfo, - _rfResultCustomizer :: !ResultCustomizer, - _rfField :: !(G.Field G.NoFragments var) - } - deriving (Functor, Foldable, Traversable) - -$(makeLenses ''RemoteFieldG) - -type RemoteField = RemoteFieldG RemoteSchemaVariable - data RemoteSchemaPermsCtx = RemoteSchemaPermsEnabled | RemoteSchemaPermsDisabled diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index e9dae8db7cc..228a3da9bf1 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -138,6 +138,7 @@ import Hasura.Incremental import Hasura.Prelude import Hasura.RQL.DDL.WebhookTransforms import Hasura.RQL.IR.BoolExp +import Hasura.RQL.IR.RemoteSchema import Hasura.RQL.Types.Action import Hasura.RQL.Types.Allowlist import Hasura.RQL.Types.ApiLimit @@ -226,9 +227,9 @@ data IntrospectionResult = IntrospectionResult instance Cacheable IntrospectionResult data ParsedIntrospectionG m = ParsedIntrospection - { piQuery :: [P.FieldParser m (NamespacedField RemoteField)], - piMutation :: Maybe [P.FieldParser m (NamespacedField RemoteField)], - piSubscription :: Maybe [P.FieldParser m (NamespacedField RemoteField)] + { piQuery :: [P.FieldParser m (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))], + piMutation :: Maybe [P.FieldParser m (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))], + piSubscription :: Maybe [P.FieldParser m (NamespacedField (RemoteSchemaRootField Void RemoteSchemaVariable))] } type ParsedIntrospection = ParsedIntrospectionG (P.ParseT Identity) diff --git a/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs index 2600a8a6c9e..151f41200b6 100644 --- a/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs +++ b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs @@ -18,6 +18,7 @@ import Hasura.GraphQL.Parser.TestUtils import Hasura.GraphQL.RemoteServer (identityCustomizer) import Hasura.GraphQL.Schema.Remote import Hasura.Prelude +import Hasura.RQL.IR.RemoteSchema import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.SchemaCache import Hasura.Session @@ -106,7 +107,7 @@ buildQueryParsers introspection = do RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer pure $ head query <&> \case - NotNamespaced remoteFld -> _rfField remoteFld + NotNamespaced remoteFld -> convertGraphQLField $ _rfField remoteFld Namespaced _ -> -- Shouldn't happen if we're using identityCustomizer -- TODO: add some tests for remote schema customization