Validate field selections on composite types
This commit is contained in:
@ -2,8 +2,8 @@
|
||||
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 ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | GraphQL validator.
|
||||
module Language.GraphQL.Validate
|
||||
@ -16,14 +16,21 @@ 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
|
||||
@ -37,16 +44,20 @@ document schema' rules' document' =
|
||||
}
|
||||
reader = do
|
||||
rule' <- lift $ Seq.fromList rules'
|
||||
join $ lift $ foldr (definition rule') Seq.empty document'
|
||||
join $ lift $ foldr (definition rule' context) Seq.empty document'
|
||||
|
||||
definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m)
|
||||
definition (DefinitionRule rule) definition' accumulator =
|
||||
definition :: Rule m
|
||||
-> Validation m
|
||||
-> Definition
|
||||
-> Seq (RuleT m)
|
||||
-> Seq (RuleT m)
|
||||
definition (DefinitionRule rule) _ definition' accumulator =
|
||||
accumulator |> rule definition'
|
||||
definition rule (ExecutableDefinition executableDefinition') accumulator =
|
||||
accumulator >< executableDefinition rule executableDefinition'
|
||||
definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
|
||||
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 =
|
||||
definition rule _ (TypeSystemExtension extension _) accumulator =
|
||||
accumulator >< typeSystemExtension rule extension
|
||||
|
||||
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
|
||||
@ -82,11 +93,14 @@ schemaExtension rule = \case
|
||||
SchemaOperationExtension directives' _ -> directives rule directives'
|
||||
SchemaDirectivesExtension directives' -> directives rule directives'
|
||||
|
||||
executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
|
||||
executableDefinition rule (DefinitionOperation operation) =
|
||||
operationDefinition rule operation
|
||||
executableDefinition rule (DefinitionFragment fragment) =
|
||||
fragmentDefinition rule fragment
|
||||
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
|
||||
@ -124,60 +138,103 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
|
||||
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
|
||||
directives rule directives'
|
||||
|
||||
operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
|
||||
operationDefinition rule operation
|
||||
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 rule selections
|
||||
| OperationDefinition _ _ _ directives' selections _ <- operation =
|
||||
selectionSet rule selections >< directives rule directives'
|
||||
| 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 :: Rule m -> FragmentDefinition -> Seq (RuleT m)
|
||||
fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
|
||||
pure $ rule fragmentDefinition'
|
||||
fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
|
||||
| FragmentRule definitionRule _ <- rule =
|
||||
applyToChildren |> definitionRule fragmentDefinition'
|
||||
| otherwise = applyToChildren
|
||||
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
|
||||
applyToChildren = selectionSet rule selections
|
||||
types' = types context
|
||||
applyToChildren typeCondition directives' selections
|
||||
= selectionSet types' rule (lookupType' typeCondition) selections
|
||||
>< directives rule directives'
|
||||
lookupType' = flip lookupType types'
|
||||
|
||||
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
|
||||
selectionSet = foldMap . selection
|
||||
lookupType :: forall m
|
||||
. TypeCondition
|
||||
-> HashMap Name (Schema.Type m)
|
||||
-> Maybe (Out.Type m)
|
||||
lookupType typeCondition types' = HashMap.lookup typeCondition types'
|
||||
>>= typeToOut
|
||||
|
||||
selection :: Rule m -> Selection -> Seq (RuleT m)
|
||||
selection rule selection'
|
||||
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 selection'
|
||||
applyToChildren |> selectionRule objectType selection'
|
||||
| otherwise = applyToChildren
|
||||
where
|
||||
applyToChildren =
|
||||
case selection' of
|
||||
FieldSelection field' -> field rule field'
|
||||
FieldSelection field' -> field types' rule objectType field'
|
||||
InlineFragmentSelection inlineFragment' ->
|
||||
inlineFragment rule inlineFragment'
|
||||
inlineFragment types' rule objectType inlineFragment'
|
||||
FragmentSpreadSelection fragmentSpread' ->
|
||||
fragmentSpread rule fragmentSpread'
|
||||
|
||||
field :: Rule m -> Field -> Seq (RuleT m)
|
||||
field rule field'@(Field _ _ arguments' directives' selections _)
|
||||
| FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
|
||||
| ArgumentsRule fieldRule _ <- rule = applyToChildren |> fieldRule field'
|
||||
| otherwise = applyToChildren
|
||||
field :: forall m. ApplyRule m Field
|
||||
field types' rule objectType field' = go field'
|
||||
where
|
||||
applyToChildren = selectionSet rule selections
|
||||
>< directives rule directives'
|
||||
>< arguments rule arguments'
|
||||
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
|
||||
@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
|
||||
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
|
||||
argument _ _ = lift mempty
|
||||
|
||||
inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
|
||||
inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
|
||||
| FragmentRule _ fragmentRule <- rule =
|
||||
applyToChildren |> fragmentRule inlineFragment'
|
||||
| otherwise = applyToChildren
|
||||
inlineFragment :: forall m. ApplyRule m InlineFragment
|
||||
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
|
||||
where
|
||||
applyToChildren = selectionSet rule selections
|
||||
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)
|
||||
|
||||
Reference in New Issue
Block a user