diff --git a/CHANGELOG.md b/CHANGELOG.md index 54a102f7f9e..f1f893f436b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ ### Bug fixes and improvements +- server: fix a bug where remote schema permissions would fail when used in conjunction with query variables (fix #6656) - server: add `rename_source` metadata API (fix #6681) - server: fix subscriptions with session argument in user-defined function (fix #6657) - server: MSSQL: Support ORDER BY for text/ntext types. diff --git a/scripts/dev.sh b/scripts/dev.sh index 430b3c561b6..fc452ba3cfe 100755 --- a/scripts/dev.sh +++ b/scripts/dev.sh @@ -447,8 +447,6 @@ elif [ "$MODE" = "test" ]; then # Using --metadata-database-url flag to test multiple backends # HASURA_GRAPHQL_PG_SOURCE_URL_* For a couple multi-source pytests: - HASURA_GRAPHQL_PG_SOURCE_URL_1="$PG_DB_URL" \ - HASURA_GRAPHQL_PG_SOURCE_URL_2="$PG_DB_URL" \ cabal new-run --project-file=cabal.project.dev-sh -- exe:graphql-engine \ --metadata-database-url="$PG_DB_URL" serve \ --stringify-numeric-types \ diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index a17017b730c..efe1c57944e 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -634,12 +634,14 @@ test-suite graphql-engine-tests , monad-control , mtl , natural-transformation >=0.4 && <0.5 + , network-uri , optparse-applicative , pg-client , process , QuickCheck , safe , split + , template-haskell , text , time , transformers-base @@ -651,11 +653,13 @@ test-suite graphql-engine-tests Data.Parser.CacheControlSpec Data.Parser.JSONPathSpec Data.Parser.URLTemplate + Data.Text.RawString Data.TimeSpec Hasura.CacheBoundedSpec Hasura.EventingSpec Hasura.GraphQL.Parser.DirectivesTest Hasura.GraphQL.Parser.TestUtils + Hasura.GraphQL.Schema.RemoteTest Hasura.IncrementalSpec Hasura.RQL.MetadataSpec Hasura.RQL.Types.EndpointSpec diff --git a/server/src-lib/Hasura/Backends/Postgres/Execute/RemoteJoin.hs b/server/src-lib/Hasura/Backends/Postgres/Execute/RemoteJoin.hs index e50044014d9..052ec9d626d 100644 --- a/server/src-lib/Hasura/Backends/Postgres/Execute/RemoteJoin.hs +++ b/server/src-lib/Hasura/Backends/Postgres/Execute/RemoteJoin.hs @@ -324,7 +324,7 @@ fetchRemoteJoinFields -> m AO.Object fetchRemoteJoinFields env manager reqHdrs userInfo remoteJoins = do results <- forM (Map.toList remoteSchemaBatch) $ \(rsi, batch) -> do - resolvedRemoteFields <- traverse (traverse (resolveRemoteVariable userInfo)) $ _rjfField <$> batch + resolvedRemoteFields <- runVariableCache $ traverse (traverse (resolveRemoteVariable userInfo)) $ _rjfField <$> batch let gqlReq = fieldsToRequest resolvedRemoteFields -- NOTE: discard remote headers (for now): (_, _, respBody) <- execRemoteGQ env manager userInfo reqHdrs rsi gqlReq @@ -346,21 +346,8 @@ fetchRemoteJoinFields env manager reqHdrs userInfo remoteJoins = do remoteSchemaBatch = Map.groupOnNE _rjfRemoteSchema remoteJoins fieldsToRequest :: NonEmpty (G.Field G.NoFragments Variable) -> GQLReqOutgoing - fieldsToRequest gFields@(headField :| _) = - let variableInfos = - -- only the `headField` is used for collecting the variables here because - -- the variable information of all the fields will be the same. - -- For example: - -- { - -- author { - -- name - -- remote_relationship (extra_arg: $extra_arg) - -- } - -- } - -- - -- If there are 10 authors, then there are 10 fields that will be requested - -- each containing exactly the same variable info. - collectVariablesFromField headField + fieldsToRequest gFields = + let variableInfos = foldMap collectVariablesFromField gFields in GQLReq { _grOperationName = Nothing , _grVariables = @@ -375,7 +362,7 @@ fetchRemoteJoinFields env manager reqHdrs userInfo remoteJoins = do } } --- | Replace 'RemoteJoinField' in composite JSON with it's json value from remote server response. +-- | Replace 'RemoteJoinField' in composite JSON with its json value from remote server response. replaceRemoteFields :: MonadError QErr m => CompositeValue (Maybe RemoteJoinField) diff --git a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs index a4186acb9a5..18c4ac97b5a 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Mutation.hs @@ -96,7 +96,7 @@ convertMutationSelectionSet env logger gqlContext SQLGenCtx{stringifyNum} userIn \(SourceConfigWith sourceConfig (MDBR db)) -> mkDBMutationPlan env manager reqHeaders userInfo stringifyNum sourceName sourceConfig db RFRemote remoteField -> do - RemoteFieldG remoteSchemaInfo resolvedRemoteField <- resolveRemoteField userInfo remoteField + RemoteFieldG remoteSchemaInfo resolvedRemoteField <- runVariableCache $ resolveRemoteField userInfo remoteField pure $ buildExecStepRemote remoteSchemaInfo G.OperationTypeMutation $ [G.SelectionField resolvedRemoteField] RFAction action -> do (actionName, _fch) <- pure $ case action of diff --git a/server/src-lib/Hasura/GraphQL/Execute/Query.hs b/server/src-lib/Hasura/GraphQL/Execute/Query.hs index c0b29517767..b4c4bbb2558 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Query.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Query.hs @@ -91,7 +91,7 @@ convertQuerySelSet env logger gqlContext userInfo manager reqHeaders directives \(SourceConfigWith sourceConfig (QDBR db)) -> mkDBQueryPlan env manager reqHeaders userInfo sourceName sourceConfig db RFRemote rf -> do - RemoteFieldG remoteSchemaInfo remoteField <- for rf $ resolveRemoteVariable userInfo + RemoteFieldG remoteSchemaInfo remoteField <- runVariableCache $ for rf $ resolveRemoteVariable userInfo pure $ buildExecStepRemote remoteSchemaInfo G.OperationTypeQuery [G.SelectionField remoteField] RFAction a -> do (action, actionName, fch) <- pure $ case a of diff --git a/server/src-lib/Hasura/GraphQL/Execute/Remote.hs b/server/src-lib/Hasura/GraphQL/Execute/Remote.hs index 1879a3e4857..dc24c7edbf9 100644 --- a/server/src-lib/Hasura/GraphQL/Execute/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Execute/Remote.hs @@ -4,6 +4,7 @@ module Hasura.GraphQL.Execute.Remote , collectVariables , resolveRemoteVariable , resolveRemoteField + , runVariableCache ) where import Hasura.Prelude @@ -85,41 +86,60 @@ buildExecStepRemote remoteSchemaInfo tp selSet = -- | resolveRemoteVariable resolves a `RemoteSchemaVariable` into a GraphQL `Variable`. A --- `RemoteSchemaVariable` can either be a query variable i.e. variable provided in the --- query or it can be a `SessionPresetVariable` in which case we look up the value of --- the session variable and coerce it into the appropriate type and then construct the --- GraphQL `Variable`. *NOTE*: The session variable preset is a hard preset i.e. if the --- session variable doesn't exist, an error will be thrown. +-- `RemoteSchemaVariable` can either be a query variable i.e. variable provided in the +-- query or it can be a `SessionPresetVariable` in which case we look up the value of the +-- session variable and coerce it into the appropriate type and then construct the GraphQL +-- `Variable`. *NOTE*: The session variable preset is a hard preset i.e. if the session +-- variable doesn't exist, an error will be thrown. -- --- The name of the GraphQL variable generated will be a GraphQL-ized (replacing '-' by '_') --- version of the session --- variable, since session variables are not valid GraphQL names. +-- The name of the GraphQL variable generated will be a GraphQL-ized (replacing '-' by +-- '_') version of the session variable, since session variables are not valid GraphQL +-- names. -- --- For example, considering the following schema for a role: +-- Additionally, we need to handle partially traversed JSON values; likewise, we create a +-- new variable out of thin air. -- -- +-- For example, considering the following schema for a role: +-- +-- input UserName { +-- firstName : String! @preset(value:"Foo") +-- lastName : String! +-- } +-- -- type Query { --- user(user_id: Int! @preset(value:"x-hasura-user-id")): User +-- user( +-- user_id: Int! @preset(value:"x-hasura-user-id") +-- user_name: UserName! +-- ): User -- } -- --- and the incoming query to the graphql-engine is: +-- and the incoming query to the graphql-engine is: -- --- query { --- user { id name } +-- query($foo: UserName!) { +-- user(user_name: $foo) { id name } -- } -- --- After resolving the session argument presets, the query that will --- be sent to the remote server will be: +-- with variables: -- --- query ($x_hasura_user_id: Int!) { --- user (user_id: $x_hasura_user_id) { id name } +-- { "foo": {"lastName": "Bar"} } +-- +-- +-- After resolving the session argument presets, the query that will be sent to the remote +-- server will be: +-- +-- query ($x_hasura_user_id: Int!, $hasura_json_var_1: String!) { +-- user (user_id: $x_hasura_user_id, user_name: {firstName: "Foo", lastName: $hasura_json_var_1}) { +-- id +-- name -- } +-- } -- resolveRemoteVariable :: (MonadError QErr m) => UserInfo -> RemoteSchemaVariable - -> m Variable + -> StateT (HashMap J.Value Int) m Variable resolveRemoteVariable userInfo = \case SessionPresetVariable sessionVar typeName presetInfo -> do sessionVarVal <- onNothing (getSessionVariableValue sessionVar $ _uiSession userInfo) @@ -163,11 +183,25 @@ resolveRemoteVariable userInfo = \case -- nullability is false, because we treat presets as hard presets let variableGType = G.TypeNamed (G.Nullability False) typeName pure $ Variable (VIRequired varName) variableGType (GraphQLValue coercedValue) + RemoteJSONValue gtype jsonValue -> do + cache <- get + index <- Map.lookup jsonValue cache `onNothing` do + let i = Map.size cache + 1 + put $ Map.insert jsonValue i cache + pure i + let varName = G.unsafeMkName $ "hasura_json_var_" <> tshow index + pure $ Variable (VIRequired varName) gtype $ JSONValue jsonValue QueryVariable variable -> pure variable resolveRemoteField :: (MonadError QErr m) => UserInfo -> RemoteField - -> m (RemoteFieldG Variable) + -> StateT (HashMap J.Value Int) m (RemoteFieldG Variable) resolveRemoteField userInfo = traverse (resolveRemoteVariable userInfo) + +runVariableCache + :: Monad m + => StateT (HashMap J.Value Int) m a + -> m a +runVariableCache = flip evalStateT mempty diff --git a/server/src-lib/Hasura/GraphQL/Parser.hs b/server/src-lib/Hasura/GraphQL/Parser.hs index 6244ce3e7cb..84ee9147f9c 100644 --- a/server/src-lib/Hasura/GraphQL/Parser.hs +++ b/server/src-lib/Hasura/GraphQL/Parser.hs @@ -16,7 +16,6 @@ module Hasura.GraphQL.Parser , json , jsonb , identifier - , unsafeRawScalar , enum , nullable diff --git a/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs b/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs index 4043dee5e80..efc78eea0be 100644 --- a/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs +++ b/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs @@ -208,18 +208,6 @@ json, jsonb :: MonadParse m => Parser 'Both m A.Value json = namedJSON $$(litName "json") Nothing jsonb = namedJSON $$(litName "jsonb") Nothing --- | Explicitly define any desired scalar type. This is unsafe because it does --- not mark queries as unreusable when they should be. -unsafeRawScalar - :: MonadParse n - => Name - -> Maybe Description - -> Parser 'Both n (InputValue Variable) -unsafeRawScalar name description = Parser - { pType = NonNullable $ TNamed $ mkDefinition name description TIScalar - , pParser = pure - } - enum :: MonadParse m => Name diff --git a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs index b0367deb33c..4aa18bc62ba 100644 --- a/server/src-lib/Hasura/GraphQL/Schema/Remote.hs +++ b/server/src-lib/Hasura/GraphQL/Schema/Remote.hs @@ -1,14 +1,8 @@ +{-# LANGUAGE ViewPatterns #-} + module Hasura.GraphQL.Schema.Remote ( buildRemoteParser - , inputValueDefinitionParser - , lookupObject - , lookupType - , lookupScalar , remoteField - , lookupInterface - , lookupUnion - , lookupEnum - , lookupInputObject ) where import Hasura.Prelude @@ -17,10 +11,11 @@ import qualified Data.HashMap.Strict as Map import qualified Data.HashMap.Strict.InsOrd as OMap import qualified Data.HashMap.Strict.InsOrd.Extended as OMap import qualified Data.List.NonEmpty as NE +import qualified Language.GraphQL.Draft.Syntax as G +import Data.Monoid (Any (..)) import Data.Text.Extended import Data.Type.Equality -import Language.GraphQL.Draft.Syntax as G import qualified Hasura.GraphQL.Parser.Internal.Parser as P @@ -31,11 +26,8 @@ import Hasura.RQL.Types.RemoteSchema import Hasura.RQL.Types.SchemaCache -type RemoteSchemaObjectDefinition = G.ObjectTypeDefinition RemoteSchemaInputValueDefinition -type RemoteSchemaInputObjectDefinition = G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition -type RemoteSchemaInterfaceDefinition = G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -type RemoteSchemaFieldDefinition = G.FieldDefinition RemoteSchemaInputValueDefinition -type RemoteSchemaTypeDefinition = G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition +-------------------------------------------------------------------------------- +-- Top level function buildRemoteParser :: forall m n @@ -44,31 +36,32 @@ buildRemoteParser -> RemoteSchemaInfo -> m ( [P.FieldParser n RemoteField] , Maybe [P.FieldParser n RemoteField] - , Maybe [P.FieldParser n RemoteField]) + , Maybe [P.FieldParser n RemoteField] + ) buildRemoteParser (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 :: RemoteSchemaFieldDefinition -> m (P.FieldParser n RemoteField) + makeFieldParser :: G.FieldDefinition RemoteSchemaInputValueDefinition -> m (P.FieldParser n RemoteField) makeFieldParser fieldDef = do - fldParser <- remoteField' sdoc fieldDef + fldParser <- remoteFieldFromDefinition sdoc fieldDef pure $ (RemoteFieldG info) <$> fldParser makeParsers :: G.Name -> m [P.FieldParser n RemoteField] makeParsers rootName = case lookupType sdoc rootName of Just (G.TypeDefinitionObject o) -> - traverse makeFieldParser $ _otdFieldsDefinition o + traverse makeFieldParser $ G._otdFieldsDefinition o _ -> throw400 Unexpected $ rootName <<> " has to be an object type" - -- | The spec says that the `schema` definition can be omitted, if the root names - -- are the defaults (Query, Mutation and Subscription). This function is used - -- to constructor a `FieldParser` for the mutation and subscription roots. - -- If the user has given a custom Mutation/Subscription root name, then it will - -- look for that and if it's not found in the schema document, then an error is thrown. - -- If no root name has been provided, we lookup the schema document for an object with - -- the default name and if that's not found, we omit the said Root from the schema. + -- | The spec says that the `schema` definition can be omitted, if the root names are the + -- defaults (Query, Mutation and Subscription). This function is used to construct a + -- `FieldParser` for the mutation and subscription roots. If the user has given a custom + -- Mutation/Subscription root name, then it will look for that and if it's not found in the + -- schema document, then an error is thrown. If no root name has been provided, we lookup the + -- schema document for an object with the default name and if that's not found, we omit the said + -- Root from the schema. makeNonQueryRootFieldParser :: Maybe G.Name -> G.Name -> m (Maybe [P.FieldParser n RemoteField]) makeNonQueryRootFieldParser userProvidedRootName defaultRootName = case userProvidedRootName of @@ -77,24 +70,425 @@ buildRemoteParser (IntrospectionResult sdoc queryRoot mutationRoot subscriptionR let isDefaultRootObjectExists = isJust $ lookupObject sdoc defaultRootName in bool (pure Nothing) (traverse makeParsers $ Just defaultRootName) $ isDefaultRootObjectExists -remoteField' + + +-------------------------------------------------------------------------------- +-- Remote schema input parsers + +{- Note [Variable expansion in remote schema input parsers] + +### Input parsers as lightweight type checkers + +The purpose of input parsers for remote schemas is not to translate the provided input values into +an internal representation: those values will be transmitted more or less unmodified to the remote +service; their main purpose is simply to check the shape of the input against the remote schema. + +Consider, for instance, the following remote schema: + + input Foo { + bar: Int! + } + + type Query { + run(foo: Foo!): Int! + } + + +Our parsers will need to decide which invocations of `run` are valid: + + query { + run(null) # invalid: foo is non-nullable + run(foo: {baz: 0}) # invalid: Foo doesn't have a "baz" field + run(foo: {bar: "0"}) # actually valid! + } + + +That last example is surprising: why would we accept a string literal for an Int? It simply is +because we delegate the task of translating the literal into a scalar to the remote server. After +all, *we* advertise some values as Int in the schema, despite accepting string literals. + + +### Inserting remote permissions presets + +Where things get more complicated is with remote permissions. We allow users to specify "presets": +values that will always be provided to the remote schema, and that the user cannot customize in +their query. For instance, given the following schema with permissions: + + input Range { + low: Int! @preset(value: 0) + high: Int! + } + + type Query { + getValues(range: Range!): [Int] + } + + +a user cannot specify "low" in OUR schema, as we will insert its value when parsing the incoming +query. This is the second purpose of those input parsers: they insert remote schema presets where +required. In this case: + + # we receive + query { + getValues(range: {high: 42}) + } + + # we emit + query { + getValues(range: {low: 0, high: 42}) + } + + +### Variable expansion + +But where this gets even more complicated is with variables. As much as possible, we simply forward +variables without interpeting them (not all JSON values are representable in GraphQL). We do so +whenever possible; for instance, using the previously established remote schema: + + # we receive + query: + query($h: Int!) { + getValues(range: {high: $h}) + } + variables: + { "h": 42 } + + # we emit + query: + query($h: Int!) { + getValues(range: {low: 0, high: $h}) + } + variables: + { "h": 42 } + + +The tricky case is when a preset field is *within a variable*. We then have no choice: we have to +expand the variable, and rewrap the value as best as we can, to minimize the amount of JSON +evaluation. For instance: + + # we receive + query: + query($r: Range!) { + getValues(range: $r) + } + variables: + { "r": {"high": 42} } + + # we emit + query: + query($hasura_json_var_1: Int!) { + getValues(range: {low: 0, high: $hasura_json_var_1}) + } + variables: + { "hasura_json_var_1": 42 } + + +Our parsers, like all others in our model, expand the variables as they traverse the tree, and add +the preset values where required. But the downside of this is that we will create one such JSON +variable per scalar within a JSON variable! + + +### Short-circuiting optimization + +To avoid this, we track in the parsers whether an alteration has occured: if we had to insert a +preset value. As long as we don't, we can discard the output of the parser, as it will contain the +exact same value as the input (if perhaps represented differently); by discarding the output and +just forwarding the input, we avoid expanding variables if no preset needs be inserted. +-} + + +-- | Helper, used to track whether an input value was altered during its parsing. At time of +-- writing, the only possible source of alteration is preset values. They might force evaluation of +-- variables, and encapsulation of sub-JSON expressions as new variables. Each parser indicates +-- whether such alteration took place within its part of the tree. +-- See Note [Variable expansion in remote schema input parsers] for more information. + +newtype Altered = Altered { getAltered :: Bool } + deriving (Show) + deriving (Semigroup, Monoid) via Any + + +-- | 'inputValueDefinitionParser' accepts a 'G.InputValueDefinition' and will return an +-- 'InputFieldsParser' for it. If a non 'Input' GraphQL type is found in the 'type' of the +-- 'InputValueDefinition' then an error will be thrown. +-- +-- Each parser also returns a boolean that indicates whether the parsed value was altered by +-- presets. Presets might force the evaluation of variables that would otherwise be transmitted +-- unmodified. +inputValueDefinitionParser :: forall n m - . (MonadSchema n m, MonadError QErr m) + . (MonadSchema n m, MonadError QErr m) => RemoteSchemaIntrospection - -> RemoteSchemaFieldDefinition - -> m (FieldParser n (Field NoFragments RemoteSchemaVariable)) -remoteField' schemaDoc (G.FieldDefinition description name argsDefinition gType _) = convertType gType + -> G.InputValueDefinition + -> m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable))) +inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType maybeDefaultVal _directives) = + buildField fieldConstructor fieldType where - -- TODO add directives, deprecation - convertType = \case - G.TypeNamed (Nullability True) fieldTypeName -> - P.nullableField <$> remoteFieldFromName schemaDoc name description fieldTypeName argsDefinition - G.TypeNamed (Nullability False) fieldTypeName -> do - P.nonNullableField <$> remoteFieldFromName schemaDoc name description fieldTypeName argsDefinition - G.TypeList (Nullability True) gType' -> - P.nullableField . P.multipleField <$> convertType gType' - G.TypeList (Nullability False) gType' -> - P.nonNullableField . P.multipleField <$> convertType gType' + doNullability + :: forall a k . 'Input <: k + => G.Nullability + -> Parser k n (Maybe a) + -> Parser k n (Maybe a) + doNullability (G.Nullability True) = fmap join . P.nullable + doNullability (G.Nullability False) = id + + fieldConstructor + :: forall k. 'Input <: k + => Parser k n (Maybe (Altered, G.Value RemoteSchemaVariable)) + -> InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable)) + fieldConstructor (shortCircuitIfUnaltered -> parser) = + case maybeDefaultVal of + Nothing -> + if G.isNullable fieldType + then join <$> fieldOptional name desc parser + else field name desc parser + Just defaultVal -> fieldWithDefault name desc defaultVal parser + + buildField + :: ( forall k. 'Input <: k + => Parser k n (Maybe (Altered, G.Value RemoteSchemaVariable)) + -> InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable)) + ) + -> G.GType + -> m (InputFieldsParser n (Maybe (Altered, G.Value RemoteSchemaVariable))) + buildField mkInputFieldsParser = \case + G.TypeNamed nullability typeName -> + case lookupType schemaDoc typeName of + Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName + Just typeDef -> + case typeDef of + G.TypeDefinitionScalar scalarTypeDefn -> + pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldScalarParser scalarTypeDefn + G.TypeDefinitionEnum defn -> + pure $ mkInputFieldsParser $ doNullability nullability $ Just <$> remoteFieldEnumParser defn + G.TypeDefinitionObject _ -> + throw400 RemoteSchemaError "expected input type, but got output type" + G.TypeDefinitionInputObject defn -> do + potentialObject <- remoteInputObjectParser schemaDoc defn + pure $ case potentialObject of + Left dummyInputFieldsParser -> do + -- We couln't create a parser, meaning we can't create a field for this + -- object. Instead we must return a "pure" InputFieldsParser that always yields + -- the needed result without containing a field definition. + -- + -- !!! WARNING #1 !!! + -- Since we have no input field in the schema for this field, we can't make the + -- distinction between it being actually present at parsing time or not. We + -- therefore choose to behave as if it was always present, and we always + -- include the preset values in the result. + -- + -- !!! WARNING #2 !!! + -- We are re-using an 'InputFieldsParser' that was created earlier! Won't that + -- create new fields in the current context? No, it won't, but only because in + -- this case we know that it was created from the preset fields in + -- 'argumentsParser', and therefore contains no field definition. + Just <$> dummyInputFieldsParser + Right actualParser -> do + -- We're in the normal case: we do have a parser for the input object, which is + -- therefore valid (non-empty). + mkInputFieldsParser $ doNullability nullability $ Just <$> actualParser + G.TypeDefinitionUnion _ -> + throw400 RemoteSchemaError "expected input type, but got output type" + G.TypeDefinitionInterface _ -> + throw400 RemoteSchemaError "expected input type, but got output type" + G.TypeList nullability subType -> do + buildField (mkInputFieldsParser . doNullability nullability . fmap (Just . fmap G.VList . aggregateListAndAlteration) . P.list) subType + +-- | remoteFieldScalarParser attempts to parse a scalar value for a given remote field +-- +-- We do not attempt to verify that the literal is correct! Some GraphQL implementations, including +-- ours, are a bit flexible with the intepretations of literals; for instance, there are several +-- places in our schema where we declare something to be an `Int`, but actually accept `String` +-- literals. We do however peform variable type-checking. +-- +-- If we encounter a JSON value, it means that we were introspecting a query variable. To call the +-- remote schema, we need a graphql value; we therefore need to treat that JSON expression as if it +-- 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. +remoteFieldScalarParser + :: MonadParse n + => G.ScalarTypeDefinition + -> P.Parser 'Both n (Altered, G.Value RemoteSchemaVariable) +remoteFieldScalarParser (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 + P.typeCheck False gType var + pure $ QueryVariable var + } + where + schemaType = NonNullable $ TNamed $ mkDefinition name description TIScalar + gType = toGraphQLType schemaType + +remoteFieldEnumParser + :: MonadParse n + => G.EnumTypeDefinition + -> Parser 'Both n (Altered, G.Value RemoteSchemaVariable) +remoteFieldEnumParser (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 name desc $ NE.fromList enumValDefns + +-- | remoteInputObjectParser returns an input parser for a given 'G.InputObjectTypeDefinition' +-- +-- Now, this is tricky! We are faced with two contradicting constraints here. On one hand, the +-- GraphQL spec forbids us from creating empty input objects. This means that if all the arguments +-- have presets, we CANNOT use the parser this function creates, and the caller cannot create a +-- field for this object (and instead should use @pure@ to include the preset values in the result +-- of parsing the fields). +-- +-- One way we could fix this would be to change the type of this function to return a `Maybe +-- Parser`, inspect the result of 'argumentsParser', and return @Nothing@ when we realize that there +-- aren't any actual field in it (or at least return a value that propagates the preset values). But +-- this would contradict our second constraint: this function needs to be memoized! +-- +-- At time of writing, we can't memoize functions that return arbitrary functors of Parsers; so no +-- memoizing Maybe Parser or Either Presets Parser. Which means that we would need to first call +-- `argumentsParser`, then memoize the "Just" branch that builds the actual Parser. The problem is +-- that the recursive call ro remoteSchemaInputObject is within 'argumentsParser', meaning the call +-- to it MUST be in the memoized branch! +-- +-- This is why, in the end, we do the following: we first test whether there is any non-preset +-- 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) + => RemoteSchemaIntrospection + -> G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition + -> m ( Either + (InputFieldsParser n (Altered, G.Value RemoteSchemaVariable)) + (Parser 'Input n (Altered, G.Value RemoteSchemaVariable)) + ) +remoteInputObjectParser schemaDoc defn@(G.InputObjectTypeDefinition desc name _ valueDefns) = + if all (isJust . _rsitdPresetArgument) valueDefns + then + -- All the fields are preset: we can't create a parser, that would result in an invalid type in + -- the schema (an input object with no field). We therefore forward the InputFieldsParser + -- unmodified. No need to memoize this branch: since all arguments are preset, 'argumentsParser' + -- won't be recursively calling this function. + Left . fmap (fmap G.VObject) <$> argumentsParser valueDefns schemaDoc + else + -- At least one field is not a preset, meaning we have the guarantee that there will be at least + -- one field in the input object. We have to memoize this branch as we might recursively call + -- the same parser. + Right <$> P.memoizeOn 'remoteInputObjectParser defn do + argsParser <- argumentsParser valueDefns schemaDoc + pure $ fmap G.VObject <$> P.object name desc argsParser + +-- | Variable expansion optimization. +-- Since each parser returns a value that indicates whether it was altered, we can detect when no +-- alteration took place, and replace the parsed and expanded value by its original. +-- See Note [Variable expansion in remote schema input parsers] for more information. +shortCircuitIfUnaltered + :: forall k n + . ('Input <: k, MonadParse n) + => Parser k n (Maybe (Altered, G.Value RemoteSchemaVariable)) + -> Parser k n (Maybe (Altered, G.Value RemoteSchemaVariable)) +shortCircuitIfUnaltered parser = P.Parser + { pType = P.pType parser + , pParser = \value -> do + result <- P.pParser parser value + pure $ case result of + -- The parser did yield a value, and it was unmodified by presets + -- we can short-citcuit by transforming the input value, therefore + -- "unpeeling" variables and avoiding extraneous JSON variables. + Just (Altered False, _) -> Just $ (Altered False,) $ case castWith (P.inputParserInput @k) value of + -- The input was a GraphQL value: just forward it. + GraphQLValue v -> QueryVariable <$> v + -- The input value was already a JSON value: we still have to create + -- a new JSON variable, but it will still be more efficient than having + -- all the leaves of said value each be their own distinct value. + JSONValue v -> G.VVariable $ RemoteJSONValue (toGraphQLType $ P.pType parser) v + -- Otherwise either the parser did not yield any value, or a value + -- that has been altered by presets and permissions; we forward it + -- unoptimized. + _ -> result + } + +-- | argumentsParser is used for creating an argument parser for remote fields, +-- This function is called for field arguments and input object fields. This +-- function works in the following way: +-- +-- * if a field is not preset, we recursively call `inputValueDefinitionParser` on it +-- * otherwise, we use the preset +-- +-- For example, consider the following input objects: +-- +-- input MessageWhereInpObj { +-- id: IntCompareObj +-- name: StringCompareObj +-- } +-- +-- input IntCompareObj { +-- eq : Int @preset(value: 2) +-- gt : Int +-- lt : Int +-- } +-- +-- parsing a MessageWhereInpObj will result in the following call tree: +-- +-- -> argumentsParser MessageWhereInpObj +-- -> id => inputValueDefinitionParser IntCompareObj +-- -> remoteInputObjectParser IntCompareObj +-- -> argumentsParser IntCompareObj +-- -> eq => using preset, no recursion +-- -> gt => inputValueDefinitionParser Int +-- -> remoteFieldScalarParser Int +-- -> lt => inputValueDefinitionParser Int +-- -> remoteFieldScalarParser Int +-- -> name => inputValueDefinitionParser StringCompareObj +-- -> ... +-- +-- Furthermore, like all other input parsers in this file, 'argumentsParser' indicates whether this +-- 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) + => G.ArgumentsDefinition RemoteSchemaInputValueDefinition + -> RemoteSchemaIntrospection + -> m (InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable))) +argumentsParser args schemaDoc = do + -- ! DANGER ! + -- + -- This function is mutually recursive with 'inputValueDefinitionParser': if one of the non-preset + -- arguments is an input object, then recursively we'll end up using 'argumentsParser' to parse + -- its arguments. Note however that if all arguments have a preset value, then this function will + -- not call 'inputValueDefinitionParser', and will simply return without any recursion. + -- + -- This is labelled as dangerous because another function in this module, + -- 'remoteInputObjectParser', EXPLICITLY RELIES ON THIS BEHAVIOUR. Due to limitations of the + -- GraphQL spec and of parser memoization functions, it cannot memoize the case where all + -- arguments are preset, and therefore relies on the assumption that 'argumentsParser' is not + -- recursive in this edge case. + -- + -- This assumptions is unlikely to ever be broken; but if you ever modify this function, please + -- nonetheless make sure that it is maintained. + argsParsers <- for args \arg -> do + let argDef = _rsitdDefinition arg + argName = G._ivdName argDef + argParser <- case _rsitdPresetArgument arg of + Nothing -> inputValueDefinitionParser schemaDoc argDef + -- This is the source of all possible alterations: one of the fields is preset; everything + -- "above" this field in the tree will be considered "altered", and the optimizations will + -- not apply. + Just preset -> pure $ pure $ pure (Altered True, preset) + pure $ fmap (fmap (argName,)) <$> argParser + pure $ sequenceA argsParsers <&> fmap Map.fromList . aggregateListAndAlteration + +aggregateListAndAlteration :: [Maybe (Altered, a)] -> (Altered, [a]) +aggregateListAndAlteration = first mconcat . unzip . catMaybes + + + +-------------------------------------------------------------------------------- +-- Remote schema output parsers -- | 'remoteSchemaObject' returns a output parser for a given 'ObjectTypeDefinition'. remoteSchemaObject @@ -102,10 +496,10 @@ remoteSchemaObject . (MonadSchema n m, MonadError QErr m) => RemoteSchemaIntrospection -> G.ObjectTypeDefinition RemoteSchemaInputValueDefinition - -> m (Parser 'Output n [Field NoFragments RemoteSchemaVariable]) + -> 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 (remoteField' schemaDoc) subFields + subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) subFields interfaceDefs <- traverse getInterface interfaces implements <- traverse (remoteSchemaInterface schemaDoc) interfaceDefs -- TODO: also check sub-interfaces, when these are supported in a future graphql spec @@ -116,15 +510,15 @@ remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name inter P.SelectTypename _ -> G.Field (Just alias) $$(G.litName "__typename") mempty mempty mempty) where - getInterface :: G.Name -> m RemoteSchemaInterfaceDefinition + getInterface :: G.Name -> m (G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition) getInterface interfaceName = onNothing (lookupInterface schemaDoc interfaceName) $ throw400 RemoteSchemaError $ "Could not find interface " <> squote interfaceName <> " implemented by Object type " <> squote name - validateImplementsFields :: RemoteSchemaInterfaceDefinition -> m () + validateImplementsFields :: G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition -> m () validateImplementsFields interface = - traverse_ (validateImplementsField (_itdName interface)) (G._itdFieldsDefinition interface) - validateImplementsField :: G.Name -> RemoteSchemaFieldDefinition -> m () + traverse_ (validateImplementsField (G._itdName interface)) (G._itdFieldsDefinition interface) + validateImplementsField :: G.Name -> G.FieldDefinition RemoteSchemaInputValueDefinition -> m () validateImplementsField interfaceName interfaceField = case lookup (G._fldName interfaceField) (zip (fmap G._fldName subFields) subFields) of Nothing -> throw400 RemoteSchemaError $ @@ -179,36 +573,20 @@ remoteSchemaObject schemaDoc defn@(G.ObjectTypeDefinition description name inter -- TODO this ignores nullability which is probably wrong, even though the GraphQL spec is ambiguous validateSubType (G.TypeList _ x) (G.TypeList _ y) = validateSubType x y -- It is OK to "upgrade" the strictness - validateSubType (G.TypeNamed (Nullability False) x) (G.TypeNamed (Nullability True) y) = - validateSubType (G.TypeNamed (Nullability True) x) (G.TypeNamed (Nullability True) y) + validateSubType (G.TypeNamed (G.Nullability False) x) (G.TypeNamed (G.Nullability True) y) = + validateSubType (G.TypeNamed (G.Nullability True) x) (G.TypeNamed (G.Nullability True) y) validateSubType (G.TypeNamed nx x) (G.TypeNamed ny y) = case (lookupType schemaDoc x , lookupType schemaDoc y) of (Just x' , Just y') -> nx == ny && validateSubTypeDefinition x' y' _ -> False validateSubType _ _ = False validateSubTypeDefinition x' y' | x' == y' = True - validateSubTypeDefinition (TypeDefinitionObject otd) (TypeDefinitionInterface itd) + validateSubTypeDefinition (G.TypeDefinitionObject otd) (G.TypeDefinitionInterface itd) = G._otdName otd `elem` G._itdPossibleTypes itd - validateSubTypeDefinition (TypeDefinitionObject _otd) (TypeDefinitionUnion _utd) + validateSubTypeDefinition (G.TypeDefinitionObject _otd) (G.TypeDefinitionUnion _utd) = True -- TODO write appropriate check (may require saving 'possibleTypes' in Syntax.hs) validateSubTypeDefinition _ _ = False --- | helper function to get a parser of an object with it's name --- This function is called from 'remoteSchemaInterface' and --- 'remoteSchemaObject' functions. Both of these have a slightly --- 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) - => RemoteSchemaIntrospection - -> (G.Name -> m RemoteSchemaObjectDefinition) - -> G.Name - -> m (Parser 'Output n (Name, [Field NoFragments RemoteSchemaVariable])) -getObjectParser schemaDoc getObject objName = do - obj <- remoteSchemaObject schemaDoc =<< getObject objName - return $ (objName,) <$> obj - {- Note [Querying remote schema interfaces] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When querying Remote schema interfaces, we need to re-construct @@ -264,11 +642,11 @@ remoteSchemaInterface :: forall n m . (MonadSchema n m, MonadError QErr m) => RemoteSchemaIntrospection - -> RemoteSchemaInterfaceDefinition - -> m (Parser 'Output n (G.SelectionSet NoFragments RemoteSchemaVariable)) + -> 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 (remoteField' schemaDoc) fields + subFieldParsers <- traverse (remoteFieldFromDefinition schemaDoc) 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 @@ -281,7 +659,7 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name -- to 'possibleTypes'. pure $ P.selectionSetInterface name description subFieldParsers objs <&> constructInterfaceSelectionSet where - getObject :: G.Name -> m RemoteSchemaObjectDefinition + getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject objectName = onNothing (lookupObject schemaDoc objectName) $ case lookupInterface schemaDoc objectName of @@ -292,8 +670,8 @@ remoteSchemaInterface schemaDoc defn@(G.InterfaceTypeDefinition description name -- 'constructInterfaceQuery' constructs a remote interface query. constructInterfaceSelectionSet - :: [(G.Name, [Field NoFragments RemoteSchemaVariable])] - -> SelectionSet NoFragments RemoteSchemaVariable + :: [(G.Name, [G.Field G.NoFragments RemoteSchemaVariable])] + -> G.SelectionSet G.NoFragments RemoteSchemaVariable constructInterfaceSelectionSet objNameAndFields = let -- common interface fields that exist in every -- selection set provided @@ -331,7 +709,7 @@ remoteSchemaUnion . (MonadSchema n m, MonadError QErr m) => RemoteSchemaIntrospection -> G.UnionTypeDefinition - -> m (Parser 'Output n (SelectionSet NoFragments RemoteSchemaVariable)) + -> m (Parser 'Output n (G.SelectionSet G.NoFragments RemoteSchemaVariable)) remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _directives objectNames) = P.memoizeOn 'remoteSchemaObject defn do objs <- traverse (getObjectParser schemaDoc getObject) objectNames @@ -355,7 +733,7 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct Just (G.SelectionInlineFragment $ G.InlineFragment (Just objName) mempty $ fmap G.SelectionField fields)) where - getObject :: G.Name -> m RemoteSchemaObjectDefinition + getObject :: G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) getObject objectName = onNothing (lookupObject schemaDoc objectName) $ case lookupInterface schemaDoc objectName of @@ -364,128 +742,35 @@ remoteSchemaUnion schemaDoc defn@(G.UnionTypeDefinition description name _direct Just _ -> throw400 RemoteSchemaError $ "Union type " <> squote name <> " can only include object types. It cannot include " <> squote objectName --- | remoteSchemaInputObject returns an input parser for a given 'G.InputObjectTypeDefinition' --- --- Now, this is tricky! We are faced with two contradicting constraints here. On one hand, the --- GraphQL spec forbids us from creating empty input objects. This means that if all the arguments --- have presets, we CANNOT use the parser this function creates, and the caller cannot create a --- field for this object (and instead should use @pure@ to include the preset values in the result --- of parsing the fields). --- --- One way we could fix this would be to change the type of this function to return a `Maybe --- Parser`, inspect the result of 'argumentsParser', and return @Nothing@ when we realize that there --- aren't any actual field in it (or at least return a value that propagates the preset values). But --- this would contradict our second constraint: this function needs to be memoized! --- --- At time of writing, we can't memoize functions that return arbitrary functors of Parsers; so no --- memoizing Maybe Parser or Either Presets Parser. Which means that we would need to first call --- `argumentsParser`, then memoize the "Just" branch that builds the actual Parser. The problem is --- that the recursive call ro remoteSchemaInputObject is within 'argumentsParser', meaning the call --- to it MUST be in the memoized branch! --- --- This is why, in the end, we do the following: we first test whether there is any non-preset --- 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! -remoteSchemaInputObject +remoteFieldFromDefinition :: forall n m - . (MonadSchema n m, MonadError QErr m) + . (MonadSchema n m, MonadError QErr m) => RemoteSchemaIntrospection - -> G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition - -> m ( Either - (InputFieldsParser n (Maybe (HashMap G.Name (Value RemoteSchemaVariable)))) - (Parser 'Input n (Maybe (HashMap G.Name (Value RemoteSchemaVariable)))) - ) -remoteSchemaInputObject schemaDoc defn@(G.InputObjectTypeDefinition desc name _ valueDefns) = - if all (isJust . _rsitdPresetArgument) valueDefns - then - -- All the fields are preset: we can't create a parser, that would result in an invalid type in - -- the schema (an input object with no field). We therefore forward the InputFieldsParser - -- unmodified. No need to memoize this branch: since all arguments are preset, 'argumentsParser' - -- won't be recursively calling this function. - Left <$> argumentsParser valueDefns schemaDoc - else - -- At least one field is not a preset, meaning we have the guarantee that there will be at least - -- one field in the input object. We have to memoize this branch as we might recursively call - -- the same parser. - Right <$> P.memoizeOn 'remoteSchemaInputObject defn do - argsParser <- argumentsParser valueDefns schemaDoc - pure $ P.object name desc $ argsParser + -> 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) + addNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) + = P.FieldParser (Definition name' un desc (FieldInfo args (Nullable (TList typ)))) parser -lookupType - :: RemoteSchemaIntrospection - -> G.Name - -> Maybe RemoteSchemaTypeDefinition -lookupType (RemoteSchemaIntrospection types) name = find (\tp -> getNamedTyp tp == name) types - where - getNamedTyp :: G.TypeDefinition possibleTypes RemoteSchemaInputValueDefinition -> G.Name - getNamedTyp ty = case ty of - G.TypeDefinitionScalar t -> G._stdName t - G.TypeDefinitionObject t -> G._otdName t - G.TypeDefinitionInterface t -> G._itdName t - G.TypeDefinitionUnion t -> G._utdName t - G.TypeDefinitionEnum t -> G._etdName t - G.TypeDefinitionInputObject t -> G._iotdName t + addNonNullableList :: FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) + addNonNullableList (P.FieldParser (Definition name' un desc (FieldInfo args typ)) parser) + = P.FieldParser (Definition name' un desc (FieldInfo args (NonNullable (TList typ)))) parser -lookupObject :: RemoteSchemaIntrospection -> G.Name -> Maybe RemoteSchemaObjectDefinition -lookupObject (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] -> Maybe RemoteSchemaObjectDefinition - go ((G.TypeDefinitionObject t):tps) - | G._otdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing - -lookupInterface :: RemoteSchemaIntrospection -> G.Name -> Maybe RemoteSchemaInterfaceDefinition -lookupInterface (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] - -> Maybe (G.InterfaceTypeDefinition possibleTypes RemoteSchemaInputValueDefinition) - go ((G.TypeDefinitionInterface t):tps) - | G._itdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing - -lookupScalar :: RemoteSchemaIntrospection -> G.Name -> Maybe G.ScalarTypeDefinition -lookupScalar (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] -> Maybe G.ScalarTypeDefinition - go ((G.TypeDefinitionScalar t):tps) - | G._stdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing - -lookupUnion :: RemoteSchemaIntrospection -> G.Name -> Maybe G.UnionTypeDefinition -lookupUnion (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] -> Maybe G.UnionTypeDefinition - go ((G.TypeDefinitionUnion t):tps) - | G._utdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing - -lookupEnum :: RemoteSchemaIntrospection -> G.Name -> Maybe G.EnumTypeDefinition -lookupEnum (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] -> Maybe G.EnumTypeDefinition - go ((G.TypeDefinitionEnum t):tps) - | G._etdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing - -lookupInputObject :: RemoteSchemaIntrospection -> G.Name -> Maybe RemoteSchemaInputObjectDefinition -lookupInputObject (RemoteSchemaIntrospection types) name = go types - where - go :: [TypeDefinition possibleTypes RemoteSchemaInputValueDefinition] -> Maybe RemoteSchemaInputObjectDefinition - go ((G.TypeDefinitionInputObject t):tps) - | G._iotdName t == name = Just t - | otherwise = go tps - go (_:tps) = go tps - go [] = Nothing + -- TODO add directives, deprecation + convertType :: G.GType -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) + convertType gType' = do + case gType' of + G.TypeNamed (G.Nullability True) fieldTypeName -> + P.nullableField <$> remoteFieldFromName schemaDoc 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 + G.TypeList (G.Nullability False) gType'' -> + addNonNullableList <$> convertType gType'' + in convertType gType -- | 'remoteFieldFromName' accepts a GraphQL name and searches for its definition -- in the 'RemoteSchemaIntrospection'. @@ -497,193 +782,12 @@ remoteFieldFromName -> Maybe G.Description -> G.Name -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition - -> m (FieldParser n (Field NoFragments RemoteSchemaVariable)) + -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) remoteFieldFromName sdoc 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 --- | 'inputValueDefinitionParser' accepts a 'G.InputValueDefinition' and will return an --- 'InputFieldsParser' for it. If a non 'Input' GraphQL type is found in the 'type' of --- the 'InputValueDefinition' then an error will be thrown. -inputValueDefinitionParser - :: forall n m - . (MonadSchema n m, MonadError QErr m) - => RemoteSchemaIntrospection - -> G.InputValueDefinition - -> m (InputFieldsParser n ((Maybe (InputValue Variable)),(Maybe (HashMap G.Name (Value RemoteSchemaVariable))))) -inputValueDefinitionParser schemaDoc (G.InputValueDefinition desc name fieldType maybeDefaultVal _directives) = - let doNullability - :: forall a k . 'Input <: k - => G.Nullability - -> Parser k n (Maybe a) - -> Parser k n (Maybe a) - doNullability (G.Nullability True) = fmap join . P.nullable - doNullability (G.Nullability False) = id - - fieldConstructor - :: forall k. 'Input <: k - => Parser k n (Maybe (HashMap G.Name (Value RemoteSchemaVariable))) - -> InputFieldsParser n ((Maybe (InputValue Variable)), Maybe (HashMap G.Name (Value RemoteSchemaVariable))) - fieldConstructor parser = - let wrappedParser :: Parser k n (InputValue Variable, Maybe (HashMap G.Name (Value RemoteSchemaVariable))) - wrappedParser = - P.Parser - { P.pType = P.pType parser - , P.pParser = \value -> - let inputValP = castWith (P.inputParserInput @k) value - in P.pParser parser value <&> (inputValP,) - } - in case maybeDefaultVal of - Nothing -> - if G.isNullable fieldType - then fieldOptional name desc wrappedParser <&> f - else Just <$> field name desc wrappedParser <&> f - Just defaultVal -> Just <$> fieldWithDefault name desc defaultVal wrappedParser <&> f - where - f :: Maybe (InputValue Variable, (Maybe (HashMap G.Name (G.Value RemoteSchemaVariable)))) - -> (Maybe (InputValue Variable), Maybe (HashMap G.Name (G.Value RemoteSchemaVariable))) - f Nothing = (Nothing, Nothing) - f (Just (inpValue, presetVal)) = (Just inpValue, (Map.singleton name . G.VObject) <$> presetVal) - - - buildField - :: G.GType - -> (forall k. 'Input <: k - => Parser k n (Maybe (HashMap G.Name (Value RemoteSchemaVariable))) - -> InputFieldsParser n ((Maybe (InputValue Variable)), (Maybe (HashMap G.Name (G.Value RemoteSchemaVariable))))) - -> m (InputFieldsParser n ((Maybe (InputValue Variable)), (Maybe (HashMap G.Name (G.Value RemoteSchemaVariable))))) - buildField fieldType' fieldConstructor' = case fieldType' of - G.TypeNamed nullability typeName -> - case lookupType schemaDoc typeName of - Nothing -> throw400 RemoteSchemaError $ "Could not find type with name " <>> typeName - Just typeDef -> - case typeDef of - G.TypeDefinitionScalar scalarTypeDefn -> - pure $ fieldConstructor' $ doNullability nullability $ (remoteFieldScalarParser scalarTypeDefn $> Nothing) - G.TypeDefinitionEnum defn -> - pure $ fieldConstructor' $ doNullability nullability $ remoteFieldEnumParser defn $> Nothing - G.TypeDefinitionObject _ -> throw400 RemoteSchemaError "expected input type, but got output type" -- couldn't find the equivalent error in Validate/Types.hs, so using a new error message - G.TypeDefinitionInputObject defn -> do - potentialObject <- remoteSchemaInputObject schemaDoc defn - pure $ case potentialObject of - Left dummyInputFieldsParser -> do - -- We couln't create a parser, meaning we can't create a field for this - -- object. Instead we must return a "pure" InputFieldsParser that always yields - -- the needed result without containing a field definition. - -- - -- !!! WARNING #1 !!! - -- Since we have no input field in the schema for this field, we can't make the - -- distinction between it being actually present at parsing time or not. We - -- therefore choose to behave as if it was always present, and we always - -- include the preset values in the result. - -- - -- !!! WARNING #2 !!! - -- We are re-using an 'InputFieldsParser' that was created earlier! Won't that - -- create new fields in the current context? No, it won't, but only because in - -- this case we know that it was created from the preset fields in - -- 'argumentsParser', and therefore contains no field definition. - let dummyInputValue = Just $ GraphQLValue $ G.VObject mempty - dummyInputFieldsParser <&> \presets -> - (dummyInputValue, (Map.singleton name . G.VObject) <$> presets) - Right actualParser -> do - -- We're in the normal case: we do have a parser for the input object, which is - -- therefore valid (non-empty). - fieldConstructor' $ doNullability nullability actualParser - G.TypeDefinitionUnion _ -> throw400 RemoteSchemaError "expected input type, but got output type" - G.TypeDefinitionInterface _ -> throw400 RemoteSchemaError "expected input type, but got output type" - G.TypeList nullability subType -> - buildField subType (fieldConstructor' . doNullability nullability . fmap fold . P.list) - - in buildField fieldType fieldConstructor - --- | argumentsParser is used for creating an argument parser for remote fields, --- This function is called for field arguments and input object fields. This --- function works in the following way: --- 1. All the non-preset arguments are collected and then each of these arguments will --- be used to call the `inputValueDefinitionParser` function, because we intend --- these arguments be exposed in the schema --- 2. The preset arguments are collected and converted into a HashMap with the --- name of the field as the key and the preset value as the value of the hashmap --- 3. Now, after #1, we have a input parser for the non-preset arguments, we combine --- the current presets with the presets of the non-preset arguments. This is --- confusing, because it is confusing! --- --- For example, consider the following input objects: --- --- input MessageWhereInpObj { --- id: IntCompareObj --- name: StringCompareObj --- } --- --- input IntCompareObj { --- eq : Int @preset(value: 2) --- gt : Int --- lt : Int --- } --- --- When parsing `MessageWhereInpObj`, we see that any of the fields don't have a --- preset, so we add both of them to the schema. When parsing the `id` --- field, we see that it's of the input object type, so now, `IntCompareObj` is parsed --- and one of its three fields have a preset set. So, we build a preset map for `IntCompareObj` --- which will be `{eq: 2}`. The input parser for `IntCompareObj` will contain this --- preset map with it. After `IntCompareObj` is parsed, the `MessageWhereInpObj` --- will continue parsing the `id` field and then it sees that the `IntCompareObj` --- has a preset associated with it, so now the preset of `IntCompareObj` will be --- associated with `id`. A new preset map pertinent to `MessageWhereInpObj` will --- be created, which will be `{id: {eq: 2}}`. So, whenever an incoming query queries --- for `MessageWhereInpObj` the preset associated will get added to the final arguments --- map. -argumentsParser - :: forall n m - . (MonadSchema n m, MonadError QErr m) - => G.ArgumentsDefinition RemoteSchemaInputValueDefinition - -> RemoteSchemaIntrospection - -> m (InputFieldsParser n (Maybe (HashMap G.Name (Value RemoteSchemaVariable)))) -argumentsParser args schemaDoc = do - -- ! DANGER ! - -- - -- This function is mutually recursive with 'inputValueDefinitionParser': if one of the non-preset - -- arguments is an input object, then recursively we'll end up using 'argumentsParser' to parse - -- its arguments. Note however that if there is no "nonPresetArgs", meaning that all the arguments - -- have a preset value, then this function will not call 'inputValueDefinitionParser', and will - -- simply return without any recursion. - -- - -- This is labelled as dangerous because another function in this module, - -- 'remoteSchemaInputObject', EXPLICITLY RELIES ON THIS BEHAVIOUR. Due to limitations of the - -- GraphQL spec and of parser memoization functions, it cannot memoize the case where all - -- arguments are preset, and therefore relies on the assumption that 'argumentsParser' is not - -- recursive in this edge case. - -- - -- This assumptions is unlikely to ever be broken; but if you ever modify this function, please - -- nonetheless make sure that it is maintained. - nonPresetArgsParser <- sequenceA <$> for nonPresetArgs (inputValueDefinitionParser schemaDoc) - let nonPresetArgsParser' = (fmap . fmap) snd nonPresetArgsParser - pure $ mkPresets <$> nonPresetArgsParser' - where - nonPresetArgs = - map _rsitdDefinition $ - filter (isNothing . _rsitdPresetArgument) args - - currentPreset :: Maybe (HashMap G.Name (Value RemoteSchemaVariable)) - currentPreset = - let presetArgs' = - flip mapMaybe args $ \(RemoteSchemaInputValueDefinition inpValDefn preset) -> - (G._ivdName inpValDefn, ) <$> preset - in case presetArgs' of - [] -> Nothing - _ -> Just $ Map.fromList presetArgs' - - mkPresets - :: [(Maybe (HashMap G.Name (Value RemoteSchemaVariable)))] - -> Maybe (HashMap G.Name (Value RemoteSchemaVariable)) - mkPresets previousPresets = - let nestedPreset = - case catMaybes previousPresets of - [] -> Nothing - previousPresets' -> Just $ Map.unions previousPresets' - in currentPreset <> nestedPreset - -- | '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. @@ -695,7 +799,7 @@ remoteField -> Maybe G.Description -> G.ArgumentsDefinition RemoteSchemaInputValueDefinition -> G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition - -> m (FieldParser n (Field NoFragments RemoteSchemaVariable)) + -> m (FieldParser n (G.Field G.NoFragments RemoteSchemaVariable)) remoteField sdoc fieldName description argsDefn typeDefn = do -- TODO add directives argsParser <- argumentsParser argsDefn sdoc @@ -706,136 +810,43 @@ remoteField sdoc fieldName description argsDefn typeDefn = do let remoteSchemaObjSelSet = fmap G.SelectionField <$> remoteSchemaObjFields pure remoteSchemaObjSelSet <&> mkFieldParserWithSelectionSet argsParser G.TypeDefinitionScalar scalarTypeDefn -> - pure $ mkFieldParserWithoutSelectionSet argsParser - $ remoteFieldScalarParser scalarTypeDefn + pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldScalarParser scalarTypeDefn G.TypeDefinitionEnum enumTypeDefn -> - pure $ mkFieldParserWithoutSelectionSet argsParser - $ remoteFieldEnumParser enumTypeDefn + pure $ mkFieldParserWithoutSelectionSet argsParser $ void $ remoteFieldEnumParser enumTypeDefn G.TypeDefinitionInterface ifaceTypeDefn -> - remoteSchemaInterface sdoc ifaceTypeDefn <&> - mkFieldParserWithSelectionSet argsParser + remoteSchemaInterface sdoc ifaceTypeDefn <&> mkFieldParserWithSelectionSet argsParser G.TypeDefinitionUnion unionTypeDefn -> - remoteSchemaUnion sdoc unionTypeDefn <&> - mkFieldParserWithSelectionSet argsParser + remoteSchemaUnion sdoc unionTypeDefn <&> mkFieldParserWithSelectionSet argsParser _ -> throw400 RemoteSchemaError "expected output type, but got input type" where - -- | This function is used to merge two GraphQL Values. The function is - -- called from a `Map.union` function, which means that the arguments - -- to this function come from the same common key of the two HashMaps - -- that are being merged. The only time the function is called is - -- when some of the fields of an Input Object fields have preset set - -- and the remaining input object fields are queried by the user, then - -- the preset arguments and the user arguments are merged using this function. - -- For example: - -- - -- input UserDetails { - -- id: Int! @preset(value: 1) - -- name: String! - -- } - -- - -- type Mutation { - -- createUser(details: UserDetails): User - -- } - -- - -- Now, since the `id` field already has a preset, the user will not be able - -- to provide value for it and can only be able to provide the value for `name`. - -- - -- mutation { - -- createUser(details: {name: "foo"}) { - -- name - -- } - -- } - -- - -- When we construct the remote query, we will have a HashMap of the preset - -- arguments and the user provided arguments. As mentioned earlier, this function - -- will be called when two maps share a common key, the common key here being - -- `details`. The preset argument hash map will be `{details: {id: 1}}` - -- and the user argument `{details: {name: "foo"}}`. Combining these two will - -- give `{details: {name: "foo", id: 1}}` and then the remote schema is queried - -- with the merged arguments. - mergeValue - :: Maybe (G.Value RemoteSchemaVariable) - -> Maybe (G.Value RemoteSchemaVariable) - -> Maybe (G.Value RemoteSchemaVariable) - mergeValue userArgVal presetArgVal = - case (userArgVal, presetArgVal) of - (Just (G.VList l), Just (G.VList r)) -> Just $ G.VList $ l <> r - (Just (G.VObject l), Just (G.VObject r)) -> G.VObject <$> mergeMaps l r - _ -> Nothing - where - mergeMaps l r = sequenceA $ Map.unionWith mergeValue (Just <$> l) (Just <$> r) - - mergeArgs userArgMap presetArgMap = - sequenceA $ Map.unionWith mergeValue (Just <$> userArgMap) (Just <$> presetArgMap) - - makeField - :: Maybe G.Name - -> G.Name - -> HashMap G.Name (G.Value Variable) - -> Maybe (HashMap G.Name (G.Value RemoteSchemaVariable)) - -> SelectionSet NoFragments RemoteSchemaVariable - -> Maybe (G.Field NoFragments RemoteSchemaVariable) - makeField alias fldName userProvidedArgs presetArgs selSet = do - let userProvidedArgs' = fmap QueryVariable <$> userProvidedArgs - resolvedArgs <- - case presetArgs of - Just presetArg' -> mergeArgs userProvidedArgs' presetArg' - Nothing -> Just userProvidedArgs' - Just $ G.Field alias fldName resolvedArgs mempty selSet - - validateField - :: Maybe (G.Field NoFragments RemoteSchemaVariable) - -> n (G.Field NoFragments RemoteSchemaVariable) - validateField (Just fld) = pure fld - -- ideally, we should be throwing a 500 below - -- The below case, ideally will never happen, because such a query will - -- not be a valid one and it will fail at the validation stage - validateField Nothing = parseErrorWith Unexpected $ "only objects or lists can be merged" - mkFieldParserWithoutSelectionSet - :: InputFieldsParser n (Maybe (HashMap G.Name (G.Value RemoteSchemaVariable))) + :: InputFieldsParser n (Altered, HashMap G.Name (G.Value RemoteSchemaVariable)) -> Parser 'Both n () - -> FieldParser n (Field NoFragments RemoteSchemaVariable) + -> FieldParser n (G.Field G.NoFragments RemoteSchemaVariable) mkFieldParserWithoutSelectionSet argsParser outputParser = - -- 'rawSelection' is used here to get the alias and args data - -- specified to be able to construct the `Field NoFragments G.Name` - let fieldParser = - P.rawSelection fieldName description argsParser outputParser - <&> (\(alias, userProvidedArgs, presetArgs) -> - makeField alias fieldName userProvidedArgs presetArgs []) - in fieldParser `P.bindField` validateField + P.rawSelection fieldName description argsParser outputParser + <&> \(alias, _, (_, args)) -> G.Field alias fieldName args mempty [] mkFieldParserWithSelectionSet - :: InputFieldsParser n (Maybe (HashMap G.Name (G.Value RemoteSchemaVariable))) - -> Parser 'Output n (SelectionSet NoFragments RemoteSchemaVariable) - -> FieldParser n (Field NoFragments RemoteSchemaVariable) + :: 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 = - -- 'rawSubselection' is used here to get the alias and args data - -- specified to be able to construct the `Field NoFragments G.Name` - let fieldParser = - P.rawSubselection fieldName description argsParser outputParser - <&> (\(alias, userProvidedArgs, presetArgs, selSet) -> - makeField alias fieldName userProvidedArgs presetArgs selSet) - in fieldParser `P.bindField` validateField + P.rawSubselection fieldName description argsParser outputParser + <&> \(alias, _, (_, args), selSet) -> G.Field alias fieldName args mempty selSet -remoteFieldScalarParser - :: MonadParse n - => G.ScalarTypeDefinition - -> Parser 'Both n () -remoteFieldScalarParser (G.ScalarTypeDefinition description name _directives) = - case G.unName name of - "Boolean" -> P.boolean $> () - "Int" -> P.int $> () - "Float" -> P.float $> () - "String" -> P.string $> () - "ID" -> P.identifier $> () - _ -> P.unsafeRawScalar name description $> () - -remoteFieldEnumParser - :: MonadParse n - => G.EnumTypeDefinition - -> Parser 'Both n () -remoteFieldEnumParser (G.EnumTypeDefinition desc name _directives valueDefns) = - let enumValDefns = valueDefns <&> \(G.EnumValueDefinition enumDesc enumName _) -> - (mkDefinition (G.unEnumValue enumName) enumDesc P.EnumValueInfo,()) - in P.enum name desc $ NE.fromList enumValDefns +-- | helper function to get a parser of an object with it's name +-- This function is called from 'remoteSchemaInterface' and +-- 'remoteSchemaObject' functions. Both of these have a slightly +-- 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) + => RemoteSchemaIntrospection + -> (G.Name -> m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)) + -> G.Name + -> m (Parser 'Output n (G.Name, [G.Field G.NoFragments RemoteSchemaVariable])) +getObjectParser schemaDoc getObject objName = do + obj <- remoteSchemaObject schemaDoc =<< getObject objName + return $ (objName,) <$> obj diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs index 74132376aa7..a1f5c2d2222 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs @@ -16,7 +16,6 @@ import qualified Language.GraphQL.Draft.Syntax as G import Data.Text.Extended -import Hasura.GraphQL.Schema.Remote import Hasura.RQL.Types.Backend import Hasura.RQL.Types.Column import Hasura.RQL.Types.Common diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema/Permission.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema/Permission.hs index 60491df3d39..994c89e11e8 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema/Permission.hs @@ -50,7 +50,6 @@ import Data.List.Extended (duplicates, getDifference) import Data.Text.Extended import Hasura.Base.Error -import Hasura.GraphQL.Schema.Remote import Hasura.RQL.Types hiding (GraphQLType, defaultScalars) import Hasura.Server.Utils (englishList, isSessionVariable) import Hasura.Session diff --git a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs index ea3cec9bc60..9d5e3e7c2d2 100644 --- a/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/Types/RemoteSchema.hs @@ -7,14 +7,15 @@ import qualified Data.Aeson.TH as J import qualified Data.Environment as Env import qualified Data.HashSet as Set import qualified Data.Text as T -import Data.Text.Extended -import Data.Text.NonEmpty import qualified Database.PG.Query as Q import qualified Language.GraphQL.Draft.Printer as G import qualified Language.GraphQL.Draft.Syntax as G import qualified Network.URI.Extended as N import qualified Text.Builder as TB +import Data.Text.Extended +import Data.Text.NonEmpty + import Hasura.Base.Error import Hasura.GraphQL.Parser.Schema (Variable) import Hasura.Incremental (Cacheable) @@ -22,6 +23,7 @@ import Hasura.RQL.DDL.Headers (HeaderConf (..)) import Hasura.RQL.Types.Common import Hasura.Session + type UrlFromEnv = Text -- | Remote schema identifier. @@ -176,6 +178,7 @@ instance Cacheable SessionArgumentPresetInfo data RemoteSchemaVariable = SessionPresetVariable !SessionVariable !G.Name !SessionArgumentPresetInfo | QueryVariable !Variable + | RemoteJSONValue !G.GType !J.Value deriving (Show, Eq, Generic, Ord) instance Hashable RemoteSchemaVariable instance Cacheable RemoteSchemaVariable @@ -207,3 +210,67 @@ instance J.ToJSON RemoteSchemaPermsCtx where toJSON = \case RemoteSchemaPermsEnabled -> J.Bool True RemoteSchemaPermsDisabled -> J.Bool False + + +lookupType + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe (G.TypeDefinition [G.Name] RemoteSchemaInputValueDefinition) +lookupType (RemoteSchemaIntrospection types) name = find (\tp -> getNamedTyp tp == name) types + where + getNamedTyp :: G.TypeDefinition possibleTypes RemoteSchemaInputValueDefinition -> G.Name + getNamedTyp ty = case ty of + G.TypeDefinitionScalar t -> G._stdName t + G.TypeDefinitionObject t -> G._otdName t + G.TypeDefinitionInterface t -> G._itdName t + G.TypeDefinitionUnion t -> G._utdName t + G.TypeDefinitionEnum t -> G._etdName t + G.TypeDefinitionInputObject t -> G._iotdName t + +lookupObject + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition) +lookupObject (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionObject t | G._otdName t == name -> Just t + _ -> Nothing + +lookupInterface + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe (G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition) +lookupInterface (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionInterface t | G._itdName t == name -> Just t + _ -> Nothing + +lookupScalar + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe G.ScalarTypeDefinition +lookupScalar (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionScalar t | G._stdName t == name -> Just t + _ -> Nothing + +lookupUnion + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe G.UnionTypeDefinition +lookupUnion (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionUnion t | G._utdName t == name -> Just t + _ -> Nothing + +lookupEnum + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe G.EnumTypeDefinition +lookupEnum (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionEnum t | G._etdName t == name -> Just t + _ -> Nothing + +lookupInputObject + :: RemoteSchemaIntrospection + -> G.Name + -> Maybe (G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition) +lookupInputObject (RemoteSchemaIntrospection types) name = choice $ types <&> \case + G.TypeDefinitionInputObject t | G._iotdName t == name -> Just t + _ -> Nothing diff --git a/server/src-test/Data/Text/RawString.hs b/server/src-test/Data/Text/RawString.hs new file mode 100644 index 00000000000..14262105995 --- /dev/null +++ b/server/src-test/Data/Text/RawString.hs @@ -0,0 +1,17 @@ +module Data.Text.RawString (raw) where + +import Hasura.Prelude + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + + +raw :: QuasiQuoter +raw = QuasiQuoter + { quoteExp = pure . LitE . StringL + , quotePat = const $ failWith "pattern" + , quoteType = const $ failWith "type" + , quoteDec = const $ failWith "declaration" + } + where + failWith t = fail $ "illegal raw string quote location; expected expresion, got " <> t diff --git a/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs new file mode 100644 index 00000000000..a9e58f58d73 --- /dev/null +++ b/server/src-test/Hasura/GraphQL/Schema/RemoteTest.hs @@ -0,0 +1,295 @@ +module Hasura.GraphQL.Schema.RemoteTest (spec) where + +import Hasura.Prelude + +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import qualified Language.GraphQL.Draft.Parser as G +import qualified Language.GraphQL.Draft.Syntax as G +import qualified Network.URI as N + +import Data.Text.Extended +import Data.Text.RawString +import Test.Hspec + +import qualified Hasura.GraphQL.Parser.Internal.Parser as P + +import Hasura.Base.Error +import Hasura.GraphQL.Context +import Hasura.GraphQL.Execute.Inline +import Hasura.GraphQL.Execute.Resolve +import Hasura.GraphQL.Parser.Monad +import Hasura.GraphQL.Parser.Schema +import Hasura.GraphQL.Parser.TestUtils +import Hasura.GraphQL.Schema.Remote +import Hasura.RQL.Types.RemoteSchema +import Hasura.RQL.Types.SchemaCache +import Hasura.Session + + +-- test tools + +runError :: Monad m => ExceptT QErr m a -> m a +runError = runExceptT >=> (`onLeft` (error . T.unpack . qeError)) + + +mkTestRemoteSchema :: Text -> RemoteSchemaIntrospection +mkTestRemoteSchema schema = RemoteSchemaIntrospection $ runIdentity $ runError $ do + G.SchemaDocument types <- G.parseSchemaDocument schema `onLeft` throw500 + pure $ flip mapMaybe types \case + G.TypeSystemDefinitionSchema _ -> Nothing + G.TypeSystemDefinitionType td -> Just $ case fmap toRemoteInputValue td of + G.TypeDefinitionScalar std -> G.TypeDefinitionScalar std + G.TypeDefinitionObject otd -> G.TypeDefinitionObject otd + G.TypeDefinitionUnion utd -> G.TypeDefinitionUnion utd + G.TypeDefinitionEnum etd -> G.TypeDefinitionEnum etd + G.TypeDefinitionInputObject itd -> G.TypeDefinitionInputObject itd + G.TypeDefinitionInterface itd -> G.TypeDefinitionInterface $ G.InterfaceTypeDefinition + { G._itdDescription = G._itdDescription itd + , G._itdName = G._itdName itd + , G._itdDirectives = G._itdDirectives itd + , G._itdFieldsDefinition = G._itdFieldsDefinition itd + , G._itdPossibleTypes = [] + } + where + toRemoteInputValue ivd = RemoteSchemaInputValueDefinition + { _rsitdDefinition = ivd + , _rsitdPresetArgument = choice $ G._ivdDirectives ivd <&> \dir -> do + guard $ G._dName dir == $$(G.litName "preset") + value <- M.lookup $$(G.litName "value") $ G._dArguments dir + Just $ case value of + G.VString "x-hasura-test" -> G.VVariable $ + SessionPresetVariable (mkSessionVariable "x-hasura-test") $$(G.litName "String") SessionArgumentPresetScalar + _ -> absurd <$> value + } + +mkTestExecutableDocument :: Text -> ([G.VariableDefinition], G.SelectionSet G.NoFragments G.Name) +mkTestExecutableDocument t = runIdentity $ runError $ do + G.ExecutableDocument execDoc <- G.parseExecutableDoc t `onLeft` throw500 + case execDoc of + [G.ExecutableDefinitionOperation op] -> case op of + G.OperationDefinitionUnTyped selSet -> ([],) <$> inlineSelectionSet [] selSet + G.OperationDefinitionTyped opDef -> do + unless (G._todType opDef == G.OperationTypeQuery) $ + throw500 "only queries for now" + resSelSet <- inlineSelectionSet [] $ G._todSelectionSet opDef + pure (G._todVariableDefinitions opDef, resSelSet) + _ -> throw500 "must have only one query in the document" + +mkTestVariableValues :: LBS.ByteString -> M.HashMap G.Name J.Value +mkTestVariableValues vars = runIdentity $ runError $ do + value <- J.eitherDecode vars `onLeft` (throw500 . T.pack) + case value of + J.Object vs -> M.fromList <$> for (M.toList vs) \(name, val) -> do + gname <- G.mkName name `onNothing` throw500 ("wrong Name: " <>> name) + pure (gname, val) + _ -> throw500 "variables must be an object" + + +buildQueryParsers + :: RemoteSchemaIntrospection + -> IO (P.FieldParser TestMonad (G.Field G.NoFragments RemoteSchemaVariable)) +buildQueryParsers introspection = do + let introResult = IntrospectionResult introspection $$(G.litName "Query") Nothing Nothing + (query, _, _) <- runError + $ runSchemaT + $ buildRemoteParser introResult + $ RemoteSchemaInfo + N.nullURI [] False 60 + pure $ head query <&> \(RemoteFieldG _ f) -> f + + +runQueryParser + :: P.FieldParser TestMonad a + -> ([G.VariableDefinition], G.SelectionSet G.NoFragments G.Name) + -> M.HashMap G.Name J.Value + -> a +runQueryParser parser (varDefs, selSet) vars = runIdentity $ runError $ do + (_, resolvedSelSet) <- resolveVariables varDefs vars [] selSet + field <- case resolvedSelSet of + [G.SelectionField f] -> pure f + _ -> error "expecting only one field in the query" + runTest (P.fParser parser field) `onLeft` throw500 + +run + :: Text -- schema + -> Text -- query + -> LBS.ByteString -- variables + -> IO (G.Field G.NoFragments RemoteSchemaVariable) +run s q v = do + parser <- buildQueryParsers $ mkTestRemoteSchema s + pure $ runQueryParser + parser + (mkTestExecutableDocument q) + (mkTestVariableValues v) + + +-- actual test + +spec :: Spec +spec = do + testNoVarExpansionIfNoPreset + testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField + testPartialVarExpansionIfPreset + +testNoVarExpansionIfNoPreset :: Spec +testNoVarExpansionIfNoPreset = it "variables aren't expanded if there's no preset" $ do + field <- run + -- schema + [raw| +scalar Int + +input A { + b: B +} + +input B { + c: C +} + +input C { + i: Int +} + +type Query { + test(a: A!): Int +} +|] + -- query + [raw| +query($a: A!) { + test(a: $a) +} +|] + -- variables + [raw| +{ + "a": { + "b": { + "c": { + "i": 0 + } + } + } +} +|] + let arg = head $ M.toList $ G._fArguments field + arg `shouldBe` + ( $$(G.litName "a") + -- the parser did not create a new JSON variable, and forwarded the query variable unmodified + , G.VVariable $ QueryVariable $ Variable + (VIRequired $$(G.litName "a")) + (G.TypeNamed (G.Nullability False) $$(G.litName "A")) + (JSONValue $ J.Object $ M.fromList [("b", J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])])]) + ) + +testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField :: Spec +testNoVarExpansionIfNoPresetUnlessTopLevelOptionalField = it "unless fieldOptional peels the variable first" $ do + field <- run + -- schema + [raw| +scalar Int + +input A { + b: B +} + +input B { + c: C +} + +input C { + i: Int +} + +type Query { + test(a: A): Int +} +|] + -- query + [raw| +query($a: A) { + test(a: $a) +} +|] + -- variables + [raw| +{ + "a": { + "b": { + "c": { + "i": 0 + } + } + } +} +|] + let arg = head $ M.toList $ G._fArguments field + arg `shouldBe` + ( $$(G.litName "a") + -- fieldOptional has peeled the variable; all we see is a JSON blob, and in doubt + -- we repackage it as a newly minted JSON variable + , G.VVariable $ RemoteJSONValue + (G.TypeNamed (G.Nullability True) $$(G.litName "A")) + (J.Object $ M.fromList [("b", J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])])]) + ) + +testPartialVarExpansionIfPreset :: Spec +testPartialVarExpansionIfPreset = it "presets cause partial var expansion" $ do + field <- run + -- schema + [raw| +scalar Int + +input A { + x: Int @preset(value: 0) + b: B +} + +input B { + c: C +} + +input C { + i: Int +} + +type Query { + test(a: A!): Int +} +|] + -- query + [raw| +query($a: A!) { + test(a: $a) +} +|] + -- variables + [raw| +{ + "a": { + "b": { + "c": { + "i": 0 + } + } + } +} +|] + let arg = head $ M.toList $ G._fArguments field + arg `shouldBe` + ( $$(G.litName "a") + -- the preset has caused partial variable expansion, only up to where it's needed + , G.VObject $ M.fromList + [ ( $$(G.litName "x") + , G.VInt 0 + ) + , ( $$(G.litName "b") + , G.VVariable $ RemoteJSONValue + (G.TypeNamed (G.Nullability True) $$(G.litName "B")) + (J.Object $ M.fromList [("c", J.Object $ M.fromList [("i", J.Number 0)])]) + ) + ] + ) diff --git a/server/src-test/Main.hs b/server/src-test/Main.hs index 397c31b8c65..347ad8948df 100644 --- a/server/src-test/Main.hs +++ b/server/src-test/Main.hs @@ -5,6 +5,11 @@ import Hasura.Prelude import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Environment as Env +import qualified Data.NonNegativeIntSpec as NonNegetiveIntSpec +import qualified Data.Parser.CacheControlSpec as CacheControlParser +import qualified Data.Parser.JSONPathSpec as JsonPath +import qualified Data.Parser.URLTemplate as URLTemplate +import qualified Data.TimeSpec as TimeSpec import qualified Database.PG.Query as Q import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP @@ -19,14 +24,10 @@ import System.Environment (getEnvironment) import System.Exit (exitFailure) import Test.Hspec -import qualified Data.NonNegativeIntSpec as NonNegetiveIntSpec -import qualified Data.Parser.CacheControlSpec as CacheControlParser -import qualified Data.Parser.JSONPathSpec as JsonPath -import qualified Data.Parser.URLTemplate as URLTemplate -import qualified Data.TimeSpec as TimeSpec import qualified Hasura.CacheBoundedSpec as CacheBoundedSpec import qualified Hasura.EventingSpec as EventingSpec import qualified Hasura.GraphQL.Parser.DirectivesTest as GraphQLDirectivesSpec +import qualified Hasura.GraphQL.Schema.RemoteTest as GraphRemoteSchemaSpec import qualified Hasura.IncrementalSpec as IncrementalSpec import qualified Hasura.RQL.Types.EndpointSpec as EndpointSpec import qualified Hasura.SQL.WKTSpec as WKTSpec @@ -75,6 +76,7 @@ unitSpecs = do describe "Hasura.Cache.Bounded" CacheBoundedSpec.spec describe "Hasura.Eventing" EventingSpec.spec describe "Hasura.GraphQL.Parser.Directives" GraphQLDirectivesSpec.spec + describe "Hasura.GraphQL.Schema.Remote" GraphRemoteSchemaSpec.spec describe "Hasura.Incremental" IncrementalSpec.spec describe "Hasura.RQL.Types.Endpoint" EndpointSpec.spec describe "Hasura.SQL.WKT" WKTSpec.spec diff --git a/server/tests-py/queries/remote_schemas/permissions/argument_presets/add_permission_with_static_preset_argument.yaml b/server/tests-py/queries/remote_schemas/permissions/argument_presets/add_permission_with_static_preset_argument.yaml index 3c266b0bf6d..98d89ae3240 100644 --- a/server/tests-py/queries/remote_schemas/permissions/argument_presets/add_permission_with_static_preset_argument.yaml +++ b/server/tests-py/queries/remote_schemas/permissions/argument_presets/add_permission_with_static_preset_argument.yaml @@ -37,6 +37,11 @@ args: eq : String } + input IncludeInpObj { + id: [Int] @preset(value: [1,2,3]) + name: [String] + } + type Photo { height : Int width : Int @@ -49,7 +54,7 @@ args: type Query { hello: String - messages(where: MessageWhereInpObj @preset(value: {id: {eq: 1}})): [Message] + messages(where: MessageWhereInpObj @preset(value: {id: {eq: 1}}), includes: IncludeInpObj): [Message] user(user_id: Int! @preset(value: 2)): User users(user_ids: [Int]!): [User] message(id: Int!) : Message diff --git a/server/tests-py/queries/remote_schemas/permissions/argument_presets/execution_with_static_preset_args.yaml b/server/tests-py/queries/remote_schemas/permissions/argument_presets/execution_with_static_preset_args.yaml index 5f71d321b31..856fe53310f 100644 --- a/server/tests-py/queries/remote_schemas/permissions/argument_presets/execution_with_static_preset_args.yaml +++ b/server/tests-py/queries/remote_schemas/permissions/argument_presets/execution_with_static_preset_args.yaml @@ -118,3 +118,23 @@ __type: profilePicture: width: 101 + +- description: "query in which a preset field is within a variable" + url: /v1/graphql + status: 200 + headers: + X-Hasura-Role: user + query: + query: | + query($i: IncludeInpObj) { + messages(includes: $i) { + id + } + } + variables: + i: + name: ["alice"] + response: + data: + messages: + - id: 1 diff --git a/server/tests-py/queries/remote_schemas/validation/argument_validation.yaml b/server/tests-py/queries/remote_schemas/validation/argument_validation.yaml index 596bec0f28a..bd95f349841 100644 --- a/server/tests-py/queries/remote_schemas/validation/argument_validation.yaml +++ b/server/tests-py/queries/remote_schemas/validation/argument_validation.yaml @@ -16,7 +16,7 @@ code: validation-failed message: '"user" has no argument named "foo"' -- description: query the remote with a non-existing input argument 'foo' +- description: query the remote with a string literal for an int url: /v1/graphql status: 200 query: @@ -28,11 +28,12 @@ } } response: + data: errors: - - extensions: - path: $.selectionSet.user.args.id - code: validation-failed - message: "expected a 32-bit integer for type \"Int\", but found a string" + - message: "Argument \"id\" has invalid value \"1\".\nExpected type \"Int\", found \"1\"." + locations: + - line: 1 + column: 19 - description: query the remote with a non-existing input object field 'foo' url: /v1/graphql