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
|
{- 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 (foldrM)
import Data.Sequence (Seq(..), (><), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
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)
-- | If an error can be associated to a particular field in the GraphQL result,
-- it must contain an entry with the key path that details the path of the
-- response field which experienced the error. This allows clients to identify
-- whether a null result is intentional or caused by a runtime error.
data Path
= Segment Text -- ^ Field name.
| Index Int -- ^ List index if a field returned a list.
deriving (Eq, Show)
-- | Validation error.
data Error = Error
{ message :: String
, locations :: [Location]
, path :: [Path]
} deriving (Eq, Show)
-- | 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) =
flip mapReaderT (rule definition') $ \case
Just message' ->
pure $ accumulator |> Error
{ message = message'
, locations = [definitionLocation definition']
, path = []
}
Nothing -> pure accumulator
ruleFilter _ accumulator _ = pure accumulator
definitionLocation (ExecutableDefinition executableDefinition')
| DefinitionOperation definitionOperation <- executableDefinition'
, SelectionSet _ location <- definitionOperation = location
| DefinitionOperation definitionOperation <- executableDefinition'
, OperationDefinition _ _ _ _ _ location <- definitionOperation =
location
| DefinitionFragment fragmentDefinition' <- executableDefinition'
, FragmentDefinition _ _ _ _ location <- fragmentDefinition' = location
definitionLocation (TypeSystemDefinition _ location) = location
definitionLocation (TypeSystemExtension _ location) = location
executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
executableDefinition (DefinitionOperation definition') =
operationDefinition definition'
executableDefinition (DefinitionFragment definition') =
fragmentDefinition definition'
operationDefinition :: forall m. OperationDefinition -> ValidateT m
operationDefinition operation =
asks rules >>= foldM (ruleFilter operation) Seq.empty
where
ruleFilter definition' accumulator (OperationDefinitionRule rule) =
flip mapReaderT (rule definition') $ \case
Just message' ->
pure $ accumulator |> Error
{ message = message'
, locations = [definitionLocation operation]
, path = []
}
Nothing -> pure accumulator
ruleFilter _ accumulator _ = pure accumulator
definitionLocation (SelectionSet _ location) = location
definitionLocation (OperationDefinition _ _ _ _ _ location) = location
fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
fragmentDefinition _fragment = pure Seq.empty
|
