Validate arguments are defined

This commit is contained in:
Eugen Wissner 2020-09-28 07:06:15 +02:00
parent ced9b815db
commit 4602eb1df3
19 changed files with 375 additions and 185 deletions

View File

@ -23,6 +23,7 @@ and this project adheres to
the path without executing the query. the path without executing the query.
- `Error.Error`: `path` added. It is currently always empty. - `Error.Error`: `path` added. It is currently always empty.
- `Validate.Validation.Path` was moved to `Error`. - `Validate.Validation.Path` was moved to `Error`.
- `Type.Schema.Schema` gets an additional field, `Schema.directives`.
### Added ### Added
- `Validate.Validation.Rule` constructors: - `Validate.Validation.Rule` constructors:
@ -32,6 +33,7 @@ and this project adheres to
- `ArgumentsRule` - `ArgumentsRule`
- `DirectivesRule` - `DirectivesRule`
- `VariablesRule` - `VariablesRule`
- `FieldRule`
- `Validate.Rules`: - `Validate.Rules`:
- `fragmentsOnCompositeTypesRule` - `fragmentsOnCompositeTypesRule`
- `fragmentSpreadTargetDefinedRule` - `fragmentSpreadTargetDefinedRule`
@ -48,10 +50,15 @@ and this project adheres to
- `uniqueInputFieldNamesRule` - `uniqueInputFieldNamesRule`
- `fieldsOnCorrectTypeRule` - `fieldsOnCorrectTypeRule`
- `scalarLeafsRule` - `scalarLeafsRule`
- `knownArgumentNamesRule`
- `AST.Document.Field`. - `AST.Document.Field`.
- `AST.Document.FragmentSpread`. - `AST.Document.FragmentSpread`.
- `AST.Document.InlineFragment`. - `AST.Document.InlineFragment`.
- `AST.Document.Node`. - `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 ### Fixed
- Collecting existing types from the schema considers subscriptions. - Collecting existing types from the schema considers subscriptions.

View File

@ -18,7 +18,7 @@ import Language.GraphQL.AST
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
import qualified Language.GraphQL.Validate as Validate import qualified Language.GraphQL.Validate as Validate
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema (Schema)
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is -- | If the text parses correctly as a @GraphQL@ query the query is

View File

@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
-> HashMap Name a -- ^ Variable substitution function. -> HashMap Name a -- ^ Variable substitution function.
-> Document -- @GraphQL@ document. -> Document -- @GraphQL@ document.
-> m (Either (ResponseEventStream m b) (Response b)) -> m (Either (ResponseEventStream m b) (Response b))
execute schema operationName subs document = execute schema' operationName subs document =
case Transform.document schema operationName subs document of case Transform.document schema' operationName subs document of
Left queryError -> pure Left queryError -> pure
$ Right $ Right
$ singleError $ singleError

View File

@ -49,14 +49,15 @@ import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type as Type
import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out 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. -- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m) { fragments :: HashMap Full.Name (Fragment m)
, fragmentDefinitions :: FragmentDefinitions , fragmentDefinitions :: FragmentDefinitions
, variableValues :: Type.Subs , variableValues :: Type.Subs
, types :: HashMap Full.Name (Type m) , types :: HashMap Full.Name (Schema.Type m)
} }
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition 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. -- | Contains the operation to be executed along with its root type.
data Document m = Document 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 data OperationDefinition = OperationDefinition
Full.OperationType Full.OperationType
@ -140,7 +141,7 @@ getOperation (Just operationName) operations
coerceVariableValues :: Coerce.VariableValue a coerceVariableValues :: Coerce.VariableValue a
=> forall m => forall m
. HashMap Full.Name (Type m) . HashMap Full.Name (Schema.Type m)
-> OperationDefinition -> OperationDefinition
-> HashMap.HashMap Full.Name a -> HashMap.HashMap Full.Name a
-> Either QueryError Type.Subs -> Either QueryError Type.Subs
@ -203,14 +204,14 @@ document schema operationName subs ast = do
} }
case chosenOperation of case chosenOperation of
OperationDefinition Full.Query _ _ _ _ -> OperationDefinition Full.Query _ _ _ _ ->
pure $ Document referencedTypes (query schema) pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement $ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _ OperationDefinition Full.Mutation _ _ _ _
| Just mutationType <- mutation schema -> | Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement $ operation chosenOperation replacement
OperationDefinition Full.Subscription _ _ _ _ OperationDefinition Full.Subscription _ _ _ _
| Just subscriptionType <- subscription schema -> | Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement $ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation _ -> Left UnsupportedRootOperation

View File

@ -21,6 +21,6 @@ module Language.GraphQL.Type
) where ) where
import Language.GraphQL.Type.Definition 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.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out

View File

@ -11,6 +11,7 @@
-- with 'Language.GraphQL.Type.Out'. -- with 'Language.GraphQL.Type.Out'.
module Language.GraphQL.Type.In module Language.GraphQL.Type.In
( Argument(..) ( Argument(..)
, Arguments
, InputField(..) , InputField(..)
, InputObjectType(..) , InputObjectType(..)
, Type(..) , Type(..)
@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.Definition as Definition
-- | Single field of an 'InputObjectType'. -- | 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. -- | 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 -- type can wrap other wrapping or named types. Wrapping types are lists and
-- Non-Null types (named types are nullable by default). -- Non-Null types (named types are nullable by default).
data Type data Type
= NamedScalarType ScalarType = NamedScalarType Definition.ScalarType
| NamedEnumType EnumType | NamedEnumType Definition.EnumType
| NamedInputObjectType InputObjectType | NamedInputObjectType InputObjectType
| ListType Type | ListType Type
| NonNullScalarType ScalarType | NonNullScalarType Definition.ScalarType
| NonNullEnumType EnumType | NonNullEnumType Definition.EnumType
| NonNullInputObjectType InputObjectType | NonNullInputObjectType InputObjectType
| NonNullListType Type | NonNullListType Type
deriving Eq deriving Eq
-- | Field argument definition. -- | 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'. -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
pattern ScalarBaseType :: ScalarType -> Type pattern ScalarBaseType :: Definition.ScalarType -> Type
pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType) pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
-- | Matches either 'NamedEnumType' or 'NonNullEnumType'. -- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
pattern EnumBaseType :: EnumType -> Type pattern EnumBaseType :: Definition.EnumType -> Type
pattern EnumBaseType enumType <- (isEnumType -> Just enumType) pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'. -- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-} {-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
isScalarType :: Type -> Maybe ScalarType isScalarType :: Type -> Maybe Definition.ScalarType
isScalarType (NamedScalarType inputType) = Just inputType isScalarType (NamedScalarType inputType) = Just inputType
isScalarType (NonNullScalarType inputType) = Just inputType isScalarType (NonNullScalarType inputType) = Just inputType
isScalarType _ = Nothing isScalarType _ = Nothing
@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
isInputObjectType (NonNullInputObjectType inputType) = Just inputType isInputObjectType (NonNullInputObjectType inputType) = Just inputType
isInputObjectType _ = Nothing isInputObjectType _ = Nothing
isEnumType :: Type -> Maybe EnumType isEnumType :: Type -> Maybe Definition.EnumType
isEnumType (NamedEnumType inputType) = Just inputType isEnumType (NamedEnumType inputType) = Just inputType
isEnumType (NonNullEnumType inputType) = Just inputType isEnumType (NonNullEnumType inputType) = Just inputType
isEnumType _ = Nothing isEnumType _ = Nothing

View File

@ -18,12 +18,12 @@ module Language.GraphQL.Type.Internal
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST as Full
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out 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. -- | These types may describe the parent context of a selection set.
data CompositeType m data CompositeType m
@ -39,13 +39,15 @@ data AbstractType m
deriving Eq deriving Eq
-- | Traverses the schema and finds all referenced types. -- | 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 = collectReferencedTypes schema =
let queryTypes = traverseObjectType (query schema) HashMap.empty let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
$ mutation schema $ Schema.mutation schema
in maybe mutationTypes (`traverseObjectType` queryTypes) in maybe mutationTypes (`traverseObjectType` queryTypes)
$ subscription schema $ Schema.subscription schema
where where
collect traverser typeName element foundTypes collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes | HashMap.member typeName foundTypes = foundTypes
@ -59,17 +61,17 @@ collectReferencedTypes schema =
getField (Out.EventStreamResolver field _ _) = field getField (Out.EventStreamResolver field _ _) = field
traverseInputType (In.InputObjectBaseType objectType) = traverseInputType (In.InputObjectBaseType objectType) =
let In.InputObjectType typeName _ inputFields = objectType let In.InputObjectType typeName _ inputFields = objectType
element = InputObjectType objectType element = Schema.InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element in collect traverser typeName element
traverseInputType (In.ListBaseType listType) = traverseInputType (In.ListBaseType listType) =
traverseInputType listType traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) = traverseInputType (In.ScalarBaseType scalarType) =
let Definition.ScalarType typeName _ = 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) = traverseInputType (In.EnumBaseType enumType) =
let Definition.EnumType typeName _ _ = 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) = traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) = traverseOutputType (Out.InterfaceBaseType interfaceType) =
@ -77,23 +79,23 @@ collectReferencedTypes schema =
traverseOutputType (Out.UnionBaseType unionType) = traverseOutputType (Out.UnionBaseType unionType) =
let Out.UnionType typeName _ types = unionType let Out.UnionType typeName _ types = unionType
traverser = flip (foldr traverseObjectType) types traverser = flip (foldr traverseObjectType) types
in collect traverser typeName (UnionType unionType) in collect traverser typeName (Schema.UnionType unionType)
traverseOutputType (Out.ListBaseType listType) = traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) = traverseOutputType (Out.ScalarBaseType scalarType) =
let Definition.ScalarType typeName _ = 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) = traverseOutputType (Out.EnumBaseType enumType) =
let Definition.EnumType typeName _ _ = enumType let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType) in collect Prelude.id typeName (Schema.EnumType enumType)
traverseObjectType objectType foundTypes = traverseObjectType objectType foundTypes =
let Out.ObjectType typeName _ interfaces fields = objectType let Out.ObjectType typeName _ interfaces fields = objectType
element = ObjectType objectType element = Schema.ObjectType objectType
traverser = polymorphicTraverser interfaces (getField <$> fields) traverser = polymorphicTraverser interfaces (getField <$> fields)
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes = traverseInterfaceType interfaceType foundTypes =
let Out.InterfaceType typeName _ interfaces fields = interfaceType let Out.InterfaceType typeName _ interfaces fields = interfaceType
element = InterfaceType interfaceType element = Schema.InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes in collect traverser typeName element foundTypes
polymorphicTraverser interfaces fields polymorphicTraverser interfaces fields
@ -126,27 +128,28 @@ instanceOf objectType (AbstractUnionType unionType) =
lookupTypeCondition :: forall m lookupTypeCondition :: forall m
. Full.Name . Full.Name
-> HashMap Full.Name (Type m) -> HashMap Full.Name (Schema.Type m)
-> Maybe (CompositeType m) -> Maybe (CompositeType m)
lookupTypeCondition type' types' = lookupTypeCondition type' types' =
case HashMap.lookup type' types' of case HashMap.lookup type' types' of
Just (ObjectType objectType) -> Just $ CompositeObjectType objectType Just (Schema.ObjectType objectType) ->
Just (UnionType unionType) -> Just $ CompositeUnionType unionType Just $ CompositeObjectType objectType
Just (InterfaceType interfaceType) -> Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType
Just (Schema.InterfaceType interfaceType) ->
Just $ CompositeInterfaceType interfaceType Just $ CompositeInterfaceType interfaceType
_ -> Nothing _ -> Nothing
lookupInputType lookupInputType
:: Full.Type :: Full.Type
-> HashMap.HashMap Full.Name (Type m) -> HashMap.HashMap Full.Name (Schema.Type m)
-> Maybe In.Type -> Maybe In.Type
lookupInputType (Full.TypeNamed name) types = lookupInputType (Full.TypeNamed name) types =
case HashMap.lookup name types of case HashMap.lookup name types of
Just (ScalarType scalarType) -> Just (Schema.ScalarType scalarType) ->
Just $ In.NamedScalarType scalarType Just $ In.NamedScalarType scalarType
Just (EnumType enumType) -> Just (Schema.EnumType enumType) ->
Just $ In.NamedEnumType enumType Just $ In.NamedEnumType enumType
Just (InputObjectType objectType) -> Just (Schema.InputObjectType objectType) ->
Just $ In.NamedInputObjectType objectType Just $ In.NamedInputObjectType objectType
_ -> Nothing _ -> Nothing
lookupInputType (Full.TypeList list) types lookupInputType (Full.TypeList list) types
@ -154,18 +157,18 @@ lookupInputType (Full.TypeList list) types
<$> lookupInputType list types <$> lookupInputType list types
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
case HashMap.lookup nonNull types of case HashMap.lookup nonNull types of
Just (ScalarType scalarType) -> Just (Schema.ScalarType scalarType) ->
Just $ In.NonNullScalarType scalarType Just $ In.NonNullScalarType scalarType
Just (EnumType enumType) -> Just (Schema.EnumType enumType) ->
Just $ In.NonNullEnumType enumType Just $ In.NonNullEnumType enumType
Just (InputObjectType objectType) -> Just (Schema.InputObjectType objectType) ->
Just $ In.NonNullInputObjectType objectType Just $ In.NonNullInputObjectType objectType
_ -> Nothing _ -> Nothing
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
= In.NonNullListType = In.NonNullListType
<$> lookupInputType nonNull types <$> 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 lookupTypeField fieldName = \case
Out.ObjectBaseType objectType -> Out.ObjectBaseType objectType ->
objectChild objectType objectChild objectType
@ -177,8 +180,6 @@ lookupTypeField fieldName = \case
objectChild (Out.ObjectType _ _ _ resolvers) = objectChild (Out.ObjectType _ _ _ resolvers) =
resolverType <$> HashMap.lookup fieldName resolvers resolverType <$> HashMap.lookup fieldName resolvers
interfaceChild (Out.InterfaceType _ _ _ fields) = interfaceChild (Out.InterfaceType _ _ _ fields) =
fieldType <$> HashMap.lookup fieldName fields HashMap.lookup fieldName fields
resolverType (Out.ValueResolver objectField _) = fieldType objectField resolverType (Out.ValueResolver objectField _) = objectField
resolverType (Out.EventStreamResolver objectField _ _) = resolverType (Out.EventStreamResolver objectField _ _) = objectField
fieldType objectField
fieldType (Out.Field _ type' _) = type'

View File

@ -2,13 +2,22 @@
v. 2.0. If a copy of the MPL was not distributed with this file, You can 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/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas. -- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema module Language.GraphQL.Type.Schema
( Schema(..) ( Directive(..)
, Directives
, Schema(..)
, Type(..) , Type(..)
, schema
) where ) 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.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
@ -23,6 +32,12 @@ data Type m
| UnionType (Out.UnionType m) | UnionType (Out.UnionType m)
deriving Eq 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, -- | 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 -- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor. -- validator and executor.
@ -34,4 +49,14 @@ data Schema m = Schema
{ query :: Out.ObjectType m { query :: Out.ObjectType m
, mutation :: Maybe (Out.ObjectType m) , mutation :: Maybe (Out.ObjectType m)
, subscription :: 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
} }

View File

@ -3,11 +3,12 @@
obtain one at https://mozilla.org/MPL/2.0/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator. -- | GraphQL validator.
module Language.GraphQL.Validate module Language.GraphQL.Validate
( Error(..) ( Validation.Error(..)
, document , document
, module Language.GraphQL.Validate.Rules , module Language.GraphQL.Validate.Rules
) where ) where
@ -20,38 +21,100 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..), (><), (|>)) import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as 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.AST.Document
import Language.GraphQL.Type.Internal 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 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 qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Rules 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 = type ApplySelectionRule m a
HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m) = 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 -- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid. -- 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' = document schema' rules' document' =
runReaderT reader context runReaderT reader context
where where
context = Validation context = Validation
{ ast = document' { Validation.ast = document'
, schema = schema' , Validation.schema = schema'
, types = collectReferencedTypes 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 reader = do
rule' <- lift $ Seq.fromList rules' rule' <- lift $ Seq.fromList rules'
join $ lift $ foldr (definition rule' context) Seq.empty document' join $ lift $ foldr (definition rule' context) Seq.empty document'
definition :: Rule m definition :: Validation.Rule m
-> Validation m -> Validation m
-> Definition -> Definition
-> Seq (RuleT m) -> Seq (Validation.RuleT m)
-> Seq (RuleT m) -> Seq (Validation.RuleT m)
definition (DefinitionRule rule) _ definition' accumulator = definition (Validation.DefinitionRule rule) _ definition' accumulator =
accumulator |> rule definition' accumulator |> rule definition'
definition rule context (ExecutableDefinition definition') accumulator = definition rule context (ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule context definition' accumulator >< executableDefinition rule context definition'
@ -60,12 +123,12 @@ definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
definition rule _ (TypeSystemExtension extension _) accumulator = definition rule _ (TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension rule extension accumulator >< typeSystemExtension rule extension
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m) typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension
typeSystemExtension rule = \case typeSystemExtension rule = \case
SchemaExtension extension -> schemaExtension rule extension SchemaExtension extension -> schemaExtension rule extension
TypeExtension extension -> typeExtension rule extension TypeExtension extension -> typeExtension rule extension
typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m) typeExtension :: forall m. ApplyRule m TypeExtension
typeExtension rule = \case typeExtension rule = \case
ScalarTypeExtension _ directives' -> directives rule directives' ScalarTypeExtension _ directives' -> directives rule directives'
ObjectTypeFieldsDefinitionExtension _ _ directives' fields -> ObjectTypeFieldsDefinitionExtension _ _ directives' fields ->
@ -88,27 +151,28 @@ typeExtension rule = \case
InputObjectTypeDirectivesExtension _ directives' -> InputObjectTypeDirectivesExtension _ directives' ->
directives rule directives' directives rule directives'
schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m) schemaExtension :: forall m. ApplyRule m SchemaExtension
schemaExtension rule = \case schemaExtension rule = \case
SchemaOperationExtension directives' _ -> directives rule directives' SchemaOperationExtension directives' _ -> directives rule directives'
SchemaDirectivesExtension directives' -> directives rule directives' SchemaDirectivesExtension directives' -> directives rule directives'
executableDefinition :: Rule m executableDefinition :: forall m
. Validation.Rule m
-> Validation m -> Validation m
-> ExecutableDefinition -> ExecutableDefinition
-> Seq (RuleT m) -> Seq (Validation.RuleT m)
executableDefinition rule context (DefinitionOperation operation) = executableDefinition rule context (DefinitionOperation operation) =
operationDefinition rule context operation operationDefinition rule context operation
executableDefinition rule context (DefinitionFragment fragment) = executableDefinition rule context (DefinitionFragment fragment) =
fragmentDefinition rule context fragment fragmentDefinition rule context fragment
typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m) typeSystemDefinition :: forall m. ApplyRule m TypeSystemDefinition
typeSystemDefinition rule = \case typeSystemDefinition rule = \case
SchemaDefinition directives' _ -> directives rule directives' SchemaDefinition directives' _ -> directives rule directives'
TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition' TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition'
DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments' DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments'
typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m) typeDefinition :: forall m. ApplyRule m TypeDefinition
typeDefinition rule = \case typeDefinition rule = \case
ScalarTypeDefinition _ _ directives' -> directives rule directives' ScalarTypeDefinition _ _ directives' -> directives rule directives'
ObjectTypeDefinition _ _ _ directives' fields -> ObjectTypeDefinition _ _ _ directives' fields ->
@ -122,30 +186,31 @@ typeDefinition rule = \case
-> directives rule directives' -> directives rule directives'
<> foldMap (inputValueDefinition rule) fields <> foldMap (inputValueDefinition rule) fields
enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m) enumValueDefinition :: forall m. ApplyRule m EnumValueDefinition
enumValueDefinition rule (EnumValueDefinition _ _ directives') = enumValueDefinition rule (EnumValueDefinition _ _ directives') =
directives rule directives' directives rule directives'
fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m) fieldDefinition :: forall m. ApplyRule m FieldDefinition
fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') = fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') =
directives rule directives' >< argumentsDefinition rule arguments' directives rule directives' >< argumentsDefinition rule arguments'
argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m) argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition
argumentsDefinition rule (ArgumentsDefinition definitions) = argumentsDefinition rule (ArgumentsDefinition definitions) =
foldMap (inputValueDefinition rule) definitions foldMap (inputValueDefinition rule) definitions
inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m) inputValueDefinition :: forall m. ApplyRule m InputValueDefinition
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') = inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
directives rule directives' directives rule directives'
operationDefinition :: Rule m operationDefinition :: forall m
. Validation.Rule m
-> Validation m -> Validation m
-> OperationDefinition -> OperationDefinition
-> Seq (RuleT m) -> Seq (Validation.RuleT m)
operationDefinition rule context operation operationDefinition rule context operation
| OperationDefinitionRule operationRule <- rule = | Validation.OperationDefinitionRule operationRule <- rule =
pure $ operationRule operation pure $ operationRule operation
| VariablesRule variablesRule <- rule | Validation.VariablesRule variablesRule <- rule
, OperationDefinition _ _ variables _ _ _ <- operation , OperationDefinition _ _ variables _ _ _ <- operation
= Seq.fromList (variableDefinition rule <$> variables) = Seq.fromList (variableDefinition rule <$> variables)
|> variablesRule variables |> variablesRule variables
@ -155,11 +220,13 @@ operationDefinition rule context operation
= selectionSet types' rule (getRootType operationType) selections = selectionSet types' rule (getRootType operationType) selections
>< directives rule directives' >< directives rule directives'
where where
types' = types context types' = Validation.types context
getRootType Query = Just $ Out.NamedObjectType $ query $ schema context getRootType Query =
getRootType Mutation = Out.NamedObjectType <$> mutation (schema context) Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context
getRootType Mutation =
Out.NamedObjectType <$> Schema.mutation (Validation.schema context)
getRootType Subscription = 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 :: forall m. Schema.Type m -> Maybe (Out.Type m)
typeToOut (Schema.ObjectType objectType) = 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 (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
typeToOut _ = Nothing typeToOut _ = Nothing
variableDefinition :: Rule m -> VariableDefinition -> RuleT m variableDefinition :: forall m
variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) = . Validation.Rule m
-> VariableDefinition
-> Validation.RuleT m
variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) =
maybe (lift mempty) rule value maybe (lift mempty) rule value
variableDefinition _ _ = lift mempty variableDefinition _ _ = lift mempty
fragmentDefinition :: forall m fragmentDefinition :: forall m
. Rule m . Validation.Rule m
-> Validation m -> Validation m
-> FragmentDefinition -> FragmentDefinition
-> Seq (RuleT m) -> Seq (Validation.RuleT m)
fragmentDefinition (FragmentDefinitionRule rule) _ definition' = fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
pure $ rule definition' pure $ rule definition'
fragmentDefinition rule context definition' fragmentDefinition rule context definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition' | FragmentDefinition _ typeCondition directives' selections _ <- definition'
, FragmentRule definitionRule _ <- rule , Validation.FragmentRule definitionRule _ <- rule
= applyToChildren typeCondition directives' selections = applyToChildren typeCondition directives' selections
|> definitionRule definition' |> definitionRule definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition' | FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections = applyToChildren typeCondition directives' selections
where where
types' = types context types' = Validation.types context
applyToChildren typeCondition directives' selections applyToChildren typeCondition directives' selections
= selectionSet types' rule (lookupType' typeCondition) selections = selectionSet types' rule (lookupType' typeCondition) selections
>< directives rule directives' >< directives rule directives'
@ -204,12 +274,12 @@ lookupType :: forall m
lookupType typeCondition types' = HashMap.lookup typeCondition types' lookupType typeCondition types' = HashMap.lookup typeCondition types'
>>= typeToOut >>= 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 selectionSet types' rule = foldMap . selection types' rule
selection :: forall m. ApplyRule m Selection selection :: forall m. ApplySelectionRule m Selection
selection types' rule objectType selection' selection types' rule objectType selection'
| SelectionRule selectionRule <- rule = | Validation.SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule objectType selection' applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren | otherwise = applyToChildren
where where
@ -221,33 +291,37 @@ selection types' rule objectType selection'
FragmentSpreadSelection fragmentSpread' -> FragmentSpreadSelection fragmentSpread' ->
fragmentSpread rule fragmentSpread' fragmentSpread rule fragmentSpread'
field :: forall m. ApplyRule m Field field :: forall m. ApplySelectionRule m Field
field types' rule objectType field' = go field' field types' rule objectType field' = go field'
where where
go (Field _ fieldName arguments' directives' selections _) go (Field _ fieldName _ _ _ _)
| ArgumentsRule fieldRule _ <- rule | Validation.FieldRule fieldRule <- rule =
= applyToChildren fieldName arguments' directives' selections applyToChildren fieldName |> fieldRule objectType field'
|> fieldRule field' | Validation.ArgumentsRule argumentsRule _ <- rule =
| otherwise = applyToChildren fieldName |> argumentsRule objectType field'
applyToChildren fieldName arguments' directives' selections | otherwise = applyToChildren fieldName
applyToChildren fieldName arguments' directives' selections = typeFieldType (Out.Field _ type' _) = type'
let child = objectType >>= lookupTypeField fieldName applyToChildren fieldName =
in selectionSet types' rule child selections let Field _ _ arguments' directives' selections _ = field'
fieldType = objectType
>>= fmap typeFieldType . lookupTypeField fieldName
in selectionSet types' rule fieldType selections
>< directives rule directives' >< directives rule directives'
>< arguments rule arguments' >< arguments rule arguments'
arguments :: Rule m -> [Argument] -> Seq (RuleT m) arguments :: forall m. ApplyRule m [Argument]
arguments = (.) Seq.fromList . fmap . argument arguments = (.) Seq.fromList . fmap . argument
argument :: Rule m -> Argument -> RuleT m argument :: forall m. Validation.Rule m -> Argument -> Validation.RuleT m
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value argument (Validation.ValueRule rule _) (Argument _ (Node value _) _) =
rule value
argument _ _ = lift mempty argument _ _ = lift mempty
inlineFragment :: forall m. ApplyRule m InlineFragment inlineFragment :: forall m. ApplySelectionRule m InlineFragment
inlineFragment types' rule objectType inlineFragment' = go inlineFragment' inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
where where
go (InlineFragment optionalType directives' selections _) go (InlineFragment optionalType directives' selections _)
| FragmentRule _ fragmentRule <- rule | Validation.FragmentRule _ fragmentRule <- rule
= applyToChildren (refineTarget optionalType) directives' selections = applyToChildren (refineTarget optionalType) directives' selections
|> fragmentRule inlineFragment' |> fragmentRule inlineFragment'
| otherwise = applyToChildren (refineTarget optionalType) directives' selections | otherwise = applyToChildren (refineTarget optionalType) directives' selections
@ -257,24 +331,24 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
= selectionSet types' rule objectType' selections = selectionSet types' rule objectType' selections
>< directives rule directives' >< directives rule directives'
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m) fragmentSpread :: forall m. ApplyRule m FragmentSpread
fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _) fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
| FragmentSpreadRule fragmentRule <- rule = | Validation.FragmentSpreadRule fragmentRule <- rule =
applyToChildren |> fragmentRule fragmentSpread' applyToChildren |> fragmentRule fragmentSpread'
| otherwise = applyToChildren | otherwise = applyToChildren
where where
applyToChildren = directives rule directives' 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' directives rule directives'
| DirectivesRule directivesRule <- rule = | Validation.DirectivesRule directivesRule <- rule =
applyToChildren |> directivesRule directiveList applyToChildren |> directivesRule directiveList
| otherwise = applyToChildren | otherwise = applyToChildren
where where
directiveList = toList directives' directiveList = toList directives'
applyToChildren = foldMap (directive rule) directiveList applyToChildren = foldMap (directive rule) directiveList
directive :: Rule m -> Directive -> Seq (RuleT m) directive :: forall m. ApplyRule m Directive
directive (ArgumentsRule _ argumentsRule) directive' = directive (Validation.ArgumentsRule _ argumentsRule) directive' =
pure $ argumentsRule directive' pure $ argumentsRule directive'
directive rule (Directive _ arguments' _) = arguments rule arguments' directive rule (Directive _ arguments' _) = arguments rule arguments'

View File

@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule , fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, knownArgumentNamesRule
, noFragmentCyclesRule , noFragmentCyclesRule
, noUndefinedVariablesRule , noUndefinedVariablesRule
, noUnusedFragmentsRule , noUnusedFragmentsRule
@ -44,7 +45,7 @@ import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn) import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -71,6 +72,7 @@ specifiedRules =
, fieldsOnCorrectTypeRule , fieldsOnCorrectTypeRule
, scalarLeafsRule , scalarLeafsRule
-- Arguments. -- Arguments.
, knownArgumentNamesRule
, uniqueArgumentNamesRule , uniqueArgumentNamesRule
-- Fragments. -- Fragments.
, uniqueFragmentNamesRule , uniqueFragmentNamesRule
@ -134,20 +136,20 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
forSpread accumulator fragmentSelection forSpread accumulator fragmentSelection
InlineFragmentSelection fragmentSelection -> InlineFragmentSelection fragmentSelection ->
forInline accumulator fragmentSelection forInline accumulator fragmentSelection
forField accumulator (Field alias name _ directives _ _) forField accumulator (Field alias name _ directives' _ _)
| any skip directives = pure accumulator | any skip directives' = pure accumulator
| Just aliasedName <- alias = pure | Just aliasedName <- alias = pure
$ HashSet.insert aliasedName accumulator $ HashSet.insert aliasedName accumulator
| otherwise = pure $ HashSet.insert name accumulator | otherwise = pure $ HashSet.insert name accumulator
forSpread accumulator (FragmentSpread fragmentName directives _) forSpread accumulator (FragmentSpread fragmentName directives' _)
| any skip directives = pure accumulator | any skip directives' = pure accumulator
| otherwise = do | otherwise = do
inVisitetFragments <- gets $ HashSet.member fragmentName inVisitetFragments <- gets $ HashSet.member fragmentName
if inVisitetFragments if inVisitetFragments
then pure accumulator then pure accumulator
else collectFromSpread fragmentName accumulator else collectFromSpread fragmentName accumulator
forInline accumulator (InlineFragment maybeType directives selections _) forInline accumulator (InlineFragment maybeType directives' selections _)
| any skip directives = pure accumulator | any skip directives' = pure accumulator
| Just typeCondition <- maybeType = | Just typeCondition <- maybeType =
collectFromFragment typeCondition selections accumulator collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator | otherwise = HashSet.union accumulator
@ -494,7 +496,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
uniqueArgumentNamesRule :: forall m. Rule m uniqueArgumentNamesRule :: forall m. Rule m
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
where where
fieldRule (Field _ _ arguments _ _ _) = fieldRule _ (Field _ _ arguments _ _ _) =
lift $ filterDuplicates extract "argument" arguments lift $ filterDuplicates extract "argument" arguments
directiveRule (Directive _ arguments _) = directiveRule (Directive _ arguments _) =
lift $ filterDuplicates extract "argument" arguments lift $ filterDuplicates extract "argument" arguments
@ -519,9 +521,9 @@ filterDuplicates extract nodeType = Seq.fromList
where where
getName = fst . extract getName = fst . extract
equalByName lhs rhs = getName lhs == getName rhs equalByName lhs rhs = getName lhs == getName rhs
makeError directives = Error makeError directives' = Error
{ message = makeMessage $ head directives { message = makeMessage $ head directives'
, locations = snd . extract <$> directives , locations = snd . extract <$> directives'
} }
makeMessage directive = concat makeMessage directive = concat
[ "There can be only one " [ "There can be only one "
@ -614,11 +616,11 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
filterSelections' = filterSelections variableFilter filterSelections' = filterSelections variableFilter
variableFilter :: Selection -> ValidationState m (Name, [Location]) variableFilter :: Selection -> ValidationState m (Name, [Location])
variableFilter (InlineFragmentSelection inline) variableFilter (InlineFragmentSelection inline)
| InlineFragment _ directives _ _ <- inline = | InlineFragment _ directives' _ _ <- inline =
lift $ lift $ mapDirectives directives lift $ lift $ mapDirectives directives'
variableFilter (FieldSelection fieldSelection) variableFilter (FieldSelection fieldSelection)
| Field _ _ arguments directives _ _ <- fieldSelection = | Field _ _ arguments directives' _ _ <- fieldSelection =
lift $ lift $ mapArguments arguments <> mapDirectives directives lift $ lift $ mapArguments arguments <> mapDirectives directives'
variableFilter (FragmentSpreadSelection spread) variableFilter (FragmentSpreadSelection spread)
| FragmentSpread fragmentName _ _ <- spread = do | FragmentSpread fragmentName _ _ <- spread = do
definitions <- lift $ asks ast definitions <- lift $ asks ast
@ -628,9 +630,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
Just (viewFragment -> Just fragmentDefinition) Just (viewFragment -> Just fragmentDefinition)
| not visited -> diveIntoSpread fragmentDefinition | not visited -> diveIntoSpread fragmentDefinition
_ -> lift $ lift mempty _ -> lift $ lift mempty
diveIntoSpread (FragmentDefinition _ _ directives selections _) diveIntoSpread (FragmentDefinition _ _ directives' selections _)
= filterSelections' selections = filterSelections' selections
>>= lift . mapReaderT (<> mapDirectives directives) . pure >>= lift . mapReaderT (<> mapDirectives directives') . pure
findDirectiveVariables (Directive _ arguments _) = mapArguments arguments findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapArguments = Seq.fromList . mapMaybe findArgumentVariables
mapDirectives = foldMap findDirectiveVariables 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 target field of a field selection must be defined on the scoped type of
-- the selection set. There are no limitations on alias names. -- the selection set. There are no limitations on alias names.
fieldsOnCorrectTypeRule :: forall m. Rule m fieldsOnCorrectTypeRule :: forall m. Rule m
fieldsOnCorrectTypeRule = SelectionRule go fieldsOnCorrectTypeRule = FieldRule fieldRule
where where
go (Just objectType) (FieldSelection fieldSelection) = fieldRule parentType (Field _ fieldName _ _ _ location)
fieldRule objectType fieldSelection | Just objectType <- parentType
go _ _ = lift mempty , Nothing <- lookupTypeField fieldName objectType
fieldRule objectType (Field _ fieldName _ _ _ location)
| Nothing <- lookupTypeField fieldName objectType
, Just typeName <- compositeTypeName objectType = pure $ Error , Just typeName <- compositeTypeName objectType = pure $ Error
{ message = errorMessage fieldName typeName { message = errorMessage fieldName typeName
, locations = [location] , locations = [location]
@ -702,6 +702,8 @@ fieldsOnCorrectTypeRule = SelectionRule go
, Text.unpack typeName , Text.unpack typeName
, "\"." , "\"."
] ]
compositeTypeName :: forall m. Out.Type m -> Maybe Name
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
Just typeName Just typeName
compositeTypeName (Out.InterfaceBaseType interfaceType) = compositeTypeName (Out.InterfaceBaseType interfaceType) =
@ -719,14 +721,13 @@ fieldsOnCorrectTypeRule = SelectionRule go
-- | Field selections on scalars or enums are never allowed, because they are -- | Field selections on scalars or enums are never allowed, because they are
-- the leaf nodes of any GraphQL query. -- the leaf nodes of any GraphQL query.
scalarLeafsRule :: forall m. Rule m scalarLeafsRule :: forall m. Rule m
scalarLeafsRule = SelectionRule go scalarLeafsRule = FieldRule fieldRule
where where
go (Just objectType) (FieldSelection fieldSelection) = fieldRule parentType selectionField@(Field _ fieldName _ _ _ _)
fieldRule objectType fieldSelection | Just objectType <- parentType
go _ _ = lift mempty , Just field <- lookupTypeField fieldName objectType =
fieldRule objectType selectionField@(Field _ fieldName _ _ _ _) let Out.Field _ fieldType _ = field
| Just fieldType <- lookupTypeField fieldName objectType = in lift $ check fieldType selectionField
lift $ check fieldType selectionField
| otherwise = lift mempty | otherwise = lift mempty
check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
checkNotEmpty typeName checkNotEmpty typeName
@ -765,3 +766,49 @@ scalarLeafsRule = SelectionRule go
{ message = errorMessage { message = errorMessage
, locations = [location] , 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
, "\"."
]

View File

@ -29,6 +29,7 @@ data Validation m = Validation
{ ast :: Document { ast :: Document
, schema :: Schema m , schema :: Schema m
, types :: HashMap Name (Schema.Type m) , types :: HashMap Name (Schema.Type m)
, directives :: Schema.Directives
} }
-- | 'Rule' assigns a function to each AST node that can be validated. If the -- | '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) | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m) | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
| FragmentSpreadRule (FragmentSpread -> 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) | DirectivesRule ([Directive] -> RuleT m)
| VariablesRule ([VariableDefinition] -> RuleT m) | VariablesRule ([VariableDefinition] -> RuleT m)
| ValueRule (Value -> RuleT m) (ConstValue -> RuleT m) | ValueRule (Value -> RuleT m) (ConstValue -> RuleT m)

View File

@ -1,4 +1,4 @@
resolver: lts-16.15 resolver: lts-16.16
packages: packages:
- . - .

View File

@ -25,11 +25,12 @@ import Test.Hspec (Spec, context, describe, it, shouldBe)
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
schema :: Schema (Either SomeException) philosopherSchema :: Schema (Either SomeException)
schema = Schema philosopherSchema = Schema
{ query = queryType { query = queryType
, mutation = Nothing , mutation = Nothing
, subscription = Just subscriptionType , subscription = Just subscriptionType
, directives = HashMap.empty
} }
queryType :: Out.ObjectType (Either SomeException) queryType :: Out.ObjectType (Either SomeException)
@ -79,7 +80,8 @@ type EitherStreamOrValue = Either
(Response Aeson.Value) (Response Aeson.Value)
execute' :: Document -> Either SomeException EitherStreamOrValue 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 :: Spec
spec = spec =

View File

@ -21,11 +21,12 @@ import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
schema :: Schema IO petSchema :: Schema IO
schema = Schema petSchema = Schema
{ query = queryType { query = queryType
, mutation = Nothing , mutation = Nothing
, subscription = Just subscriptionType , subscription = Just subscriptionType
, directives = HashMap.empty
} }
queryType :: ObjectType IO queryType :: ObjectType IO
@ -132,7 +133,7 @@ validate :: Text -> [Error]
validate queryString = validate queryString =
case parse AST.document "" queryString of case parse AST.document "" queryString of
Left _ -> [] Left _ -> []
Right ast -> toList $ document schema specifiedRules ast Right ast -> toList $ document petSchema specifiedRules ast
spec :: Spec spec :: Spec
spec = spec =
@ -544,3 +545,34 @@ spec =
, locations = [AST.Location 4 19] , locations = [AST.Location 4 19]
} }
in validate queryString `shouldBe` [expected] 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]

View File

@ -19,8 +19,7 @@ import Test.Hspec.GraphQL
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = Schema experimentalResolver = schema queryType
{ query = queryType, mutation = Nothing, subscription = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"

View File

@ -67,8 +67,7 @@ sizeFieldType
$ pure $ snd size $ pure $ snd size
toSchema :: Text -> (Text, Value) -> Schema IO toSchema :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = Schema toSchema t (_, resolve) = schema queryType
{ query = queryType, mutation = Nothing, subscription = Nothing }
where where
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType] garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty

View File

@ -23,11 +23,12 @@ hatType = Out.ObjectType "Hat" Nothing []
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty) $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 60 $ pure $ Int 60
schema :: Schema IO garmentSchema :: Schema IO
schema = Schema garmentSchema = Schema
{ query = Out.ObjectType "Query" Nothing [] hatFieldResolver { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
, mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
, subscription = Nothing , subscription = Nothing
, directives = HashMap.empty
} }
where where
garment = pure $ Object $ HashMap.fromList garment = pure $ Object $ HashMap.fromList
@ -57,7 +58,7 @@ spec =
[ "circumference" .= (60 :: Int) [ "circumference" .= (60 :: Int)
] ]
] ]
actual <- graphql schema querySource actual <- graphql garmentSchema querySource
actual `shouldResolveTo` expected actual `shouldResolveTo` expected
it "chooses Mutation" $ do it "chooses Mutation" $ do
@ -70,5 +71,5 @@ spec =
$ object $ object
[ "incrementCircumference" .= (61 :: Int) [ "incrementCircumference" .= (61 :: Int)
] ]
actual <- graphql schema querySource actual <- graphql garmentSchema querySource
actual `shouldResolveTo` expected actual `shouldResolveTo` expected

View File

@ -357,10 +357,10 @@ spec = describe "Star Wars Query Tests" $ do
testQuery :: Text -> Aeson.Value -> Expectation testQuery :: Text -> Aeson.Value -> Expectation
testQuery q expected = testQuery q expected =
let Right (Right actual) = graphql schema q let Right (Right actual) = graphql starWarsSchema q
in Aeson.Object actual `shouldBe` expected in Aeson.Object actual `shouldBe` expected
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected = 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 in Aeson.Object actual `shouldBe` expected

View File

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Test.StarWars.Schema module Test.StarWars.Schema
( schema ( starWarsSchema
) where ) where
import Control.Monad.Catch (MonadThrow(..), SomeException) 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 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: Schema (Either SomeException) starWarsSchema :: Schema (Either SomeException)
schema = Schema starWarsSchema = schema queryType
{ query = queryType
, mutation = Nothing
, subscription = Nothing
}
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroFieldResolver) [ ("hero", heroFieldResolver)