From 5bfce057c637bce9570dd74978d1db35c66e093b Mon Sep 17 00:00:00 2001 From: David Overton Date: Tue, 30 Nov 2021 11:37:14 +1100 Subject: [PATCH] Refactor remote schema customization PR-URL: https://github.com/hasura/graphql-engine-mono/pull/2771 GitOrigin-RevId: 0c90136f956df3f4552140e6ca3d2f4766f8b3f5 --- server/graphql-engine.cabal | 1 - .../Hasura/GraphQL/Execute/Mutation.hs | 2 +- .../src-lib/Hasura/GraphQL/Execute/Query.hs | 2 +- .../src-lib/Hasura/GraphQL/Execute/Remote.hs | 6 +- server/src-lib/Hasura/GraphQL/Namespace.hs | 25 + server/src-lib/Hasura/GraphQL/RemoteServer.hs | 15 +- server/src-lib/Hasura/GraphQL/Schema.hs | 58 +- .../src-lib/Hasura/GraphQL/Schema/Backend.hs | 3 +- .../src-lib/Hasura/GraphQL/Schema/Remote.hs | 525 ++++++------------ .../src-lib/Hasura/GraphQL/Schema/Select.hs | 16 +- .../src-lib/Hasura/GraphQL/Transport/HTTP.hs | 27 +- .../Hasura/GraphQL/Transport/WebSocket.hs | 2 +- .../src-lib/Hasura/RQL/Types/RemoteSchema.hs | 47 +- .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 16 +- .../Hasura/RQL/Types/SourceCustomization.hs | 7 + .../Hasura/GraphQL/RemoteServerSpec.hs | 115 ---- .../Hasura/GraphQL/Schema/RemoteTest.hs | 23 +- server/src-test/Main.hs | 2 - .../validation/customize_all_the_things.yaml | 54 +- .../validation/field_prefix_validation.yaml | 2 +- .../validation/namespace_validation.yaml | 6 - .../validation/type_prefix_validation.yaml | 49 +- server/tests-py/test_schema_stitching.py | 2 +- 23 files changed, 322 insertions(+), 683 deletions(-) delete mode 100644 server/src-test/Hasura/GraphQL/RemoteServerSpec.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 2b9279f9209..c308973ac25 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -816,7 +816,6 @@ test-suite graphql-engine-tests Hasura.GraphQL.NamespaceSpec Hasura.GraphQL.Parser.DirectivesTest Hasura.GraphQL.Parser.TestUtils - Hasura.GraphQL.RemoteServerSpec Hasura.GraphQL.Schema.RemoteTest Hasura.IncrementalSpec Hasura.RQL.IR.Generator diff --git a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs index d18313a91f4..6dbd8fd6383 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs @@ -128,7 +128,7 @@ convertMutationSelectionSet pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins RFRemote remoteField -> do RemoteFieldG remoteSchemaInfo resultCustomizer resolvedRemoteField <- runVariableCache $ resolveRemoteField userInfo remoteField - pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeMutation $ getRemoteFieldSelectionSet resolvedRemoteField + pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeMutation [G.SelectionField resolvedRemoteField] 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 ae94cbfa134..04f2e58d96d 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Query.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Query.hs @@ -114,7 +114,7 @@ convertQuerySelSet pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins RFRemote rf -> do RemoteFieldG remoteSchemaInfo resultCustomizer remoteField <- runVariableCache $ for rf $ resolveRemoteVariable userInfo - pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeQuery $ getRemoteFieldSelectionSet remoteField + pure $ buildExecStepRemote remoteSchemaInfo resultCustomizer G.OperationTypeQuery [G.SelectionField remoteField] 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 facb5417650..9cdb6ba6292 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Remote.hs @@ -212,10 +212,10 @@ resolveRemoteVariable userInfo = \case -- | TODO: Documentation. resolveRemoteField :: - (MonadError QErr m, Traversable f) => + (MonadError QErr m) => UserInfo -> - RemoteFieldG f RemoteSchemaVariable -> - StateT RemoteJSONVariableMap m (RemoteFieldG f Variable) + RemoteFieldG RemoteSchemaVariable -> + StateT RemoteJSONVariableMap m (RemoteFieldG Variable) resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo) -- | TODO: Documentation. diff --git a/server/src-lib/Hasura/GraphQL/Namespace.hs b/server/src-lib/Hasura/GraphQL/Namespace.hs index 2d6e9c32c48..7941d8c0929 100644 --- a/server/src-lib/Hasura/GraphQL/Namespace.hs +++ b/server/src-lib/Hasura/GraphQL/Namespace.hs @@ -8,12 +8,15 @@ module Hasura.GraphQL.Namespace NamespacedFieldMap, flattenNamespaces, unflattenNamespaces, + customizeNamespace, ) where import Data.Aeson qualified as J import Data.HashMap.Strict.InsOrd qualified as OMap import Data.Text.Extended +import Hasura.GraphQL.Parser +import Hasura.GraphQL.Parser qualified as P import Hasura.Prelude import Language.GraphQL.Draft.Syntax qualified as G @@ -76,3 +79,25 @@ unflattenNamespaces = OMap.foldlWithKey' insert mempty Just ns -> OMap.insertWith merge ns (Namespaced $ (OMap.singleton _rfaAlias v)) m merge (Namespaced m) (Namespaced m') = Namespaced (OMap.union m' m) -- Note: order of arguments to OMap.union to preserve ordering merge v _ = v + +-- | Wrap the field parser results in @NamespacedField@ +customizeNamespace :: + forall n a. + (MonadParse n) => + Maybe G.Name -> + (G.Name -> P.ParsedSelection a -> a) -> + P.MkTypename -> + [FieldParser n a] -> + [FieldParser n (NamespacedField a)] +customizeNamespace (Just namespace) fromParsedSelection mkNamespaceTypename fieldParsers = + -- Source or remote schema has a namespace field so wrap the parsers + -- in a new namespace field parser. + [P.subselection_ namespace Nothing parser] + where + parser :: Parser 'Output n (NamespacedField a) + parser = + Namespaced . OMap.mapWithKey fromParsedSelection + <$> P.selectionSet (mkNamespaceTypename namespace) Nothing fieldParsers +customizeNamespace Nothing _ _ fieldParsers = + -- No namespace so just wrap the field parser results in @NotNamespaced@. + fmap NotNamespaced <$> fieldParsers diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index 9ae54e585a7..0b69922bbd1 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -24,10 +24,8 @@ import Data.HashSet qualified as Set import Data.List.Extended (duplicates) import Data.Text qualified as T import Data.Text.Extended (dquoteList, (<<>)) -import Data.Tuple (swap) import Hasura.Base.Error import Hasura.GraphQL.Parser.Collect () -import Hasura.GraphQL.Parser.Monad qualified as P -- Needed for GHCi and HLS due to TH in cyclically dependent modules (see https://gitlab.haskell.org/ghc/ghc/-/issues/1012) import Hasura.GraphQL.Schema.Remote (buildRemoteParser) import Hasura.GraphQL.Transport.HTTP.Protocol @@ -165,8 +163,7 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do let _rscInfo = RemoteSchemaInfo {..} -- Check that the parsed GraphQL type info is valid by running the schema generation - (piQuery, piMutation, piSubscription) <- - P.runSchemaT @m @(P.ParseT Identity) $ buildRemoteParser _rscIntroOriginal _rscInfo + _rscParsed <- buildRemoteParser _rscIntroOriginal _rscInfo -- The 'rawIntrospectionResult' contains the 'Bytestring' response of -- the introspection result of the remote server. We store this in the @@ -175,7 +172,6 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do return RemoteSchemaCtx { _rscPermissions = mempty, - _rscParsed = ParsedIntrospection {..}, .. } where @@ -458,7 +454,7 @@ execRemoteGQ env manager userInfo reqHdrs rsdef gqlReq@GQLReq {..} = do userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo identityCustomizer :: RemoteSchemaCustomizer -identityCustomizer = RemoteSchemaCustomizer Nothing mempty mempty mempty mempty +identityCustomizer = RemoteSchemaCustomizer Nothing mempty mempty typeDefinitionName :: G.TypeDefinition a b -> G.Name typeDefinitionName = \case @@ -473,8 +469,6 @@ getCustomizer :: IntrospectionResult -> Maybe RemoteSchemaCustomization -> Remot getCustomizer _ Nothing = identityCustomizer getCustomizer IntrospectionResult {..} (Just RemoteSchemaCustomization {..}) = RemoteSchemaCustomizer {..} where - mapMap f = Map.fromList . map f . Map.toList - invertMap = mapMap swap -- key collisions are checked for later in validateSchemaCustomizations rootTypeNames = if isNothing _rscRootFieldsNamespace then catMaybes [Just irQueryRoot, irMutationRoot, irSubscriptionRoot] @@ -518,14 +512,9 @@ getCustomizer IntrospectionResult {..} (Just RemoteSchemaCustomization {..}) = R let customizationMap = Map.fromList $ map (\rfc -> (_rfcParentType rfc, rfc)) fieldNameCustomizations in Map.intersectionWith mkFieldRenameMap customizationMap typeFieldMap - mapLookup :: (Eq a, Hashable a) => HashMap a a -> a -> a - mapLookup m a = fromMaybe a $ Map.lookup a m - _rscNamespaceFieldName = _rscRootFieldsNamespace _rscCustomizeTypeName = typeRenameMap _rscCustomizeFieldName = fieldRenameMap - _rscDecustomizeTypeName = invertMap typeRenameMap - _rscDecustomizeFieldName = mapMap (mapLookup typeRenameMap *** invertMap) fieldRenameMap throwRemoteSchema :: QErrM m => diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 068812e1694..c9780559b1c 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -153,24 +153,8 @@ customizeFields :: P.MkTypename -> f [FieldParser n (RootField db remote action JO.Value)] -> f [FieldParser n (NamespacedField (RootField db remote action JO.Value))] -customizeFields sourceCustomization = - fmap . customizeNamespace sourceCustomization - -customizeNamespace :: - forall n db remote action. - (MonadParse n) => - SourceCustomization -> - P.MkTypename -> - [FieldParser n (RootField db remote action JO.Value)] -> - [FieldParser n (NamespacedField (RootField db remote action JO.Value))] -customizeNamespace SourceCustomization {_scRootFields = Just RootFieldsCustomization {_rootfcNamespace = Just namespace}} mkNamespaceTypename fieldParsers = - [P.subselection_ namespace Nothing parser] - where - parser :: Parser 'Output n (NamespacedField (RootField db remote action JO.Value)) - parser = - Namespaced . fmap typenameToRawRF - <$> P.selectionSet (mkNamespaceTypename namespace) Nothing fieldParsers -customizeNamespace _ _ fieldParsers = fmap NotNamespaced <$> fieldParsers +customizeFields SourceCustomization {..} = + fmap . customizeNamespace (_rootfcNamespace =<< _scRootFields) (const typenameToRawRF) buildRoleContext :: forall m. @@ -236,12 +220,12 @@ buildRoleContext where getQueryRemotes :: [ParsedIntrospection] -> - [P.FieldParser (P.ParseT Identity) RemoteField] + [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] getQueryRemotes = concatMap piQuery getMutationRemotes :: [ParsedIntrospection] -> - [P.FieldParser (P.ParseT Identity) RemoteField] + [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] getMutationRemotes = concatMap (concat . piMutation) buildSource :: @@ -422,14 +406,14 @@ unauthenticatedContext :: MonadIO m, MonadUnique m ) => - [P.FieldParser (P.ParseT Identity) RemoteField] -> - [P.FieldParser (P.ParseT Identity) RemoteField] -> + [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] -> + [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] -> RemoteSchemaPermsCtx -> m GQLContext unauthenticatedContext adminQueryRemotes adminMutationRemotes remoteSchemaPermsCtx = P.runSchemaT $ do let isRemoteSchemaPermsEnabled = remoteSchemaPermsCtx == RemoteSchemaPermsEnabled - queryFields = bool (fmap (fmap $ NotNamespaced . RFRemote) adminQueryRemotes) [] isRemoteSchemaPermsEnabled - mutationFields = bool (fmap (fmap $ NotNamespaced . RFRemote) adminMutationRemotes) [] isRemoteSchemaPermsEnabled + queryFields = bool (fmap (fmap $ fmap RFRemote) adminQueryRemotes) [] isRemoteSchemaPermsEnabled + mutationFields = bool (fmap (fmap $ fmap RFRemote) adminMutationRemotes) [] isRemoteSchemaPermsEnabled mutationParser <- whenMaybe (not $ null mutationFields) $ P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFields @@ -452,9 +436,7 @@ buildRoleBasedRemoteSchemaParser roleName remoteSchemaCache = do for remoteSchemaIntroInfos $ \RemoteSchemaCtx {..} -> for (Map.lookup roleName _rscPermissions) $ \introspectRes -> do let customizer = rsCustomizer _rscInfo - (queryParsers, mutationParsers, subscriptionParsers) <- - P.runSchemaT @m @(P.ParseT Identity) $ buildRemoteParser introspectRes _rscInfo - let parsedIntrospection = ParsedIntrospection queryParsers mutationParsers subscriptionParsers + parsedIntrospection <- buildRemoteParser introspectRes _rscInfo return (_rscName, RemoteRelationshipQueryContext introspectRes parsedIntrospection customizer) return $ catMaybes remoteSchemaPerms @@ -629,10 +611,11 @@ buildQueryParser :: MonadRole r m, Has QueryContext r, Has P.MkTypename r, - Has MkRootFieldName r + Has MkRootFieldName r, + Has CustomizeRemoteFieldName r ) => [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] -> - [P.FieldParser n RemoteField] -> + [P.FieldParser n (NamespacedField RemoteField)] -> [ActionInfo] -> NonObjectTypeMap -> Maybe (Parser 'Output n (RootFieldMap (MutationRootField UnpreparedValue))) -> @@ -640,7 +623,7 @@ buildQueryParser :: m (Parser 'Output n (RootFieldMap (QueryRootField UnpreparedValue))) buildQueryParser pgQueryFields remoteFields allActions nonObjectCustomTypes mutationParser subscriptionParser = do actionQueryFields <- concat <$> traverse (buildActionQueryFields nonObjectCustomTypes) allActions - let allQueryFields = pgQueryFields <> fmap (fmap NotNamespaced) (actionQueryFields <> map (fmap RFRemote) remoteFields) + let allQueryFields = pgQueryFields <> fmap (fmap NotNamespaced) actionQueryFields <> fmap (fmap $ fmap RFRemote) remoteFields queryWithIntrospectionHelper allQueryFields mutationParser subscriptionParser queryWithIntrospectionHelper :: @@ -730,7 +713,8 @@ buildSubscriptionParser :: MonadRole r m, Has QueryContext r, Has P.MkTypename r, - Has MkRootFieldName r + Has MkRootFieldName r, + Has CustomizeRemoteFieldName r ) => [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] -> [ActionInfo] -> @@ -749,9 +733,10 @@ buildMutationParser :: MonadRole r m, Has QueryContext r, Has P.MkTypename r, - Has MkRootFieldName r + Has MkRootFieldName r, + Has CustomizeRemoteFieldName r ) => - [P.FieldParser n RemoteField] -> + [P.FieldParser n (NamespacedField RemoteField)] -> [ActionInfo] -> NonObjectTypeMap -> [P.FieldParser n (NamespacedField (MutationRootField UnpreparedValue))] -> @@ -761,7 +746,7 @@ buildMutationParser allRemotes allActions nonObjectCustomTypes mutationFields = let mutationFieldsParser = mutationFields <> (fmap NotNamespaced <$> actionParsers) - <> (fmap (NotNamespaced . RFRemote) <$> allRemotes) + <> (fmap (fmap RFRemote) <$> allRemotes) whenMaybe (not $ null mutationFieldsParser) $ P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF) @@ -820,7 +805,8 @@ type ConcreteSchemaT m a = SourceCache, QueryContext, P.MkTypename, - MkRootFieldName + MkRootFieldName, + CustomizeRemoteFieldName ) m ) @@ -835,7 +821,7 @@ runMonadSchema :: ConcreteSchemaT m a -> m a runMonadSchema roleName queryContext pgSources m = - flip runReaderT (roleName, pgSources, queryContext, P.Typename, id) $ P.runSchemaT m + P.runSchemaT m `runReaderT` (roleName, pgSources, queryContext, P.Typename, id, const id) -- | Whether the request is sent with `x-hasura-use-backend-only-permissions` set to `true`. data Scenario = Backend | Frontend deriving (Enum, Show, Eq) diff --git a/server/src-lib/Hasura/GraphQL/Schema/Backend.hs b/server/src-lib/Hasura/GraphQL/Schema/Backend.hs index 2c63dd1ef05..be9aed8eaf5 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Backend.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Backend.hs @@ -64,7 +64,8 @@ type MonadBuildSchema b r m n = MonadRole r m, Has QueryContext r, Has MkTypename r, - Has MkRootFieldName r + Has MkRootFieldName r, + Has CustomizeRemoteFieldName r ) -- | This type class is responsible for generating the schema of a backend. diff --git a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs index e98114c2422..384a90f941e 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs @@ -4,49 +4,67 @@ module Hasura.GraphQL.Schema.Remote ( buildRemoteParser, remoteField, - customizeFieldParser, + makeResultCustomizer, + withRemoteSchemaCustomization, ) where -import Control.Lens.Extended - ( Lens', - set, - use, - (%=), - (^.), - _1, - _2, - _3, - _4, - ) -import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.Unique +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.List.NonEmpty qualified as NE import Data.Monoid (Any (..)) -import Data.Parser.JSONPath -import Data.Text qualified as T import Data.Text.Extended import Data.Type.Equality import Hasura.Base.Error +import Hasura.GraphQL.Namespace 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.Types.Common (stringScalar) import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.ResultCustomization -import Hasura.RQL.Types.SchemaCache (IntrospectionResult (IntrospectionResult, irMutationRoot, irQueryRoot, irSubscriptionRoot)) +import Hasura.RQL.Types.SchemaCache (IntrospectionResult (IntrospectionResult, irMutationRoot, irQueryRoot, irSubscriptionRoot), ParsedIntrospectionG (..)) +import Hasura.RQL.Types.SourceCustomization import Language.GraphQL.Draft.Syntax qualified as G -------------------------------------------------------------------------------- -- Top level function --- TODO return ParsedIntrospection ? buildRemoteParser :: forall m n. - (MonadSchema n m, MonadError QErr m) => + (MonadIO m, MonadUnique m, MonadError QErr m, MonadParse n) => + IntrospectionResult -> + RemoteSchemaInfo -> + m (ParsedIntrospectionG n) +buildRemoteParser introspectionResult remoteSchemaInfo@RemoteSchemaInfo {..} = do + (rawQueryParsers, rawMutationParsers, rawSubscriptionParsers) <- + runMonadBuildRemoteSchema $ + withRemoteSchemaCustomization rsCustomizer $ + buildRawRemoteParser introspectionResult remoteSchemaInfo + pure $ + ParsedIntrospection + (customizeRemoteNamespace remoteSchemaInfo (irQueryRoot introspectionResult) rawQueryParsers) + (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) $ + if _fName == $$(G.litName "__typename") + then customizeTypeNameString (_rscCustomizeTypeName remoteSchemaCustomizer) + else foldMap resultCustomizerFromSelection _fSelectionSet + where + resultCustomizerFromSelection :: G.Selection G.NoFragments a -> ResultCustomizer + resultCustomizerFromSelection = \case + G.SelectionField fld -> makeResultCustomizer remoteSchemaCustomizer fld + G.SelectionInlineFragment G.InlineFragment {..} -> foldMap resultCustomizerFromSelection _ifSelectionSet + +buildRawRemoteParser :: + forall r m n. + MonadBuildRemoteSchema r m n => IntrospectionResult -> RemoteSchemaInfo -> -- | parsers for, respectively: queries, mutations, and subscriptions @@ -55,45 +73,27 @@ buildRemoteParser :: Maybe [P.FieldParser n RemoteField], Maybe [P.FieldParser n RemoteField] ) -buildRemoteParser introspectionResult remoteSchemaInfo = do - (rawQueryParsers, rawMutationParsers, rawSubscriptionParsers) <- buildRawRemoteParser introspectionResult remoteSchemaInfo - pure $ - evalMemoState $ do - queryParsers <- customizeFieldParsers remoteSchemaInfo (irQueryRoot introspectionResult) rawQueryParsers - mutationParsers <- sequence $ customizeFieldParsers remoteSchemaInfo <$> irMutationRoot introspectionResult <*> rawMutationParsers - subscriptionParsers <- sequence $ customizeFieldParsers remoteSchemaInfo <$> irSubscriptionRoot introspectionResult <*> rawSubscriptionParsers - pure (queryParsers, mutationParsers, subscriptionParsers) - -buildRawRemoteParser :: - forall m n. - (MonadSchema n m, MonadError QErr m) => - IntrospectionResult -> - RemoteSchemaInfo -> - -- | parsers for, respectively: queries, mutations, and subscriptions - m - ( [P.FieldParser n RawRemoteField], - Maybe [P.FieldParser n RawRemoteField], - Maybe [P.FieldParser n RawRemoteField] - ) -buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info@RemoteSchemaInfo {..} = do +buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info = do queryT <- makeParsers queryRoot mutationT <- makeNonQueryRootFieldParser mutationRoot $$(G.litName "Mutation") subscriptionT <- makeNonQueryRootFieldParser subscriptionRoot $$(G.litName "Subscription") return (queryT, mutationT, subscriptionT) where - makeFieldParser :: G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RawRemoteField) - makeFieldParser fieldDef = do - fldParser <- remoteFieldFromDefinition sdoc fieldDef - pure $ RemoteFieldG info mempty <$> fldParser + makeFieldParser :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RemoteField) + makeFieldParser rootTypeName fieldDef = + fmap makeRemoteField <$> remoteFieldFromDefinition sdoc rootTypeName fieldDef - makeParsers :: G.Name -> m [P.FieldParser n RawRemoteField] + makeRemoteField :: G.Field G.NoFragments RemoteSchemaVariable -> RemoteField + makeRemoteField fld = RemoteFieldG info (makeResultCustomizer (rsCustomizer info) fld) fld + + makeParsers :: G.Name -> m [P.FieldParser n RemoteField] makeParsers rootName = case lookupType sdoc rootName of Just (G.TypeDefinitionObject o) -> - traverse makeFieldParser $ G._otdFieldsDefinition 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 RawRemoteField]) + makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n RemoteField]) makeNonQueryRootFieldParser userProvidedRootName defaultRootName = case userProvidedRootName of Just _rootName -> traverse makeParsers userProvidedRootName @@ -234,8 +234,8 @@ newtype Altered = Altered {getAltered :: Bool} -- presets. Presets might force the evaluation of variables that would otherwise be transmitted -- unmodified. inputValueDefinitionParser :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.InputValueDefinition -> m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable))) @@ -276,12 +276,13 @@ inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType G.TypeNamed nullability typeName -> case lookupType schemaDoc typeName of Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName - Just typeDef -> + Just typeDef -> do + customizeTypename <- asks getter case typeDef of G.TypeDefinitionScalar scalarTypeDefn -> - pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser scalarTypeDefn + pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser customizeTypename scalarTypeDefn G.TypeDefinitionEnum defn -> - pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser defn + pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser customizeTypename defn G.TypeDefinitionObject _ -> throw400 RemoteSchemaError "expected input type, but got output type" G.TypeDefinitionInputObject defn -> do @@ -327,35 +328,47 @@ inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType -- were a query variable of its own. To avoid ending up with one such variable per scalar in the -- query, we also track alterations, to apply optimizations. -- See Note [Variable expansion in remote schema input parsers] for more information. +-- +-- If the value contains a variable with a customized type name then we need to consider it to be +-- altered to ensure that the original type name is passed to the remote server. remoteFieldScalarParser :: MonadParse n => + MkTypename -> G.ScalarTypeDefinition -> P.Parser 'Both n (Altered, G.Value RemoteSchemaVariable) -remoteFieldScalarParser (G.ScalarTypeDefinition description name _directives) = +remoteFieldScalarParser customizeTypename (G.ScalarTypeDefinition description name _directives) = P.Parser { pType = schemaType, - pParser = \inputValue -> - (Altered False,) <$> case inputValue of - JSONValue v -> pure $ G.VVariable $ RemoteJSONValue gType v - GraphQLValue v -> for v \var -> do + pParser = \case + JSONValue v -> + pure $ (Altered $ G.getBaseType gType /= name, G.VVariable $ RemoteJSONValue (mkRemoteGType gType) v) + GraphQLValue v -> case v of + G.VVariable var -> do P.typeCheck False gType var - pure $ QueryVariable var + pure $ (Altered $ G.getBaseType (vType var) /= name, G.VVariable $ QueryVariable var {vType = mkRemoteGType (vType var)}) + _ -> pure (Altered False, QueryVariable <$> v) } where - schemaType = NonNullable $ TNamed $ mkDefinition (Typename name) description TIScalar + customizedTypename = customizeTypename name + schemaType = NonNullable $ TNamed $ mkDefinition customizedTypename description TIScalar gType = toGraphQLType schemaType + mkRemoteGType = \case + G.TypeNamed n _ -> G.TypeNamed n name + G.TypeList n l -> G.TypeList n $ mkRemoteGType l + remoteFieldEnumParser :: MonadParse n => + MkTypename -> G.EnumTypeDefinition -> Parser 'Both n (Altered, G.Value RemoteSchemaVariable) -remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) = +remoteFieldEnumParser customizeTypename (G.EnumTypeDefinition desc name _directives valueDefns) = let enumValDefns = valueDefns <&> \(G.EnumValueDefinition enumDesc enumName _) -> ( mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo, G.VEnum enumName ) - in fmap (Altered False,) $ P.enum (Typename name) desc $ NE.fromList enumValDefns + in fmap (Altered False,) $ P.enum (customizeTypename name) desc $ NE.fromList enumValDefns -- | remoteInputObjectParser returns an input parser for a given 'G.InputObjectTypeDefinition' -- @@ -380,8 +393,8 @@ remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) = -- field: if yes, we memoize that branch and proceed as normal. Otherwise we can omit the -- memoization: we know for sure that the preset fields won't generate a recursive call! remoteInputObjectParser :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition -> m @@ -401,8 +414,9 @@ remoteInputObjectParser schemaDoc defn@(G.InputObjectTypeDefinition desc name _ -- the same parser. Right <$> P.memoizeOn 'remoteInputObjectParser defn do + typename <- mkTypename name argsParser <- argumentsParser valueDefns schemaDoc - pure $ fmap G.VObject <$> P.object (Typename name) desc argsParser + pure $ fmap G.VObject <$> P.object typename desc argsParser -- | Variable expansion optimization. -- Since each parser returns a value that indicates whether it was altered, we can detect when no @@ -474,8 +488,8 @@ shortCircuitIfUnaltered parser = -- part of the tree was altered during parsing; if any of the fields is preset, or recursively -- contains values that contain presets further down, then this result is labelled as altered. argumentsParser :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> RemoteSchemaIntrospection -> m (InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable))) @@ -515,20 +529,21 @@ aggregateListAndAlteration = first mconcat . unzip . catMaybes -- | 'remoteSchemaObject' returns a output parser for a given 'ObjectTypeDefinition'. remoteSchemaObject :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.ObjectTypeDefinition RemoteSchemaInputValueDefinition -> m (Parser 'Output n [G.Field G.NoFragments RemoteSchemaVariable]) remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name interfaces _directives subFields) = P.memoizeOn 'remoteSchemaObject defn do - subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) subFields + subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) subFields interfaceDefs <- traverse getInterface interfaces implements <- traverse (remoteSchemaInterface schemaDoc) interfaceDefs -- TODO: also check sub-interfaces, when these are supported in a future graphql spec traverse_ validateImplementsFields interfaceDefs + typename <- mkTypename name pure $ - P.selectionSetObject (Typename name) description subFieldParsers implements + P.selectionSetObject typename description subFieldParsers implements <&> toList . OMap.mapWithKey ( \alias -> handleTypename $ \_ -> @@ -694,14 +709,14 @@ constructed query. -- | 'remoteSchemaInterface' returns a output parser for a given 'InterfaceTypeDefinition'. -- Also check Note [Querying remote schema interfaces] remoteSchemaInterface :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name _directives fields possibleTypes) = P.memoizeOn 'remoteSchemaObject defn do - subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) fields + subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) fields objs <- traverse (getObjectParser schemaDoc getObject) possibleTypes -- In the Draft GraphQL spec (> June 2018), interfaces can themselves -- implement superinterfaces. In the future, we may need to support this @@ -712,7 +727,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name -- types in the schema document that claim to implement this interface. We -- should have a check that expresses that that collection of objects is equal -- to 'possibleTypes'. - pure $ P.selectionSetInterface (Typename name) description subFieldParsers objs <&> constructInterfaceSelectionSet + typename <- mkTypename name + pure $ P.selectionSetInterface typename description subFieldParsers objs <&> constructInterfaceSelectionSet where getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject objectName = @@ -767,8 +783,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name -- | 'remoteSchemaUnion' returns a output parser for a given 'UnionTypeDefinition'. remoteSchemaUnion :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.UnionTypeDefinition -> m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) @@ -777,8 +793,9 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct 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 name) description objs + P.selectionSetUnion typename description objs <&> ( \objNameAndFields -> catMaybes $ objNameAndFields <&> \(objName, fields) -> @@ -816,17 +833,18 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct <> squote objectName remoteFieldFromDefinition :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> + G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) -remoteFieldFromDefinition schemaDoc (G.FieldDefinition description name argsDefinition gType _) = - let addNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> 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' un desc (FieldInfo args typ)) parser) = P.FieldParser (Definition name' un desc (FieldInfo args (Nullable (TList typ)))) parser - addNonNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) + addNonNullableList :: FieldParser n a -> FieldParser n a addNonNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) = P.FieldParser (Definition name' un desc (FieldInfo args (NonNullable (TList typ)))) parser @@ -835,85 +853,96 @@ remoteFieldFromDefinition schemaDoc (G.FieldDefinition description name argsDefi convertType gType' = do case gType' of G.TypeNamed (G.Nullability True) fieldTypeName -> - P.nullableField <$> remoteFieldFromName schemaDoc name description fieldTypeName argsDefinition + 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 name description fieldTypeName argsDefinition + P.nonNullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition G.TypeList (G.Nullability False) gType'' -> addNonNullableList <$> convertType gType'' - in convertType gType + convertType gType -- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition -- in the 'RemoteSchemaIntrospection'. remoteFieldFromName :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.Name -> + G.Name -> Maybe G.Description -> G.Name -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) -remoteFieldFromName sdoc fieldName description fieldTypeName argsDefns = +remoteFieldFromName sdoc parentTypeName fieldName description fieldTypeName argsDefns = case lookupType sdoc fieldTypeName of Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> fieldTypeName - Just typeDef -> remoteField sdoc fieldName description argsDefns typeDef + Just typeDef -> remoteField sdoc parentTypeName fieldName description argsDefns typeDef -- | 'remoteField' accepts a 'G.TypeDefinition' and will returns a 'FieldParser' for it. -- Note that the 'G.TypeDefinition' should be of the GraphQL 'Output' kind, when an -- GraphQL 'Input' kind is provided, then error will be thrown. remoteField :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> G.Name -> + G.Name -> Maybe G.Description -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) -remoteField sdoc fieldName description argsDefn typeDefn = do +remoteField sdoc parentTypeName fieldName description argsDefn typeDefn = do -- TODO add directives argsParser <- argumentsParser argsDefn sdoc + customizeTypename <- asks getter + customizeFieldName <- asks getter + let customizedFieldName = customizeFieldName parentTypeName fieldName case typeDefn of G.TypeDefinitionObject objTypeDefn -> do remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn -- converting [Field NoFragments Name] to (SelectionSet NoFragments G.Name) let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields - pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet argsParser + pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet customizedFieldName argsParser G.TypeDefinitionScalar scalarTypeDefn -> - pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldScalarParser scalarTypeDefn + pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldScalarParser customizeTypename scalarTypeDefn G.TypeDefinitionEnum enumTypeDefn -> - pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldEnumParser enumTypeDefn + pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldEnumParser customizeTypename enumTypeDefn G.TypeDefinitionInterface ifaceTypeDefn -> - remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet argsParser + remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser G.TypeDefinitionUnion unionTypeDefn -> - remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet argsParser + remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser _ -> 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 - mkField alias args selSet = - G.Field alias fieldName args mempty selSet + 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 mkFieldParserWithoutSelectionSet :: + G.Name -> InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> Parser 'Both n () -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) - mkFieldParserWithoutSelectionSet argsParser outputParser = - P.rawSelection fieldName description argsParser outputParser - <&> \(alias, _, (_, args)) -> mkField alias args [] + mkFieldParserWithoutSelectionSet customizedFieldName argsParser outputParser = + P.rawSelection customizedFieldName description argsParser outputParser + <&> \(alias, _, (_, args)) -> mkField alias customizedFieldName args [] 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) - mkFieldParserWithSelectionSet argsParser outputParser = - P.rawSubselection fieldName description argsParser outputParser - <&> \(alias, _, (_, args), selSet) -> mkField alias args selSet + mkFieldParserWithSelectionSet customizedFieldName argsParser outputParser = + P.rawSubselection customizedFieldName description argsParser outputParser + <&> \(alias, _, (_, args), selSet) -> mkField alias customizedFieldName args selSet -- | helper function to get a parser of an object with it's name -- This function is called from 'remoteSchemaInterface' and @@ -921,8 +950,8 @@ remoteField sdoc fieldName description argsDefn typeDefn = do -- different implementation of 'getObject', which is the -- reason 'getObject' is an argument to this function getObjectParser :: - forall n m. - (MonadSchema n m, MonadError QErr m) => + forall r m n. + MonadBuildRemoteSchema r m n => RemoteSchemaIntrospection -> (G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) -> G.Name -> @@ -931,265 +960,37 @@ getObjectParser schemaDoc getObject objName = do obj <- remoteSchemaObject schemaDoc =<< getObject objName return $ (objName,) <$> obj -addCustomNamespace :: - forall m. - MonadParse m => - RemoteSchemaInfo -> - G.Name -> - G.Name -> - [P.FieldParser m RawRemoteField] -> - P.FieldParser m RemoteField -addCustomNamespace remoteSchemaInfo rootTypeName namespace fieldParsers = - P.subselection_ namespace Nothing remoteFieldParser - where - rawRemoteFieldsParser :: Parser 'Output m [RawRemoteField] - rawRemoteFieldsParser = - P.selectionSet (Typename rootTypeName) Nothing fieldParsers - <&> toList - . OMap.mapWithKey - ( \alias -> \case - P.SelectField fld -> fld - P.SelectTypename fld -> - -- In P.selectionSet we lose the resultCustomizer from __typename fields so we need to put it back - let resultCustomizer = modifyFieldByName alias $ customizeTypeNameString $ _rscCustomizeTypeName $ rsCustomizer remoteSchemaInfo - in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty - ) - - remoteFieldParser :: Parser 'Output m RemoteField - remoteFieldParser = - rawRemoteFieldsParser <&> \remoteFields -> - RemoteFieldG - remoteSchemaInfo - (foldMap _rfResultCustomizer remoteFields) - (RRFNamespaceField $ G.SelectionField . _rfField <$> remoteFields) - -customizeFieldParsers :: - forall m n. - (MonadState MemoState m, MonadFix m, MonadParse n) => - RemoteSchemaInfo -> - G.Name -> - [P.FieldParser n RawRemoteField] -> - m [P.FieldParser n RemoteField] -customizeFieldParsers remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers = do - fieldParsers' <- - if hasTypeOrFieldCustomizations rsCustomizer - then traverse (customizeFieldParser' (set rfResultCustomizer) rsCustomizer rootTypeName) fieldParsers - else -- no need to customize individual FieldParsers if there are no type or field name customizations - pure fieldParsers - pure $ case _rscNamespaceFieldName rsCustomizer of - Nothing -> fmap realRemoteField <$> fieldParsers' - Just namespace -> [addCustomNamespace remoteSchemaInfo rootTypeName namespace fieldParsers'] - -customizeFieldParser :: - forall n a b. +customizeRemoteNamespace :: + forall n. (MonadParse n) => - (ResultCustomizer -> a -> b) -> - RemoteSchemaCustomizer -> + RemoteSchemaInfo -> G.Name -> - P.FieldParser n a -> - (P.FieldParser n b) -customizeFieldParser setResultCustomizer remoteSchemaCustomizer rootTypeName = - if hasTypeOrFieldCustomizations remoteSchemaCustomizer - then evalMemoState . customizeFieldParser' setResultCustomizer remoteSchemaCustomizer rootTypeName - else fmap $ setResultCustomizer mempty - -customizeFieldParser' :: - forall m n a b. - (MonadState MemoState m, MonadFix m, MonadParse n) => - (ResultCustomizer -> a -> b) -> - RemoteSchemaCustomizer -> - G.Name -> - P.FieldParser n a -> - m (P.FieldParser n b) -customizeFieldParser' setResultCustomizer remoteSchemaCustomizer rootTypeName P.FieldParser {..} = do - customizedDefinition <- customizeFieldDefinition remoteSchemaCustomizer rootTypeName fDefinition - let customizedRootTypeName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer rootTypeName - pure - P.FieldParser - { fParser = - fParserWithResultCustomizer - <=< customizeField customizedRootTypeName (dInfo customizedDefinition) . fmap customizeVariable, - fDefinition = customizedDefinition - } + [P.FieldParser n RemoteField] -> + [P.FieldParser n (NamespacedField RemoteField)] +customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers = + customizeNamespace (_rscNamespaceFieldName rsCustomizer) fromParsedSelection mkNamespaceTypename fieldParsers where - fParserWithResultCustomizer :: (ResultCustomizer, G.Field G.NoFragments Variable) -> n b - fParserWithResultCustomizer (resultCustomizer, fld) = - setResultCustomizer resultCustomizer <$> fParser fld + fromParsedSelection alias = + 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 + mkNamespaceTypename = Typename . const (remoteSchemaCustomizeTypeName rsCustomizer rootTypeName) - customizeVariable :: Variable -> Variable - customizeVariable Variable {..} = Variable {vType = customizeGraphQLType vType, ..} +type MonadBuildRemoteSchema r m n = (MonadSchema n m, MonadError QErr m, MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r) - customizeGraphQLType :: G.GType -> G.GType - customizeGraphQLType = \case - G.TypeNamed nullability name -> G.TypeNamed nullability $ remoteSchemaDecustomizeTypeName remoteSchemaCustomizer name - G.TypeList nullability gtype -> G.TypeList nullability $ customizeGraphQLType gtype - - customizeField :: G.Name -> P.FieldInfo -> G.Field G.NoFragments var -> n (ResultCustomizer, G.Field G.NoFragments var) - customizeField parentTypeName (P.FieldInfo _ fieldType) (G.Field alias fieldName args directives selSet) = do - let fieldName' = - if "__" `T.isPrefixOf` G.unName fieldName - then fieldName - else remoteSchemaDecustomizeFieldName remoteSchemaCustomizer parentTypeName fieldName - alias' = alias <|> if fieldName' == fieldName then Nothing else Just fieldName - selSet' :: [(ResultCustomizer, G.Selection G.NoFragments var)] <- withPath (++ [Key "selectionSet"]) $ - case fieldType ^. definitionLens of - typeDef@(Definition _ _ _ TIObject {}) -> traverse (customizeSelection typeDef) selSet - typeDef@(Definition _ _ _ TIInterface {}) -> traverse (customizeSelection typeDef) selSet - typeDef@(Definition _ _ _ TIUnion {}) -> traverse (customizeSelection typeDef) selSet - _ -> pure $ (mempty,) <$> selSet - let resultCustomizer = - modifyFieldByName (fromMaybe fieldName' alias') $ - if fieldName' == $$(G.litName "__typename") - then customizeTypeNameString (_rscCustomizeTypeName remoteSchemaCustomizer) - else foldMap fst selSet' - pure $ (resultCustomizer, G.Field alias' fieldName' args directives $ snd <$> selSet') - - customizeSelection :: Definition (TypeInfo 'Output) -> G.Selection G.NoFragments var -> n (ResultCustomizer, G.Selection G.NoFragments var) - customizeSelection parentTypeDef = \case - G.SelectionField fld@G.Field {..} -> - withPath (++ [Key $ G.unName _fName]) $ do - let parentTypeName = getName parentTypeDef - fieldInfo <- findField _fName parentTypeName $ dInfo parentTypeDef - second G.SelectionField <$> customizeField parentTypeName fieldInfo fld - G.SelectionInlineFragment G.InlineFragment {..} -> do - inlineFragmentType <- - case _ifTypeCondition of - Nothing -> pure parentTypeDef - Just typeName -> findSubtype typeName parentTypeDef - customizedSelectionSet <- traverse (customizeSelection inlineFragmentType) _ifSelectionSet - pure $ - ( foldMap fst customizedSelectionSet, - G.SelectionInlineFragment - G.InlineFragment - { _ifTypeCondition = remoteSchemaDecustomizeTypeName remoteSchemaCustomizer <$> _ifTypeCondition, - _ifSelectionSet = snd <$> customizedSelectionSet, - .. - } - ) - - findField :: G.Name -> G.Name -> TypeInfo 'Output -> n P.FieldInfo - findField fieldName parentTypeName parentTypeInfo = - if fieldName == $$(G.litName "__typename") -- TODO can we avoid checking for __typename in two different places? - then pure $ P.FieldInfo [] $ NonNullable $ TNamed $ mkDefinition (Typename stringScalar) Nothing TIScalar - else do - fields <- case parentTypeInfo of - TIObject objectInfo -> pure $ oiFields objectInfo - TIInterface interfaceInfo -> pure $ iiFields interfaceInfo - _ -> parseError $ "Type " <> parentTypeName <<> " has no fields" - fld <- find ((== fieldName) . dName) fields `onNothing` parseError ("field " <> fieldName <<> " not found in type: " <> squote parentTypeName) - pure $ dInfo fld - - findSubtype :: G.Name -> Definition (TypeInfo 'Output) -> n (Definition (TypeInfo 'Output)) - findSubtype typeName parentTypeDef = - if typeName == getName parentTypeDef - then pure parentTypeDef - else do - possibleTypes <- - case dInfo parentTypeDef of - TIInterface interfaceInfo -> pure $ iiPossibleTypes interfaceInfo - TIUnion unionInfo -> pure $ uiPossibleTypes unionInfo - _ -> parseError $ "Type " <> getName parentTypeDef <<> " has no possible subtypes" - fmap TIObject <$> find ((== typeName) . dName) possibleTypes - `onNothing` parseError ("Type " <> typeName <<> " is not a subtype of " <>> getName parentTypeDef) - -type MemoState = (HashMap G.Name ObjectInfo, HashMap G.Name InterfaceInfo, HashMap G.Name UnionInfo, HashMap G.Name InputObjectInfo) - -evalMemoState :: Lazy.State MemoState a -> a -evalMemoState = flip Lazy.evalState (mempty, mempty, mempty, mempty) - --- | memo function used to "tie the knot" and preserve sharing in the customized type definitions --- It would be nice if we could just re-use MonadSchema and memoizeOn, but the types there are too --- parser-specific. -memo :: (MonadState s m, MonadFix m, Hashable k, Eq k) => Lens' s (HashMap k v) -> (k -> v -> m v) -> k -> v -> m v -memo lens f k v = do - m <- use lens - Map.lookup k m `onNothing` mdo - -- Note: v' is added to the state _before_ it is produced - lens %= Map.insert k v' - v' <- f k v - pure v' - -customizeFieldDefinition :: - forall m. - (MonadState MemoState m, MonadFix m) => - RemoteSchemaCustomizer -> - G.Name -> - Definition P.FieldInfo -> - m (Definition P.FieldInfo) -customizeFieldDefinition remoteSchemaCustomizer = customizeFieldDefinition' +runMonadBuildRemoteSchema :: Monad m => SchemaT n (ReaderT (MkTypename, CustomizeRemoteFieldName) m) a -> m a +runMonadBuildRemoteSchema m = flip runReaderT (Typename, idFieldCustomizer) $ runSchemaT m where - customizeFieldDefinition' :: G.Name -> Definition P.FieldInfo -> m (Definition P.FieldInfo) - customizeFieldDefinition' parentTypeName Definition {..} = do - dInfo' <- customizeFieldInfo dInfo - pure - Definition - { dName = remoteSchemaCustomizeFieldName remoteSchemaCustomizer parentTypeName dName, - dInfo = dInfo', - .. - } + idFieldCustomizer :: CustomizeRemoteFieldName + idFieldCustomizer = const id - customizeFieldInfo :: P.FieldInfo -> m P.FieldInfo - customizeFieldInfo (P.FieldInfo args typ) = - P.FieldInfo <$> traverse (traverse $ customizeInputFieldInfo) args <*> customizeType typ - - customizeTypeDefinition :: (G.Name -> b -> m b) -> Definition b -> m (Definition b) - customizeTypeDefinition f Definition {..} = do - dInfo' <- f dName dInfo - pure - Definition - { dName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer dName, - dInfo = dInfo', - .. - } - - customizeType :: Type k -> m (Type k) - customizeType = \case - NonNullable nn -> NonNullable <$> customizeNonNullableType nn - Nullable nn -> Nullable <$> customizeNonNullableType nn - - customizeNonNullableType :: NonNullableType k -> m (NonNullableType k) - customizeNonNullableType = \case - TList typ -> TList <$> customizeType typ - TNamed definition -> TNamed <$> customizeTypeDefinition customizeTypeInfo definition - - customizeTypeInfo :: G.Name -> TypeInfo k -> m (TypeInfo k) - customizeTypeInfo typeName = \case - ti@TIScalar -> pure ti - ti@TIEnum {} -> pure ti - TIInputObject ioi -> TIInputObject <$> customizeInputObjectInfo typeName ioi - TIObject oi -> TIObject <$> customizeObjectInfo typeName oi - TIInterface ii -> TIInterface <$> customizeInterfaceInfo typeName ii - TIUnion ui -> TIUnion <$> customizeUnionInfo typeName ui - - customizeInputFieldInfo :: InputFieldInfo -> m InputFieldInfo - customizeInputFieldInfo = \case - IFRequired nnType -> IFRequired <$> customizeNonNullableType nnType - IFOptional typ value -> IFOptional <$> customizeType typ <*> pure value - - customizeObjectInfo :: G.Name -> ObjectInfo -> m ObjectInfo - customizeObjectInfo = memo _1 $ \typeName ObjectInfo {..} -> do - oiFields' <- traverse (customizeFieldDefinition' typeName) oiFields - oiImplements' <- traverse (customizeTypeDefinition customizeInterfaceInfo) oiImplements - pure - ObjectInfo - { oiFields = oiFields', - oiImplements = oiImplements' - } - - customizeInterfaceInfo :: G.Name -> InterfaceInfo -> m InterfaceInfo - customizeInterfaceInfo = memo _2 $ \typeName InterfaceInfo {..} -> do - iiFields' <- traverse (customizeFieldDefinition' typeName) iiFields - iiPossibleTypes' <- traverse (customizeTypeDefinition customizeObjectInfo) iiPossibleTypes - pure - InterfaceInfo - { iiFields = iiFields', - iiPossibleTypes = iiPossibleTypes' - } - - customizeUnionInfo :: G.Name -> UnionInfo -> m UnionInfo - customizeUnionInfo = memo _3 $ \_typeName (UnionInfo possibleTypes) -> - UnionInfo <$> traverse (customizeTypeDefinition customizeObjectInfo) possibleTypes - - customizeInputObjectInfo :: G.Name -> InputObjectInfo -> m InputObjectInfo - customizeInputObjectInfo = memo _4 $ \_typeName (InputObjectInfo args) -> - InputObjectInfo <$> traverse (traverse $ customizeInputFieldInfo) args +withRemoteSchemaCustomization :: + forall m r a. + (MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r) => + RemoteSchemaCustomizer -> + m a -> + m a +withRemoteSchemaCustomization remoteSchemaCustomizer = + withTypenameCustomization (Typename . remoteSchemaCustomizeTypeName remoteSchemaCustomizer) + . withRemoteFieldNameCustomization (remoteSchemaCustomizeFieldName remoteSchemaCustomizer) diff --git a/server/src-lib/Hasura/GraphQL/Schema/Select.hs b/server/src-lib/Hasura/GraphQL/Schema/Select.hs index 9fef058c008..1d612e5a088 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Select.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Select.hs @@ -1376,23 +1376,27 @@ remoteRelationshipField remoteFieldInfo = runMaybeT do -- These are the arguments that are given by the user while executing a query let remoteFieldUserArguments = map snd $ Map.toList remoteFieldParamMap remoteFld <- - lift $ - customizeFieldParser (,) remoteSchemaCustomizer parentTypeName . P.wrapFieldParser nestedFieldType - <$> remoteField remoteRelationshipIntrospection fieldName Nothing remoteFieldUserArguments fieldTypeDefinition + withRemoteSchemaCustomization remoteSchemaCustomizer $ + lift $ + P.wrapFieldParser nestedFieldType + <$> remoteField remoteRelationshipIntrospection parentTypeName fieldName Nothing remoteFieldUserArguments fieldTypeDefinition pure $ pure $ remoteFld - `P.bindField` \(resultCustomizer, G.Field {G._fArguments = args, G._fSelectionSet = selSet, G._fName = fname}) -> do + `P.bindField` \fld@G.Field {G._fArguments = args, G._fSelectionSet = selSet, G._fName = fname} -> do let remoteArgs = Map.toList args <&> \(argName, argVal) -> IR.RemoteFieldArgument argName $ P.GraphQLValue $ argVal - let resultCustomizer' = applyFieldCalls fieldCalls $ applyAliasMapping (singletonAliasMapping fname (fcName $ NE.last fieldCalls)) resultCustomizer + let resultCustomizer = + applyFieldCalls fieldCalls $ + applyAliasMapping (singletonAliasMapping fname (fcName $ NE.last fieldCalls)) $ + makeResultCustomizer remoteSchemaCustomizer fld pure $ IR.AFRemote $ IR.RemoteSelectRemoteSchema $ IR.RemoteSchemaSelect { _rselArgs = remoteArgs, - _rselResultCustomizer = resultCustomizer', + _rselResultCustomizer = resultCustomizer, _rselSelection = selSet, _rselHasuraFields = hasuraFields, _rselFieldCall = fieldCalls, diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index 575d2daee4a..f4524b337fb 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -468,7 +468,7 @@ runGQ env logger reqId userInfo ipAddress reqHeaders queryType reqUnparsed = do runRemoteGQ httpManager fieldName rsi resultCustomizer gqlReq = do (telemTimeIO_DT, remoteResponseHeaders, resp) <- doQErr $ E.execRemoteGQ env httpManager userInfo reqHeaders (rsDef rsi) gqlReq - value <- extractFieldFromResponse fieldName rsi resultCustomizer resp + value <- extractFieldFromResponse fieldName resultCustomizer resp let filteredHeaders = filter ((== "Set-Cookie") . fst) remoteResponseHeaders pure $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) filteredHeaders @@ -564,14 +564,11 @@ extractFieldFromResponse :: forall m. Monad m => RootFieldAlias -> - RemoteSchemaInfo -> ResultCustomizer -> LBS.ByteString -> ExceptT (Either GQExecError QErr) m JO.Value -extractFieldFromResponse fieldName rsi resultCustomizer resp = do - let namespace = fmap G.unName $ _rscNamespaceFieldName $ rsCustomizer rsi - fieldName' = G.unName $ _rfaAlias fieldName - -- TODO: use RootFieldAlias for remote fields +extractFieldFromResponse fieldName resultCustomizer resp = do + let fieldName' = G.unName $ _rfaAlias fieldName dataVal <- applyResultCustomizer resultCustomizer <$> do @@ -579,19 +576,11 @@ extractFieldFromResponse fieldName rsi resultCustomizer resp = do case graphQLResponse of GraphQLResponseErrors errs -> doGQExecError errs GraphQLResponseData d -> pure d - case namespace of - Just _ -> - -- If using a custom namespace field then the response from the remote server - -- will already be unwrapped so just return it. - return dataVal - _ -> do - -- No custom namespace so we need to look up the field name in the data - -- object. - dataObj <- onLeft (JO.asObject dataVal) do400 - fieldVal <- - onNothing (JO.lookup fieldName' dataObj) $ - do400 $ "expecting key " <> fieldName' - return fieldVal + dataObj <- onLeft (JO.asObject dataVal) do400 + fieldVal <- + onNothing (JO.lookup fieldName' dataObj) $ + do400 $ "expecting key " <> fieldName' + return fieldVal where do400 = withExceptT Right . throw400 RemoteSchemaError doGQExecError = withExceptT Left . throwError . GQExecError diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 1f0d8eae7b7..7f90004ebf9 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -717,7 +717,7 @@ onStart env enabledLogTypes serverEnv wsConn (StartMsg opId q) onMessageActions (telemTimeIO_DT, _respHdrs, resp) <- doQErr $ E.execRemoteGQ env httpMgr userInfo reqHdrs (rsDef rsi) gqlReq - value <- mapExceptT lift $ extractFieldFromResponse fieldName rsi resultCustomizer resp + value <- mapExceptT lift $ extractFieldFromResponse fieldName resultCustomizer resp return $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) [] WSServerEnv diff --git a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs index 698d55897f2..5e50cc9f535 100644 --- a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs @@ -3,11 +3,9 @@ module Hasura.RQL.Types.RemoteSchema AddRemoteSchemaQuery (..), AliasMapping, DropRemoteSchemaPermissions (..), - RawRemoteField, RemoteField, RemoteFieldCustomization (..), RemoteFieldG (..), - RemoteRootField (..), RemoteSchemaCustomization (..), RemoteSchemaCustomizer (..), RemoteSchemaDef (..), @@ -25,7 +23,6 @@ module Hasura.RQL.Types.RemoteSchema ValidatedRemoteSchemaDef (..), applyAliasMapping, customizeTypeNameString, - getRemoteFieldSelectionSet, getUrlFromEnv, hasTypeOrFieldCustomizations, lookupEnum, @@ -36,11 +33,8 @@ module Hasura.RQL.Types.RemoteSchema lookupType, lookupUnion, modifyFieldByName, - realRemoteField, remoteSchemaCustomizeFieldName, remoteSchemaCustomizeTypeName, - remoteSchemaDecustomizeFieldName, - remoteSchemaDecustomizeTypeName, rfField, rfRemoteSchemaInfo, rfResultCustomizer, @@ -185,11 +179,7 @@ data RemoteSchemaCustomizer = RemoteSchemaCustomizer -- | type name -> type name _rscCustomizeTypeName :: !(HashMap G.Name G.Name), -- | type name -> field name -> field name - _rscCustomizeFieldName :: !(HashMap G.Name (HashMap G.Name G.Name)), - -- | type name -> type name - _rscDecustomizeTypeName :: !(HashMap G.Name G.Name), - -- | type name -> field name -> field name - _rscDecustomizeFieldName :: !(HashMap G.Name (HashMap G.Name G.Name)) + _rscCustomizeFieldName :: !(HashMap G.Name (HashMap G.Name G.Name)) } deriving (Show, Eq, Generic) @@ -209,14 +199,6 @@ remoteSchemaCustomizeFieldName :: RemoteSchemaCustomizer -> G.Name -> G.Name -> remoteSchemaCustomizeFieldName RemoteSchemaCustomizer {..} typeName fieldName = Map.lookup typeName _rscCustomizeFieldName >>= Map.lookup fieldName & fromMaybe fieldName -remoteSchemaDecustomizeTypeName :: RemoteSchemaCustomizer -> G.Name -> G.Name -remoteSchemaDecustomizeTypeName RemoteSchemaCustomizer {..} typeName = - Map.lookupDefault typeName typeName _rscDecustomizeTypeName - -remoteSchemaDecustomizeFieldName :: RemoteSchemaCustomizer -> G.Name -> G.Name -> G.Name -remoteSchemaDecustomizeFieldName RemoteSchemaCustomizer {..} typeName fieldName = - Map.lookup typeName _rscDecustomizeFieldName >>= Map.lookup fieldName & fromMaybe fieldName - hasTypeOrFieldCustomizations :: RemoteSchemaCustomizer -> Bool hasTypeOrFieldCustomizations RemoteSchemaCustomizer {..} = not $ Map.null _rscCustomizeTypeName && Map.null _rscCustomizeFieldName @@ -428,37 +410,16 @@ newtype RemoteSchemaIntrospection = RemoteSchemaIntrospection [(G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)] deriving (Show, Eq, Generic, Hashable, Cacheable, Ord) --- | An RemoteRootField could either be a real field on the remote server --- or represent a virtual namespace that only exists in the Hasura schema. -data RemoteRootField var - = -- | virtual namespace field - RRFNamespaceField !(G.SelectionSet G.NoFragments var) - | -- | a real field on the remote server - RRFRealField !(G.Field G.NoFragments var) - deriving (Functor, Foldable, Traversable) - --- | For a real remote field gives a SelectionSet for selecting the field itself. --- For a virtual field gives the unwrapped SelectionSet for the field. -getRemoteFieldSelectionSet :: RemoteRootField var -> G.SelectionSet G.NoFragments var -getRemoteFieldSelectionSet = \case - RRFNamespaceField selSet -> selSet - RRFRealField fld -> [G.SelectionField fld] - -data RemoteFieldG f var = RemoteFieldG +data RemoteFieldG var = RemoteFieldG { _rfRemoteSchemaInfo :: !RemoteSchemaInfo, _rfResultCustomizer :: !ResultCustomizer, - _rfField :: !(f var) + _rfField :: !(G.Field G.NoFragments var) } deriving (Functor, Foldable, Traversable) $(makeLenses ''RemoteFieldG) -type RawRemoteField = RemoteFieldG (G.Field G.NoFragments) RemoteSchemaVariable - -type RemoteField = RemoteFieldG RemoteRootField RemoteSchemaVariable - -realRemoteField :: RawRemoteField -> RemoteField -realRemoteField RemoteFieldG {..} = RemoteFieldG {_rfField = RRFRealField _rfField, ..} +type RemoteField = RemoteFieldG RemoteSchemaVariable data RemoteSchemaPermsCtx = RemoteSchemaPermsEnabled diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 11cb8610f5f..7eaec1fad38 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -44,12 +44,11 @@ module Hasura.RQL.Types.SchemaCache ViewInfo (..), isMutable, IntrospectionResult (..), - ParsedIntrospection (..), + ParsedIntrospectionG (..), + ParsedIntrospection, RemoteSchemaCustomizer (..), remoteSchemaCustomizeTypeName, remoteSchemaCustomizeFieldName, - remoteSchemaDecustomizeTypeName, - remoteSchemaDecustomizeFieldName, RemoteSchemaCtx (..), rscName, rscInfo, @@ -126,6 +125,7 @@ import Database.PG.Query qualified as Q import Hasura.Backends.Postgres.Connection qualified as PG import Hasura.Base.Error import Hasura.GraphQL.Context (GQLContext, RoleContext) +import Hasura.GraphQL.Namespace import Hasura.GraphQL.Parser qualified as P import Hasura.Incremental ( Cacheable, @@ -220,12 +220,14 @@ data IntrospectionResult = IntrospectionResult instance Cacheable IntrospectionResult -data ParsedIntrospection = ParsedIntrospection - { piQuery :: [P.FieldParser (P.ParseT Identity) RemoteField], - piMutation :: Maybe [P.FieldParser (P.ParseT Identity) RemoteField], - piSubscription :: Maybe [P.FieldParser (P.ParseT Identity) RemoteField] +data ParsedIntrospectionG m = ParsedIntrospection + { piQuery :: [P.FieldParser m (NamespacedField RemoteField)], + piMutation :: Maybe [P.FieldParser m (NamespacedField RemoteField)], + piSubscription :: Maybe [P.FieldParser m (NamespacedField RemoteField)] } +type ParsedIntrospection = ParsedIntrospectionG (P.ParseT Identity) + -- | See 'fetchRemoteSchema'. data RemoteSchemaCtx = RemoteSchemaCtx { _rscName :: !RemoteSchemaName, diff --git a/server/src-lib/Hasura/RQL/Types/SourceCustomization.hs b/server/src-lib/Hasura/RQL/Types/SourceCustomization.hs index 6236df0a101..5482b608f26 100644 --- a/server/src-lib/Hasura/RQL/Types/SourceCustomization.hs +++ b/server/src-lib/Hasura/RQL/Types/SourceCustomization.hs @@ -11,6 +11,8 @@ module Hasura.RQL.Types.SourceCustomization SourceCustomization (..), withSourceCustomization, MkRootFieldName, + CustomizeRemoteFieldName, + withRemoteFieldNameCustomization, ) where @@ -122,3 +124,8 @@ withSourceCustomization :: withSourceCustomization SourceCustomization {..} = withTypenameCustomization (mkCustomizedTypename _scTypeNames) . withRootFieldNameCustomization (mkCustomizedFieldName _scRootFields) + +type CustomizeRemoteFieldName = G.Name -> G.Name -> G.Name + +withRemoteFieldNameCustomization :: forall m r a. (MonadReader r m, Has CustomizeRemoteFieldName r) => CustomizeRemoteFieldName -> m a -> m a +withRemoteFieldNameCustomization = local . set hasLens diff --git a/server/src-test/Hasura/GraphQL/RemoteServerSpec.hs b/server/src-test/Hasura/GraphQL/RemoteServerSpec.hs deleted file mode 100644 index 5da6fde61f9..00000000000 --- a/server/src-test/Hasura/GraphQL/RemoteServerSpec.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Hasura.GraphQL.RemoteServerSpec (spec) where - -import Data.Containers.ListUtils (nubOrd) -import Data.Either (isRight) -import Data.HashMap.Strict qualified as Map -import Hasura.Generator () -import Hasura.GraphQL.RemoteServer -import Hasura.Prelude -import Hasura.RQL.Types.RemoteSchema -import Hasura.RQL.Types.SchemaCache -import Language.GraphQL.Draft.Syntax qualified as G -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck - -spec :: Spec -spec = do - describe "IntrospectionResult" $ do - describe "getCustomizer" $ do - prop "inverse" $ - forAllShrinkShow gen shrink_ show_ $ \(introspectionResult, typesAndFields, customization) -> - let customizer = getCustomizer introspectionResult (Just customization) - customizeTypeName = remoteSchemaCustomizeTypeName customizer - customizeFieldName = remoteSchemaCustomizeFieldName customizer - decustomizeTypeName = remoteSchemaDecustomizeTypeName customizer - decustomizeFieldName = remoteSchemaDecustomizeFieldName customizer - typeTests = - conjoin $ - Map.keys typesAndFields <&> \typeName -> - decustomizeTypeName (customizeTypeName typeName) === typeName - fieldTests = - conjoin $ - Map.toList typesAndFields <&> \(typeName, fieldNames) -> - conjoin $ - fieldNames <&> \fieldName -> - decustomizeFieldName (customizeTypeName typeName) (customizeFieldName typeName fieldName) === fieldName - in isRight (validateSchemaCustomizationsDistinct customizer $ irDoc introspectionResult) - ==> typeTests .&&. fieldTests - -getTypesAndFields :: IntrospectionResult -> HashMap G.Name [G.Name] -getTypesAndFields IntrospectionResult {irDoc = RemoteSchemaIntrospection typeDefinitions} = - Map.fromList $ map getTypeAndFields typeDefinitions - where - getTypeAndFields = \case - G.TypeDefinitionScalar G.ScalarTypeDefinition {..} -> (_stdName, []) - G.TypeDefinitionObject G.ObjectTypeDefinition {..} -> (_otdName, G._fldName <$> _otdFieldsDefinition) - G.TypeDefinitionInterface G.InterfaceTypeDefinition {..} -> (_itdName, G._fldName <$> _itdFieldsDefinition) - G.TypeDefinitionUnion G.UnionTypeDefinition {..} -> (_utdName, []) - G.TypeDefinitionEnum G.EnumTypeDefinition {..} -> (_etdName, []) - G.TypeDefinitionInputObject G.InputObjectTypeDefinition {..} -> (_iotdName, []) - -genCustomization :: HashMap G.Name [G.Name] -> Gen RemoteSchemaCustomization -genCustomization typesAndFields = RemoteSchemaCustomization <$> arbitrary <*> fmap Just genTypeNames <*> fmap Just genFieldNames - where - genTypeNames = RemoteTypeCustomization <$> arbitrary <*> arbitrary <*> genMap (Map.keys typesAndFields) - genFieldNames = do - typesAndFields' <- sublistOf $ Map.toList typesAndFields - for typesAndFields' $ \(typeName, fieldNames) -> - RemoteFieldCustomization typeName <$> arbitrary <*> arbitrary <*> genMap fieldNames - genMap names = do - keys <- sublistOf names - values <- nubOrd . filter (`notElem` names) <$> infiniteList - pure $ Map.fromList $ zip keys values - -gen :: Gen (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization) -gen = do - introspectionResult <- arbitrary - let typesAndFields = getTypesAndFields introspectionResult - customization <- genCustomization typesAndFields - pure (introspectionResult, typesAndFields, customization) - -shrink_ :: (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization) -> [(IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization)] -shrink_ (introspectionResult, typesAndFields, customization@RemoteSchemaCustomization {..}) = - (shrinkCustomization <&> (introspectionResult,typesAndFields,)) - ++ (shrinkTypesAndFields <&> (introspectionResult,,customization)) - where - shrinkCustomization = shrinkNamespace ++ shrinkTypeNames ++ shrinkFieldNames - - shrinkMaybe _ Nothing = [] - shrinkMaybe f (Just x) = Nothing : (Just <$> f x) - - shrinkMaybe' = shrinkMaybe shrinkNothing - - shrinkHashMap f = shrinkMapBy Map.fromList Map.toList $ shrinkList f - - shrinkHashMap' = shrinkHashMap shrinkNothing - - shrinkNamespace = do - ns <- shrinkMaybe' _rscRootFieldsNamespace - pure $ customization {_rscRootFieldsNamespace = ns} - - shrinkTypeNames = do - tns <- shrinkMaybe shrinkTypeNames' _rscTypeNames - pure $ customization {_rscTypeNames = tns} - - shrinkTypeNames' rtc@RemoteTypeCustomization {..} = - (shrinkMaybe' _rtcPrefix <&> \p -> rtc {_rtcPrefix = p}) - ++ (shrinkMaybe' _rtcSuffix <&> \s -> rtc {_rtcSuffix = s}) - ++ (shrinkHashMap' _rtcMapping <&> \m -> rtc {_rtcMapping = m}) - - shrinkFieldNames = do - fns <- shrinkMaybe (shrinkList shrinkFieldNames') _rscFieldNames - pure $ customization {_rscFieldNames = fns} - - shrinkFieldNames' rfc@RemoteFieldCustomization {..} = - (shrinkMaybe' _rfcPrefix <&> \p -> rfc {_rfcPrefix = p}) - ++ (shrinkMaybe' _rfcSuffix <&> \s -> rfc {_rfcSuffix = s}) - ++ (shrinkHashMap' _rfcMapping <&> \m -> rfc {_rfcMapping = m}) - - shrinkTypesAndFields = shrinkHashMap (traverse $ shrinkList shrinkNothing) typesAndFields - -show_ :: (IntrospectionResult, HashMap G.Name [G.Name], RemoteSchemaCustomization) -> String -show_ (_a, b, c) = show (b, c) diff --git a/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs index cee053fe556..84aa6e660ff 100644 --- a/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs +++ b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs @@ -11,8 +11,8 @@ import Hasura.Base.Error import Hasura.GraphQL.Execute.Inline import Hasura.GraphQL.Execute.Remote (resolveRemoteVariable, runVariableCache) import Hasura.GraphQL.Execute.Resolve +import Hasura.GraphQL.Namespace import Hasura.GraphQL.Parser.Internal.Parser qualified as P -import Hasura.GraphQL.Parser.Monad import Hasura.GraphQL.Parser.Schema import Hasura.GraphQL.Parser.TestUtils import Hasura.GraphQL.RemoteServer (identityCustomizer) @@ -99,20 +99,17 @@ buildQueryParsers :: IO (P.FieldParser TestMonad (G.Field G.NoFragments RemoteSchemaVariable)) buildQueryParsers introspection = do let introResult = IntrospectionResult introspection $$(G.litName "Query") Nothing Nothing - (query, _, _) <- + ParsedIntrospection query _ _ <- runError $ - runSchemaT $ - buildRemoteParser introResult $ - RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer + buildRemoteParser introResult $ + RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer pure $ - head query <&> \(RemoteFieldG _ _ abstractField) -> - case abstractField of - RRFRealField f -> f - RRFNamespaceField _ -> - error "buildQueryParsers: unexpected RRFNamespaceField" - --- Shouldn't happen if we're using identityCustomizer --- TODO: add some tests for remote schema customization + head query <&> \case + NotNamespaced remoteFld -> _rfField remoteFld + Namespaced _ -> + -- Shouldn't happen if we're using identityCustomizer + -- TODO: add some tests for remote schema customization + error "buildQueryParsers: unexpected Namespaced field" runQueryParser :: P.FieldParser TestMonad any -> diff --git a/server/src-test/Main.hs b/server/src-test/Main.hs index 4463fb00104..24150a360e3 100644 --- a/server/src-test/Main.hs +++ b/server/src-test/Main.hs @@ -23,7 +23,6 @@ import Hasura.App import Hasura.EventingSpec qualified as EventingSpec import Hasura.GraphQL.NamespaceSpec qualified as NamespaceSpec import Hasura.GraphQL.Parser.DirectivesTest qualified as GraphQLDirectivesSpec -import Hasura.GraphQL.RemoteServerSpec qualified as RemoteServerSpec import Hasura.GraphQL.Schema.RemoteTest qualified as GraphRemoteSchemaSpec import Hasura.IncrementalSpec qualified as IncrementalSpec import Hasura.Logging @@ -90,7 +89,6 @@ unitSpecs = do describe "Hasura.RQL.Types.Common" CommonTypesSpec.spec describe "Hasura.RQL.Types.Endpoint" EndpointSpec.spec describe "Hasura.GraphQL.Namespace" NamespaceSpec.spec - describe "Hasura.GraphQL.RemoteServer" RemoteServerSpec.spec describe "Hasura.SQL.WKT" WKTSpec.spec describe "Hasura.Server.Auth" AuthSpec.spec describe "Hasura.Server.Telemetry" TelemetrySpec.spec diff --git a/server/tests-py/queries/remote_schemas/validation/customize_all_the_things.yaml b/server/tests-py/queries/remote_schemas/validation/customize_all_the_things.yaml index c14c23e0340..7b92f7806e7 100644 --- a/server/tests-py/queries/remote_schemas/validation/customize_all_the_things.yaml +++ b/server/tests-py/queries/remote_schemas/validation/customize_all_the_things.yaml @@ -69,11 +69,11 @@ } } response: - errors: - - extensions: - path: $.selectionSet.star_wars.selectionSet.super_hero.selectionSet - code: validation-failed - message: Type "Droid" is not a subtype of "FooCharacter_x" + data: + star_wars: + super_hero: + ident: '1' + foo_name_f: R2-D2 - description: query with fragment url: /v1/graphql @@ -123,27 +123,27 @@ ident: "1" foo_name_f: R2-D2 -# - description: query with variable with wrong type name -# url: /v1/graphql -# status: 200 -# query: -# query: | -# query Hero($ep: Int!) { -# star_wars { -# super_hero(episode: $ep) { -# ident -# foo_name_f -# } -# } -# } -# variables: -# ep: 4 -# response: -# errors: -# - extensions: -# path: $.selectionSet.star_wars.selectionSet.super_hero.args.episode -# code: validation-failed -# message: variable "ep" is declared as Int!, but used where MyInt! is expected +- description: query with variable with wrong type name + url: /v1/graphql + status: 200 + query: + query: | + query Hero($ep: Int!) { + star_wars { + super_hero(episode: $ep) { + ident + foo_name_f + } + } + } + variables: + ep: 4 + response: + errors: + - extensions: + path: $.selectionSet.star_wars.selectionSet.super_hero.args.episode + code: validation-failed + message: variable "ep" is declared as Int!, but used where MyInt! is expected - description: query with __type introspection url: /v1/graphql @@ -334,7 +334,7 @@ - extensions: path: $.selectionSet.star_wars.selectionSet.super_hero.selectionSet.id code: validation-failed - message: "field \"id\" not found in type: 'FooCharacter_x'" + message: "field \"id\" not found in type: 'FooHuman_x'" - description: query aliases url: /v1/graphql diff --git a/server/tests-py/queries/remote_schemas/validation/field_prefix_validation.yaml b/server/tests-py/queries/remote_schemas/validation/field_prefix_validation.yaml index 2536b6f2357..8e77343c1ca 100644 --- a/server/tests-py/queries/remote_schemas/validation/field_prefix_validation.yaml +++ b/server/tests-py/queries/remote_schemas/validation/field_prefix_validation.yaml @@ -36,7 +36,7 @@ - extensions: path: $.selectionSet.hero.selectionSet.id code: validation-failed - message: "field \"id\" not found in type: 'Character'" + message: "field \"id\" not found in type: 'Human'" - description: query aliases url: /v1/graphql diff --git a/server/tests-py/queries/remote_schemas/validation/namespace_validation.yaml b/server/tests-py/queries/remote_schemas/validation/namespace_validation.yaml index 9bac7c611ed..de3521469d8 100644 --- a/server/tests-py/queries/remote_schemas/validation/namespace_validation.yaml +++ b/server/tests-py/queries/remote_schemas/validation/namespace_validation.yaml @@ -8,11 +8,6 @@ hero(episode: 4) { id name - ... on BarDroid { - id - name - primaryFunction - } } } } @@ -22,4 +17,3 @@ hero: id: '1' name: R2-D2 - primaryFunction: Astromech diff --git a/server/tests-py/queries/remote_schemas/validation/type_prefix_validation.yaml b/server/tests-py/queries/remote_schemas/validation/type_prefix_validation.yaml index f55ed0ef4f7..eb759c1389e 100644 --- a/server/tests-py/queries/remote_schemas/validation/type_prefix_validation.yaml +++ b/server/tests-py/queries/remote_schemas/validation/type_prefix_validation.yaml @@ -5,6 +5,7 @@ query: | { hero(episode: 4) { + __typename id name ... on FooDroid { @@ -17,6 +18,7 @@ response: data: hero: + __typename: FooDroid id: "1" name: R2-D2 primaryFunction: Astromech @@ -62,11 +64,10 @@ } } response: - errors: - - extensions: - path: $.selectionSet.hero.selectionSet - code: validation-failed - message: Type "Droid" is not a subtype of "FooCharacter" + data: + hero: + id: '1' + name: R2-D2 - description: query with fragment url: /v1/graphql @@ -108,25 +109,25 @@ id: "1" name: R2-D2 -# - description: query with variable with wrong type name -# url: /v1/graphql -# status: 200 -# query: -# query: | -# query Hero($ep: Int!) { -# hero(episode: $ep) { -# id -# name -# } -# } -# variables: -# ep: 4 -# response: -# errors: -# - extensions: -# path: $.selectionSet.hero.args.episode -# code: validation-failed -# message: variable "ep" is declared as Int!, but used where MyInt! is expected +- description: query with variable with wrong type name + url: /v1/graphql + status: 200 + query: + query: | + query Hero($ep: Int!) { + hero(episode: $ep) { + id + name + } + } + variables: + ep: 4 + response: + errors: + - extensions: + path: $.selectionSet.hero.args.episode + code: validation-failed + message: variable "ep" is declared as Int!, but used where MyInt! is expected - description: query with __type introspection url: /v1/graphql diff --git a/server/tests-py/test_schema_stitching.py b/server/tests-py/test_schema_stitching.py index ec1613dcdb1..890f7cb39b4 100644 --- a/server/tests-py/test_schema_stitching.py +++ b/server/tests-py/test_schema_stitching.py @@ -836,7 +836,7 @@ class TestValidateRemoteSchemaNamespaceQuery: def transact(self, request, hge_ctx): config = request.config if not config.getoption('--skip-schema-setup'): - customization = { "root_fields_namespace": "foo", "type_names": {"prefix": "Bar" }} + customization = { "root_fields_namespace": "foo" } q = mk_add_remote_q('character-foo', 'http://localhost:5000/character-iface-graphql', customization=customization) st_code, resp = hge_ctx.v1q(q) assert st_code == 200, resp