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
219
|
{- 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 OverloadedStrings #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
( schema
, schemaWithTypes
, module Language.GraphQL.Type.Internal
) where
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Type.Internal
( Directive(..)
, Directives
, Schema
, Type(..)
, description
, directives
, implementations
, mutation
, subscription
, query
, types
)
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Internal
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
-- | Schema constructor.
--
-- __Note:__ When the schema is constructed, by default only the types that
-- are reachable by traversing the root types are included, other types must
-- be explicitly referenced using 'schemaWithTypes' instead.
schema :: forall m
. Out.ObjectType m -- ^ Query type.
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
-> Directives -- ^ Directive definitions.
-> Schema m -- ^ Schema.
schema queryRoot mutationRoot subscriptionRoot =
schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty
-- | Constructs a complete schema, including user-defined types not referenced
-- in the schema directly (for example interface implementations).
schemaWithTypes :: forall m
. Maybe Text -- ^ Schema description
-> Out.ObjectType m -- ^ Query type.
-> Maybe (Out.ObjectType m) -- ^ Mutation type.
-> Maybe (Out.ObjectType m) -- ^ Subscription type.
-> [Type m] -- ^ Additional types.
-> Directives -- ^ Directive definitions.
-> Schema m -- ^ Schema.
schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions =
Internal.Schema description' queryRoot mutationRoot subscriptionRoot
allDirectives collectedTypes collectedImplementations
where
allTypes = foldr addTypeDefinition HashMap.empty types'
addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator =
HashMap.insert typeName type' accumulator
addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator =
HashMap.insert typeName type' accumulator
addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator =
HashMap.insert typeName type' accumulator
addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator =
HashMap.insert typeName type' accumulator
addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator =
HashMap.insert typeName type' accumulator
addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator =
HashMap.insert typeName type' accumulator
collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes
collectedImplementations = collectImplementations collectedTypes
allDirectives = HashMap.union directiveDefinitions defaultDirectives
defaultDirectives = HashMap.fromList
[ ("skip", skipDirective)
, ("include", includeDirective)
, ("deprecated", deprecatedDirective)
, ("specifiedBy", specifiedByDirective)
]
includeDirective =
Directive includeDescription includeArguments False skipIncludeLocations
includeArguments = HashMap.singleton "if"
$ In.Argument (Just "Included when true.") ifType Nothing
includeDescription = Just
"Directs the executor to include this field or fragment only when the \
\`if` argument is true."
skipDirective = Directive skipDescription skipArguments False skipIncludeLocations
skipArguments = HashMap.singleton "if"
$ In.Argument (Just "skipped when true.") ifType Nothing
ifType = In.NonNullScalarType Definition.boolean
skipDescription = Just
"Directs the executor to skip this field or fragment when the `if` \
\argument is true."
skipIncludeLocations =
[ ExecutableDirectiveLocation DirectiveLocation.Field
, ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
, ExecutableDirectiveLocation DirectiveLocation.InlineFragment
]
deprecatedDirective =
Directive deprecatedDescription deprecatedArguments False deprecatedLocations
reasonDescription = Just
"Explains why this element was deprecated, usually also including a \
\suggestion for how to access supported similar data. Formatted using \
\the Markdown syntax, as specified by \
\[CommonMark](https://commonmark.org/).'"
deprecatedArguments = HashMap.singleton "reason"
$ In.Argument reasonDescription (In.NamedScalarType Definition.string)
$ Just "No longer supported"
deprecatedDescription = Just
"Marks an element of a GraphQL schema as no longer supported."
deprecatedLocations =
[ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
, TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
, TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
, TypeSystemDirectiveLocation DirectiveLocation.EnumValue
]
specifiedByDirective =
Directive specifiedByDescription specifiedByArguments False specifiedByLocations
urlDescription = Just
"The URL that specifies the behavior of this scalar."
specifiedByArguments = HashMap.singleton "url"
$ In.Argument urlDescription (In.NonNullScalarType Definition.string) Nothing
specifiedByDescription = Just
"Exposes a URL that specifies the behavior of this scalar."
specifiedByLocations =
[TypeSystemDirectiveLocation DirectiveLocation.Scalar]
-- | Traverses the schema and finds all referenced types.
collectReferencedTypes :: forall m
. Out.ObjectType m
-> Maybe (Out.ObjectType m)
-> Maybe (Out.ObjectType m)
-> HashMap Full.Name (Type m)
-> HashMap Full.Name (Type m)
collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes =
let queryTypes = traverseObjectType queryRoot extraTypes
mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
mutationRoot
in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot
where
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
getField (Out.ValueResolver field _) = field
getField (Out.EventStreamResolver field _ _) = field
traverseInputType (In.InputObjectBaseType objectType) =
let In.InputObjectType typeName _ inputFields = objectType
element = InputObjectType objectType
traverser = flip (foldr visitInputFields) inputFields
in collect traverser typeName element
traverseInputType (In.ListBaseType listType) =
traverseInputType listType
traverseInputType (In.ScalarBaseType scalarType) =
let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseInputType (In.EnumBaseType enumType) =
let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseOutputType (Out.ObjectBaseType objectType) =
traverseObjectType objectType
traverseOutputType (Out.InterfaceBaseType interfaceType) =
traverseInterfaceType interfaceType
traverseOutputType (Out.UnionBaseType unionType) =
let Out.UnionType typeName _ types' = unionType
traverser = flip (foldr traverseObjectType) types'
in collect traverser typeName (UnionType unionType)
traverseOutputType (Out.ListBaseType listType) =
traverseOutputType listType
traverseOutputType (Out.ScalarBaseType scalarType) =
let Definition.ScalarType typeName _ = scalarType
in collect Prelude.id typeName (ScalarType scalarType)
traverseOutputType (Out.EnumBaseType enumType) =
let Definition.EnumType typeName _ _ = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
let Out.ObjectType typeName _ interfaces fields = objectType
element = ObjectType objectType
traverser = polymorphicTraverser interfaces (getField <$> fields)
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let Out.InterfaceType typeName _ interfaces fields = interfaceType
element = InterfaceType interfaceType
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces
-- | Looks for objects and interfaces under the schema types and collects the
-- interfaces they implement.
collectImplementations :: forall m
. HashMap Full.Name (Type m)
-> HashMap Full.Name [Type m]
collectImplementations = HashMap.foldr go HashMap.empty
where
go implementation@(InterfaceType interfaceType) accumulator =
let Out.InterfaceType _ _ interfaces _ = interfaceType
in foldr (add implementation) accumulator interfaces
go implementation@(ObjectType objectType) accumulator =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr (add implementation) accumulator interfaces
go _ accumulator = accumulator
add implementation (Out.InterfaceType typeName _ _ _) =
HashMap.insertWith (++) typeName [implementation]
|
