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
|
{- 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 #-}
{-# LANGUAGE RecordWildCards #-}
module Language.GraphQL.Executor
( Error(..)
, Operation(..)
, QueryError(..)
, Response(..)
, Segment(..)
, coerceVariableValues
, executeRequest
) where
import qualified Language.GraphQL.AST.Document as Full
import qualified Data.Aeson as Aeson
import Data.Foldable (find)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as Text
import qualified Language.GraphQL.Execute.Coerce as Coerce
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Internal as Type.Internal
import qualified Language.GraphQL.Type.Schema as Schema
data Segment = Segment String | Index Int
data Error = Error
{ message :: String
, locations :: [Full.Location]
, path :: [Segment]
}
data Response = Response
{ data' :: Aeson.Object
, errors :: [Error]
}
data QueryError
= OperationNameRequired
| OperationNotFound String
| CoercionError
instance Show QueryError where
show OperationNameRequired = "Operation name is required."
show (OperationNotFound operationName) =
concat ["Operation \"", operationName, "\" not found."]
show CoercionError = "Coercion error."
respondWithQueryError :: QueryError -> Response
respondWithQueryError queryError
= Response mempty
$ pure
$ Error{ message = show queryError, locations = [], path = [] }
-- operationName selectionSet location
data Operation = Operation
Full.OperationType
(Maybe String)
[Full.VariableDefinition]
Full.SelectionSet
Full.Location
document :: Full.Document -> [Operation]
document = foldr filterOperation []
where
filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
| Full.DefinitionOperation operationDefinition' <- executableDefinition =
operationDefinition operationDefinition' : accumulator
filterOperation _ accumulator = accumulator -- Fragment.
operationDefinition :: Full.OperationDefinition -> Operation
operationDefinition = \case
Full.OperationDefinition operationType operationName variables _ selectionSet operationLocation ->
let maybeOperationName = Text.unpack <$> operationName
in Operation operationType maybeOperationName variables selectionSet operationLocation
Full.SelectionSet selectionSet operationLocation ->
Operation Full.Query Nothing [] selectionSet operationLocation
executeRequest :: Type.Internal.Schema IO
-> Full.Document
-> Maybe String
-> Aeson.Object
-> Aeson.Object
-> IO Response
executeRequest _schema sourceDocument operationName _variableValues _initialValue =
let transformedDocument = document sourceDocument
operation = getOperation transformedDocument operationName
in case operation of
Left queryError -> pure $ respondWithQueryError queryError
Right (Operation Full.Query _ _ _ _) -> executeQuery
Right (Operation Full.Mutation _ _ _ _) -> executeMutation
Right (Operation Full.Subscription _ _ _ _) -> subscribe
getOperation :: [Operation] -> Maybe String -> Either QueryError Operation
getOperation [operation] Nothing = Right operation
getOperation operations (Just givenOperationName)
= maybe (Left $ OperationNotFound givenOperationName) Right
$ find findOperationByName operations
where
findOperationByName (Operation _ (Just operationName) _ _ _) =
givenOperationName == operationName
findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired
executeQuery :: IO Response
executeQuery = pure $ Response mempty mempty
executeMutation :: IO Response
executeMutation = pure $ Response mempty mempty
subscribe :: IO Response
subscribe = pure $ Response mempty mempty
coerceVariableValues :: Coerce.VariableValue a
=> forall m
. HashMap Full.Name (Schema.Type m)
-> Operation
-> HashMap Full.Name a
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition' variableValues =
let Operation _ _ variableDefinitions _ _ = operationDefinition'
in maybe (Left CoercionError) Right
$ foldr forEach (Just HashMap.empty) variableDefinitions
where
forEach variableDefinition coercedValues = do
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition
let defaultValue' = constValue . Full.node <$> defaultValue
variableType <- Type.Internal.lookupInputType variableTypeName types
Coerce.matchFieldValues
coerceVariableValue'
variableValues
variableName
variableType
defaultValue'
coercedValues
coerceVariableValue' variableType value'
= Coerce.coerceVariableValue variableType value'
>>= Coerce.coerceInputLiteral variableType
constValue :: Full.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i
constValue (Full.ConstFloat f) = Type.Float f
constValue (Full.ConstString x) = Type.String x
constValue (Full.ConstBoolean b) = Type.Boolean b
constValue Full.ConstNull = Type.Null
constValue (Full.ConstEnum e) = Type.Enum e
constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value')
|
