Validate arguments are defined
This commit is contained in:
@ -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'
|
||||
|
||||
Reference in New Issue
Block a user