Refactor remote schema customization

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/2771
GitOrigin-RevId: 0c90136f956df3f4552140e6ca3d2f4766f8b3f5
This commit is contained in:
David Overton 2021-11-30 11:37:14 +11:00 committed by hasura-bot
parent 1d39c9ca2f
commit 5bfce057c6
23 changed files with 322 additions and 683 deletions

View File

@ -816,7 +816,6 @@ test-suite graphql-engine-tests
Hasura.GraphQL.NamespaceSpec Hasura.GraphQL.NamespaceSpec
Hasura.GraphQL.Parser.DirectivesTest Hasura.GraphQL.Parser.DirectivesTest
Hasura.GraphQL.Parser.TestUtils Hasura.GraphQL.Parser.TestUtils
Hasura.GraphQL.RemoteServerSpec
Hasura.GraphQL.Schema.RemoteTest Hasura.GraphQL.Schema.RemoteTest
Hasura.IncrementalSpec Hasura.IncrementalSpec
Hasura.RQL.IR.Generator Hasura.RQL.IR.Generator

View File

@ -128,7 +128,7 @@ convertMutationSelectionSet
pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins
RFRemote remoteField -> do RFRemote remoteField -> do
RemoteFieldG remoteSchemaInfo resultCustomizer resolvedRemoteField <- runVariableCache $ resolveRemoteField userInfo remoteField 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 RFAction action -> do
let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionMutation action let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionMutation action
(actionName, _fch) <- pure $ case noRelsDBAST of (actionName, _fch) <- pure $ case noRelsDBAST of

View File

@ -114,7 +114,7 @@ convertQuerySelSet
pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins pure $ ExecStepDB [] (AB.mkAnyBackend dbStepInfo) remoteJoins
RFRemote rf -> do RFRemote rf -> do
RemoteFieldG remoteSchemaInfo resultCustomizer remoteField <- runVariableCache $ for rf $ resolveRemoteVariable userInfo 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 RFAction action -> do
let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionQuery action let (noRelsDBAST, remoteJoins) = RJ.getRemoteJoinsActionQuery action
(actionExecution, actionName, fch) <- pure $ case noRelsDBAST of (actionExecution, actionName, fch) <- pure $ case noRelsDBAST of

View File

@ -212,10 +212,10 @@ resolveRemoteVariable userInfo = \case
-- | TODO: Documentation. -- | TODO: Documentation.
resolveRemoteField :: resolveRemoteField ::
(MonadError QErr m, Traversable f) => (MonadError QErr m) =>
UserInfo -> UserInfo ->
RemoteFieldG f RemoteSchemaVariable -> RemoteFieldG RemoteSchemaVariable ->
StateT RemoteJSONVariableMap m (RemoteFieldG f Variable) StateT RemoteJSONVariableMap m (RemoteFieldG Variable)
resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo) resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo)
-- | TODO: Documentation. -- | TODO: Documentation.

View File

@ -8,12 +8,15 @@ module Hasura.GraphQL.Namespace
NamespacedFieldMap, NamespacedFieldMap,
flattenNamespaces, flattenNamespaces,
unflattenNamespaces, unflattenNamespaces,
customizeNamespace,
) )
where where
import Data.Aeson qualified as J import Data.Aeson qualified as J
import Data.HashMap.Strict.InsOrd qualified as OMap import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Text.Extended import Data.Text.Extended
import Hasura.GraphQL.Parser
import Hasura.GraphQL.Parser qualified as P
import Hasura.Prelude import Hasura.Prelude
import Language.GraphQL.Draft.Syntax qualified as G 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 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 (Namespaced m) (Namespaced m') = Namespaced (OMap.union m' m) -- Note: order of arguments to OMap.union to preserve ordering
merge v _ = v 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

View File

@ -24,10 +24,8 @@ import Data.HashSet qualified as Set
import Data.List.Extended (duplicates) import Data.List.Extended (duplicates)
import Data.Text qualified as T import Data.Text qualified as T
import Data.Text.Extended (dquoteList, (<<>)) import Data.Text.Extended (dquoteList, (<<>))
import Data.Tuple (swap)
import Hasura.Base.Error import Hasura.Base.Error
import Hasura.GraphQL.Parser.Collect () 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) -- 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.Schema.Remote (buildRemoteParser)
import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol
@ -165,8 +163,7 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do
let _rscInfo = RemoteSchemaInfo {..} let _rscInfo = RemoteSchemaInfo {..}
-- Check that the parsed GraphQL type info is valid by running the schema generation -- Check that the parsed GraphQL type info is valid by running the schema generation
(piQuery, piMutation, piSubscription) <- _rscParsed <- buildRemoteParser _rscIntroOriginal _rscInfo
P.runSchemaT @m @(P.ParseT Identity) $ buildRemoteParser _rscIntroOriginal _rscInfo
-- The 'rawIntrospectionResult' contains the 'Bytestring' response of -- The 'rawIntrospectionResult' contains the 'Bytestring' response of
-- the introspection result of the remote server. We store this in the -- the introspection result of the remote server. We store this in the
@ -175,7 +172,6 @@ fetchRemoteSchema env manager _rscName rsDef@ValidatedRemoteSchemaDef {..} = do
return return
RemoteSchemaCtx RemoteSchemaCtx
{ _rscPermissions = mempty, { _rscPermissions = mempty,
_rscParsed = ParsedIntrospection {..},
.. ..
} }
where where
@ -458,7 +454,7 @@ execRemoteGQ env manager userInfo reqHdrs rsdef gqlReq@GQLReq {..} = do
userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo
identityCustomizer :: RemoteSchemaCustomizer identityCustomizer :: RemoteSchemaCustomizer
identityCustomizer = RemoteSchemaCustomizer Nothing mempty mempty mempty mempty identityCustomizer = RemoteSchemaCustomizer Nothing mempty mempty
typeDefinitionName :: G.TypeDefinition a b -> G.Name typeDefinitionName :: G.TypeDefinition a b -> G.Name
typeDefinitionName = \case typeDefinitionName = \case
@ -473,8 +469,6 @@ getCustomizer :: IntrospectionResult -> Maybe RemoteSchemaCustomization -> Remot
getCustomizer _ Nothing = identityCustomizer getCustomizer _ Nothing = identityCustomizer
getCustomizer IntrospectionResult {..} (Just RemoteSchemaCustomization {..}) = RemoteSchemaCustomizer {..} getCustomizer IntrospectionResult {..} (Just RemoteSchemaCustomization {..}) = RemoteSchemaCustomizer {..}
where where
mapMap f = Map.fromList . map f . Map.toList
invertMap = mapMap swap -- key collisions are checked for later in validateSchemaCustomizations
rootTypeNames = rootTypeNames =
if isNothing _rscRootFieldsNamespace if isNothing _rscRootFieldsNamespace
then catMaybes [Just irQueryRoot, irMutationRoot, irSubscriptionRoot] 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 let customizationMap = Map.fromList $ map (\rfc -> (_rfcParentType rfc, rfc)) fieldNameCustomizations
in Map.intersectionWith mkFieldRenameMap customizationMap typeFieldMap 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 _rscNamespaceFieldName = _rscRootFieldsNamespace
_rscCustomizeTypeName = typeRenameMap _rscCustomizeTypeName = typeRenameMap
_rscCustomizeFieldName = fieldRenameMap _rscCustomizeFieldName = fieldRenameMap
_rscDecustomizeTypeName = invertMap typeRenameMap
_rscDecustomizeFieldName = mapMap (mapLookup typeRenameMap *** invertMap) fieldRenameMap
throwRemoteSchema :: throwRemoteSchema ::
QErrM m => QErrM m =>

View File

@ -153,24 +153,8 @@ customizeFields ::
P.MkTypename -> P.MkTypename ->
f [FieldParser n (RootField db remote action JO.Value)] -> f [FieldParser n (RootField db remote action JO.Value)] ->
f [FieldParser n (NamespacedField (RootField db remote action JO.Value))] f [FieldParser n (NamespacedField (RootField db remote action JO.Value))]
customizeFields sourceCustomization = customizeFields SourceCustomization {..} =
fmap . customizeNamespace sourceCustomization fmap . customizeNamespace (_rootfcNamespace =<< _scRootFields) (const typenameToRawRF)
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
buildRoleContext :: buildRoleContext ::
forall m. forall m.
@ -236,12 +220,12 @@ buildRoleContext
where where
getQueryRemotes :: getQueryRemotes ::
[ParsedIntrospection] -> [ParsedIntrospection] ->
[P.FieldParser (P.ParseT Identity) RemoteField] [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)]
getQueryRemotes = concatMap piQuery getQueryRemotes = concatMap piQuery
getMutationRemotes :: getMutationRemotes ::
[ParsedIntrospection] -> [ParsedIntrospection] ->
[P.FieldParser (P.ParseT Identity) RemoteField] [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)]
getMutationRemotes = concatMap (concat . piMutation) getMutationRemotes = concatMap (concat . piMutation)
buildSource :: buildSource ::
@ -422,14 +406,14 @@ unauthenticatedContext ::
MonadIO m, MonadIO m,
MonadUnique m MonadUnique m
) => ) =>
[P.FieldParser (P.ParseT Identity) RemoteField] -> [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] ->
[P.FieldParser (P.ParseT Identity) RemoteField] -> [P.FieldParser (P.ParseT Identity) (NamespacedField RemoteField)] ->
RemoteSchemaPermsCtx -> RemoteSchemaPermsCtx ->
m GQLContext m GQLContext
unauthenticatedContext adminQueryRemotes adminMutationRemotes remoteSchemaPermsCtx = P.runSchemaT $ do unauthenticatedContext adminQueryRemotes adminMutationRemotes remoteSchemaPermsCtx = P.runSchemaT $ do
let isRemoteSchemaPermsEnabled = remoteSchemaPermsCtx == RemoteSchemaPermsEnabled let isRemoteSchemaPermsEnabled = remoteSchemaPermsCtx == RemoteSchemaPermsEnabled
queryFields = bool (fmap (fmap $ NotNamespaced . RFRemote) adminQueryRemotes) [] isRemoteSchemaPermsEnabled queryFields = bool (fmap (fmap $ fmap RFRemote) adminQueryRemotes) [] isRemoteSchemaPermsEnabled
mutationFields = bool (fmap (fmap $ NotNamespaced . RFRemote) adminMutationRemotes) [] isRemoteSchemaPermsEnabled mutationFields = bool (fmap (fmap $ fmap RFRemote) adminMutationRemotes) [] isRemoteSchemaPermsEnabled
mutationParser <- mutationParser <-
whenMaybe (not $ null mutationFields) $ whenMaybe (not $ null mutationFields) $
P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFields P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFields
@ -452,9 +436,7 @@ buildRoleBasedRemoteSchemaParser roleName remoteSchemaCache = do
for remoteSchemaIntroInfos $ \RemoteSchemaCtx {..} -> for remoteSchemaIntroInfos $ \RemoteSchemaCtx {..} ->
for (Map.lookup roleName _rscPermissions) $ \introspectRes -> do for (Map.lookup roleName _rscPermissions) $ \introspectRes -> do
let customizer = rsCustomizer _rscInfo let customizer = rsCustomizer _rscInfo
(queryParsers, mutationParsers, subscriptionParsers) <- parsedIntrospection <- buildRemoteParser introspectRes _rscInfo
P.runSchemaT @m @(P.ParseT Identity) $ buildRemoteParser introspectRes _rscInfo
let parsedIntrospection = ParsedIntrospection queryParsers mutationParsers subscriptionParsers
return (_rscName, RemoteRelationshipQueryContext introspectRes parsedIntrospection customizer) return (_rscName, RemoteRelationshipQueryContext introspectRes parsedIntrospection customizer)
return $ catMaybes remoteSchemaPerms return $ catMaybes remoteSchemaPerms
@ -629,10 +611,11 @@ buildQueryParser ::
MonadRole r m, MonadRole r m,
Has QueryContext r, Has QueryContext r,
Has P.MkTypename r, Has P.MkTypename r,
Has MkRootFieldName r Has MkRootFieldName r,
Has CustomizeRemoteFieldName r
) => ) =>
[P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] -> [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] ->
[P.FieldParser n RemoteField] -> [P.FieldParser n (NamespacedField RemoteField)] ->
[ActionInfo] -> [ActionInfo] ->
NonObjectTypeMap -> NonObjectTypeMap ->
Maybe (Parser 'Output n (RootFieldMap (MutationRootField UnpreparedValue))) -> Maybe (Parser 'Output n (RootFieldMap (MutationRootField UnpreparedValue))) ->
@ -640,7 +623,7 @@ buildQueryParser ::
m (Parser 'Output n (RootFieldMap (QueryRootField UnpreparedValue))) m (Parser 'Output n (RootFieldMap (QueryRootField UnpreparedValue)))
buildQueryParser pgQueryFields remoteFields allActions nonObjectCustomTypes mutationParser subscriptionParser = do buildQueryParser pgQueryFields remoteFields allActions nonObjectCustomTypes mutationParser subscriptionParser = do
actionQueryFields <- concat <$> traverse (buildActionQueryFields nonObjectCustomTypes) allActions 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 allQueryFields mutationParser subscriptionParser
queryWithIntrospectionHelper :: queryWithIntrospectionHelper ::
@ -730,7 +713,8 @@ buildSubscriptionParser ::
MonadRole r m, MonadRole r m,
Has QueryContext r, Has QueryContext r,
Has P.MkTypename r, Has P.MkTypename r,
Has MkRootFieldName r Has MkRootFieldName r,
Has CustomizeRemoteFieldName r
) => ) =>
[P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] -> [P.FieldParser n (NamespacedField (QueryRootField UnpreparedValue))] ->
[ActionInfo] -> [ActionInfo] ->
@ -749,9 +733,10 @@ buildMutationParser ::
MonadRole r m, MonadRole r m,
Has QueryContext r, Has QueryContext r,
Has P.MkTypename r, Has P.MkTypename r,
Has MkRootFieldName r Has MkRootFieldName r,
Has CustomizeRemoteFieldName r
) => ) =>
[P.FieldParser n RemoteField] -> [P.FieldParser n (NamespacedField RemoteField)] ->
[ActionInfo] -> [ActionInfo] ->
NonObjectTypeMap -> NonObjectTypeMap ->
[P.FieldParser n (NamespacedField (MutationRootField UnpreparedValue))] -> [P.FieldParser n (NamespacedField (MutationRootField UnpreparedValue))] ->
@ -761,7 +746,7 @@ buildMutationParser allRemotes allActions nonObjectCustomTypes mutationFields =
let mutationFieldsParser = let mutationFieldsParser =
mutationFields mutationFields
<> (fmap NotNamespaced <$> actionParsers) <> (fmap NotNamespaced <$> actionParsers)
<> (fmap (NotNamespaced . RFRemote) <$> allRemotes) <> (fmap (fmap RFRemote) <$> allRemotes)
whenMaybe (not $ null mutationFieldsParser) $ whenMaybe (not $ null mutationFieldsParser) $
P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser P.safeSelectionSet mutationRoot (Just $ G.Description "mutation root") mutationFieldsParser
<&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF) <&> fmap (flattenNamespaces . fmap typenameToNamespacedRawRF)
@ -820,7 +805,8 @@ type ConcreteSchemaT m a =
SourceCache, SourceCache,
QueryContext, QueryContext,
P.MkTypename, P.MkTypename,
MkRootFieldName MkRootFieldName,
CustomizeRemoteFieldName
) )
m m
) )
@ -835,7 +821,7 @@ runMonadSchema ::
ConcreteSchemaT m a -> ConcreteSchemaT m a ->
m a m a
runMonadSchema roleName queryContext pgSources m = 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`. -- | Whether the request is sent with `x-hasura-use-backend-only-permissions` set to `true`.
data Scenario = Backend | Frontend deriving (Enum, Show, Eq) data Scenario = Backend | Frontend deriving (Enum, Show, Eq)

View File

@ -64,7 +64,8 @@ type MonadBuildSchema b r m n =
MonadRole r m, MonadRole r m,
Has QueryContext r, Has QueryContext r,
Has MkTypename 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. -- | This type class is responsible for generating the schema of a backend.

View File

@ -4,49 +4,67 @@
module Hasura.GraphQL.Schema.Remote module Hasura.GraphQL.Schema.Remote
( buildRemoteParser, ( buildRemoteParser,
remoteField, remoteField,
customizeFieldParser, makeResultCustomizer,
withRemoteSchemaCustomization,
) )
where where
import Control.Lens.Extended import Control.Monad.Unique
( Lens', import Data.Has
set,
use,
(%=),
(^.),
_1,
_2,
_3,
_4,
)
import Control.Monad.State.Lazy qualified as Lazy
import Data.HashMap.Strict qualified as Map import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.HashMap.Strict.InsOrd.Extended qualified as OMap import Data.HashMap.Strict.InsOrd.Extended qualified as OMap
import Data.List.NonEmpty qualified as NE import Data.List.NonEmpty qualified as NE
import Data.Monoid (Any (..)) import Data.Monoid (Any (..))
import Data.Parser.JSONPath
import Data.Text qualified as T
import Data.Text.Extended import Data.Text.Extended
import Data.Type.Equality import Data.Type.Equality
import Hasura.Base.Error import Hasura.Base.Error
import Hasura.GraphQL.Namespace
import Hasura.GraphQL.Parser as P import Hasura.GraphQL.Parser as P
import Hasura.GraphQL.Parser.Internal.Parser qualified as P import Hasura.GraphQL.Parser.Internal.Parser qualified as P
import Hasura.GraphQL.Parser.Internal.TypeChecking qualified as P import Hasura.GraphQL.Parser.Internal.TypeChecking qualified as P
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types.Common (stringScalar)
import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.ResultCustomization 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 import Language.GraphQL.Draft.Syntax qualified as G
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Top level function -- Top level function
-- TODO return ParsedIntrospection ?
buildRemoteParser :: buildRemoteParser ::
forall m n. 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 -> IntrospectionResult ->
RemoteSchemaInfo -> RemoteSchemaInfo ->
-- | parsers for, respectively: queries, mutations, and subscriptions -- | parsers for, respectively: queries, mutations, and subscriptions
@ -55,45 +73,27 @@ buildRemoteParser ::
Maybe [P.FieldParser n RemoteField], Maybe [P.FieldParser n RemoteField],
Maybe [P.FieldParser n RemoteField] Maybe [P.FieldParser n RemoteField]
) )
buildRemoteParser introspectionResult remoteSchemaInfo = do buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info = 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
queryT <- makeParsers queryRoot queryT <- makeParsers queryRoot
mutationT <- makeNonQueryRootFieldParser mutationRoot $$(G.litName "Mutation") mutationT <- makeNonQueryRootFieldParser mutationRoot $$(G.litName "Mutation")
subscriptionT <- makeNonQueryRootFieldParser subscriptionRoot $$(G.litName "Subscription") subscriptionT <- makeNonQueryRootFieldParser subscriptionRoot $$(G.litName "Subscription")
return (queryT, mutationT, subscriptionT) return (queryT, mutationT, subscriptionT)
where where
makeFieldParser :: G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RawRemoteField) makeFieldParser :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RemoteField)
makeFieldParser fieldDef = do makeFieldParser rootTypeName fieldDef =
fldParser <- remoteFieldFromDefinition sdoc fieldDef fmap makeRemoteField <$> remoteFieldFromDefinition sdoc rootTypeName fieldDef
pure $ RemoteFieldG info mempty <$> fldParser
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 = makeParsers rootName =
case lookupType sdoc rootName of case lookupType sdoc rootName of
Just (G.TypeDefinitionObject o) -> Just (G.TypeDefinitionObject o) ->
traverse makeFieldParser $ G._otdFieldsDefinition o traverse (makeFieldParser rootName) $ G._otdFieldsDefinition o
_ -> throw400 Unexpected $ rootName <<> " has to be an object type" _ -> 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 = makeNonQueryRootFieldParser userProvidedRootName defaultRootName =
case userProvidedRootName of case userProvidedRootName of
Just _rootName -> traverse makeParsers userProvidedRootName 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 -- presets. Presets might force the evaluation of variables that would otherwise be transmitted
-- unmodified. -- unmodified.
inputValueDefinitionParser :: inputValueDefinitionParser ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.InputValueDefinition -> G.InputValueDefinition ->
m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable))) m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable)))
@ -276,12 +276,13 @@ inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType
G.TypeNamed nullability typeName -> G.TypeNamed nullability typeName ->
case lookupType schemaDoc typeName of case lookupType schemaDoc typeName of
Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName
Just typeDef -> Just typeDef -> do
customizeTypename <- asks getter
case typeDef of case typeDef of
G.TypeDefinitionScalar scalarTypeDefn -> G.TypeDefinitionScalar scalarTypeDefn ->
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser scalarTypeDefn pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser customizeTypename scalarTypeDefn
G.TypeDefinitionEnum defn -> G.TypeDefinitionEnum defn ->
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser defn pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser customizeTypename defn
G.TypeDefinitionObject _ -> G.TypeDefinitionObject _ ->
throw400 RemoteSchemaError "expected input type, but got output type" throw400 RemoteSchemaError "expected input type, but got output type"
G.TypeDefinitionInputObject defn -> do 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 -- 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. -- query, we also track alterations, to apply optimizations.
-- See Note [Variable expansion in remote schema input parsers] for more information. -- 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 :: remoteFieldScalarParser ::
MonadParse n => MonadParse n =>
MkTypename ->
G.ScalarTypeDefinition -> G.ScalarTypeDefinition ->
P.Parser 'Both n (Altered, G.Value RemoteSchemaVariable) P.Parser 'Both n (Altered, G.Value RemoteSchemaVariable)
remoteFieldScalarParser (G.ScalarTypeDefinition description name _directives) = remoteFieldScalarParser customizeTypename (G.ScalarTypeDefinition description name _directives) =
P.Parser P.Parser
{ pType = schemaType, { pType = schemaType,
pParser = \inputValue -> pParser = \case
(Altered False,) <$> case inputValue of JSONValue v ->
JSONValue v -> pure $ G.VVariable $ RemoteJSONValue gType v pure $ (Altered $ G.getBaseType gType /= name, G.VVariable $ RemoteJSONValue (mkRemoteGType gType) v)
GraphQLValue v -> for v \var -> do GraphQLValue v -> case v of
G.VVariable var -> do
P.typeCheck False gType var 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 where
schemaType = NonNullable $ TNamed $ mkDefinition (Typename name) description TIScalar customizedTypename = customizeTypename name
schemaType = NonNullable $ TNamed $ mkDefinition customizedTypename description TIScalar
gType = toGraphQLType schemaType gType = toGraphQLType schemaType
mkRemoteGType = \case
G.TypeNamed n _ -> G.TypeNamed n name
G.TypeList n l -> G.TypeList n $ mkRemoteGType l
remoteFieldEnumParser :: remoteFieldEnumParser ::
MonadParse n => MonadParse n =>
MkTypename ->
G.EnumTypeDefinition -> G.EnumTypeDefinition ->
Parser 'Both n (Altered, G.Value RemoteSchemaVariable) Parser 'Both n (Altered, G.Value RemoteSchemaVariable)
remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) = remoteFieldEnumParser customizeTypename (G.EnumTypeDefinition desc name _directives valueDefns) =
let enumValDefns = let enumValDefns =
valueDefns <&> \(G.EnumValueDefinition enumDesc enumName _) -> valueDefns <&> \(G.EnumValueDefinition enumDesc enumName _) ->
( mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo, ( mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo,
G.VEnum enumName 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' -- | 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 -- 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! -- memoization: we know for sure that the preset fields won't generate a recursive call!
remoteInputObjectParser :: remoteInputObjectParser ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition -> G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition ->
m m
@ -401,8 +414,9 @@ remoteInputObjectParser schemaDoc defn@(G.InputObjectTypeDefinition desc name _
-- the same parser. -- the same parser.
Right <$> P.memoizeOn 'remoteInputObjectParser defn do Right <$> P.memoizeOn 'remoteInputObjectParser defn do
typename <- mkTypename name
argsParser <- argumentsParser valueDefns schemaDoc 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. -- | Variable expansion optimization.
-- Since each parser returns a value that indicates whether it was altered, we can detect when no -- 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 -- 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. -- contains values that contain presets further down, then this result is labelled as altered.
argumentsParser :: argumentsParser ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
m (InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable))) 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' returns a output parser for a given 'ObjectTypeDefinition'.
remoteSchemaObject :: remoteSchemaObject ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.ObjectTypeDefinition RemoteSchemaInputValueDefinition -> G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
m (Parser 'Output n [G.Field G.NoFragments RemoteSchemaVariable]) m (Parser 'Output n [G.Field G.NoFragments RemoteSchemaVariable])
remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name interfaces _directives subFields) = remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name interfaces _directives subFields) =
P.memoizeOn 'remoteSchemaObject defn do P.memoizeOn 'remoteSchemaObject defn do
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) subFields subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) subFields
interfaceDefs <- traverse getInterface interfaces interfaceDefs <- traverse getInterface interfaces
implements <- traverse (remoteSchemaInterface schemaDoc) interfaceDefs implements <- traverse (remoteSchemaInterface schemaDoc) interfaceDefs
-- TODO: also check sub-interfaces, when these are supported in a future graphql spec -- TODO: also check sub-interfaces, when these are supported in a future graphql spec
traverse_ validateImplementsFields interfaceDefs traverse_ validateImplementsFields interfaceDefs
typename <- mkTypename name
pure $ pure $
P.selectionSetObject (Typename name) description subFieldParsers implements P.selectionSetObject typename description subFieldParsers implements
<&> toList <&> toList
. OMap.mapWithKey . OMap.mapWithKey
( \alias -> handleTypename $ \_ -> ( \alias -> handleTypename $ \_ ->
@ -694,14 +709,14 @@ constructed query.
-- | 'remoteSchemaInterface' returns a output parser for a given 'InterfaceTypeDefinition'. -- | 'remoteSchemaInterface' returns a output parser for a given 'InterfaceTypeDefinition'.
-- Also check Note [Querying remote schema interfaces] -- Also check Note [Querying remote schema interfaces]
remoteSchemaInterface :: remoteSchemaInterface ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable))
remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name _directives fields possibleTypes) = remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name _directives fields possibleTypes) =
P.memoizeOn 'remoteSchemaObject defn do P.memoizeOn 'remoteSchemaObject defn do
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) fields subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) fields
objs <- traverse (getObjectParser schemaDoc getObject) possibleTypes objs <- traverse (getObjectParser schemaDoc getObject) possibleTypes
-- In the Draft GraphQL spec (> June 2018), interfaces can themselves -- In the Draft GraphQL spec (> June 2018), interfaces can themselves
-- implement superinterfaces. In the future, we may need to support this -- 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 -- 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 -- should have a check that expresses that that collection of objects is equal
-- to 'possibleTypes'. -- to 'possibleTypes'.
pure $ P.selectionSetInterface (Typename name) description subFieldParsers objs <&> constructInterfaceSelectionSet typename <- mkTypename name
pure $ P.selectionSetInterface typename description subFieldParsers objs <&> constructInterfaceSelectionSet
where where
getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
getObject objectName = getObject objectName =
@ -767,8 +783,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name
-- | 'remoteSchemaUnion' returns a output parser for a given 'UnionTypeDefinition'. -- | 'remoteSchemaUnion' returns a output parser for a given 'UnionTypeDefinition'.
remoteSchemaUnion :: remoteSchemaUnion ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.UnionTypeDefinition -> G.UnionTypeDefinition ->
m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) 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 objs <- traverse (getObjectParser schemaDoc getObject) objectNames
when (null objs) $ when (null objs) $
throw400 RemoteSchemaError $ "List of member types cannot be empty for union type " <> squote name throw400 RemoteSchemaError $ "List of member types cannot be empty for union type " <> squote name
typename <- mkTypename name
pure $ pure $
P.selectionSetUnion (Typename name) description objs P.selectionSetUnion typename description objs
<&> ( \objNameAndFields -> <&> ( \objNameAndFields ->
catMaybes $ catMaybes $
objNameAndFields <&> \(objName, fields) -> objNameAndFields <&> \(objName, fields) ->
@ -816,17 +833,18 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct
<> squote objectName <> squote objectName
remoteFieldFromDefinition :: remoteFieldFromDefinition ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.Name ->
G.FieldDefinition RemoteSchemaInputValueDefinition -> G.FieldDefinition RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable))
remoteFieldFromDefinition schemaDoc (G.FieldDefinition description name argsDefinition gType _) = remoteFieldFromDefinition schemaDoc parentTypeName (G.FieldDefinition description name argsDefinition gType _) = do
let addNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) let addNullableList :: FieldParser n a -> FieldParser n a
addNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) = addNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) =
P.FieldParser (Definition name' un desc (FieldInfo args (Nullable (TList 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) = addNonNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) =
P.FieldParser (Definition name' un desc (FieldInfo args (NonNullable (TList 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 convertType gType' = do
case gType' of case gType' of
G.TypeNamed (G.Nullability True) fieldTypeName -> 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'' -> G.TypeList (G.Nullability True) gType'' ->
addNullableList <$> convertType gType'' addNullableList <$> convertType gType''
G.TypeNamed (G.Nullability False) fieldTypeName -> do 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'' -> G.TypeList (G.Nullability False) gType'' ->
addNonNullableList <$> convertType gType'' addNonNullableList <$> convertType gType''
in convertType gType convertType gType
-- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition -- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition
-- in the 'RemoteSchemaIntrospection'. -- in the 'RemoteSchemaIntrospection'.
remoteFieldFromName :: remoteFieldFromName ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.Name -> G.Name ->
G.Name ->
Maybe G.Description -> Maybe G.Description ->
G.Name -> G.Name ->
G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) 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 case lookupType sdoc fieldTypeName of
Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> fieldTypeName 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. -- | '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 -- Note that the 'G.TypeDefinition' should be of the GraphQL 'Output' kind, when an
-- GraphQL 'Input' kind is provided, then error will be thrown. -- GraphQL 'Input' kind is provided, then error will be thrown.
remoteField :: remoteField ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
G.Name -> G.Name ->
G.Name ->
Maybe G.Description -> Maybe G.Description ->
G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) 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 -- TODO add directives
argsParser <- argumentsParser argsDefn sdoc argsParser <- argumentsParser argsDefn sdoc
customizeTypename <- asks getter
customizeFieldName <- asks getter
let customizedFieldName = customizeFieldName parentTypeName fieldName
case typeDefn of case typeDefn of
G.TypeDefinitionObject objTypeDefn -> do G.TypeDefinitionObject objTypeDefn -> do
remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn
-- converting [Field NoFragments Name] to (SelectionSet NoFragments G.Name) -- converting [Field NoFragments Name] to (SelectionSet NoFragments G.Name)
let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields
pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet argsParser pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
G.TypeDefinitionScalar scalarTypeDefn -> G.TypeDefinitionScalar scalarTypeDefn ->
pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldScalarParser scalarTypeDefn pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldScalarParser customizeTypename scalarTypeDefn
G.TypeDefinitionEnum enumTypeDefn -> G.TypeDefinitionEnum enumTypeDefn ->
pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldEnumParser enumTypeDefn pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldEnumParser customizeTypename enumTypeDefn
G.TypeDefinitionInterface ifaceTypeDefn -> G.TypeDefinitionInterface ifaceTypeDefn ->
remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet argsParser remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
G.TypeDefinitionUnion unionTypeDefn -> G.TypeDefinitionUnion unionTypeDefn ->
remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet argsParser remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
_ -> throw400 RemoteSchemaError "expected output type, but got input type" _ -> throw400 RemoteSchemaError "expected output type, but got input type"
where where
mkField :: mkField ::
Maybe G.Name -> Maybe G.Name ->
G.Name ->
HashMap G.Name (G.Value RemoteSchemaVariable) -> HashMap G.Name (G.Value RemoteSchemaVariable) ->
G.SelectionSet G.NoFragments RemoteSchemaVariable -> G.SelectionSet G.NoFragments RemoteSchemaVariable ->
G.Field G.NoFragments RemoteSchemaVariable G.Field G.NoFragments RemoteSchemaVariable
mkField alias args selSet = mkField alias customizedFieldName args selSet =
G.Field alias fieldName args mempty 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 :: mkFieldParserWithoutSelectionSet ::
G.Name ->
InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) ->
Parser 'Both n () -> Parser 'Both n () ->
FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
mkFieldParserWithoutSelectionSet argsParser outputParser = mkFieldParserWithoutSelectionSet customizedFieldName argsParser outputParser =
P.rawSelection fieldName description argsParser outputParser P.rawSelection customizedFieldName description argsParser outputParser
<&> \(alias, _, (_, args)) -> mkField alias args [] <&> \(alias, _, (_, args)) -> mkField alias customizedFieldName args []
mkFieldParserWithSelectionSet :: mkFieldParserWithSelectionSet ::
G.Name ->
InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) ->
Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable) -> Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable) ->
FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
mkFieldParserWithSelectionSet argsParser outputParser = mkFieldParserWithSelectionSet customizedFieldName argsParser outputParser =
P.rawSubselection fieldName description argsParser outputParser P.rawSubselection customizedFieldName description argsParser outputParser
<&> \(alias, _, (_, args), selSet) -> mkField alias args selSet <&> \(alias, _, (_, args), selSet) -> mkField alias customizedFieldName args selSet
-- | helper function to get a parser of an object with it's name -- | helper function to get a parser of an object with it's name
-- This function is called from 'remoteSchemaInterface' and -- 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 -- different implementation of 'getObject', which is the
-- reason 'getObject' is an argument to this function -- reason 'getObject' is an argument to this function
getObjectParser :: getObjectParser ::
forall n m. forall r m n.
(MonadSchema n m, MonadError QErr m) => MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection -> RemoteSchemaIntrospection ->
(G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) -> (G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) ->
G.Name -> G.Name ->
@ -931,265 +960,37 @@ getObjectParser schemaDoc getObject objName = do
obj <- remoteSchemaObject schemaDoc =<< getObject objName obj <- remoteSchemaObject schemaDoc =<< getObject objName
return $ (objName,) <$> obj return $ (objName,) <$> obj
addCustomNamespace :: customizeRemoteNamespace ::
forall m. forall n.
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.
(MonadParse n) => (MonadParse n) =>
(ResultCustomizer -> a -> b) -> RemoteSchemaInfo ->
RemoteSchemaCustomizer ->
G.Name -> G.Name ->
P.FieldParser n a -> [P.FieldParser n RemoteField] ->
(P.FieldParser n b) [P.FieldParser n (NamespacedField RemoteField)]
customizeFieldParser setResultCustomizer remoteSchemaCustomizer rootTypeName = customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers =
if hasTypeOrFieldCustomizations remoteSchemaCustomizer customizeNamespace (_rscNamespaceFieldName rsCustomizer) fromParsedSelection mkNamespaceTypename fieldParsers
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
}
where where
fParserWithResultCustomizer :: (ResultCustomizer, G.Field G.NoFragments Variable) -> n b fromParsedSelection alias =
fParserWithResultCustomizer (resultCustomizer, fld) = handleTypename . const $
setResultCustomizer resultCustomizer <$> fParser 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
in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty
mkNamespaceTypename = Typename . const (remoteSchemaCustomizeTypeName rsCustomizer rootTypeName)
customizeVariable :: Variable -> Variable type MonadBuildRemoteSchema r m n = (MonadSchema n m, MonadError QErr m, MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r)
customizeVariable Variable {..} = Variable {vType = customizeGraphQLType vType, ..}
customizeGraphQLType :: G.GType -> G.GType runMonadBuildRemoteSchema :: Monad m => SchemaT n (ReaderT (MkTypename, CustomizeRemoteFieldName) m) a -> m a
customizeGraphQLType = \case runMonadBuildRemoteSchema m = flip runReaderT (Typename, idFieldCustomizer) $ runSchemaT m
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'
where where
customizeFieldDefinition' :: G.Name -> Definition P.FieldInfo -> m (Definition P.FieldInfo) idFieldCustomizer :: CustomizeRemoteFieldName
customizeFieldDefinition' parentTypeName Definition {..} = do idFieldCustomizer = const id
dInfo' <- customizeFieldInfo dInfo
pure
Definition
{ dName = remoteSchemaCustomizeFieldName remoteSchemaCustomizer parentTypeName dName,
dInfo = dInfo',
..
}
customizeFieldInfo :: P.FieldInfo -> m P.FieldInfo withRemoteSchemaCustomization ::
customizeFieldInfo (P.FieldInfo args typ) = forall m r a.
P.FieldInfo <$> traverse (traverse $ customizeInputFieldInfo) args <*> customizeType typ (MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r) =>
RemoteSchemaCustomizer ->
customizeTypeDefinition :: (G.Name -> b -> m b) -> Definition b -> m (Definition b) m a ->
customizeTypeDefinition f Definition {..} = do m a
dInfo' <- f dName dInfo withRemoteSchemaCustomization remoteSchemaCustomizer =
pure withTypenameCustomization (Typename . remoteSchemaCustomizeTypeName remoteSchemaCustomizer)
Definition . withRemoteFieldNameCustomization (remoteSchemaCustomizeFieldName remoteSchemaCustomizer)
{ 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

View File

@ -1376,23 +1376,27 @@ remoteRelationshipField remoteFieldInfo = runMaybeT do
-- These are the arguments that are given by the user while executing a query -- These are the arguments that are given by the user while executing a query
let remoteFieldUserArguments = map snd $ Map.toList remoteFieldParamMap let remoteFieldUserArguments = map snd $ Map.toList remoteFieldParamMap
remoteFld <- remoteFld <-
withRemoteSchemaCustomization remoteSchemaCustomizer $
lift $ lift $
customizeFieldParser (,) remoteSchemaCustomizer parentTypeName . P.wrapFieldParser nestedFieldType P.wrapFieldParser nestedFieldType
<$> remoteField remoteRelationshipIntrospection fieldName Nothing remoteFieldUserArguments fieldTypeDefinition <$> remoteField remoteRelationshipIntrospection parentTypeName fieldName Nothing remoteFieldUserArguments fieldTypeDefinition
pure $ pure $
pure $ pure $
remoteFld 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 = let remoteArgs =
Map.toList args <&> \(argName, argVal) -> IR.RemoteFieldArgument argName $ P.GraphQLValue $ argVal 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 $ pure $
IR.AFRemote $ IR.AFRemote $
IR.RemoteSelectRemoteSchema $ IR.RemoteSelectRemoteSchema $
IR.RemoteSchemaSelect IR.RemoteSchemaSelect
{ _rselArgs = remoteArgs, { _rselArgs = remoteArgs,
_rselResultCustomizer = resultCustomizer', _rselResultCustomizer = resultCustomizer,
_rselSelection = selSet, _rselSelection = selSet,
_rselHasuraFields = hasuraFields, _rselHasuraFields = hasuraFields,
_rselFieldCall = fieldCalls, _rselFieldCall = fieldCalls,

View File

@ -468,7 +468,7 @@ runGQ env logger reqId userInfo ipAddress reqHeaders queryType reqUnparsed = do
runRemoteGQ httpManager fieldName rsi resultCustomizer gqlReq = do runRemoteGQ httpManager fieldName rsi resultCustomizer gqlReq = do
(telemTimeIO_DT, remoteResponseHeaders, resp) <- (telemTimeIO_DT, remoteResponseHeaders, resp) <-
doQErr $ E.execRemoteGQ env httpManager userInfo reqHeaders (rsDef rsi) gqlReq 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 let filteredHeaders = filter ((== "Set-Cookie") . fst) remoteResponseHeaders
pure $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) filteredHeaders pure $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) filteredHeaders
@ -564,14 +564,11 @@ extractFieldFromResponse ::
forall m. forall m.
Monad m => Monad m =>
RootFieldAlias -> RootFieldAlias ->
RemoteSchemaInfo ->
ResultCustomizer -> ResultCustomizer ->
LBS.ByteString -> LBS.ByteString ->
ExceptT (Either GQExecError QErr) m JO.Value ExceptT (Either GQExecError QErr) m JO.Value
extractFieldFromResponse fieldName rsi resultCustomizer resp = do extractFieldFromResponse fieldName resultCustomizer resp = do
let namespace = fmap G.unName $ _rscNamespaceFieldName $ rsCustomizer rsi let fieldName' = G.unName $ _rfaAlias fieldName
fieldName' = G.unName $ _rfaAlias fieldName
-- TODO: use RootFieldAlias for remote fields
dataVal <- dataVal <-
applyResultCustomizer resultCustomizer applyResultCustomizer resultCustomizer
<$> do <$> do
@ -579,14 +576,6 @@ extractFieldFromResponse fieldName rsi resultCustomizer resp = do
case graphQLResponse of case graphQLResponse of
GraphQLResponseErrors errs -> doGQExecError errs GraphQLResponseErrors errs -> doGQExecError errs
GraphQLResponseData d -> pure d 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 dataObj <- onLeft (JO.asObject dataVal) do400
fieldVal <- fieldVal <-
onNothing (JO.lookup fieldName' dataObj) $ onNothing (JO.lookup fieldName' dataObj) $

View File

@ -717,7 +717,7 @@ onStart env enabledLogTypes serverEnv wsConn (StartMsg opId q) onMessageActions
(telemTimeIO_DT, _respHdrs, resp) <- (telemTimeIO_DT, _respHdrs, resp) <-
doQErr $ doQErr $
E.execRemoteGQ env httpMgr userInfo reqHdrs (rsDef rsi) gqlReq 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) [] return $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) []
WSServerEnv WSServerEnv

View File

@ -3,11 +3,9 @@ module Hasura.RQL.Types.RemoteSchema
AddRemoteSchemaQuery (..), AddRemoteSchemaQuery (..),
AliasMapping, AliasMapping,
DropRemoteSchemaPermissions (..), DropRemoteSchemaPermissions (..),
RawRemoteField,
RemoteField, RemoteField,
RemoteFieldCustomization (..), RemoteFieldCustomization (..),
RemoteFieldG (..), RemoteFieldG (..),
RemoteRootField (..),
RemoteSchemaCustomization (..), RemoteSchemaCustomization (..),
RemoteSchemaCustomizer (..), RemoteSchemaCustomizer (..),
RemoteSchemaDef (..), RemoteSchemaDef (..),
@ -25,7 +23,6 @@ module Hasura.RQL.Types.RemoteSchema
ValidatedRemoteSchemaDef (..), ValidatedRemoteSchemaDef (..),
applyAliasMapping, applyAliasMapping,
customizeTypeNameString, customizeTypeNameString,
getRemoteFieldSelectionSet,
getUrlFromEnv, getUrlFromEnv,
hasTypeOrFieldCustomizations, hasTypeOrFieldCustomizations,
lookupEnum, lookupEnum,
@ -36,11 +33,8 @@ module Hasura.RQL.Types.RemoteSchema
lookupType, lookupType,
lookupUnion, lookupUnion,
modifyFieldByName, modifyFieldByName,
realRemoteField,
remoteSchemaCustomizeFieldName, remoteSchemaCustomizeFieldName,
remoteSchemaCustomizeTypeName, remoteSchemaCustomizeTypeName,
remoteSchemaDecustomizeFieldName,
remoteSchemaDecustomizeTypeName,
rfField, rfField,
rfRemoteSchemaInfo, rfRemoteSchemaInfo,
rfResultCustomizer, rfResultCustomizer,
@ -185,11 +179,7 @@ data RemoteSchemaCustomizer = RemoteSchemaCustomizer
-- | type name -> type name -- | type name -> type name
_rscCustomizeTypeName :: !(HashMap G.Name G.Name), _rscCustomizeTypeName :: !(HashMap G.Name G.Name),
-- | type name -> field name -> field name -- | type name -> field name -> field name
_rscCustomizeFieldName :: !(HashMap G.Name (HashMap G.Name G.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))
} }
deriving (Show, Eq, Generic) deriving (Show, Eq, Generic)
@ -209,14 +199,6 @@ remoteSchemaCustomizeFieldName :: RemoteSchemaCustomizer -> G.Name -> G.Name ->
remoteSchemaCustomizeFieldName RemoteSchemaCustomizer {..} typeName fieldName = remoteSchemaCustomizeFieldName RemoteSchemaCustomizer {..} typeName fieldName =
Map.lookup typeName _rscCustomizeFieldName >>= Map.lookup fieldName & fromMaybe 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 -> Bool
hasTypeOrFieldCustomizations RemoteSchemaCustomizer {..} = hasTypeOrFieldCustomizations RemoteSchemaCustomizer {..} =
not $ Map.null _rscCustomizeTypeName && Map.null _rscCustomizeFieldName not $ Map.null _rscCustomizeTypeName && Map.null _rscCustomizeFieldName
@ -428,37 +410,16 @@ newtype RemoteSchemaIntrospection
= RemoteSchemaIntrospection [(G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)] = RemoteSchemaIntrospection [(G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition)]
deriving (Show, Eq, Generic, Hashable, Cacheable, Ord) deriving (Show, Eq, Generic, Hashable, Cacheable, Ord)
-- | An RemoteRootField could either be a real field on the remote server data RemoteFieldG var = RemoteFieldG
-- 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
{ _rfRemoteSchemaInfo :: !RemoteSchemaInfo, { _rfRemoteSchemaInfo :: !RemoteSchemaInfo,
_rfResultCustomizer :: !ResultCustomizer, _rfResultCustomizer :: !ResultCustomizer,
_rfField :: !(f var) _rfField :: !(G.Field G.NoFragments var)
} }
deriving (Functor, Foldable, Traversable) deriving (Functor, Foldable, Traversable)
$(makeLenses ''RemoteFieldG) $(makeLenses ''RemoteFieldG)
type RawRemoteField = RemoteFieldG (G.Field G.NoFragments) RemoteSchemaVariable type RemoteField = RemoteFieldG RemoteSchemaVariable
type RemoteField = RemoteFieldG RemoteRootField RemoteSchemaVariable
realRemoteField :: RawRemoteField -> RemoteField
realRemoteField RemoteFieldG {..} = RemoteFieldG {_rfField = RRFRealField _rfField, ..}
data RemoteSchemaPermsCtx data RemoteSchemaPermsCtx
= RemoteSchemaPermsEnabled = RemoteSchemaPermsEnabled

View File

@ -44,12 +44,11 @@ module Hasura.RQL.Types.SchemaCache
ViewInfo (..), ViewInfo (..),
isMutable, isMutable,
IntrospectionResult (..), IntrospectionResult (..),
ParsedIntrospection (..), ParsedIntrospectionG (..),
ParsedIntrospection,
RemoteSchemaCustomizer (..), RemoteSchemaCustomizer (..),
remoteSchemaCustomizeTypeName, remoteSchemaCustomizeTypeName,
remoteSchemaCustomizeFieldName, remoteSchemaCustomizeFieldName,
remoteSchemaDecustomizeTypeName,
remoteSchemaDecustomizeFieldName,
RemoteSchemaCtx (..), RemoteSchemaCtx (..),
rscName, rscName,
rscInfo, rscInfo,
@ -126,6 +125,7 @@ import Database.PG.Query qualified as Q
import Hasura.Backends.Postgres.Connection qualified as PG import Hasura.Backends.Postgres.Connection qualified as PG
import Hasura.Base.Error import Hasura.Base.Error
import Hasura.GraphQL.Context (GQLContext, RoleContext) import Hasura.GraphQL.Context (GQLContext, RoleContext)
import Hasura.GraphQL.Namespace
import Hasura.GraphQL.Parser qualified as P import Hasura.GraphQL.Parser qualified as P
import Hasura.Incremental import Hasura.Incremental
( Cacheable, ( Cacheable,
@ -220,12 +220,14 @@ data IntrospectionResult = IntrospectionResult
instance Cacheable IntrospectionResult instance Cacheable IntrospectionResult
data ParsedIntrospection = ParsedIntrospection data ParsedIntrospectionG m = ParsedIntrospection
{ piQuery :: [P.FieldParser (P.ParseT Identity) RemoteField], { piQuery :: [P.FieldParser m (NamespacedField RemoteField)],
piMutation :: Maybe [P.FieldParser (P.ParseT Identity) RemoteField], piMutation :: Maybe [P.FieldParser m (NamespacedField RemoteField)],
piSubscription :: Maybe [P.FieldParser (P.ParseT Identity) RemoteField] piSubscription :: Maybe [P.FieldParser m (NamespacedField RemoteField)]
} }
type ParsedIntrospection = ParsedIntrospectionG (P.ParseT Identity)
-- | See 'fetchRemoteSchema'. -- | See 'fetchRemoteSchema'.
data RemoteSchemaCtx = RemoteSchemaCtx data RemoteSchemaCtx = RemoteSchemaCtx
{ _rscName :: !RemoteSchemaName, { _rscName :: !RemoteSchemaName,

View File

@ -11,6 +11,8 @@ module Hasura.RQL.Types.SourceCustomization
SourceCustomization (..), SourceCustomization (..),
withSourceCustomization, withSourceCustomization,
MkRootFieldName, MkRootFieldName,
CustomizeRemoteFieldName,
withRemoteFieldNameCustomization,
) )
where where
@ -122,3 +124,8 @@ withSourceCustomization ::
withSourceCustomization SourceCustomization {..} = withSourceCustomization SourceCustomization {..} =
withTypenameCustomization (mkCustomizedTypename _scTypeNames) withTypenameCustomization (mkCustomizedTypename _scTypeNames)
. withRootFieldNameCustomization (mkCustomizedFieldName _scRootFields) . 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

View File

@ -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)

View File

@ -11,8 +11,8 @@ import Hasura.Base.Error
import Hasura.GraphQL.Execute.Inline import Hasura.GraphQL.Execute.Inline
import Hasura.GraphQL.Execute.Remote (resolveRemoteVariable, runVariableCache) import Hasura.GraphQL.Execute.Remote (resolveRemoteVariable, runVariableCache)
import Hasura.GraphQL.Execute.Resolve import Hasura.GraphQL.Execute.Resolve
import Hasura.GraphQL.Namespace
import Hasura.GraphQL.Parser.Internal.Parser qualified as P import Hasura.GraphQL.Parser.Internal.Parser qualified as P
import Hasura.GraphQL.Parser.Monad
import Hasura.GraphQL.Parser.Schema import Hasura.GraphQL.Parser.Schema
import Hasura.GraphQL.Parser.TestUtils import Hasura.GraphQL.Parser.TestUtils
import Hasura.GraphQL.RemoteServer (identityCustomizer) import Hasura.GraphQL.RemoteServer (identityCustomizer)
@ -99,20 +99,17 @@ buildQueryParsers ::
IO (P.FieldParser TestMonad (G.Field G.NoFragments RemoteSchemaVariable)) IO (P.FieldParser TestMonad (G.Field G.NoFragments RemoteSchemaVariable))
buildQueryParsers introspection = do buildQueryParsers introspection = do
let introResult = IntrospectionResult introspection $$(G.litName "Query") Nothing Nothing let introResult = IntrospectionResult introspection $$(G.litName "Query") Nothing Nothing
(query, _, _) <- ParsedIntrospection query _ _ <-
runError $ runError $
runSchemaT $
buildRemoteParser introResult $ buildRemoteParser introResult $
RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer RemoteSchemaInfo (ValidatedRemoteSchemaDef N.nullURI [] False 60 Nothing) identityCustomizer
pure $ pure $
head query <&> \(RemoteFieldG _ _ abstractField) -> head query <&> \case
case abstractField of NotNamespaced remoteFld -> _rfField remoteFld
RRFRealField f -> f Namespaced _ ->
RRFNamespaceField _ -> -- Shouldn't happen if we're using identityCustomizer
error "buildQueryParsers: unexpected RRFNamespaceField" -- TODO: add some tests for remote schema customization
error "buildQueryParsers: unexpected Namespaced field"
-- Shouldn't happen if we're using identityCustomizer
-- TODO: add some tests for remote schema customization
runQueryParser :: runQueryParser ::
P.FieldParser TestMonad any -> P.FieldParser TestMonad any ->

View File

@ -23,7 +23,6 @@ import Hasura.App
import Hasura.EventingSpec qualified as EventingSpec import Hasura.EventingSpec qualified as EventingSpec
import Hasura.GraphQL.NamespaceSpec qualified as NamespaceSpec import Hasura.GraphQL.NamespaceSpec qualified as NamespaceSpec
import Hasura.GraphQL.Parser.DirectivesTest qualified as GraphQLDirectivesSpec 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.GraphQL.Schema.RemoteTest qualified as GraphRemoteSchemaSpec
import Hasura.IncrementalSpec qualified as IncrementalSpec import Hasura.IncrementalSpec qualified as IncrementalSpec
import Hasura.Logging import Hasura.Logging
@ -90,7 +89,6 @@ unitSpecs = do
describe "Hasura.RQL.Types.Common" CommonTypesSpec.spec describe "Hasura.RQL.Types.Common" CommonTypesSpec.spec
describe "Hasura.RQL.Types.Endpoint" EndpointSpec.spec describe "Hasura.RQL.Types.Endpoint" EndpointSpec.spec
describe "Hasura.GraphQL.Namespace" NamespaceSpec.spec describe "Hasura.GraphQL.Namespace" NamespaceSpec.spec
describe "Hasura.GraphQL.RemoteServer" RemoteServerSpec.spec
describe "Hasura.SQL.WKT" WKTSpec.spec describe "Hasura.SQL.WKT" WKTSpec.spec
describe "Hasura.Server.Auth" AuthSpec.spec describe "Hasura.Server.Auth" AuthSpec.spec
describe "Hasura.Server.Telemetry" TelemetrySpec.spec describe "Hasura.Server.Telemetry" TelemetrySpec.spec

View File

@ -69,11 +69,11 @@
} }
} }
response: response:
errors: data:
- extensions: star_wars:
path: $.selectionSet.star_wars.selectionSet.super_hero.selectionSet super_hero:
code: validation-failed ident: '1'
message: Type "Droid" is not a subtype of "FooCharacter_x" foo_name_f: R2-D2
- description: query with fragment - description: query with fragment
url: /v1/graphql url: /v1/graphql
@ -123,27 +123,27 @@
ident: "1" ident: "1"
foo_name_f: R2-D2 foo_name_f: R2-D2
# - description: query with variable with wrong type name - description: query with variable with wrong type name
# url: /v1/graphql url: /v1/graphql
# status: 200 status: 200
# query: query:
# query: | query: |
# query Hero($ep: Int!) { query Hero($ep: Int!) {
# star_wars { star_wars {
# super_hero(episode: $ep) { super_hero(episode: $ep) {
# ident ident
# foo_name_f foo_name_f
# } }
# } }
# } }
# variables: variables:
# ep: 4 ep: 4
# response: response:
# errors: errors:
# - extensions: - extensions:
# path: $.selectionSet.star_wars.selectionSet.super_hero.args.episode path: $.selectionSet.star_wars.selectionSet.super_hero.args.episode
# code: validation-failed code: validation-failed
# message: variable "ep" is declared as Int!, but used where MyInt! is expected message: variable "ep" is declared as Int!, but used where MyInt! is expected
- description: query with __type introspection - description: query with __type introspection
url: /v1/graphql url: /v1/graphql
@ -334,7 +334,7 @@
- extensions: - extensions:
path: $.selectionSet.star_wars.selectionSet.super_hero.selectionSet.id path: $.selectionSet.star_wars.selectionSet.super_hero.selectionSet.id
code: validation-failed code: validation-failed
message: "field \"id\" not found in type: 'FooCharacter_x'" message: "field \"id\" not found in type: 'FooHuman_x'"
- description: query aliases - description: query aliases
url: /v1/graphql url: /v1/graphql

View File

@ -36,7 +36,7 @@
- extensions: - extensions:
path: $.selectionSet.hero.selectionSet.id path: $.selectionSet.hero.selectionSet.id
code: validation-failed code: validation-failed
message: "field \"id\" not found in type: 'Character'" message: "field \"id\" not found in type: 'Human'"
- description: query aliases - description: query aliases
url: /v1/graphql url: /v1/graphql

View File

@ -8,11 +8,6 @@
hero(episode: 4) { hero(episode: 4) {
id id
name name
... on BarDroid {
id
name
primaryFunction
}
} }
} }
} }
@ -22,4 +17,3 @@
hero: hero:
id: '1' id: '1'
name: R2-D2 name: R2-D2
primaryFunction: Astromech

View File

@ -5,6 +5,7 @@
query: | query: |
{ {
hero(episode: 4) { hero(episode: 4) {
__typename
id id
name name
... on FooDroid { ... on FooDroid {
@ -17,6 +18,7 @@
response: response:
data: data:
hero: hero:
__typename: FooDroid
id: "1" id: "1"
name: R2-D2 name: R2-D2
primaryFunction: Astromech primaryFunction: Astromech
@ -62,11 +64,10 @@
} }
} }
response: response:
errors: data:
- extensions: hero:
path: $.selectionSet.hero.selectionSet id: '1'
code: validation-failed name: R2-D2
message: Type "Droid" is not a subtype of "FooCharacter"
- description: query with fragment - description: query with fragment
url: /v1/graphql url: /v1/graphql
@ -108,25 +109,25 @@
id: "1" id: "1"
name: R2-D2 name: R2-D2
# - description: query with variable with wrong type name - description: query with variable with wrong type name
# url: /v1/graphql url: /v1/graphql
# status: 200 status: 200
# query: query:
# query: | query: |
# query Hero($ep: Int!) { query Hero($ep: Int!) {
# hero(episode: $ep) { hero(episode: $ep) {
# id id
# name name
# } }
# } }
# variables: variables:
# ep: 4 ep: 4
# response: response:
# errors: errors:
# - extensions: - extensions:
# path: $.selectionSet.hero.args.episode path: $.selectionSet.hero.args.episode
# code: validation-failed code: validation-failed
# message: variable "ep" is declared as Int!, but used where MyInt! is expected message: variable "ep" is declared as Int!, but used where MyInt! is expected
- description: query with __type introspection - description: query with __type introspection
url: /v1/graphql url: /v1/graphql

View File

@ -836,7 +836,7 @@ class TestValidateRemoteSchemaNamespaceQuery:
def transact(self, request, hge_ctx): def transact(self, request, hge_ctx):
config = request.config config = request.config
if not config.getoption('--skip-schema-setup'): 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) q = mk_add_remote_q('character-foo', 'http://localhost:5000/character-iface-graphql', customization=customization)
st_code, resp = hge_ctx.v1q(q) st_code, resp = hge_ctx.v1q(q)
assert st_code == 200, resp assert st_code == 200, resp