1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
{- 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 ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
-- | GraphQL validator.
module Language.GraphQL.Validate
( Error(..)
, Path(..)
, document
, module Language.GraphQL.Validate.Rules
) where
import Control.Monad (foldM)
import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
import Data.Foldable (fold, foldrM)
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal
import Language.GraphQL.Type.Schema (Schema(..))
import Language.GraphQL.Validate.Rules
import Language.GraphQL.Validate.Validation
type ValidateT m = Reader (Validation m) (Seq Error)
-- | 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' =
runReader (foldrM go Seq.empty document') context
where
context = Validation
{ ast = document'
, schema = schema'
, types = collectReferencedTypes schema'
, rules = rules'
}
go definition' accumulator = (accumulator ><) <$> definition definition'
definition :: forall m. Definition -> ValidateT m
definition = \case
definition'@(ExecutableDefinition executableDefinition') -> do
applied <- applyRules definition'
children <- executableDefinition executableDefinition'
pure $ children >< applied
definition' -> applyRules definition'
where
applyRules definition' =
asks rules >>= foldM (ruleFilter definition') Seq.empty
ruleFilter definition' accumulator (DefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule definition'
ruleFilter _ accumulator _ = pure accumulator
runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
runRule accumulator (Just error') = pure $ accumulator |> error'
runRule accumulator Nothing = pure accumulator
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
executableDefinition (DefinitionOperation definition') =
operationDefinition definition'
executableDefinition (DefinitionFragment definition') =
fragmentDefinition definition'
operationDefinition :: forall m. OperationDefinition -> ValidateT m
operationDefinition operation =
let selectionSet = getSelectionSet operation
in visitChildSelections ruleFilter selectionSet
where
ruleFilter accumulator (OperationDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule operation
ruleFilter accumulator _ = pure accumulator
getSelectionSet (SelectionSet selectionSet _) = selectionSet
getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
selection :: forall m. Selection -> ValidateT m
selection selection'
| FragmentSpread{} <- selection' =
asks rules >>= foldM ruleFilter Seq.empty
| Field _ _ _ _ selectionSet _ <- selection' =
visitChildSelections ruleFilter selectionSet
| InlineFragment _ _ selectionSet _ <- selection' =
visitChildSelections ruleFilter selectionSet
where
ruleFilter accumulator (SelectionRule rule) =
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
traverseSelectionSet = fmap fold . traverse selection
visitChildSelections :: Traversable t
=> (Seq Error -> Rule m -> ValidateT m)
-> t Selection
-> ValidateT m
visitChildSelections ruleFilter selectionSet = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- traverseSelectionSet selectionSet
pure $ children >< applied
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
visitChildSelections ruleFilter selectionSet
where
ruleFilter accumulator (FragmentDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator _ = pure accumulator
|
