graphql/src/Language/GraphQL/Validate.hs

281 lines
12 KiB
Haskell

{- 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/. -}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | GraphQL validator.
module Language.GraphQL.Validate
( Error(..)
, 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
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema(..))
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Rules
import Language.GraphQL.Validate.Validation
type ApplyRule m a =
HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (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 schema' rules' document' =
runReaderT reader context
where
context = Validation
{ ast = document'
, schema = schema'
, types = collectReferencedTypes schema'
}
reader = do
rule' <- lift $ Seq.fromList rules'
join $ lift $ foldr (definition rule' context) Seq.empty document'
definition :: Rule m
-> Validation m
-> Definition
-> Seq (RuleT m)
-> Seq (RuleT m)
definition (DefinitionRule rule) _ definition' accumulator =
accumulator |> rule definition'
definition rule context (ExecutableDefinition definition') accumulator =
accumulator >< executableDefinition rule context definition'
definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
accumulator >< typeSystemDefinition rule typeSystemDefinition'
definition rule _ (TypeSystemExtension extension _) accumulator =
accumulator >< typeSystemExtension rule extension
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
typeSystemExtension rule = \case
SchemaExtension extension -> schemaExtension rule extension
TypeExtension extension -> typeExtension rule extension
typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m)
typeExtension rule = \case
ScalarTypeExtension _ directives' -> directives rule directives'
ObjectTypeFieldsDefinitionExtension _ _ directives' fields ->
directives rule directives' >< foldMap (fieldDefinition rule) fields
ObjectTypeDirectivesExtension _ _ directives' -> directives rule directives'
ObjectTypeImplementsInterfacesExtension _ _ -> mempty
InterfaceTypeFieldsDefinitionExtension _ directives' fields ->
directives rule directives' >< foldMap (fieldDefinition rule) fields
InterfaceTypeDirectivesExtension _ directives' ->
directives rule directives'
UnionTypeUnionMemberTypesExtension _ directives' _ ->
directives rule directives'
UnionTypeDirectivesExtension _ directives' -> directives rule directives'
EnumTypeEnumValuesDefinitionExtension _ directives' values ->
directives rule directives' >< foldMap (enumValueDefinition rule) values
EnumTypeDirectivesExtension _ directives' -> directives rule directives'
InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
-> directives rule directives'
>< foldMap (inputValueDefinition rule) fields
InputObjectTypeDirectivesExtension _ directives' ->
directives rule directives'
schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m)
schemaExtension rule = \case
SchemaOperationExtension directives' _ -> directives rule directives'
SchemaDirectivesExtension directives' -> directives rule directives'
executableDefinition :: Rule m
-> Validation m
-> ExecutableDefinition
-> Seq (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 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 rule = \case
ScalarTypeDefinition _ _ directives' -> directives rule directives'
ObjectTypeDefinition _ _ _ directives' fields ->
directives rule directives' >< foldMap (fieldDefinition rule) fields
InterfaceTypeDefinition _ _ directives' fields ->
directives rule directives' >< foldMap (fieldDefinition rule) fields
UnionTypeDefinition _ _ directives' _ -> directives rule directives'
EnumTypeDefinition _ _ directives' values ->
directives rule directives' >< foldMap (enumValueDefinition rule) values
InputObjectTypeDefinition _ _ directives' fields
-> directives rule directives'
<> foldMap (inputValueDefinition rule) fields
enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m)
enumValueDefinition rule (EnumValueDefinition _ _ directives') =
directives rule directives'
fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m)
fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') =
directives rule directives' >< argumentsDefinition rule arguments'
argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m)
argumentsDefinition rule (ArgumentsDefinition definitions) =
foldMap (inputValueDefinition rule) definitions
inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
directives rule directives'
operationDefinition :: Rule m
-> Validation m
-> OperationDefinition
-> Seq (RuleT m)
operationDefinition rule context operation
| OperationDefinitionRule operationRule <- rule =
pure $ operationRule operation
| VariablesRule variablesRule <- rule
, OperationDefinition _ _ variables _ _ _ <- operation
= Seq.fromList (variableDefinition rule <$> variables)
|> variablesRule variables
| SelectionSet selections _ <- operation =
selectionSet types' rule (getRootType Query) selections
| OperationDefinition operationType _ _ directives' selections _ <- 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)
getRootType Subscription =
Out.NamedObjectType <$> subscription (schema 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
variableDefinition :: Rule m -> VariableDefinition -> RuleT m
variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
maybe (lift mempty) rule value
variableDefinition _ _ = lift mempty
fragmentDefinition :: forall m
. Rule m
-> Validation m
-> FragmentDefinition
-> Seq (RuleT m)
fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
pure $ rule definition'
fragmentDefinition rule context definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
, FragmentRule definitionRule _ <- rule
= applyToChildren typeCondition directives' selections
|> definitionRule definition'
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections
where
types' = types context
applyToChildren typeCondition directives' selections
= selectionSet types' rule (lookupType' typeCondition) selections
>< directives rule directives'
lookupType' = flip lookupType types'
lookupType :: forall m
. TypeCondition
-> HashMap Name (Schema.Type m)
-> Maybe (Out.Type m)
lookupType typeCondition types' = HashMap.lookup typeCondition types'
>>= typeToOut
selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
selectionSet types' rule = foldMap . selection types' rule
selection :: forall m. ApplyRule m Selection
selection types' rule objectType selection'
| SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule objectType selection'
| otherwise = applyToChildren
where
applyToChildren =
case selection' of
FieldSelection field' -> field types' rule objectType field'
InlineFragmentSelection inlineFragment' ->
inlineFragment types' rule objectType inlineFragment'
FragmentSpreadSelection fragmentSpread' ->
fragmentSpread rule fragmentSpread'
field :: forall m. ApplyRule 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
>< directives rule directives'
>< arguments rule arguments'
arguments :: Rule m -> [Argument] -> Seq (RuleT m)
arguments = (.) Seq.fromList . fmap . argument
argument :: Rule m -> Argument -> RuleT m
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
argument _ _ = lift mempty
inlineFragment :: forall m. ApplyRule m InlineFragment
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
where
go (InlineFragment optionalType directives' selections _)
| 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
= selectionSet types' rule objectType' selections
>< directives rule directives'
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)
fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
| FragmentSpreadRule fragmentRule <- rule =
applyToChildren |> fragmentRule fragmentSpread'
| otherwise = applyToChildren
where
applyToChildren = directives rule directives'
directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m)
directives rule directives'
| 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' =
pure $ argumentsRule directive'
directive rule (Directive _ arguments' _) = arguments rule arguments'