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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{- 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 #-}
-- | 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 definition'
| ExecutableDefinition executableDefinition' <- definition'
= visitChildSelections ruleFilter
$ executableDefinition executableDefinition'
| otherwise = asks rules >>= foldM ruleFilter Seq.empty
where
ruleFilter 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 $ traverseSelectionSet selectionSet
where
ruleFilter accumulator (OperationDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule operation
ruleFilter accumulator _ = pure accumulator
getSelectionSet (SelectionSet selectionSet _) = selectionSet
getSelectionSet (OperationDefinition _ _ _ _ selectionSet _) = selectionSet
visitChildSelections :: forall m
. (Seq Error -> Rule m -> ValidateT m)
-> ValidateT m
-> ValidateT m
visitChildSelections ruleFilter children' = do
rules' <- asks rules
applied <- foldM ruleFilter Seq.empty rules'
children <- children'
pure $ children >< applied
selection :: forall m. Selection -> ValidateT m
selection selection'
| FragmentSpreadSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ fragmentSpread fragmentSelection
| FieldSelection fieldSelection <- selection' =
visitChildSelections ruleFilter $ field fieldSelection
| InlineFragmentSelection fragmentSelection <- selection' =
visitChildSelections ruleFilter $ inlineFragment fragmentSelection
where
ruleFilter accumulator (SelectionRule rule) =
mapReaderT (runRule accumulator) $ rule selection'
ruleFilter accumulator _ = pure accumulator
field :: forall m. Field -> ValidateT m
field field'@(Field _ _ _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FieldRule rule) =
mapReaderT (runRule accumulator) $ rule field'
ruleFilter accumulator _ = pure accumulator
inlineFragment :: forall m. InlineFragment -> ValidateT m
inlineFragment fragment@(InlineFragment _ _ selections _) =
visitChildSelections ruleFilter $ traverseSelectionSet selections
where
ruleFilter accumulator (FragmentRule _ inlineRule) =
mapReaderT (runRule accumulator) $ inlineRule fragment
ruleFilter accumulator _ = pure accumulator
fragmentSpread :: forall m. FragmentSpread -> ValidateT m
fragmentSpread fragment =
asks rules >>= foldM ruleFilter Seq.empty
where
ruleFilter accumulator (FragmentSpreadRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator _ = pure accumulator
traverseSelectionSet :: Traversable t => forall m. t Selection -> ValidateT m
traverseSelectionSet = fmap fold . traverse selection
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition fragment@(FragmentDefinition _ _ _ selectionSet _) =
visitChildSelections ruleFilter $ traverseSelectionSet selectionSet
where
ruleFilter accumulator (FragmentDefinitionRule rule) =
mapReaderT (runRule accumulator) $ rule fragment
ruleFilter accumulator (FragmentRule definitionRule _) =
mapReaderT (runRule accumulator) $ definitionRule fragment
ruleFilter accumulator _ = pure accumulator
|
