blob: be9ba33034ea7b95a3a5ffea3439a53236a33db6 (
plain)
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
{- 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(..)
, 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.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
-- | 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') Seq.empty document'
definition :: Rule 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 =
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 -> ExecutableDefinition -> Seq (RuleT m)
executableDefinition rule (DefinitionOperation operation) =
operationDefinition rule operation
executableDefinition rule (DefinitionFragment fragment) =
fragmentDefinition rule 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 -> OperationDefinition -> Seq (RuleT m)
operationDefinition rule 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'
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
where
applyToChildren = selectionSet rule selections
>< directives rule directives'
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
selectionSet = foldMap . selection
selection :: Rule m -> Selection -> Seq (RuleT m)
selection rule selection'
| SelectionRule selectionRule <- rule =
applyToChildren |> selectionRule selection'
| otherwise = applyToChildren
where
applyToChildren =
case selection' of
FieldSelection field' -> field rule field'
InlineFragmentSelection inlineFragment' ->
inlineFragment rule 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
where
applyToChildren = selectionSet rule 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 :: Rule m -> InlineFragment -> Seq (RuleT m)
inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
| FragmentRule _ fragmentRule <- rule =
applyToChildren |> fragmentRule inlineFragment'
| otherwise = applyToChildren
where
applyToChildren = selectionSet rule 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'
|
