diff options
Diffstat (limited to 'src/Language/GraphQL/Validate.hs')
| -rw-r--r-- | src/Language/GraphQL/Validate.hs | 200 |
1 files changed, 137 insertions, 63 deletions
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index 0fa04cb..eedad6c 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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' |