graphql/src/Language/GraphQL/Validate.hs

553 lines
23 KiB
Haskell
Raw Normal View History

2020-07-20 21:29:12 +02:00
{- This Source Code Form is subject to the terms of the Mozilla Public License,
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/. -}
2020-09-17 10:33:37 +02:00
{-# LANGUAGE LambdaCase #-}
2020-10-04 18:51:21 +02:00
{-# LANGUAGE RecordWildCards #-}
2020-09-28 07:06:15 +02:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
2020-07-20 21:29:12 +02:00
2020-07-24 21:34:31 +02:00
-- | GraphQL validator.
2020-07-20 21:29:12 +02:00
module Language.GraphQL.Validate
2020-09-28 07:06:15 +02:00
( Validation.Error(..)
2020-07-20 21:29:12 +02:00
, document
, module Language.GraphQL.Validate.Rules
) where
import Control.Monad (join)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (runReaderT)
import Data.Foldable (toList)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
2020-07-20 21:29:12 +02:00
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
2020-09-28 07:06:15 +02:00
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
2020-09-30 05:14:52 +02:00
import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.Type.Internal
2020-09-28 07:06:15 +02:00
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
2020-09-28 07:06:15 +02:00
import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema
2020-07-20 21:29:12 +02:00
import Language.GraphQL.Validate.Rules
2020-09-28 07:06:15 +02:00
import Language.GraphQL.Validate.Validation (Validation(Validation))
import qualified Language.GraphQL.Validate.Validation as Validation
2020-07-20 21:29:12 +02:00
2020-09-28 07:06:15 +02:00
type ApplySelectionRule m a
2020-09-30 05:14:52 +02:00
= HashMap Full.Name (Schema.Type m)
2020-09-28 07:06:15 +02:00
-> Validation.Rule m
-> Maybe (Out.Type m)
-> a
-> Seq (Validation.RuleT m)
type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.RuleT m)
2020-07-24 21:34:31 +02:00
-- | Validates a document and returns a list of found errors. If the returned
-- list is empty, the document is valid.
2020-09-28 07:06:15 +02:00
document :: forall m
. Schema m
-> [Validation.Rule m]
2020-09-30 05:14:52 +02:00
-> Full.Document
2020-09-28 07:06:15 +02:00
-> Seq Validation.Error
2020-07-20 21:29:12 +02:00
document schema' rules' document' =
runReaderT reader context
2020-07-20 21:29:12 +02:00
where
context = Validation
2020-09-28 07:06:15 +02:00
{ Validation.ast = document'
, Validation.schema = schema'
, Validation.types = collectReferencedTypes schema'
, Validation.directives = allDirectives
2020-07-20 21:29:12 +02:00
}
2020-09-28 07:06:15 +02:00
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'
2020-09-28 07:06:15 +02:00
definition :: Validation.Rule m
-> Validation m
2020-09-30 05:14:52 +02:00
-> Full.Definition
2020-09-28 07:06:15 +02:00
-> Seq (Validation.RuleT m)
-> Seq (Validation.RuleT m)
definition (Validation.DefinitionRule rule) _ definition' accumulator =
2020-09-17 10:33:37 +02:00
accumulator |> rule definition'
2020-09-30 05:14:52 +02:00
definition rule context (Full.ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule context definition'
2020-09-30 05:14:52 +02:00
definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
accumulator >< typeSystemDefinition context rule typeSystemDefinition'
definition rule context (Full.TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension context rule extension
typeSystemExtension :: forall m
. Validation m
-> ApplyRule m Full.TypeSystemExtension
typeSystemExtension context rule = \case
Full.SchemaExtension extension -> schemaExtension context rule extension
Full.TypeExtension extension -> typeExtension context rule extension
typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
typeExtension context rule = \case
Full.ScalarTypeExtension _ directives' ->
directives context rule scalarLocation directives'
2020-09-30 05:14:52 +02:00
Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
-> directives context rule objectLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (fieldDefinition context rule) fields
Full.ObjectTypeDirectivesExtension _ _ directives' ->
directives context rule objectLocation directives'
2020-09-30 05:14:52 +02:00
Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
-> directives context rule interfaceLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (fieldDefinition context rule) fields
Full.InterfaceTypeDirectivesExtension _ directives' ->
directives context rule interfaceLocation directives'
2020-09-30 05:14:52 +02:00
Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
directives context rule unionLocation directives'
2020-09-30 05:14:52 +02:00
Full.UnionTypeDirectivesExtension _ directives' ->
directives context rule unionLocation directives'
2020-09-30 05:14:52 +02:00
Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
-> directives context rule enumLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (enumValueDefinition context rule) values
Full.EnumTypeDirectivesExtension _ directives' ->
directives context rule enumLocation directives'
2020-09-30 05:14:52 +02:00
Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
-> directives context rule inputObjectLocation directives'
>< foldMap forEachInputFieldDefinition fields
2020-09-30 05:14:52 +02:00
Full.InputObjectTypeDirectivesExtension _ directives' ->
directives context rule inputObjectLocation directives'
where
forEachInputFieldDefinition =
inputValueDefinition context rule inputFieldDefinitionLocation
2020-09-30 05:14:52 +02:00
schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
schemaExtension context rule = \case
Full.SchemaOperationExtension directives' _ ->
directives context rule schemaLocation directives'
Full.SchemaDirectivesExtension directives' ->
directives context rule schemaLocation directives'
schemaLocation :: DirectiveLocation
schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
interfaceLocation :: DirectiveLocation
interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
objectLocation :: DirectiveLocation
objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object
unionLocation :: DirectiveLocation
unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union
enumLocation :: DirectiveLocation
enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum
inputObjectLocation :: DirectiveLocation
inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject
scalarLocation :: DirectiveLocation
scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar
enumValueLocation :: DirectiveLocation
enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue
fieldDefinitionLocation :: DirectiveLocation
fieldDefinitionLocation =
TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
inputFieldDefinitionLocation :: DirectiveLocation
inputFieldDefinitionLocation =
TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
argumentDefinitionLocation :: DirectiveLocation
argumentDefinitionLocation =
TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
queryLocation :: DirectiveLocation
queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query
mutationLocation :: DirectiveLocation
mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation
subscriptionLocation :: DirectiveLocation
subscriptionLocation =
ExecutableDirectiveLocation DirectiveLocation.Subscription
fieldLocation :: DirectiveLocation
fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field
fragmentDefinitionLocation :: DirectiveLocation
fragmentDefinitionLocation =
ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition
fragmentSpreadLocation :: DirectiveLocation
fragmentSpreadLocation =
ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
inlineFragmentLocation :: DirectiveLocation
inlineFragmentLocation =
ExecutableDirectiveLocation DirectiveLocation.InlineFragment
2020-09-28 07:06:15 +02:00
executableDefinition :: forall m
. Validation.Rule m
-> Validation m
2020-09-30 05:14:52 +02:00
-> Full.ExecutableDefinition
2020-09-28 07:06:15 +02:00
-> Seq (Validation.RuleT m)
2020-09-30 05:14:52 +02:00
executableDefinition rule context (Full.DefinitionOperation operation) =
operationDefinition rule context operation
2020-09-30 05:14:52 +02:00
executableDefinition rule context (Full.DefinitionFragment fragment) =
fragmentDefinition rule context fragment
2020-09-30 05:14:52 +02:00
typeSystemDefinition :: forall m
. Validation m
-> ApplyRule m Full.TypeSystemDefinition
typeSystemDefinition context rule = \case
Full.SchemaDefinition directives' _ ->
directives context rule schemaLocation directives'
2020-09-30 05:14:52 +02:00
Full.TypeDefinition typeDefinition' ->
typeDefinition context rule typeDefinition'
Full.DirectiveDefinition _ _ arguments' _ ->
argumentsDefinition context rule arguments'
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
typeDefinition context rule = \case
Full.ScalarTypeDefinition _ _ directives' ->
directives context rule scalarLocation directives'
2020-09-30 05:14:52 +02:00
Full.ObjectTypeDefinition _ _ _ directives' fields
-> directives context rule objectLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (fieldDefinition context rule) fields
Full.InterfaceTypeDefinition _ _ directives' fields
-> directives context rule interfaceLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (fieldDefinition context rule) fields
Full.UnionTypeDefinition _ _ directives' _ ->
directives context rule unionLocation directives'
2020-09-30 05:14:52 +02:00
Full.EnumTypeDefinition _ _ directives' values
-> directives context rule enumLocation directives'
2020-09-30 05:14:52 +02:00
>< foldMap (enumValueDefinition context rule) values
Full.InputObjectTypeDefinition _ _ directives' fields
-> directives context rule inputObjectLocation directives'
<> foldMap forEachInputFieldDefinition fields
where
forEachInputFieldDefinition =
inputValueDefinition context rule inputFieldDefinitionLocation
2020-09-30 05:14:52 +02:00
enumValueDefinition :: forall m
. Validation m
-> ApplyRule m Full.EnumValueDefinition
enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
directives context rule enumValueLocation directives'
2020-09-30 05:14:52 +02:00
fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
= directives context rule fieldDefinitionLocation directives'
2020-09-30 05:14:52 +02:00
>< argumentsDefinition context rule arguments'
argumentsDefinition :: forall m
. Validation m
-> ApplyRule m Full.ArgumentsDefinition
argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
foldMap forEachArgument definitions
where
forEachArgument =
inputValueDefinition context rule argumentDefinitionLocation
2020-09-30 05:14:52 +02:00
inputValueDefinition :: forall m
. Validation m
-> Validation.Rule m
-> DirectiveLocation
-> Full.InputValueDefinition
-> Seq (Validation.RuleT m)
inputValueDefinition context rule directiveLocation definition' =
let Full.InputValueDefinition _ _ _ _ directives' = definition'
in directives context rule directiveLocation directives'
2020-09-17 10:33:37 +02:00
2020-09-28 07:06:15 +02:00
operationDefinition :: forall m
. Validation.Rule m
-> Validation m
2020-09-30 05:14:52 +02:00
-> Full.OperationDefinition
2020-09-28 07:06:15 +02:00
-> Seq (Validation.RuleT m)
operationDefinition rule context operation
2020-09-28 07:06:15 +02:00
| Validation.OperationDefinitionRule operationRule <- rule =
2020-09-19 18:18:26 +02:00
pure $ operationRule operation
2020-09-28 07:06:15 +02:00
| Validation.VariablesRule variablesRule <- rule
2020-09-30 05:14:52 +02:00
, Full.OperationDefinition _ _ variables _ _ _ <- operation =
foldMap (variableDefinition context rule) variables |> variablesRule variables
| Full.SelectionSet selections _ <- operation =
selectionSet context types' rule queryRoot selections
| Full.OperationDefinition Full.Query _ _ directives' selections _ <- operation
= selectionSet context types' rule queryRoot selections
>< directives context rule queryLocation directives'
| Full.OperationDefinition Full.Mutation _ _ directives' selections _ <- operation =
let root = Out.NamedObjectType <$> Schema.mutation schema'
in selectionSet context types' rule root selections
>< directives context rule mutationLocation directives'
| Full.OperationDefinition Full.Subscription _ _ directives' selections _ <- operation =
let root = Out.NamedObjectType <$> Schema.subscription schema'
in selectionSet context types' rule root selections
>< directives context rule subscriptionLocation directives'
where
schema' = Validation.schema context
queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
2020-09-28 07:06:15 +02:00
types' = Validation.types context
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
typeToOut (Schema.ObjectType objectType) =
Just $ Out.NamedObjectType objectType
typeToOut (Schema.InterfaceType interfaceType) =
Just $ Out.NamedInterfaceType interfaceType
typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
typeToOut _ = Nothing
2020-09-28 07:06:15 +02:00
variableDefinition :: forall m
2020-09-30 05:14:52 +02:00
. Validation m
-> ApplyRule m Full.VariableDefinition
variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
| Just defaultValue' <- value'
, variableType <- lookupInputType typeName $ Validation.types context =
2020-10-04 18:51:21 +02:00
constValue rule variableType defaultValue'
2020-09-30 05:14:52 +02:00
variableDefinition _ _ _ = mempty
constValue :: forall m
2020-09-28 07:06:15 +02:00
. Validation.Rule m
2020-09-30 05:14:52 +02:00
-> Maybe In.Type
2020-10-04 18:51:21 +02:00
-> Full.Node Full.ConstValue
2020-09-30 05:14:52 +02:00
-> Seq (Validation.RuleT m)
constValue (Validation.ValueRule _ rule) valueType = go valueType
where
2020-10-04 18:51:21 +02:00
go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
2020-09-30 05:14:52 +02:00
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|> rule inputObjectType value'
2020-10-04 18:51:21 +02:00
go listType value'@(Full.Node (Full.ConstList values) location')
= embedListLocation go listType values location'
2020-09-30 05:14:52 +02:00
|> rule listType value'
go anotherValue value' = pure $ rule anotherValue value'
2020-10-04 18:51:21 +02:00
forEach inputObjectType Full.ObjectField{value = value', ..} =
go (valueTypeByName name inputObjectType) value'
2020-09-30 05:14:52 +02:00
constValue _ _ = const mempty
inputFieldType :: In.InputField -> In.Type
inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType'
valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type
valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) =
let In.InputObjectType _ _ fieldTypes = inputObjectType
in inputFieldType <$> HashMap.lookup fieldName fieldTypes
valueTypeByName _ _ = Nothing
fragmentDefinition :: forall m
2020-09-28 07:06:15 +02:00
. Validation.Rule m
-> Validation m
2020-09-30 05:14:52 +02:00
-> Full.FragmentDefinition
2020-09-28 07:06:15 +02:00
-> Seq (Validation.RuleT m)
fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
pure $ rule definition'
fragmentDefinition rule context definition'
2020-09-30 05:14:52 +02:00
| Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
2020-09-28 07:06:15 +02:00
, Validation.FragmentRule definitionRule _ <- rule
= applyToChildren typeCondition directives' selections
|> definitionRule definition'
2020-09-30 05:14:52 +02:00
| Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections
2020-09-07 22:01:49 +02:00
where
2020-09-28 07:06:15 +02:00
types' = Validation.types context
applyToChildren typeCondition directives' selections
2020-09-30 05:14:52 +02:00
= selectionSet context types' rule (lookupType' typeCondition) selections
>< directives context rule fragmentDefinitionLocation directives'
lookupType' = flip lookupType types'
2020-09-07 22:01:49 +02:00
lookupType :: forall m
2020-09-30 05:14:52 +02:00
. Full.TypeCondition
-> HashMap Full.Name (Schema.Type m)
-> Maybe (Out.Type m)
lookupType typeCondition types' = HashMap.lookup typeCondition types'
>>= typeToOut
2020-09-30 05:14:52 +02:00
selectionSet :: Traversable t
=> forall m
. Validation m
-> ApplySelectionRule m (t Full.Selection)
selectionSet context types' rule = foldMap . selection context types' rule
2020-09-30 05:14:52 +02:00
selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection
selection context types' rule objectType selection'
2020-09-28 07:06:15 +02:00
| Validation.SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren
2020-08-28 08:32:21 +02:00
where
applyToChildren =
case selection' of
2020-09-30 05:14:52 +02:00
Full.FieldSelection field' ->
field context types' rule objectType field'
Full.InlineFragmentSelection inlineFragment' ->
inlineFragment context types' rule objectType inlineFragment'
Full.FragmentSpreadSelection fragmentSpread' ->
fragmentSpread context rule fragmentSpread'
field :: forall m. Validation m -> ApplySelectionRule m Full.Field
field context types' rule objectType field' = go field'
2020-09-17 10:33:37 +02:00
where
2020-09-30 05:14:52 +02:00
go (Full.Field _ fieldName _ _ _ _)
2020-09-28 07:06:15 +02:00
| 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'
2020-09-30 05:14:52 +02:00
typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
2020-09-28 07:06:15 +02:00
applyToChildren fieldName =
2020-09-30 05:14:52 +02:00
let Full.Field _ _ arguments' directives' selections _ = field'
typeField = objectType >>= lookupTypeField fieldName
argumentTypes = maybe mempty typeFieldArguments typeField
in selectionSet context types' rule (typeFieldType <$> typeField) selections
>< directives context rule fieldLocation directives'
2020-09-30 05:14:52 +02:00
>< arguments rule argumentTypes arguments'
arguments :: forall m
. Validation.Rule m
-> In.Arguments
-> [Full.Argument]
-> Seq (Validation.RuleT m)
arguments rule argumentTypes = foldMap forEach . Seq.fromList
where
forEach argument'@(Full.Argument argumentName _ _) =
let argumentType = HashMap.lookup argumentName argumentTypes
in argument rule argumentType argument'
argument :: forall m
. Validation.Rule m
-> Maybe In.Argument
-> Full.Argument
-> Seq (Validation.RuleT m)
argument rule argumentType (Full.Argument _ value' _) =
2020-10-04 18:51:21 +02:00
value rule (valueType <$> argumentType) value'
2020-09-17 10:33:37 +02:00
where
2020-09-30 05:14:52 +02:00
valueType (In.Argument _ valueType' _) = valueType'
2020-10-04 18:51:21 +02:00
-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
embedListLocation :: forall a m
. (Maybe In.Type -> Full.Node a -> Seq m)
-> Maybe In.Type
-> [a]
-> Full.Location
-> Seq m
embedListLocation go listType values location'
= foldMap (go $ valueTypeFromList listType)
$ flip Full.Node location' <$> Seq.fromList values
where
valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
valueTypeFromList _ = Nothing
2020-09-30 05:14:52 +02:00
value :: forall m
. Validation.Rule m
-> Maybe In.Type
2020-10-04 18:51:21 +02:00
-> Full.Node Full.Value
2020-09-30 05:14:52 +02:00
-> Seq (Validation.RuleT m)
value (Validation.ValueRule rule _) valueType = go valueType
where
2020-10-04 18:51:21 +02:00
go inputObjectType value'@(Full.Node (Full.Object fields) _)
2020-09-30 05:14:52 +02:00
= foldMap (forEach inputObjectType) (Seq.fromList fields)
|> rule inputObjectType value'
2020-10-04 18:51:21 +02:00
go listType value'@(Full.Node (Full.List values) location')
= embedListLocation go listType values location'
2020-09-30 05:14:52 +02:00
|> rule listType value'
go anotherValue value' = pure $ rule anotherValue value'
2020-10-04 18:51:21 +02:00
forEach inputObjectType Full.ObjectField{value = value', ..} =
go (valueTypeByName name inputObjectType) value'
2020-09-30 05:14:52 +02:00
value _ _ = const mempty
inlineFragment :: forall m
. Validation m
-> ApplySelectionRule m Full.InlineFragment
inlineFragment context types' rule objectType inlineFragment' =
go inlineFragment'
where
go (Full.InlineFragment optionalType directives' selections _)
2020-09-28 07:06:15 +02:00
| Validation.FragmentRule _ fragmentRule <- rule
= applyToChildren (refineTarget optionalType) directives' selections
|> fragmentRule inlineFragment'
| otherwise = applyToChildren (refineTarget optionalType) directives' selections
refineTarget (Just typeCondition) = lookupType typeCondition types'
refineTarget Nothing = objectType
applyToChildren objectType' directives' selections
2020-09-30 05:14:52 +02:00
= selectionSet context types' rule objectType' selections
>< directives context rule inlineFragmentLocation directives'
2020-09-17 10:33:37 +02:00
2020-09-30 05:14:52 +02:00
fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
2020-09-28 07:06:15 +02:00
| Validation.FragmentSpreadRule fragmentRule <- rule =
2020-09-17 10:33:37 +02:00
applyToChildren |> fragmentRule fragmentSpread'
| otherwise = applyToChildren
where
applyToChildren = directives context rule fragmentSpreadLocation directives'
2020-09-17 10:33:37 +02:00
2020-09-30 05:14:52 +02:00
directives :: Traversable t
=> forall m
. Validation m
-> Validation.Rule m
-> DirectiveLocation
-> t Full.Directive
-> Seq (Validation.RuleT m)
directives context rule directiveLocation directives'
2020-09-28 07:06:15 +02:00
| Validation.DirectivesRule directivesRule <- rule =
applyToChildren |> directivesRule directiveLocation directiveList
| otherwise = applyToChildren
where
directiveList = toList directives'
2020-09-30 05:14:52 +02:00
applyToChildren = foldMap (directive context rule) directiveList
2020-09-30 05:14:52 +02:00
directive :: forall m. Validation m -> ApplyRule m Full.Directive
directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
pure $ argumentsRule directive'
2020-09-30 05:14:52 +02:00
directive context rule (Full.Directive directiveName arguments' _) =
let argumentTypes = maybe HashMap.empty directiveArguments
$ HashMap.lookup directiveName (Validation.directives context)
in arguments rule argumentTypes arguments'
where
directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes