hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-15 09:22:43 +03:00
Code Issues Projects Releases Wiki Activity

Refactor remote schema customization

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
server/graphql-engine.cabal
View File

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

2
server/src-lib/Hasura/GraphQL/Execute/Mutation.hs
View File

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

2
server/src-lib/Hasura/GraphQL/Execute/Query.hs
View File

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

6
server/src-lib/Hasura/GraphQL/Execute/Remote.hs
View File

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

25
server/src-lib/Hasura/GraphQL/Namespace.hs
View File

@ -8,12 +8,15 @@ module Hasura.GraphQL.Namespace
NamespacedFieldMap,
flattenNamespaces,
unflattenNamespaces,
customizeNamespace,
)
where
import Data.Aeson qualified as J
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Text.Extended
import Hasura.GraphQL.Parser
import Hasura.GraphQL.Parser qualified as P
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax qualified as G
@ -76,3 +79,25 @@ unflattenNamespaces = OMap.foldlWithKey' insert mempty
Just ns -> OMap.insertWith merge ns (Namespaced $ (OMap.singleton _rfaAlias v)) m
merge (Namespaced m) (Namespaced m') = Namespaced (OMap.union m' m) -- Note: order of arguments to OMap.union to preserve ordering
merge v _ = v
-- | Wrap the field parser results in @NamespacedField@
customizeNamespace ::
forall n a.
(MonadParse n) =>
Maybe G.Name ->
(G.Name -> P.ParsedSelection a -> a) ->
P.MkTypename ->
[FieldParser n a] ->
[FieldParser n (NamespacedField a)]
customizeNamespace (Just namespace) fromParsedSelection mkNamespaceTypename fieldParsers =
-- Source or remote schema has a namespace field so wrap the parsers
-- in a new namespace field parser.
[P.subselection_ namespace Nothing parser]
where
parser :: Parser 'Output n (NamespacedField a)
parser =
Namespaced . OMap.mapWithKey fromParsedSelection
<$> P.selectionSet (mkNamespaceTypename namespace) Nothing fieldParsers
customizeNamespace Nothing _ _ fieldParsers =
-- No namespace so just wrap the field parser results in @NotNamespaced@.
fmap NotNamespaced <$> fieldParsers

15
server/src-lib/Hasura/GraphQL/RemoteServer.hs
View File

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

58
server/src-lib/Hasura/GraphQL/Schema.hs
View File

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

3
server/src-lib/Hasura/GraphQL/Schema/Backend.hs
View File

@ -64,7 +64,8 @@ type MonadBuildSchema b r m n =
MonadRole r m,
Has QueryContext r,
Has MkTypename r,
Has MkRootFieldName r
Has MkRootFieldName r,
Has CustomizeRemoteFieldName r
)
-- | This type class is responsible for generating the schema of a backend.

525
server/src-lib/Hasura/GraphQL/Schema/Remote.hs
View File

@ -4,49 +4,67 @@
module Hasura.GraphQL.Schema.Remote
( buildRemoteParser,
remoteField,
customizeFieldParser,
makeResultCustomizer,
withRemoteSchemaCustomization,
)
where
import Control.Lens.Extended
( Lens',
set,
use,
(%=),
(^.),
_1,
_2,
_3,
_4,
)
import Control.Monad.State.Lazy qualified as Lazy
import Control.Monad.Unique
import Data.Has
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.HashMap.Strict.InsOrd.Extended qualified as OMap
import Data.List.NonEmpty qualified as NE
import Data.Monoid (Any (..))
import Data.Parser.JSONPath
import Data.Text qualified as T
import Data.Text.Extended
import Data.Type.Equality
import Hasura.Base.Error
import Hasura.GraphQL.Namespace
import Hasura.GraphQL.Parser as P
import Hasura.GraphQL.Parser.Internal.Parser qualified as P
import Hasura.GraphQL.Parser.Internal.TypeChecking qualified as P
import Hasura.Prelude
import Hasura.RQL.Types.Common (stringScalar)
import Hasura.RQL.Types.RemoteSchema
import Hasura.RQL.Types.ResultCustomization
import Hasura.RQL.Types.SchemaCache (IntrospectionResult (IntrospectionResult, irMutationRoot, irQueryRoot, irSubscriptionRoot))
import Hasura.RQL.Types.SchemaCache (IntrospectionResult (IntrospectionResult, irMutationRoot, irQueryRoot, irSubscriptionRoot), ParsedIntrospectionG (..))
import Hasura.RQL.Types.SourceCustomization
import Language.GraphQL.Draft.Syntax qualified as G
--------------------------------------------------------------------------------
-- Top level function
-- TODO return ParsedIntrospection ?
buildRemoteParser ::
forall m n.
(MonadSchema n m, MonadError QErr m) =>
(MonadIO m, MonadUnique m, MonadError QErr m, MonadParse n) =>
IntrospectionResult ->
RemoteSchemaInfo ->
m (ParsedIntrospectionG n)
buildRemoteParser introspectionResult remoteSchemaInfo@RemoteSchemaInfo {..} = do
(rawQueryParsers, rawMutationParsers, rawSubscriptionParsers) <-
runMonadBuildRemoteSchema $
withRemoteSchemaCustomization rsCustomizer $
buildRawRemoteParser introspectionResult remoteSchemaInfo
pure $
ParsedIntrospection
(customizeRemoteNamespace remoteSchemaInfo (irQueryRoot introspectionResult) rawQueryParsers)
(customizeRemoteNamespace remoteSchemaInfo <$> irMutationRoot introspectionResult <*> rawMutationParsers)
(customizeRemoteNamespace remoteSchemaInfo <$> irSubscriptionRoot introspectionResult <*> rawSubscriptionParsers)
makeResultCustomizer :: RemoteSchemaCustomizer -> G.Field G.NoFragments a -> ResultCustomizer
makeResultCustomizer remoteSchemaCustomizer G.Field {..} =
modifyFieldByName (fromMaybe _fName _fAlias) $
if _fName == $$(G.litName "__typename")
then customizeTypeNameString (_rscCustomizeTypeName remoteSchemaCustomizer)
else foldMap resultCustomizerFromSelection _fSelectionSet
where
resultCustomizerFromSelection :: G.Selection G.NoFragments a -> ResultCustomizer
resultCustomizerFromSelection = \case
G.SelectionField fld -> makeResultCustomizer remoteSchemaCustomizer fld
G.SelectionInlineFragment G.InlineFragment {..} -> foldMap resultCustomizerFromSelection _ifSelectionSet
buildRawRemoteParser ::
forall r m n.
MonadBuildRemoteSchema r m n =>
IntrospectionResult ->
RemoteSchemaInfo ->
-- | parsers for, respectively: queries, mutations, and subscriptions
@ -55,45 +73,27 @@ buildRemoteParser ::
Maybe [P.FieldParser n RemoteField],
Maybe [P.FieldParser n RemoteField]
)
buildRemoteParser introspectionResult remoteSchemaInfo = do
(rawQueryParsers, rawMutationParsers, rawSubscriptionParsers) <- buildRawRemoteParser introspectionResult remoteSchemaInfo
pure $
evalMemoState $ do
queryParsers <- customizeFieldParsers remoteSchemaInfo (irQueryRoot introspectionResult) rawQueryParsers
mutationParsers <- sequence $ customizeFieldParsers remoteSchemaInfo <$> irMutationRoot introspectionResult <*> rawMutationParsers
subscriptionParsers <- sequence $ customizeFieldParsers remoteSchemaInfo <$> irSubscriptionRoot introspectionResult <*> rawSubscriptionParsers
pure (queryParsers, mutationParsers, subscriptionParsers)
buildRawRemoteParser ::
forall m n.
(MonadSchema n m, MonadError QErr m) =>
IntrospectionResult ->
RemoteSchemaInfo ->
-- | parsers for, respectively: queries, mutations, and subscriptions
m
( [P.FieldParser n RawRemoteField],
Maybe [P.FieldParser n RawRemoteField],
Maybe [P.FieldParser n RawRemoteField]
)
buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info@RemoteSchemaInfo {..} = do
buildRawRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionRoot) info = do
queryT <- makeParsers queryRoot
mutationT <- makeNonQueryRootFieldParser mutationRoot $$(G.litName "Mutation")
subscriptionT <- makeNonQueryRootFieldParser subscriptionRoot $$(G.litName "Subscription")
return (queryT, mutationT, subscriptionT)
where
makeFieldParser :: G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RawRemoteField)
makeFieldParser fieldDef = do
fldParser <- remoteFieldFromDefinition sdoc fieldDef
pure $ RemoteFieldG info mempty <$> fldParser
makeFieldParser :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RemoteField)
makeFieldParser rootTypeName fieldDef =
fmap makeRemoteField <$> remoteFieldFromDefinition sdoc rootTypeName fieldDef
makeParsers :: G.Name -> m [P.FieldParser n RawRemoteField]
makeRemoteField :: G.Field G.NoFragments RemoteSchemaVariable -> RemoteField
makeRemoteField fld = RemoteFieldG info (makeResultCustomizer (rsCustomizer info) fld) fld
makeParsers :: G.Name -> m [P.FieldParser n RemoteField]
makeParsers rootName =
case lookupType sdoc rootName of
Just (G.TypeDefinitionObject o) ->
traverse makeFieldParser $ G._otdFieldsDefinition o
traverse (makeFieldParser rootName) $ G._otdFieldsDefinition o
_ -> throw400 Unexpected $ rootName <<> " has to be an object type"
makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n RawRemoteField])
makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n RemoteField])
makeNonQueryRootFieldParser userProvidedRootName defaultRootName =
case userProvidedRootName of
Just _rootName -> traverse makeParsers userProvidedRootName
@ -234,8 +234,8 @@ newtype Altered = Altered {getAltered :: Bool}
-- presets. Presets might force the evaluation of variables that would otherwise be transmitted
-- unmodified.
inputValueDefinitionParser ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.InputValueDefinition ->
m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable)))
@ -276,12 +276,13 @@ inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType
G.TypeNamed nullability typeName ->
case lookupType schemaDoc typeName of
Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName
Just typeDef ->
Just typeDef -> do
customizeTypename <- asks getter
case typeDef of
G.TypeDefinitionScalar scalarTypeDefn ->
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser scalarTypeDefn
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser customizeTypename scalarTypeDefn
G.TypeDefinitionEnum defn ->
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser defn
pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser customizeTypename defn
G.TypeDefinitionObject _ ->
throw400 RemoteSchemaError "expected input type, but got output type"
G.TypeDefinitionInputObject defn -> do
@ -327,35 +328,47 @@ inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType
-- were a query variable of its own. To avoid ending up with one such variable per scalar in the
-- query, we also track alterations, to apply optimizations.
-- See Note [Variable expansion in remote schema input parsers] for more information.
--
-- If the value contains a variable with a customized type name then we need to consider it to be
-- altered to ensure that the original type name is passed to the remote server.
remoteFieldScalarParser ::
MonadParse n =>
MkTypename ->
G.ScalarTypeDefinition ->
P.Parser 'Both n (Altered, G.Value RemoteSchemaVariable)
remoteFieldScalarParser (G.ScalarTypeDefinition description name _directives) =
remoteFieldScalarParser customizeTypename (G.ScalarTypeDefinition description name _directives) =
P.Parser
{ pType = schemaType,
pParser = \inputValue ->
(Altered False,) <$> case inputValue of
JSONValue v -> pure $ G.VVariable $ RemoteJSONValue gType v
GraphQLValue v -> for v \var -> do
pParser = \case
JSONValue v ->
pure $ (Altered $ G.getBaseType gType /= name, G.VVariable $ RemoteJSONValue (mkRemoteGType gType) v)
GraphQLValue v -> case v of
G.VVariable var -> do
P.typeCheck False gType var
pure $ QueryVariable var
pure $ (Altered $ G.getBaseType (vType var) /= name, G.VVariable $ QueryVariable var {vType = mkRemoteGType (vType var)})
_ -> pure (Altered False, QueryVariable <$> v)
}
where
schemaType = NonNullable $ TNamed $ mkDefinition (Typename name) description TIScalar
customizedTypename = customizeTypename name
schemaType = NonNullable $ TNamed $ mkDefinition customizedTypename description TIScalar
gType = toGraphQLType schemaType
mkRemoteGType = \case
G.TypeNamed n _ -> G.TypeNamed n name
G.TypeList n l -> G.TypeList n $ mkRemoteGType l
remoteFieldEnumParser ::
MonadParse n =>
MkTypename ->
G.EnumTypeDefinition ->
Parser 'Both n (Altered, G.Value RemoteSchemaVariable)
remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) =
remoteFieldEnumParser customizeTypename (G.EnumTypeDefinition desc name _directives valueDefns) =
let enumValDefns =
valueDefns <&> \(G.EnumValueDefinition enumDesc enumName _) ->
( mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo,
G.VEnum enumName
)
in fmap (Altered False,) $ P.enum (Typename name) desc $ NE.fromList enumValDefns
in fmap (Altered False,) $ P.enum (customizeTypename name) desc $ NE.fromList enumValDefns
-- | remoteInputObjectParser returns an input parser for a given 'G.InputObjectTypeDefinition'
--
@ -380,8 +393,8 @@ remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) =
-- field: if yes, we memoize that branch and proceed as normal. Otherwise we can omit the
-- memoization: we know for sure that the preset fields won't generate a recursive call!
remoteInputObjectParser ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition ->
m
@ -401,8 +414,9 @@ remoteInputObjectParser schemaDoc defn@(G.InputObjectTypeDefinition desc name _
-- the same parser.
Right <$> P.memoizeOn 'remoteInputObjectParser defn do
typename <- mkTypename name
argsParser <- argumentsParser valueDefns schemaDoc
pure $ fmap G.VObject <$> P.object (Typename name) desc argsParser
pure $ fmap G.VObject <$> P.object typename desc argsParser
-- | Variable expansion optimization.
-- Since each parser returns a value that indicates whether it was altered, we can detect when no
@ -474,8 +488,8 @@ shortCircuitIfUnaltered parser =
-- part of the tree was altered during parsing; if any of the fields is preset, or recursively
-- contains values that contain presets further down, then this result is labelled as altered.
argumentsParser ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
RemoteSchemaIntrospection ->
m (InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)))
@ -515,20 +529,21 @@ aggregateListAndAlteration = first mconcat . unzip . catMaybes
-- | 'remoteSchemaObject' returns a output parser for a given 'ObjectTypeDefinition'.
remoteSchemaObject ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
m (Parser 'Output n [G.Field G.NoFragments RemoteSchemaVariable])
remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name interfaces _directives subFields) =
P.memoizeOn 'remoteSchemaObject defn do
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) subFields
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) subFields
interfaceDefs <- traverse getInterface interfaces
implements <- traverse (remoteSchemaInterface schemaDoc) interfaceDefs
-- TODO: also check sub-interfaces, when these are supported in a future graphql spec
traverse_ validateImplementsFields interfaceDefs
typename <- mkTypename name
pure $
P.selectionSetObject (Typename name) description subFieldParsers implements
P.selectionSetObject typename description subFieldParsers implements
<&> toList
. OMap.mapWithKey
( \alias -> handleTypename $ \_ ->
@ -694,14 +709,14 @@ constructed query.
-- | 'remoteSchemaInterface' returns a output parser for a given 'InterfaceTypeDefinition'.
-- Also check Note [Querying remote schema interfaces]
remoteSchemaInterface ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable))
remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name _directives fields possibleTypes) =
P.memoizeOn 'remoteSchemaObject defn do
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) fields
subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc name) fields
objs <- traverse (getObjectParser schemaDoc getObject) possibleTypes
-- In the Draft GraphQL spec (> June 2018), interfaces can themselves
-- implement superinterfaces. In the future, we may need to support this
@ -712,7 +727,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name
-- types in the schema document that claim to implement this interface. We
-- should have a check that expresses that that collection of objects is equal
-- to 'possibleTypes'.
pure $ P.selectionSetInterface (Typename name) description subFieldParsers objs <&> constructInterfaceSelectionSet
typename <- mkTypename name
pure $ P.selectionSetInterface typename description subFieldParsers objs <&> constructInterfaceSelectionSet
where
getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
getObject objectName =
@ -767,8 +783,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name
-- | 'remoteSchemaUnion' returns a output parser for a given 'UnionTypeDefinition'.
remoteSchemaUnion ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.UnionTypeDefinition ->
m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable))
@ -777,8 +793,9 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct
objs <- traverse (getObjectParser schemaDoc getObject) objectNames
when (null objs) $
throw400 RemoteSchemaError $ "List of member types cannot be empty for union type " <> squote name
typename <- mkTypename name
pure $
P.selectionSetUnion (Typename name) description objs
P.selectionSetUnion typename description objs
<&> ( \objNameAndFields ->
catMaybes $
objNameAndFields <&> \(objName, fields) ->
@ -816,17 +833,18 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct
<> squote objectName
remoteFieldFromDefinition ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.Name ->
G.FieldDefinition RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable))
remoteFieldFromDefinition schemaDoc (G.FieldDefinition description name argsDefinition gType _) =
let addNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
remoteFieldFromDefinition schemaDoc parentTypeName (G.FieldDefinition description name argsDefinition gType _) = do
let addNullableList :: FieldParser n a -> FieldParser n a
addNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) =
P.FieldParser (Definition name' un desc (FieldInfo args (Nullable (TList typ)))) parser
addNonNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
addNonNullableList :: FieldParser n a -> FieldParser n a
addNonNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) =
P.FieldParser (Definition name' un desc (FieldInfo args (NonNullable (TList typ)))) parser
@ -835,85 +853,96 @@ remoteFieldFromDefinition schemaDoc (G.FieldDefinition description name argsDefi
convertType gType' = do
case gType' of
G.TypeNamed (G.Nullability True) fieldTypeName ->
P.nullableField <$> remoteFieldFromName schemaDoc name description fieldTypeName argsDefinition
P.nullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition
G.TypeList (G.Nullability True) gType'' ->
addNullableList <$> convertType gType''
G.TypeNamed (G.Nullability False) fieldTypeName -> do
P.nonNullableField <$> remoteFieldFromName schemaDoc name description fieldTypeName argsDefinition
P.nonNullableField <$> remoteFieldFromName schemaDoc parentTypeName name description fieldTypeName argsDefinition
G.TypeList (G.Nullability False) gType'' ->
addNonNullableList <$> convertType gType''
in convertType gType
convertType gType
-- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition
-- in the 'RemoteSchemaIntrospection'.
remoteFieldFromName ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.Name ->
G.Name ->
Maybe G.Description ->
G.Name ->
G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable))
remoteFieldFromName sdoc fieldName description fieldTypeName argsDefns =
remoteFieldFromName sdoc parentTypeName fieldName description fieldTypeName argsDefns =
case lookupType sdoc fieldTypeName of
Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> fieldTypeName
Just typeDef -> remoteField sdoc fieldName description argsDefns typeDef
Just typeDef -> remoteField sdoc parentTypeName fieldName description argsDefns typeDef
-- | 'remoteField' accepts a 'G.TypeDefinition' and will returns a 'FieldParser' for it.
-- Note that the 'G.TypeDefinition' should be of the GraphQL 'Output' kind, when an
-- GraphQL 'Input' kind is provided, then error will be thrown.
remoteField ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
G.Name ->
G.Name ->
Maybe G.Description ->
G.ArgumentsDefinition RemoteSchemaInputValueDefinition ->
G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable))
remoteField sdoc fieldName description argsDefn typeDefn = do
remoteField sdoc parentTypeName fieldName description argsDefn typeDefn = do
-- TODO add directives
argsParser <- argumentsParser argsDefn sdoc
customizeTypename <- asks getter
customizeFieldName <- asks getter
let customizedFieldName = customizeFieldName parentTypeName fieldName
case typeDefn of
G.TypeDefinitionObject objTypeDefn -> do
remoteSchemaObjFields <- remoteSchemaObject sdoc objTypeDefn
-- converting [Field NoFragments Name] to (SelectionSet NoFragments G.Name)
let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields
pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet argsParser
pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
G.TypeDefinitionScalar scalarTypeDefn ->
pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldScalarParser scalarTypeDefn
pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldScalarParser customizeTypename scalarTypeDefn
G.TypeDefinitionEnum enumTypeDefn ->
pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldEnumParser enumTypeDefn
pure $ mkFieldParserWithoutSelectionSet customizedFieldName argsParser $ void $ remoteFieldEnumParser customizeTypename enumTypeDefn
G.TypeDefinitionInterface ifaceTypeDefn ->
remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet argsParser
remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
G.TypeDefinitionUnion unionTypeDefn ->
remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet argsParser
remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet customizedFieldName argsParser
_ -> throw400 RemoteSchemaError "expected output type, but got input type"
where
mkField ::
Maybe G.Name ->
G.Name ->
HashMap G.Name (G.Value RemoteSchemaVariable) ->
G.SelectionSet G.NoFragments RemoteSchemaVariable ->
G.Field G.NoFragments RemoteSchemaVariable
mkField alias args selSet =
G.Field alias fieldName args mempty selSet
mkField alias customizedFieldName args selSet =
-- If there's no alias then use customizedFieldName as the alias so the
-- correctly customized field name will be returned from the remote server.
let alias' = alias <|> guard (customizedFieldName /= fieldName) *> Just customizedFieldName
in G.Field alias' fieldName args mempty selSet
mkFieldParserWithoutSelectionSet ::
G.Name ->
InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) ->
Parser 'Both n () ->
FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
mkFieldParserWithoutSelectionSet argsParser outputParser =
P.rawSelection fieldName description argsParser outputParser
<&> \(alias, _, (_, args)) -> mkField alias args []
mkFieldParserWithoutSelectionSet customizedFieldName argsParser outputParser =
P.rawSelection customizedFieldName description argsParser outputParser
<&> \(alias, _, (_, args)) -> mkField alias customizedFieldName args []
mkFieldParserWithSelectionSet ::
G.Name ->
InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) ->
Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable) ->
FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)
mkFieldParserWithSelectionSet argsParser outputParser =
P.rawSubselection fieldName description argsParser outputParser
<&> \(alias, _, (_, args), selSet) -> mkField alias args selSet
mkFieldParserWithSelectionSet customizedFieldName argsParser outputParser =
P.rawSubselection customizedFieldName description argsParser outputParser
<&> \(alias, _, (_, args), selSet) -> mkField alias customizedFieldName args selSet
-- | helper function to get a parser of an object with it's name
-- This function is called from 'remoteSchemaInterface' and
@ -921,8 +950,8 @@ remoteField sdoc fieldName description argsDefn typeDefn = do
-- different implementation of 'getObject', which is the
-- reason 'getObject' is an argument to this function
getObjectParser ::
forall n m.
(MonadSchema n m, MonadError QErr m) =>
forall r m n.
MonadBuildRemoteSchema r m n =>
RemoteSchemaIntrospection ->
(G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) ->
G.Name ->
@ -931,265 +960,37 @@ getObjectParser schemaDoc getObject objName = do
obj <- remoteSchemaObject schemaDoc =<< getObject objName
return $ (objName,) <$> obj
addCustomNamespace ::
forall m.
MonadParse m =>
RemoteSchemaInfo ->
G.Name ->
G.Name ->
[P.FieldParser m RawRemoteField] ->
P.FieldParser m RemoteField
addCustomNamespace remoteSchemaInfo rootTypeName namespace fieldParsers =
P.subselection_ namespace Nothing remoteFieldParser
where
rawRemoteFieldsParser :: Parser 'Output m [RawRemoteField]
rawRemoteFieldsParser =
P.selectionSet (Typename rootTypeName) Nothing fieldParsers
<&> toList
. OMap.mapWithKey
( \alias -> \case
P.SelectField fld -> fld
P.SelectTypename fld ->
-- In P.selectionSet we lose the resultCustomizer from __typename fields so we need to put it back
let resultCustomizer = modifyFieldByName alias $ customizeTypeNameString $ _rscCustomizeTypeName $ rsCustomizer remoteSchemaInfo
in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty
)
remoteFieldParser :: Parser 'Output m RemoteField
remoteFieldParser =
rawRemoteFieldsParser <&> \remoteFields ->
RemoteFieldG
remoteSchemaInfo
(foldMap _rfResultCustomizer remoteFields)
(RRFNamespaceField $ G.SelectionField . _rfField <$> remoteFields)
customizeFieldParsers ::
forall m n.
(MonadState MemoState m, MonadFix m, MonadParse n) =>
RemoteSchemaInfo ->
G.Name ->
[P.FieldParser n RawRemoteField] ->
m [P.FieldParser n RemoteField]
customizeFieldParsers remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers = do
fieldParsers' <-
if hasTypeOrFieldCustomizations rsCustomizer
then traverse (customizeFieldParser' (set rfResultCustomizer) rsCustomizer rootTypeName) fieldParsers
else -- no need to customize individual FieldParsers if there are no type or field name customizations
pure fieldParsers
pure $ case _rscNamespaceFieldName rsCustomizer of
Nothing -> fmap realRemoteField <$> fieldParsers'
Just namespace -> [addCustomNamespace remoteSchemaInfo rootTypeName namespace fieldParsers']
customizeFieldParser ::
forall n a b.
customizeRemoteNamespace ::
forall n.
(MonadParse n) =>
(ResultCustomizer -> a -> b) ->
RemoteSchemaCustomizer ->
RemoteSchemaInfo ->
G.Name ->
P.FieldParser n a ->
(P.FieldParser n b)
customizeFieldParser setResultCustomizer remoteSchemaCustomizer rootTypeName =
if hasTypeOrFieldCustomizations remoteSchemaCustomizer
then evalMemoState . customizeFieldParser' setResultCustomizer remoteSchemaCustomizer rootTypeName
else fmap $ setResultCustomizer mempty
customizeFieldParser' ::
forall m n a b.
(MonadState MemoState m, MonadFix m, MonadParse n) =>
(ResultCustomizer -> a -> b) ->
RemoteSchemaCustomizer ->
G.Name ->
P.FieldParser n a ->
m (P.FieldParser n b)
customizeFieldParser' setResultCustomizer remoteSchemaCustomizer rootTypeName P.FieldParser {..} = do
customizedDefinition <- customizeFieldDefinition remoteSchemaCustomizer rootTypeName fDefinition
let customizedRootTypeName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer rootTypeName
pure
P.FieldParser
{ fParser =
fParserWithResultCustomizer
<=< customizeField customizedRootTypeName (dInfo customizedDefinition) . fmap customizeVariable,
fDefinition = customizedDefinition
}
[P.FieldParser n RemoteField] ->
[P.FieldParser n (NamespacedField RemoteField)]
customizeRemoteNamespace remoteSchemaInfo@RemoteSchemaInfo {..} rootTypeName fieldParsers =
customizeNamespace (_rscNamespaceFieldName rsCustomizer) fromParsedSelection mkNamespaceTypename fieldParsers
where
fParserWithResultCustomizer :: (ResultCustomizer, G.Field G.NoFragments Variable) -> n b
fParserWithResultCustomizer (resultCustomizer, fld) =
setResultCustomizer resultCustomizer <$> fParser fld
fromParsedSelection alias =
handleTypename . const $
-- In P.selectionSet we lose the resultCustomizer from __typename fields so we need to put it back
let resultCustomizer = modifyFieldByName alias $ customizeTypeNameString $ _rscCustomizeTypeName rsCustomizer
in RemoteFieldG remoteSchemaInfo resultCustomizer $ G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty
mkNamespaceTypename = Typename . const (remoteSchemaCustomizeTypeName rsCustomizer rootTypeName)
customizeVariable :: Variable -> Variable
customizeVariable Variable {..} = Variable {vType = customizeGraphQLType vType, ..}
type MonadBuildRemoteSchema r m n = (MonadSchema n m, MonadError QErr m, MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r)
customizeGraphQLType :: G.GType -> G.GType
customizeGraphQLType = \case
G.TypeNamed nullability name -> G.TypeNamed nullability $ remoteSchemaDecustomizeTypeName remoteSchemaCustomizer name
G.TypeList nullability gtype -> G.TypeList nullability $ customizeGraphQLType gtype
customizeField :: G.Name -> P.FieldInfo -> G.Field G.NoFragments var -> n (ResultCustomizer, G.Field G.NoFragments var)
customizeField parentTypeName (P.FieldInfo _ fieldType) (G.Field alias fieldName args directives selSet) = do
let fieldName' =
if "__" `T.isPrefixOf` G.unName fieldName
then fieldName
else remoteSchemaDecustomizeFieldName remoteSchemaCustomizer parentTypeName fieldName
alias' = alias <|> if fieldName' == fieldName then Nothing else Just fieldName
selSet' :: [(ResultCustomizer, G.Selection G.NoFragments var)] <- withPath (++ [Key "selectionSet"]) $
case fieldType ^. definitionLens of
typeDef@(Definition _ _ _ TIObject {}) -> traverse (customizeSelection typeDef) selSet
typeDef@(Definition _ _ _ TIInterface {}) -> traverse (customizeSelection typeDef) selSet
typeDef@(Definition _ _ _ TIUnion {}) -> traverse (customizeSelection typeDef) selSet
_ -> pure $ (mempty,) <$> selSet
let resultCustomizer =
modifyFieldByName (fromMaybe fieldName' alias') $
if fieldName' == $$(G.litName "__typename")
then customizeTypeNameString (_rscCustomizeTypeName remoteSchemaCustomizer)
else foldMap fst selSet'
pure $ (resultCustomizer, G.Field alias' fieldName' args directives $ snd <$> selSet')
customizeSelection :: Definition (TypeInfo 'Output) -> G.Selection G.NoFragments var -> n (ResultCustomizer, G.Selection G.NoFragments var)
customizeSelection parentTypeDef = \case
G.SelectionField fld@G.Field {..} ->
withPath (++ [Key $ G.unName _fName]) $ do
let parentTypeName = getName parentTypeDef
fieldInfo <- findField _fName parentTypeName $ dInfo parentTypeDef
second G.SelectionField <$> customizeField parentTypeName fieldInfo fld
G.SelectionInlineFragment G.InlineFragment {..} -> do
inlineFragmentType <-
case _ifTypeCondition of
Nothing -> pure parentTypeDef
Just typeName -> findSubtype typeName parentTypeDef
customizedSelectionSet <- traverse (customizeSelection inlineFragmentType) _ifSelectionSet
pure $
( foldMap fst customizedSelectionSet,
G.SelectionInlineFragment
G.InlineFragment
{ _ifTypeCondition = remoteSchemaDecustomizeTypeName remoteSchemaCustomizer <$> _ifTypeCondition,
_ifSelectionSet = snd <$> customizedSelectionSet,
..
}
)
findField :: G.Name -> G.Name -> TypeInfo 'Output -> n P.FieldInfo
findField fieldName parentTypeName parentTypeInfo =
if fieldName == $$(G.litName "__typename") -- TODO can we avoid checking for __typename in two different places?
then pure $ P.FieldInfo [] $ NonNullable $ TNamed $ mkDefinition (Typename stringScalar) Nothing TIScalar
else do
fields <- case parentTypeInfo of
TIObject objectInfo -> pure $ oiFields objectInfo
TIInterface interfaceInfo -> pure $ iiFields interfaceInfo
_ -> parseError $ "Type " <> parentTypeName <<> " has no fields"
fld <- find ((== fieldName) . dName) fields `onNothing` parseError ("field " <> fieldName <<> " not found in type: " <> squote parentTypeName)
pure $ dInfo fld
findSubtype :: G.Name -> Definition (TypeInfo 'Output) -> n (Definition (TypeInfo 'Output))
findSubtype typeName parentTypeDef =
if typeName == getName parentTypeDef
then pure parentTypeDef
else do
possibleTypes <-
case dInfo parentTypeDef of
TIInterface interfaceInfo -> pure $ iiPossibleTypes interfaceInfo
TIUnion unionInfo -> pure $ uiPossibleTypes unionInfo
_ -> parseError $ "Type " <> getName parentTypeDef <<> " has no possible subtypes"
fmap TIObject <$> find ((== typeName) . dName) possibleTypes
`onNothing` parseError ("Type " <> typeName <<> " is not a subtype of " <>> getName parentTypeDef)
type MemoState = (HashMap G.Name ObjectInfo, HashMap G.Name InterfaceInfo, HashMap G.Name UnionInfo, HashMap G.Name InputObjectInfo)
evalMemoState :: Lazy.State MemoState a -> a
evalMemoState = flip Lazy.evalState (mempty, mempty, mempty, mempty)
-- | memo function used to "tie the knot" and preserve sharing in the customized type definitions
-- It would be nice if we could just re-use MonadSchema and memoizeOn, but the types there are too
-- parser-specific.
memo :: (MonadState s m, MonadFix m, Hashable k, Eq k) => Lens' s (HashMap k v) -> (k -> v -> m v) -> k -> v -> m v
memo lens f k v = do
m <- use lens
Map.lookup k m `onNothing` mdo
-- Note: v' is added to the state _before_ it is produced
lens %= Map.insert k v'
v' <- f k v
pure v'
customizeFieldDefinition ::
forall m.
(MonadState MemoState m, MonadFix m) =>
RemoteSchemaCustomizer ->
G.Name ->
Definition P.FieldInfo ->
m (Definition P.FieldInfo)
customizeFieldDefinition remoteSchemaCustomizer = customizeFieldDefinition'
runMonadBuildRemoteSchema :: Monad m => SchemaT n (ReaderT (MkTypename, CustomizeRemoteFieldName) m) a -> m a
runMonadBuildRemoteSchema m = flip runReaderT (Typename, idFieldCustomizer) $ runSchemaT m
where
customizeFieldDefinition' :: G.Name -> Definition P.FieldInfo -> m (Definition P.FieldInfo)
customizeFieldDefinition' parentTypeName Definition {..} = do
dInfo' <- customizeFieldInfo dInfo
pure
Definition
{ dName = remoteSchemaCustomizeFieldName remoteSchemaCustomizer parentTypeName dName,
dInfo = dInfo',
..
}
idFieldCustomizer :: CustomizeRemoteFieldName
idFieldCustomizer = const id
customizeFieldInfo :: P.FieldInfo -> m P.FieldInfo
customizeFieldInfo (P.FieldInfo args typ) =
P.FieldInfo <$> traverse (traverse $ customizeInputFieldInfo) args <*> customizeType typ
customizeTypeDefinition :: (G.Name -> b -> m b) -> Definition b -> m (Definition b)
customizeTypeDefinition f Definition {..} = do
dInfo' <- f dName dInfo
pure
Definition
{ dName = remoteSchemaCustomizeTypeName remoteSchemaCustomizer dName,
dInfo = dInfo',
..
}
customizeType :: Type k -> m (Type k)
customizeType = \case
NonNullable nn -> NonNullable <$> customizeNonNullableType nn
Nullable nn -> Nullable <$> customizeNonNullableType nn
customizeNonNullableType :: NonNullableType k -> m (NonNullableType k)
customizeNonNullableType = \case
TList typ -> TList <$> customizeType typ
TNamed definition -> TNamed <$> customizeTypeDefinition customizeTypeInfo definition
customizeTypeInfo :: G.Name -> TypeInfo k -> m (TypeInfo k)
customizeTypeInfo typeName = \case
ti@TIScalar -> pure ti
ti@TIEnum {} -> pure ti
TIInputObject ioi -> TIInputObject <$> customizeInputObjectInfo typeName ioi
TIObject oi -> TIObject <$> customizeObjectInfo typeName oi
TIInterface ii -> TIInterface <$> customizeInterfaceInfo typeName ii
TIUnion ui -> TIUnion <$> customizeUnionInfo typeName ui
customizeInputFieldInfo :: InputFieldInfo -> m InputFieldInfo
customizeInputFieldInfo = \case
IFRequired nnType -> IFRequired <$> customizeNonNullableType nnType
IFOptional typ value -> IFOptional <$> customizeType typ <*> pure value
customizeObjectInfo :: G.Name -> ObjectInfo -> m ObjectInfo
customizeObjectInfo = memo _1 $ \typeName ObjectInfo {..} -> do
oiFields' <- traverse (customizeFieldDefinition' typeName) oiFields
oiImplements' <- traverse (customizeTypeDefinition customizeInterfaceInfo) oiImplements
pure
ObjectInfo
{ oiFields = oiFields',
oiImplements = oiImplements'
}
customizeInterfaceInfo :: G.Name -> InterfaceInfo -> m InterfaceInfo
customizeInterfaceInfo = memo _2 $ \typeName InterfaceInfo {..} -> do
iiFields' <- traverse (customizeFieldDefinition' typeName) iiFields
iiPossibleTypes' <- traverse (customizeTypeDefinition customizeObjectInfo) iiPossibleTypes
pure
InterfaceInfo
{ iiFields = iiFields',
iiPossibleTypes = iiPossibleTypes'
}
customizeUnionInfo :: G.Name -> UnionInfo -> m UnionInfo
customizeUnionInfo = memo _3 $ \_typeName (UnionInfo possibleTypes) ->
UnionInfo <$> traverse (customizeTypeDefinition customizeObjectInfo) possibleTypes
customizeInputObjectInfo :: G.Name -> InputObjectInfo -> m InputObjectInfo
customizeInputObjectInfo = memo _4 $ \_typeName (InputObjectInfo args) ->
InputObjectInfo <$> traverse (traverse $ customizeInputFieldInfo) args
withRemoteSchemaCustomization ::
forall m r a.
(MonadReader r m, Has MkTypename r, Has CustomizeRemoteFieldName r) =>
RemoteSchemaCustomizer ->
m a ->
m a
withRemoteSchemaCustomization remoteSchemaCustomizer =
withTypenameCustomization (Typename . remoteSchemaCustomizeTypeName remoteSchemaCustomizer)
. withRemoteFieldNameCustomization (remoteSchemaCustomizeFieldName remoteSchemaCustomizer)

16
server/src-lib/Hasura/GraphQL/Schema/Select.hs
View File

@ -1376,23 +1376,27 @@ remoteRelationshipField remoteFieldInfo = runMaybeT do
-- These are the arguments that are given by the user while executing a query
let remoteFieldUserArguments = map snd $ Map.toList remoteFieldParamMap
remoteFld <-
lift $
customizeFieldParser (,) remoteSchemaCustomizer parentTypeName . P.wrapFieldParser nestedFieldType
<$> remoteField remoteRelationshipIntrospection fieldName Nothing remoteFieldUserArguments fieldTypeDefinition
withRemoteSchemaCustomization remoteSchemaCustomizer $
lift $
P.wrapFieldParser nestedFieldType
<$> remoteField remoteRelationshipIntrospection parentTypeName fieldName Nothing remoteFieldUserArguments fieldTypeDefinition
pure $
pure $
remoteFld
`P.bindField` \(resultCustomizer, G.Field {G._fArguments = args, G._fSelectionSet = selSet, G._fName = fname}) -> do
`P.bindField` \fld@G.Field {G._fArguments = args, G._fSelectionSet = selSet, G._fName = fname} -> do
let remoteArgs =
Map.toList args <&> \(argName, argVal) -> IR.RemoteFieldArgument argName $ P.GraphQLValue $ argVal
let resultCustomizer' = applyFieldCalls fieldCalls $ applyAliasMapping (singletonAliasMapping fname (fcName $ NE.last fieldCalls)) resultCustomizer
let resultCustomizer =
applyFieldCalls fieldCalls $
applyAliasMapping (singletonAliasMapping fname (fcName $ NE.last fieldCalls)) $
makeResultCustomizer remoteSchemaCustomizer fld
pure $
IR.AFRemote $
IR.RemoteSelectRemoteSchema $
IR.RemoteSchemaSelect
{ _rselArgs = remoteArgs,
_rselResultCustomizer = resultCustomizer',
_rselResultCustomizer = resultCustomizer,
_rselSelection = selSet,
_rselHasuraFields = hasuraFields,
_rselFieldCall = fieldCalls,

27
server/src-lib/Hasura/GraphQL/Transport/HTTP.hs
View File

@ -468,7 +468,7 @@ runGQ env logger reqId userInfo ipAddress reqHeaders queryType reqUnparsed = do
runRemoteGQ httpManager fieldName rsi resultCustomizer gqlReq = do
(telemTimeIO_DT, remoteResponseHeaders, resp) <-
doQErr $ E.execRemoteGQ env httpManager userInfo reqHeaders (rsDef rsi) gqlReq
value <- extractFieldFromResponse fieldName rsi resultCustomizer resp
value <- extractFieldFromResponse fieldName resultCustomizer resp
let filteredHeaders = filter ((== "Set-Cookie") . fst) remoteResponseHeaders
pure $ AnnotatedResponsePart telemTimeIO_DT Telem.Remote (encJFromOrderedValue value) filteredHeaders
@ -564,14 +564,11 @@ extractFieldFromResponse ::
forall m.
Monad m =>
RootFieldAlias ->
RemoteSchemaInfo ->
ResultCustomizer ->
LBS.ByteString ->
ExceptT (Either GQExecError QErr) m JO.Value
extractFieldFromResponse fieldName rsi resultCustomizer resp = do
let namespace = fmap G.unName $ _rscNamespaceFieldName $ rsCustomizer rsi
fieldName' = G.unName $ _rfaAlias fieldName
-- TODO: use RootFieldAlias for remote fields
extractFieldFromResponse fieldName resultCustomizer resp = do
let fieldName' = G.unName $ _rfaAlias fieldName
dataVal <-
applyResultCustomizer resultCustomizer
<$> do
@ -579,19 +576,11 @@ extractFieldFromResponse fieldName rsi resultCustomizer resp = do
case graphQLResponse of
GraphQLResponseErrors errs -> doGQExecError errs
GraphQLResponseData d -> pure d
case namespace of
Just _ ->
-- If using a custom namespace field then the response from the remote server
-- will already be unwrapped so just return it.
return dataVal
_ -> do
-- No custom namespace so we need to look up the field name in the data
-- object.
dataObj <- onLeft (JO.asObject dataVal) do400
fieldVal <-
onNothing (JO.lookup fieldName' dataObj) $
do400 $ "expecting key " <> fieldName'
return fieldVal
dataObj <- onLeft (JO.asObject dataVal) do400
fieldVal <-
onNothing (JO.lookup fieldName' dataObj) $
do400 $ "expecting key " <> fieldName'
return fieldVal
where
do400 = withExceptT Right . throw400 RemoteSchemaError
doGQExecError = withExceptT Left . throwError . GQExecError

2
server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs
View File

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

47
server/src-lib/Hasura/RQL/Types/RemoteSchema.hs
View File

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

16
server/src-lib/Hasura/RQL/Types/SchemaCache.hs
View File

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

7
server/src-lib/Hasura/RQL/Types/SourceCustomization.hs
View File

@ -11,6 +11,8 @@ module Hasura.RQL.Types.SourceCustomization
SourceCustomization (..),
withSourceCustomization,
MkRootFieldName,
CustomizeRemoteFieldName,
withRemoteFieldNameCustomization,
)
where
@ -122,3 +124,8 @@ withSourceCustomization ::
withSourceCustomization SourceCustomization {..} =
withTypenameCustomization (mkCustomizedTypename _scTypeNames)
. withRootFieldNameCustomization (mkCustomizedFieldName _scRootFields)
type CustomizeRemoteFieldName = G.Name -> G.Name -> G.Name
withRemoteFieldNameCustomization :: forall m r a. (MonadReader r m, Has CustomizeRemoteFieldName r) => CustomizeRemoteFieldName -> m a -> m a
withRemoteFieldNameCustomization = local . set hasLens

115
server/src-test/Hasura/GraphQL/RemoteServerSpec.hs
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)

23
server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs
View File

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

2
server/src-test/Main.hs
View File

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

54
server/tests-py/queries/remote_schemas/validation/customize_all_the_things.yaml
View File

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

2
server/tests-py/queries/remote_schemas/validation/field_prefix_validation.yaml
View File

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

6
server/tests-py/queries/remote_schemas/validation/namespace_validation.yaml
View File

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

49
server/tests-py/queries/remote_schemas/validation/type_prefix_validation.yaml
View File

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

2
server/tests-py/test_schema_stitching.py
View File

@ -836,7 +836,7 @@ class TestValidateRemoteSchemaNamespaceQuery:
def transact(self, request, hge_ctx):
config = request.config
if not config.getoption('--skip-schema-setup'):
customization = { "root_fields_namespace": "foo", "type_names": {"prefix": "Bar" }}
customization = { "root_fields_namespace": "foo" }
q = mk_add_remote_q('character-foo', 'http://localhost:5000/character-iface-graphql', customization=customization)
st_code, resp = hge_ctx.v1q(q)
assert st_code == 200, resp