forked from OSS/graphql
Validate arguments are defined
This commit is contained in:
parent
ced9b815db
commit
4602eb1df3
@ -23,6 +23,7 @@ and this project adheres to
|
||||
the path without executing the query.
|
||||
- `Error.Error`: `path` added. It is currently always empty.
|
||||
- `Validate.Validation.Path` was moved to `Error`.
|
||||
- `Type.Schema.Schema` gets an additional field, `Schema.directives`.
|
||||
|
||||
### Added
|
||||
- `Validate.Validation.Rule` constructors:
|
||||
@ -32,6 +33,7 @@ and this project adheres to
|
||||
- `ArgumentsRule`
|
||||
- `DirectivesRule`
|
||||
- `VariablesRule`
|
||||
- `FieldRule`
|
||||
- `Validate.Rules`:
|
||||
- `fragmentsOnCompositeTypesRule`
|
||||
- `fragmentSpreadTargetDefinedRule`
|
||||
@ -48,10 +50,15 @@ and this project adheres to
|
||||
- `uniqueInputFieldNamesRule`
|
||||
- `fieldsOnCorrectTypeRule`
|
||||
- `scalarLeafsRule`
|
||||
- `knownArgumentNamesRule`
|
||||
- `AST.Document.Field`.
|
||||
- `AST.Document.FragmentSpread`.
|
||||
- `AST.Document.InlineFragment`.
|
||||
- `AST.Document.Node`.
|
||||
- `Type.In.Arguments`: Type alias for an argument map.
|
||||
- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition
|
||||
representation.
|
||||
- `Type.Schema.schema`: Shortcut for creating a schema.
|
||||
|
||||
### Fixed
|
||||
- Collecting existing types from the schema considers subscriptions.
|
||||
|
||||
@ -18,7 +18,7 @@ import Language.GraphQL.AST
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute
|
||||
import qualified Language.GraphQL.Validate as Validate
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
|
||||
@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
-> Document -- @GraphQL@ document.
|
||||
-> m (Either (ResponseEventStream m b) (Response b))
|
||||
execute schema operationName subs document =
|
||||
case Transform.document schema operationName subs document of
|
||||
execute schema' operationName subs document =
|
||||
case Transform.document schema' operationName subs document of
|
||||
Left queryError -> pure
|
||||
$ Right
|
||||
$ singleError
|
||||
|
||||
@ -49,14 +49,15 @@ import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type as Type
|
||||
import Language.GraphQL.Type.Internal
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
|
||||
-- | Associates a fragment name with a list of 'Field's.
|
||||
data Replacement m = Replacement
|
||||
{ fragments :: HashMap Full.Name (Fragment m)
|
||||
, fragmentDefinitions :: FragmentDefinitions
|
||||
, variableValues :: Type.Subs
|
||||
, types :: HashMap Full.Name (Type m)
|
||||
, types :: HashMap Full.Name (Schema.Type m)
|
||||
}
|
||||
|
||||
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
||||
@ -84,7 +85,7 @@ data Field m = Field
|
||||
|
||||
-- | Contains the operation to be executed along with its root type.
|
||||
data Document m = Document
|
||||
(HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
|
||||
(HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
|
||||
|
||||
data OperationDefinition = OperationDefinition
|
||||
Full.OperationType
|
||||
@ -140,7 +141,7 @@ getOperation (Just operationName) operations
|
||||
|
||||
coerceVariableValues :: Coerce.VariableValue a
|
||||
=> forall m
|
||||
. HashMap Full.Name (Type m)
|
||||
. HashMap Full.Name (Schema.Type m)
|
||||
-> OperationDefinition
|
||||
-> HashMap.HashMap Full.Name a
|
||||
-> Either QueryError Type.Subs
|
||||
@ -203,14 +204,14 @@ document schema operationName subs ast = do
|
||||
}
|
||||
case chosenOperation of
|
||||
OperationDefinition Full.Query _ _ _ _ ->
|
||||
pure $ Document referencedTypes (query schema)
|
||||
pure $ Document referencedTypes (Schema.query schema)
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Mutation _ _ _ _
|
||||
| Just mutationType <- mutation schema ->
|
||||
| Just mutationType <- Schema.mutation schema ->
|
||||
pure $ Document referencedTypes mutationType
|
||||
$ operation chosenOperation replacement
|
||||
OperationDefinition Full.Subscription _ _ _ _
|
||||
| Just subscriptionType <- subscription schema ->
|
||||
| Just subscriptionType <- Schema.subscription schema ->
|
||||
pure $ Document referencedTypes subscriptionType
|
||||
$ operation chosenOperation replacement
|
||||
_ -> Left UnsupportedRootOperation
|
||||
|
||||
@ -21,6 +21,6 @@ module Language.GraphQL.Type
|
||||
) where
|
||||
|
||||
import Language.GraphQL.Type.Definition
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import Language.GraphQL.Type.Schema (Schema(..), schema)
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
|
||||
@ -11,6 +11,7 @@
|
||||
-- with 'Language.GraphQL.Type.Out'.
|
||||
module Language.GraphQL.Type.In
|
||||
( Argument(..)
|
||||
, Arguments
|
||||
, InputField(..)
|
||||
, InputObjectType(..)
|
||||
, Type(..)
|
||||
@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL.AST.Document (Name)
|
||||
import Language.GraphQL.Type.Definition
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
|
||||
-- | Single field of an 'InputObjectType'.
|
||||
data InputField = InputField (Maybe Text) Type (Maybe Value)
|
||||
data InputField = InputField (Maybe Text) Type (Maybe Definition.Value)
|
||||
|
||||
-- | Input object type definition.
|
||||
--
|
||||
@ -45,25 +46,28 @@ instance Eq InputObjectType where
|
||||
-- type can wrap other wrapping or named types. Wrapping types are lists and
|
||||
-- Non-Null types (named types are nullable by default).
|
||||
data Type
|
||||
= NamedScalarType ScalarType
|
||||
| NamedEnumType EnumType
|
||||
= NamedScalarType Definition.ScalarType
|
||||
| NamedEnumType Definition.EnumType
|
||||
| NamedInputObjectType InputObjectType
|
||||
| ListType Type
|
||||
| NonNullScalarType ScalarType
|
||||
| NonNullEnumType EnumType
|
||||
| NonNullScalarType Definition.ScalarType
|
||||
| NonNullEnumType Definition.EnumType
|
||||
| NonNullInputObjectType InputObjectType
|
||||
| NonNullListType Type
|
||||
deriving Eq
|
||||
|
||||
-- | Field argument definition.
|
||||
data Argument = Argument (Maybe Text) Type (Maybe Value)
|
||||
data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
|
||||
|
||||
-- | Field argument definitions.
|
||||
type Arguments = HashMap Name Argument
|
||||
|
||||
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
|
||||
pattern ScalarBaseType :: ScalarType -> Type
|
||||
pattern ScalarBaseType :: Definition.ScalarType -> Type
|
||||
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
|
||||
|
||||
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
|
||||
pattern EnumBaseType :: EnumType -> Type
|
||||
pattern EnumBaseType :: Definition.EnumType -> Type
|
||||
pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
|
||||
|
||||
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
|
||||
@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
|
||||
|
||||
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
|
||||
|
||||
isScalarType :: Type -> Maybe ScalarType
|
||||
isScalarType :: Type -> Maybe Definition.ScalarType
|
||||
isScalarType (NamedScalarType inputType) = Just inputType
|
||||
isScalarType (NonNullScalarType inputType) = Just inputType
|
||||
isScalarType _ = Nothing
|
||||
@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
|
||||
isInputObjectType (NonNullInputObjectType inputType) = Just inputType
|
||||
isInputObjectType _ = Nothing
|
||||
|
||||
isEnumType :: Type -> Maybe EnumType
|
||||
isEnumType :: Type -> Maybe Definition.EnumType
|
||||
isEnumType (NamedEnumType inputType) = Just inputType
|
||||
isEnumType (NonNullEnumType inputType) = Just inputType
|
||||
isEnumType _ = Nothing
|
||||
|
||||
@ -18,12 +18,12 @@ module Language.GraphQL.Type.Internal
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
|
||||
-- | These types may describe the parent context of a selection set.
|
||||
data CompositeType m
|
||||
@ -39,13 +39,15 @@ data AbstractType m
|
||||
deriving Eq
|
||||
|
||||
-- | Traverses the schema and finds all referenced types.
|
||||
collectReferencedTypes :: forall m. Schema m -> HashMap Full.Name (Type m)
|
||||
collectReferencedTypes :: forall m
|
||||
. Schema m
|
||||
-> HashMap Full.Name (Schema.Type m)
|
||||
collectReferencedTypes schema =
|
||||
let queryTypes = traverseObjectType (query schema) HashMap.empty
|
||||
let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty
|
||||
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
|
||||
$ mutation schema
|
||||
$ Schema.mutation schema
|
||||
in maybe mutationTypes (`traverseObjectType` queryTypes)
|
||||
$ subscription schema
|
||||
$ Schema.subscription schema
|
||||
where
|
||||
collect traverser typeName element foundTypes
|
||||
| HashMap.member typeName foundTypes = foundTypes
|
||||
@ -59,17 +61,17 @@ collectReferencedTypes schema =
|
||||
getField (Out.EventStreamResolver field _ _) = field
|
||||
traverseInputType (In.InputObjectBaseType objectType) =
|
||||
let In.InputObjectType typeName _ inputFields = objectType
|
||||
element = InputObjectType objectType
|
||||
element = Schema.InputObjectType objectType
|
||||
traverser = flip (foldr visitInputFields) inputFields
|
||||
in collect traverser typeName element
|
||||
traverseInputType (In.ListBaseType listType) =
|
||||
traverseInputType listType
|
||||
traverseInputType (In.ScalarBaseType scalarType) =
|
||||
let Definition.ScalarType typeName _ = scalarType
|
||||
in collect Prelude.id typeName (ScalarType scalarType)
|
||||
in collect Prelude.id typeName (Schema.ScalarType scalarType)
|
||||
traverseInputType (In.EnumBaseType enumType) =
|
||||
let Definition.EnumType typeName _ _ = enumType
|
||||
in collect Prelude.id typeName (EnumType enumType)
|
||||
in collect Prelude.id typeName (Schema.EnumType enumType)
|
||||
traverseOutputType (Out.ObjectBaseType objectType) =
|
||||
traverseObjectType objectType
|
||||
traverseOutputType (Out.InterfaceBaseType interfaceType) =
|
||||
@ -77,23 +79,23 @@ collectReferencedTypes schema =
|
||||
traverseOutputType (Out.UnionBaseType unionType) =
|
||||
let Out.UnionType typeName _ types = unionType
|
||||
traverser = flip (foldr traverseObjectType) types
|
||||
in collect traverser typeName (UnionType unionType)
|
||||
in collect traverser typeName (Schema.UnionType unionType)
|
||||
traverseOutputType (Out.ListBaseType listType) =
|
||||
traverseOutputType listType
|
||||
traverseOutputType (Out.ScalarBaseType scalarType) =
|
||||
let Definition.ScalarType typeName _ = scalarType
|
||||
in collect Prelude.id typeName (ScalarType scalarType)
|
||||
in collect Prelude.id typeName (Schema.ScalarType scalarType)
|
||||
traverseOutputType (Out.EnumBaseType enumType) =
|
||||
let Definition.EnumType typeName _ _ = enumType
|
||||
in collect Prelude.id typeName (EnumType enumType)
|
||||
in collect Prelude.id typeName (Schema.EnumType enumType)
|
||||
traverseObjectType objectType foundTypes =
|
||||
let Out.ObjectType typeName _ interfaces fields = objectType
|
||||
element = ObjectType objectType
|
||||
element = Schema.ObjectType objectType
|
||||
traverser = polymorphicTraverser interfaces (getField <$> fields)
|
||||
in collect traverser typeName element foundTypes
|
||||
traverseInterfaceType interfaceType foundTypes =
|
||||
let Out.InterfaceType typeName _ interfaces fields = interfaceType
|
||||
element = InterfaceType interfaceType
|
||||
element = Schema.InterfaceType interfaceType
|
||||
traverser = polymorphicTraverser interfaces fields
|
||||
in collect traverser typeName element foundTypes
|
||||
polymorphicTraverser interfaces fields
|
||||
@ -126,27 +128,28 @@ instanceOf objectType (AbstractUnionType unionType) =
|
||||
|
||||
lookupTypeCondition :: forall m
|
||||
. Full.Name
|
||||
-> HashMap Full.Name (Type m)
|
||||
-> HashMap Full.Name (Schema.Type m)
|
||||
-> Maybe (CompositeType m)
|
||||
lookupTypeCondition type' types' =
|
||||
case HashMap.lookup type' types' of
|
||||
Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
|
||||
Just (UnionType unionType) -> Just $ CompositeUnionType unionType
|
||||
Just (InterfaceType interfaceType) ->
|
||||
Just (Schema.ObjectType objectType) ->
|
||||
Just $ CompositeObjectType objectType
|
||||
Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType
|
||||
Just (Schema.InterfaceType interfaceType) ->
|
||||
Just $ CompositeInterfaceType interfaceType
|
||||
_ -> Nothing
|
||||
|
||||
lookupInputType
|
||||
:: Full.Type
|
||||
-> HashMap.HashMap Full.Name (Type m)
|
||||
-> HashMap.HashMap Full.Name (Schema.Type m)
|
||||
-> Maybe In.Type
|
||||
lookupInputType (Full.TypeNamed name) types =
|
||||
case HashMap.lookup name types of
|
||||
Just (ScalarType scalarType) ->
|
||||
Just (Schema.ScalarType scalarType) ->
|
||||
Just $ In.NamedScalarType scalarType
|
||||
Just (EnumType enumType) ->
|
||||
Just (Schema.EnumType enumType) ->
|
||||
Just $ In.NamedEnumType enumType
|
||||
Just (InputObjectType objectType) ->
|
||||
Just (Schema.InputObjectType objectType) ->
|
||||
Just $ In.NamedInputObjectType objectType
|
||||
_ -> Nothing
|
||||
lookupInputType (Full.TypeList list) types
|
||||
@ -154,18 +157,18 @@ lookupInputType (Full.TypeList list) types
|
||||
<$> lookupInputType list types
|
||||
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
|
||||
case HashMap.lookup nonNull types of
|
||||
Just (ScalarType scalarType) ->
|
||||
Just (Schema.ScalarType scalarType) ->
|
||||
Just $ In.NonNullScalarType scalarType
|
||||
Just (EnumType enumType) ->
|
||||
Just (Schema.EnumType enumType) ->
|
||||
Just $ In.NonNullEnumType enumType
|
||||
Just (InputObjectType objectType) ->
|
||||
Just (Schema.InputObjectType objectType) ->
|
||||
Just $ In.NonNullInputObjectType objectType
|
||||
_ -> Nothing
|
||||
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
|
||||
= In.NonNullListType
|
||||
<$> lookupInputType nonNull types
|
||||
|
||||
lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
|
||||
lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
|
||||
lookupTypeField fieldName = \case
|
||||
Out.ObjectBaseType objectType ->
|
||||
objectChild objectType
|
||||
@ -177,8 +180,6 @@ lookupTypeField fieldName = \case
|
||||
objectChild (Out.ObjectType _ _ _ resolvers) =
|
||||
resolverType <$> HashMap.lookup fieldName resolvers
|
||||
interfaceChild (Out.InterfaceType _ _ _ fields) =
|
||||
fieldType <$> HashMap.lookup fieldName fields
|
||||
resolverType (Out.ValueResolver objectField _) = fieldType objectField
|
||||
resolverType (Out.EventStreamResolver objectField _ _) =
|
||||
fieldType objectField
|
||||
fieldType (Out.Field _ type' _) = type'
|
||||
HashMap.lookup fieldName fields
|
||||
resolverType (Out.ValueResolver objectField _) = objectField
|
||||
resolverType (Out.EventStreamResolver objectField _ _) = objectField
|
||||
|
||||
@ -2,13 +2,22 @@
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
|
||||
-- | This module provides a representation of a @GraphQL@ Schema in addition to
|
||||
-- functions for defining and manipulating schemas.
|
||||
module Language.GraphQL.Type.Schema
|
||||
( Schema(..)
|
||||
( Directive(..)
|
||||
, Directives
|
||||
, Schema(..)
|
||||
, Type(..)
|
||||
, schema
|
||||
) where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST.Document as Full
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
@ -23,6 +32,12 @@ data Type m
|
||||
| UnionType (Out.UnionType m)
|
||||
deriving Eq
|
||||
|
||||
-- | Directive definition.
|
||||
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
|
||||
|
||||
-- | Directive definitions.
|
||||
type Directives = HashMap Full.Name Directive
|
||||
|
||||
-- | A Schema is created by supplying the root types of each type of operation,
|
||||
-- query and mutation (optional). A schema definition is then supplied to the
|
||||
-- validator and executor.
|
||||
@ -34,4 +49,14 @@ data Schema m = Schema
|
||||
{ query :: Out.ObjectType m
|
||||
, mutation :: Maybe (Out.ObjectType m)
|
||||
, subscription :: Maybe (Out.ObjectType m)
|
||||
, directives :: Directives
|
||||
}
|
||||
|
||||
-- | Shortcut for creating a schema.
|
||||
schema :: forall m. Out.ObjectType m -> Schema m
|
||||
schema query' = Schema
|
||||
{ query = query'
|
||||
, mutation = Nothing
|
||||
, subscription = Nothing
|
||||
, directives = mempty
|
||||
}
|
||||
|
||||
@ -3,11 +3,12 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | GraphQL validator.
|
||||
module Language.GraphQL.Validate
|
||||
( Error(..)
|
||||
( Validation.Error(..)
|
||||
, document
|
||||
, module Language.GraphQL.Validate.Rules
|
||||
) where
|
||||
@ -20,38 +21,100 @@ import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Sequence (Seq(..), (><), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
|
||||
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.Type.Internal
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Language.GraphQL.Validate.Rules
|
||||
import Language.GraphQL.Validate.Validation
|
||||
import Language.GraphQL.Validate.Validation (Validation(Validation))
|
||||
import qualified Language.GraphQL.Validate.Validation as Validation
|
||||
|
||||
type ApplyRule m a =
|
||||
HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
|
||||
type ApplySelectionRule m a
|
||||
= HashMap Name (Schema.Type m)
|
||||
-> Validation.Rule m
|
||||
-> Maybe (Out.Type m)
|
||||
-> a
|
||||
-> Seq (Validation.RuleT m)
|
||||
|
||||
type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)
|
||||
|
||||
-- | Validates a document and returns a list of found errors. If the returned
|
||||
-- list is empty, the document is valid.
|
||||
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
|
||||
document :: forall m
|
||||
. Schema m
|
||||
-> [Validation.Rule m]
|
||||
-> Document
|
||||
-> Seq Validation.Error
|
||||
document schema' rules' document' =
|
||||
runReaderT reader context
|
||||
where
|
||||
context = Validation
|
||||
{ ast = document'
|
||||
, schema = schema'
|
||||
, types = collectReferencedTypes schema'
|
||||
{ Validation.ast = document'
|
||||
, Validation.schema = schema'
|
||||
, Validation.types = collectReferencedTypes schema'
|
||||
, Validation.directives = allDirectives
|
||||
}
|
||||
allDirectives =
|
||||
HashMap.union (Schema.directives schema') defaultDirectives
|
||||
defaultDirectives = HashMap.fromList
|
||||
[ ("skip", skipDirective)
|
||||
, ("include", includeDirective)
|
||||
, ("deprecated", deprecatedDirective)
|
||||
]
|
||||
includeDirective =
|
||||
Schema.Directive includeDescription skipIncludeLocations includeArguments
|
||||
includeArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "Included when true.") ifType Nothing
|
||||
includeDescription = Just
|
||||
"Directs the executor to include this field or fragment only when the \
|
||||
\`if` argument is true."
|
||||
skipDirective =
|
||||
Schema.Directive skipDescription skipIncludeLocations skipArguments
|
||||
skipArguments = HashMap.singleton "if"
|
||||
$ In.Argument (Just "skipped when true.") ifType Nothing
|
||||
ifType = In.NonNullScalarType Definition.boolean
|
||||
skipDescription = Just
|
||||
"Directs the executor to skip this field or fragment when the `if` \
|
||||
\argument is true."
|
||||
skipIncludeLocations =
|
||||
[ ExecutableDirectiveLocation DirectiveLocation.Field
|
||||
, ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
|
||||
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
|
||||
]
|
||||
deprecatedDirective =
|
||||
Schema.Directive deprecatedDescription deprecatedLocations deprecatedArguments
|
||||
reasonDescription = Just
|
||||
"Explains why this element was deprecated, usually also including a \
|
||||
\suggestion for how to access supported similar data. Formatted using \
|
||||
\the Markdown syntax, as specified by \
|
||||
\[CommonMark](https://commonmark.org/).'"
|
||||
deprecatedArguments = HashMap.singleton "reason"
|
||||
$ In.Argument reasonDescription reasonType
|
||||
$ Just "No longer supported"
|
||||
reasonType = In.NamedScalarType Definition.string
|
||||
deprecatedDescription = Just
|
||||
"Marks an element of a GraphQL schema as no longer supported."
|
||||
deprecatedLocations =
|
||||
[ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
|
||||
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
|
||||
]
|
||||
reader = do
|
||||
rule' <- lift $ Seq.fromList rules'
|
||||
join $ lift $ foldr (definition rule' context) Seq.empty document'
|
||||
|
||||
definition :: Rule m
|
||||
definition :: Validation.Rule m
|
||||
-> Validation m
|
||||
-> Definition
|
||||
-> Seq (RuleT m)
|
||||
-> Seq (RuleT m)
|
||||
definition (DefinitionRule rule) _ definition' accumulator =
|
||||
-> Seq (Validation.RuleT m)
|
||||
-> Seq (Validation.RuleT m)
|
||||
definition (Validation.DefinitionRule rule) _ definition' accumulator =
|
||||
accumulator |> rule definition'
|
||||
definition rule context (ExecutableDefinition definition') accumulator =
|
||||
accumulator >< executableDefinition rule context definition'
|
||||
@ -60,12 +123,12 @@ definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
|
||||
definition rule _ (TypeSystemExtension extension _) accumulator =
|
||||
accumulator >< typeSystemExtension rule extension
|
||||
|
||||
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
|
||||
typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension
|
||||
typeSystemExtension rule = \case
|
||||
SchemaExtension extension -> schemaExtension rule extension
|
||||
TypeExtension extension -> typeExtension rule extension
|
||||
|
||||
typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m)
|
||||
typeExtension :: forall m. ApplyRule m TypeExtension
|
||||
typeExtension rule = \case
|
||||
ScalarTypeExtension _ directives' -> directives rule directives'
|
||||
ObjectTypeFieldsDefinitionExtension _ _ directives' fields ->
|
||||
@ -88,27 +151,28 @@ typeExtension rule = \case
|
||||
InputObjectTypeDirectivesExtension _ directives' ->
|
||||
directives rule directives'
|
||||
|
||||
schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m)
|
||||
schemaExtension :: forall m. ApplyRule m SchemaExtension
|
||||
schemaExtension rule = \case
|
||||
SchemaOperationExtension directives' _ -> directives rule directives'
|
||||
SchemaDirectivesExtension directives' -> directives rule directives'
|
||||
|
||||
executableDefinition :: Rule m
|
||||
executableDefinition :: forall m
|
||||
. Validation.Rule m
|
||||
-> Validation m
|
||||
-> ExecutableDefinition
|
||||
-> Seq (RuleT m)
|
||||
-> Seq (Validation.RuleT m)
|
||||
executableDefinition rule context (DefinitionOperation operation) =
|
||||
operationDefinition rule context operation
|
||||
executableDefinition rule context (DefinitionFragment fragment) =
|
||||
fragmentDefinition rule context fragment
|
||||
|
||||
typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m)
|
||||
typeSystemDefinition :: forall m. ApplyRule m TypeSystemDefinition
|
||||
typeSystemDefinition rule = \case
|
||||
SchemaDefinition directives' _ -> directives rule directives'
|
||||
TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition'
|
||||
DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments'
|
||||
|
||||
typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m)
|
||||
typeDefinition :: forall m. ApplyRule m TypeDefinition
|
||||
typeDefinition rule = \case
|
||||
ScalarTypeDefinition _ _ directives' -> directives rule directives'
|
||||
ObjectTypeDefinition _ _ _ directives' fields ->
|
||||
@ -122,30 +186,31 @@ typeDefinition rule = \case
|
||||
-> directives rule directives'
|
||||
<> foldMap (inputValueDefinition rule) fields
|
||||
|
||||
enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m)
|
||||
enumValueDefinition :: forall m. ApplyRule m EnumValueDefinition
|
||||
enumValueDefinition rule (EnumValueDefinition _ _ directives') =
|
||||
directives rule directives'
|
||||
|
||||
fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m)
|
||||
fieldDefinition :: forall m. ApplyRule m FieldDefinition
|
||||
fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') =
|
||||
directives rule directives' >< argumentsDefinition rule arguments'
|
||||
|
||||
argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m)
|
||||
argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition
|
||||
argumentsDefinition rule (ArgumentsDefinition definitions) =
|
||||
foldMap (inputValueDefinition rule) definitions
|
||||
|
||||
inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
|
||||
inputValueDefinition :: forall m. ApplyRule m InputValueDefinition
|
||||
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
|
||||
directives rule directives'
|
||||
|
||||
operationDefinition :: Rule m
|
||||
operationDefinition :: forall m
|
||||
. Validation.Rule m
|
||||
-> Validation m
|
||||
-> OperationDefinition
|
||||
-> Seq (RuleT m)
|
||||
-> Seq (Validation.RuleT m)
|
||||
operationDefinition rule context operation
|
||||
| OperationDefinitionRule operationRule <- rule =
|
||||
| Validation.OperationDefinitionRule operationRule <- rule =
|
||||
pure $ operationRule operation
|
||||
| VariablesRule variablesRule <- rule
|
||||
| Validation.VariablesRule variablesRule <- rule
|
||||
, OperationDefinition _ _ variables _ _ _ <- operation
|
||||
= Seq.fromList (variableDefinition rule <$> variables)
|
||||
|> variablesRule variables
|
||||
@ -155,11 +220,13 @@ operationDefinition rule context operation
|
||||
= selectionSet types' rule (getRootType operationType) selections
|
||||
>< directives rule directives'
|
||||
where
|
||||
types' = types context
|
||||
getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
|
||||
getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
|
||||
types' = Validation.types context
|
||||
getRootType Query =
|
||||
Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context
|
||||
getRootType Mutation =
|
||||
Out.NamedObjectType <$> Schema.mutation (Validation.schema context)
|
||||
getRootType Subscription =
|
||||
Out.NamedObjectType <$> subscription (schema context)
|
||||
Out.NamedObjectType <$> Schema.subscription (Validation.schema context)
|
||||
|
||||
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
|
||||
typeToOut (Schema.ObjectType objectType) =
|
||||
@ -171,27 +238,30 @@ typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
|
||||
typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
|
||||
typeToOut _ = Nothing
|
||||
|
||||
variableDefinition :: Rule m -> VariableDefinition -> RuleT m
|
||||
variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
|
||||
variableDefinition :: forall m
|
||||
. Validation.Rule m
|
||||
-> VariableDefinition
|
||||
-> Validation.RuleT m
|
||||
variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) =
|
||||
maybe (lift mempty) rule value
|
||||
variableDefinition _ _ = lift mempty
|
||||
|
||||
fragmentDefinition :: forall m
|
||||
. Rule m
|
||||
. Validation.Rule m
|
||||
-> Validation m
|
||||
-> FragmentDefinition
|
||||
-> Seq (RuleT m)
|
||||
fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
|
||||
-> Seq (Validation.RuleT m)
|
||||
fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
|
||||
pure $ rule definition'
|
||||
fragmentDefinition rule context definition'
|
||||
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||
, FragmentRule definitionRule _ <- rule
|
||||
, Validation.FragmentRule definitionRule _ <- rule
|
||||
= applyToChildren typeCondition directives' selections
|
||||
|> definitionRule definition'
|
||||
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||
= applyToChildren typeCondition directives' selections
|
||||
where
|
||||
types' = types context
|
||||
types' = Validation.types context
|
||||
applyToChildren typeCondition directives' selections
|
||||
= selectionSet types' rule (lookupType' typeCondition) selections
|
||||
>< directives rule directives'
|
||||
@ -204,12 +274,12 @@ lookupType :: forall m
|
||||
lookupType typeCondition types' = HashMap.lookup typeCondition types'
|
||||
>>= typeToOut
|
||||
|
||||
selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
|
||||
selectionSet :: Traversable t => forall m. ApplySelectionRule m (t Selection)
|
||||
selectionSet types' rule = foldMap . selection types' rule
|
||||
|
||||
selection :: forall m. ApplyRule m Selection
|
||||
selection :: forall m. ApplySelectionRule m Selection
|
||||
selection types' rule objectType selection'
|
||||
| SelectionRule selectionRule <- rule =
|
||||
| Validation.SelectionRule selectionRule <- rule =
|
||||
applyToChildren |> selectionRule objectType selection'
|
||||
| otherwise = applyToChildren
|
||||
where
|
||||
@ -221,33 +291,37 @@ selection types' rule objectType selection'
|
||||
FragmentSpreadSelection fragmentSpread' ->
|
||||
fragmentSpread rule fragmentSpread'
|
||||
|
||||
field :: forall m. ApplyRule m Field
|
||||
field :: forall m. ApplySelectionRule m Field
|
||||
field types' rule objectType field' = go field'
|
||||
where
|
||||
go (Field _ fieldName arguments' directives' selections _)
|
||||
| ArgumentsRule fieldRule _ <- rule
|
||||
= applyToChildren fieldName arguments' directives' selections
|
||||
|> fieldRule field'
|
||||
| otherwise =
|
||||
applyToChildren fieldName arguments' directives' selections
|
||||
applyToChildren fieldName arguments' directives' selections =
|
||||
let child = objectType >>= lookupTypeField fieldName
|
||||
in selectionSet types' rule child selections
|
||||
go (Field _ fieldName _ _ _ _)
|
||||
| Validation.FieldRule fieldRule <- rule =
|
||||
applyToChildren fieldName |> fieldRule objectType field'
|
||||
| Validation.ArgumentsRule argumentsRule _ <- rule =
|
||||
applyToChildren fieldName |> argumentsRule objectType field'
|
||||
| otherwise = applyToChildren fieldName
|
||||
typeFieldType (Out.Field _ type' _) = type'
|
||||
applyToChildren fieldName =
|
||||
let Field _ _ arguments' directives' selections _ = field'
|
||||
fieldType = objectType
|
||||
>>= fmap typeFieldType . lookupTypeField fieldName
|
||||
in selectionSet types' rule fieldType selections
|
||||
>< directives rule directives'
|
||||
>< arguments rule arguments'
|
||||
|
||||
arguments :: Rule m -> [Argument] -> Seq (RuleT m)
|
||||
arguments :: forall m. ApplyRule m [Argument]
|
||||
arguments = (.) Seq.fromList . fmap . argument
|
||||
|
||||
argument :: Rule m -> Argument -> RuleT m
|
||||
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
|
||||
argument :: forall m. Validation.Rule m -> Argument -> Validation.RuleT m
|
||||
argument (Validation.ValueRule rule _) (Argument _ (Node value _) _) =
|
||||
rule value
|
||||
argument _ _ = lift mempty
|
||||
|
||||
inlineFragment :: forall m. ApplyRule m InlineFragment
|
||||
inlineFragment :: forall m. ApplySelectionRule m InlineFragment
|
||||
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
|
||||
where
|
||||
go (InlineFragment optionalType directives' selections _)
|
||||
| FragmentRule _ fragmentRule <- rule
|
||||
| Validation.FragmentRule _ fragmentRule <- rule
|
||||
= applyToChildren (refineTarget optionalType) directives' selections
|
||||
|> fragmentRule inlineFragment'
|
||||
| otherwise = applyToChildren (refineTarget optionalType) directives' selections
|
||||
@ -257,24 +331,24 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
|
||||
= selectionSet types' rule objectType' selections
|
||||
>< directives rule directives'
|
||||
|
||||
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)
|
||||
fragmentSpread :: forall m. ApplyRule m FragmentSpread
|
||||
fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
|
||||
| FragmentSpreadRule fragmentRule <- rule =
|
||||
| Validation.FragmentSpreadRule fragmentRule <- rule =
|
||||
applyToChildren |> fragmentRule fragmentSpread'
|
||||
| otherwise = applyToChildren
|
||||
where
|
||||
applyToChildren = directives rule directives'
|
||||
|
||||
directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m)
|
||||
directives :: Traversable t => forall m. ApplyRule m (t Directive)
|
||||
directives rule directives'
|
||||
| DirectivesRule directivesRule <- rule =
|
||||
| Validation.DirectivesRule directivesRule <- rule =
|
||||
applyToChildren |> directivesRule directiveList
|
||||
| otherwise = applyToChildren
|
||||
where
|
||||
directiveList = toList directives'
|
||||
applyToChildren = foldMap (directive rule) directiveList
|
||||
|
||||
directive :: Rule m -> Directive -> Seq (RuleT m)
|
||||
directive (ArgumentsRule _ argumentsRule) directive' =
|
||||
directive :: forall m. ApplyRule m Directive
|
||||
directive (Validation.ArgumentsRule _ argumentsRule) directive' =
|
||||
pure $ argumentsRule directive'
|
||||
directive rule (Directive _ arguments' _) = arguments rule arguments'
|
||||
|
||||
@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules
|
||||
, fragmentSpreadTargetDefinedRule
|
||||
, fragmentSpreadTypeExistenceRule
|
||||
, loneAnonymousOperationRule
|
||||
, knownArgumentNamesRule
|
||||
, noFragmentCyclesRule
|
||||
, noUndefinedVariablesRule
|
||||
, noUnusedFragmentsRule
|
||||
@ -44,7 +45,7 @@ import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
@ -71,6 +72,7 @@ specifiedRules =
|
||||
, fieldsOnCorrectTypeRule
|
||||
, scalarLeafsRule
|
||||
-- Arguments.
|
||||
, knownArgumentNamesRule
|
||||
, uniqueArgumentNamesRule
|
||||
-- Fragments.
|
||||
, uniqueFragmentNamesRule
|
||||
@ -134,20 +136,20 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
|
||||
forSpread accumulator fragmentSelection
|
||||
InlineFragmentSelection fragmentSelection ->
|
||||
forInline accumulator fragmentSelection
|
||||
forField accumulator (Field alias name _ directives _ _)
|
||||
| any skip directives = pure accumulator
|
||||
forField accumulator (Field alias name _ directives' _ _)
|
||||
| any skip directives' = pure accumulator
|
||||
| Just aliasedName <- alias = pure
|
||||
$ HashSet.insert aliasedName accumulator
|
||||
| otherwise = pure $ HashSet.insert name accumulator
|
||||
forSpread accumulator (FragmentSpread fragmentName directives _)
|
||||
| any skip directives = pure accumulator
|
||||
forSpread accumulator (FragmentSpread fragmentName directives' _)
|
||||
| any skip directives' = pure accumulator
|
||||
| otherwise = do
|
||||
inVisitetFragments <- gets $ HashSet.member fragmentName
|
||||
if inVisitetFragments
|
||||
then pure accumulator
|
||||
else collectFromSpread fragmentName accumulator
|
||||
forInline accumulator (InlineFragment maybeType directives selections _)
|
||||
| any skip directives = pure accumulator
|
||||
forInline accumulator (InlineFragment maybeType directives' selections _)
|
||||
| any skip directives' = pure accumulator
|
||||
| Just typeCondition <- maybeType =
|
||||
collectFromFragment typeCondition selections accumulator
|
||||
| otherwise = HashSet.union accumulator
|
||||
@ -494,7 +496,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
|
||||
uniqueArgumentNamesRule :: forall m. Rule m
|
||||
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
where
|
||||
fieldRule (Field _ _ arguments _ _ _) =
|
||||
fieldRule _ (Field _ _ arguments _ _ _) =
|
||||
lift $ filterDuplicates extract "argument" arguments
|
||||
directiveRule (Directive _ arguments _) =
|
||||
lift $ filterDuplicates extract "argument" arguments
|
||||
@ -519,9 +521,9 @@ filterDuplicates extract nodeType = Seq.fromList
|
||||
where
|
||||
getName = fst . extract
|
||||
equalByName lhs rhs = getName lhs == getName rhs
|
||||
makeError directives = Error
|
||||
{ message = makeMessage $ head directives
|
||||
, locations = snd . extract <$> directives
|
||||
makeError directives' = Error
|
||||
{ message = makeMessage $ head directives'
|
||||
, locations = snd . extract <$> directives'
|
||||
}
|
||||
makeMessage directive = concat
|
||||
[ "There can be only one "
|
||||
@ -614,11 +616,11 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
||||
filterSelections' = filterSelections variableFilter
|
||||
variableFilter :: Selection -> ValidationState m (Name, [Location])
|
||||
variableFilter (InlineFragmentSelection inline)
|
||||
| InlineFragment _ directives _ _ <- inline =
|
||||
lift $ lift $ mapDirectives directives
|
||||
| InlineFragment _ directives' _ _ <- inline =
|
||||
lift $ lift $ mapDirectives directives'
|
||||
variableFilter (FieldSelection fieldSelection)
|
||||
| Field _ _ arguments directives _ _ <- fieldSelection =
|
||||
lift $ lift $ mapArguments arguments <> mapDirectives directives
|
||||
| Field _ _ arguments directives' _ _ <- fieldSelection =
|
||||
lift $ lift $ mapArguments arguments <> mapDirectives directives'
|
||||
variableFilter (FragmentSpreadSelection spread)
|
||||
| FragmentSpread fragmentName _ _ <- spread = do
|
||||
definitions <- lift $ asks ast
|
||||
@ -628,9 +630,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
|
||||
Just (viewFragment -> Just fragmentDefinition)
|
||||
| not visited -> diveIntoSpread fragmentDefinition
|
||||
_ -> lift $ lift mempty
|
||||
diveIntoSpread (FragmentDefinition _ _ directives selections _)
|
||||
diveIntoSpread (FragmentDefinition _ _ directives' selections _)
|
||||
= filterSelections' selections
|
||||
>>= lift . mapReaderT (<> mapDirectives directives) . pure
|
||||
>>= lift . mapReaderT (<> mapDirectives directives') . pure
|
||||
findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
|
||||
mapArguments = Seq.fromList . mapMaybe findArgumentVariables
|
||||
mapDirectives = foldMap findDirectiveVariables
|
||||
@ -683,13 +685,11 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
|
||||
-- | The target field of a field selection must be defined on the scoped type of
|
||||
-- the selection set. There are no limitations on alias names.
|
||||
fieldsOnCorrectTypeRule :: forall m. Rule m
|
||||
fieldsOnCorrectTypeRule = SelectionRule go
|
||||
fieldsOnCorrectTypeRule = FieldRule fieldRule
|
||||
where
|
||||
go (Just objectType) (FieldSelection fieldSelection) =
|
||||
fieldRule objectType fieldSelection
|
||||
go _ _ = lift mempty
|
||||
fieldRule objectType (Field _ fieldName _ _ _ location)
|
||||
| Nothing <- lookupTypeField fieldName objectType
|
||||
fieldRule parentType (Field _ fieldName _ _ _ location)
|
||||
| Just objectType <- parentType
|
||||
, Nothing <- lookupTypeField fieldName objectType
|
||||
, Just typeName <- compositeTypeName objectType = pure $ Error
|
||||
{ message = errorMessage fieldName typeName
|
||||
, locations = [location]
|
||||
@ -702,6 +702,8 @@ fieldsOnCorrectTypeRule = SelectionRule go
|
||||
, Text.unpack typeName
|
||||
, "\"."
|
||||
]
|
||||
|
||||
compositeTypeName :: forall m. Out.Type m -> Maybe Name
|
||||
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
|
||||
Just typeName
|
||||
compositeTypeName (Out.InterfaceBaseType interfaceType) =
|
||||
@ -719,14 +721,13 @@ fieldsOnCorrectTypeRule = SelectionRule go
|
||||
-- | Field selections on scalars or enums are never allowed, because they are
|
||||
-- the leaf nodes of any GraphQL query.
|
||||
scalarLeafsRule :: forall m. Rule m
|
||||
scalarLeafsRule = SelectionRule go
|
||||
scalarLeafsRule = FieldRule fieldRule
|
||||
where
|
||||
go (Just objectType) (FieldSelection fieldSelection) =
|
||||
fieldRule objectType fieldSelection
|
||||
go _ _ = lift mempty
|
||||
fieldRule objectType selectionField@(Field _ fieldName _ _ _ _)
|
||||
| Just fieldType <- lookupTypeField fieldName objectType =
|
||||
lift $ check fieldType selectionField
|
||||
fieldRule parentType selectionField@(Field _ fieldName _ _ _ _)
|
||||
| Just objectType <- parentType
|
||||
, Just field <- lookupTypeField fieldName objectType =
|
||||
let Out.Field _ fieldType _ = field
|
||||
in lift $ check fieldType selectionField
|
||||
| otherwise = lift mempty
|
||||
check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
|
||||
checkNotEmpty typeName
|
||||
@ -765,3 +766,49 @@ scalarLeafsRule = SelectionRule go
|
||||
{ message = errorMessage
|
||||
, locations = [location]
|
||||
}
|
||||
|
||||
-- | Every argument provided to a field or directive must be defined in the set
|
||||
-- of possible arguments of that field or directive.
|
||||
knownArgumentNamesRule :: forall m. Rule m
|
||||
knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
|
||||
where
|
||||
fieldRule (Just objectType) (Field _ fieldName arguments _ _ _)
|
||||
| Just typeField <- lookupTypeField fieldName objectType
|
||||
, Just typeName <- compositeTypeName objectType =
|
||||
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
|
||||
fieldRule _ _ = lift mempty
|
||||
go typeName fieldName fieldDefinition (Argument argumentName _ location) errors
|
||||
| Out.Field _ _ definitions <- fieldDefinition
|
||||
, Just _ <- HashMap.lookup argumentName definitions = errors
|
||||
| otherwise = errors |> Error
|
||||
{ message = fieldMessage argumentName fieldName typeName
|
||||
, locations = [location]
|
||||
}
|
||||
fieldMessage argumentName fieldName typeName = concat
|
||||
[ "Unknown argument \""
|
||||
, Text.unpack argumentName
|
||||
, "\" on field \""
|
||||
, Text.unpack typeName
|
||||
, "."
|
||||
, Text.unpack fieldName
|
||||
, "\"."
|
||||
]
|
||||
directiveRule (Directive directiveName arguments _) = do
|
||||
available <- asks $ HashMap.lookup directiveName . directives
|
||||
Argument argumentName _ location <- lift $ Seq.fromList arguments
|
||||
case available of
|
||||
Just (Schema.Directive _ _ definitions)
|
||||
| not $ HashMap.member argumentName definitions ->
|
||||
pure $ makeError argumentName directiveName location
|
||||
_ -> lift mempty
|
||||
makeError argumentName directiveName location = Error
|
||||
{ message = directiveMessage argumentName directiveName
|
||||
, locations = [location]
|
||||
}
|
||||
directiveMessage argumentName directiveName = concat
|
||||
[ "Unknown argument \""
|
||||
, Text.unpack argumentName
|
||||
, "\" on directive \"@"
|
||||
, Text.unpack directiveName
|
||||
, "\"."
|
||||
]
|
||||
|
||||
@ -29,6 +29,7 @@ data Validation m = Validation
|
||||
{ ast :: Document
|
||||
, schema :: Schema m
|
||||
, types :: HashMap Name (Schema.Type m)
|
||||
, directives :: Schema.Directives
|
||||
}
|
||||
|
||||
-- | 'Rule' assigns a function to each AST node that can be validated. If the
|
||||
@ -41,7 +42,8 @@ data Rule m
|
||||
| SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
|
||||
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
|
||||
| FragmentSpreadRule (FragmentSpread -> RuleT m)
|
||||
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
|
||||
| FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)
|
||||
| ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
|
||||
| DirectivesRule ([Directive] -> RuleT m)
|
||||
| VariablesRule ([VariableDefinition] -> RuleT m)
|
||||
| ValueRule (Value -> RuleT m) (ConstValue -> RuleT m)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
resolver: lts-16.15
|
||||
resolver: lts-16.16
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
||||
@ -25,11 +25,12 @@ import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
schema :: Schema (Either SomeException)
|
||||
schema = Schema
|
||||
philosopherSchema :: Schema (Either SomeException)
|
||||
philosopherSchema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Just subscriptionType
|
||||
, directives = HashMap.empty
|
||||
}
|
||||
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
@ -79,7 +80,8 @@ type EitherStreamOrValue = Either
|
||||
(Response Aeson.Value)
|
||||
|
||||
execute' :: Document -> Either SomeException EitherStreamOrValue
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
execute' =
|
||||
execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
|
||||
@ -21,11 +21,12 @@ import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
petSchema :: Schema IO
|
||||
petSchema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Just subscriptionType
|
||||
, directives = HashMap.empty
|
||||
}
|
||||
|
||||
queryType :: ObjectType IO
|
||||
@ -132,7 +133,7 @@ validate :: Text -> [Error]
|
||||
validate queryString =
|
||||
case parse AST.document "" queryString of
|
||||
Left _ -> []
|
||||
Right ast -> toList $ document schema specifiedRules ast
|
||||
Right ast -> toList $ document petSchema specifiedRules ast
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
@ -544,3 +545,34 @@ spec =
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects field arguments missing in the type" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
doesKnowCommand(command: CLEAN_UP_HOUSE)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"command\" on field \
|
||||
\\"Dog.doesKnowCommand\"."
|
||||
, locations = [AST.Location 4 35]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects directive arguments missing in the definition" $
|
||||
let queryString = [r|
|
||||
{
|
||||
dog {
|
||||
isHousetrained(atOtherHomes: true) @include(unless: false)
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"Unknown argument \"unless\" on directive \"@include\"."
|
||||
, locations = [AST.Location 4 63]
|
||||
}
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
@ -19,8 +19,7 @@ import Test.Hspec.GraphQL
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
experimentalResolver :: Schema IO
|
||||
experimentalResolver = Schema
|
||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||
experimentalResolver = schema queryType
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "experimentalField"
|
||||
|
||||
@ -67,8 +67,7 @@ sizeFieldType
|
||||
$ pure $ snd size
|
||||
|
||||
toSchema :: Text -> (Text, Value) -> Schema IO
|
||||
toSchema t (_, resolve) = Schema
|
||||
{ query = queryType, mutation = Nothing, subscription = Nothing }
|
||||
toSchema t (_, resolve) = schema queryType
|
||||
where
|
||||
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
|
||||
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
@ -23,11 +23,12 @@ hatType = Out.ObjectType "Hat" Nothing []
|
||||
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
|
||||
$ pure $ Int 60
|
||||
|
||||
schema :: Schema IO
|
||||
schema = Schema
|
||||
garmentSchema :: Schema IO
|
||||
garmentSchema = Schema
|
||||
{ query = Out.ObjectType "Query" Nothing [] hatFieldResolver
|
||||
, mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
|
||||
, subscription = Nothing
|
||||
, directives = HashMap.empty
|
||||
}
|
||||
where
|
||||
garment = pure $ Object $ HashMap.fromList
|
||||
@ -57,7 +58,7 @@ spec =
|
||||
[ "circumference" .= (60 :: Int)
|
||||
]
|
||||
]
|
||||
actual <- graphql schema querySource
|
||||
actual <- graphql garmentSchema querySource
|
||||
actual `shouldResolveTo` expected
|
||||
|
||||
it "chooses Mutation" $ do
|
||||
@ -70,5 +71,5 @@ spec =
|
||||
$ object
|
||||
[ "incrementCircumference" .= (61 :: Int)
|
||||
]
|
||||
actual <- graphql schema querySource
|
||||
actual <- graphql garmentSchema querySource
|
||||
actual `shouldResolveTo` expected
|
||||
|
||||
@ -357,10 +357,10 @@ spec = describe "Star Wars Query Tests" $ do
|
||||
|
||||
testQuery :: Text -> Aeson.Value -> Expectation
|
||||
testQuery q expected =
|
||||
let Right (Right actual) = graphql schema q
|
||||
let Right (Right actual) = graphql starWarsSchema q
|
||||
in Aeson.Object actual `shouldBe` expected
|
||||
|
||||
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
|
||||
testQueryParams f q expected =
|
||||
let Right (Right actual) = graphqlSubs schema Nothing f q
|
||||
let Right (Right actual) = graphqlSubs starWarsSchema Nothing f q
|
||||
in Aeson.Object actual `shouldBe` expected
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Test.StarWars.Schema
|
||||
( schema
|
||||
( starWarsSchema
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow(..), SomeException)
|
||||
@ -17,12 +17,8 @@ import Prelude hiding (id)
|
||||
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
schema :: Schema (Either SomeException)
|
||||
schema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Nothing
|
||||
}
|
||||
starWarsSchema :: Schema (Either SomeException)
|
||||
starWarsSchema = schema queryType
|
||||
where
|
||||
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("hero", heroFieldResolver)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user