-
Notifications
You must be signed in to change notification settings - Fork 2.7k
/
Permission.hs
1075 lines (997 loc) · 46.9 KB
/
Permission.hs
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
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
-- |
-- = Remote Schema Permissions Validation
--
-- This module parses the GraphQL IDL (Schema Document) that's provided by
-- the user for configuring permissions for remote schemas to a schema
-- introspection object, which is then used to construct the remote schema for
-- the particular role.
--
-- This module does two things essentially:
--
-- 1. Checks if the given schema document is a subset of the upstream remote
-- schema document. This is done by checking if all the objects, interfaces,
-- unions, enums, scalars and input objects provided in the schema document
-- exist in the upstream remote schema too. We validate the fields, directives
-- and arguments too, wherever applicable.
-- 2. Parse the `preset` directives (if any) on input object fields or argument fields.
-- A `preset` directive is used to specify any preset argument on a field, it can be
-- either a static value or session variable value. There is some validation done
-- on preset directives. For example:
-- - Preset directives can only be specified at
-- `ARGUMENT_DEFINITION` or `INPUT_FIELD_DEFINITION`
-- - A field expecting object cannot have a scalar/enum preset directive and vice versa.
--
-- If a preset directive value is a session variable (like `x-hasura-*`), then it's
-- considered to be a session variable value. In the case, the user wants to treat the
-- session variable value literally, they can add the `static` key to the preset directive
-- to indicate that the value provided should be considered literally. For example:
--
-- `user(id: Int @preset(value: "x-hasura-user-id", static: true))
--
-- In this case `x-hasura-user-id` will be considered literally.
--
-- For validation, we use the `MonadValidate` monad transformer to collect as many errors
-- as possible and then report all those errors at one go to the user.
module Hasura.RemoteSchema.SchemaCache.Permission
( resolveRoleBasedRemoteSchema,
)
where
import Control.Monad.Validate
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as S
import Data.List.Extended (duplicates, getDifference)
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.Types.Metadata.Instances ()
import Hasura.RQL.Types.Roles (RoleName, adminRoleName)
import Hasura.RQL.Types.SchemaCache
import Hasura.RemoteSchema.Metadata (RemoteSchemaName)
import Hasura.RemoteSchema.SchemaCache.Types
import Hasura.Server.Utils (englishList, isSessionVariable)
import Hasura.Session (mkSessionVariable)
import Language.GraphQL.Draft.Syntax qualified as G
data FieldDefinitionType
= ObjectField
| InterfaceField
| EnumField
deriving (Show, Eq)
instance ToTxt FieldDefinitionType where
toTxt = \case
ObjectField -> "Object"
InterfaceField -> "Interface"
EnumField -> "Enum"
data ArgumentDefinitionType
= InputObjectArgument
| DirectiveArgument
deriving (Show, Eq)
instance ToTxt ArgumentDefinitionType where
toTxt = \case
InputObjectArgument -> "Input object"
DirectiveArgument -> "Directive"
data PresetInputTypeInfo
= PresetScalar G.Name
| PresetEnum G.Name [G.EnumValue]
| PresetInputObject [G.InputValueDefinition]
deriving (Show, Eq, Generic, Ord)
data GraphQLType
= Enum
| InputObject
| Object
| Interface
| Union
| Scalar
| Directive
| Field FieldDefinitionType
| Argument ArgumentDefinitionType
deriving (Show, Eq)
instance ToTxt GraphQLType where
toTxt = \case
Enum -> "Enum"
InputObject -> "Input object"
Object -> "Object"
Interface -> "Interface"
Union -> "Union"
Scalar -> "Scalar"
Directive -> "Directive"
Field ObjectField -> "Object field"
Field InterfaceField -> "Interface field"
Field EnumField -> "Enum field"
Argument InputObjectArgument -> "Input object argument"
Argument DirectiveArgument -> "Directive Argument"
data RoleBasedSchemaValidationError
= -- | error to indicate that a type provided by the user
-- differs from the corresponding type defined in the upstream
-- remote schema
NonMatchingType G.Name GraphQLType G.GType G.GType
| -- | error to indicate when a type definition doesn't exist
-- in the upstream remote schema
TypeDoesNotExist GraphQLType G.Name
| -- | error to indicate when the default value of an argument
-- differs from the default value of the corresponding argument
NonMatchingDefaultValue G.Name G.Name (Maybe (G.Value Void)) (Maybe (G.Value Void))
| -- | error to indicate when a given input argument doesn't exist
-- in the corresponding upstream input object
NonExistingInputArgument G.Name G.Name
| MissingNonNullableArguments G.Name (NonEmpty G.Name)
| -- | error to indicate when a given directive argument
-- doesn't exist in the corresponding upstream directive
NonExistingDirectiveArgument G.Name GraphQLType G.Name (NonEmpty G.Name)
| -- | error to indicate when a given field doesn't exist in a field type (Object/Interface)
NonExistingField (FieldDefinitionType, G.Name) G.Name
| -- | error to indicate when member types of an Union don't exist in the
-- corresponding upstream union
NonExistingUnionMemberTypes G.Name (NE.NonEmpty G.Name)
| -- | error to indicate when an object is trying to implement an interface
-- which exists in the schema document but the interface doesn't exist
-- in the upstream remote.
CustomInterfacesNotAllowed G.Name (NE.NonEmpty G.Name)
| -- | error to indicate when object implements interfaces that don't exist
ObjectImplementsNonExistingInterfaces G.Name (NE.NonEmpty G.Name)
| -- | error to indicate enum values in an enum do not exist in the
-- corresponding upstream enum
NonExistingEnumValues G.Name (NE.NonEmpty G.Name)
| -- | error to indicate when the user provided schema contains more than
-- one schema definition
MultipleSchemaDefinitionsFound
| -- | error to indicate when the schema definition doesn't contain the
-- query root.
MissingQueryRoot
| DuplicateTypeNames (NE.NonEmpty G.Name)
| DuplicateDirectives (GraphQLType, G.Name) (NE.NonEmpty G.Name)
| DuplicateFields (FieldDefinitionType, G.Name) (NE.NonEmpty G.Name)
| DuplicateArguments G.Name (NE.NonEmpty G.Name)
| DuplicateEnumValues G.Name (NE.NonEmpty G.Name)
| InvalidPresetDirectiveLocation
| MultiplePresetDirectives (GraphQLType, G.Name)
| NoPresetArgumentFound
| InvalidPresetArgument G.Name
| ExpectedInputTypeButGotOutputType G.Name
| EnumValueNotFound G.Name G.Name
| ExpectedEnumValue G.Name (G.Value Void)
| KeyDoesNotExistInInputObject G.Name G.Name
| ExpectedInputObject G.Name (G.Value Void)
| ExpectedScalarValue G.Name (G.Value Void)
| DisallowSessionVarForListType G.Name
| InvalidStaticValue
| -- | Error to indicate we're comparing non corresponding
-- type definitions. Ideally, this error will never occur
-- unless there's a programming error
UnexpectedNonMatchingNames G.Name G.Name GraphQLType
deriving (Show, Eq)
{-
NOTE: Unused. Should we remove?
convertTypeDef :: G.TypeDefinition [G.Name] a -> G.TypeDefinition () a
convertTypeDef (G.TypeDefinitionInterface (G.InterfaceTypeDefinition desc name dirs flds _)) =
G.TypeDefinitionInterface $ G.InterfaceTypeDefinition desc name dirs flds ()
convertTypeDef (G.TypeDefinitionScalar s) = G.TypeDefinitionScalar s
convertTypeDef (G.TypeDefinitionInputObject inpObj) = G.TypeDefinitionInputObject inpObj
convertTypeDef (G.TypeDefinitionEnum s) = G.TypeDefinitionEnum s
convertTypeDef (G.TypeDefinitionUnion s) = G.TypeDefinitionUnion s
convertTypeDef (G.TypeDefinitionObject s) = G.TypeDefinitionObject s
-}
{- Note [Remote Schema Argument Presets]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Remote schema argument presets are a way to inject values from static values or
from session variables during execution. Presets can be set using the `preset`
directive, the preset directive is defined in the following manner:
```
scalar PresetValue
directive @preset(
value: PresetValue
) on INPUT_FIELD_DEFINITION | ARGUMENT_DEFINITION
```
When a preset directive is defined on an input type, the input type is removed
from the schema and the value is injected by the graphql-engine during the
execution.
There are two types of preset:
1. Static preset
----------------
Static preset is used to preset a static GraphQL value which will be injected
during the execution of the query. Static presets can be specified on all types
of input types i.e scalars, enums and input objects and lists of these types.
The preset value (if specified) will be validated against the type it's provided.
For example:
```
users(user_id: Int @preset(value: {user_id: 1}))
```
The above example will throw an error because the preset is attempting to preset
an input object value for a scalar (Int) type.
2. Session variable preset
--------------------------
Session variable preset is used to inject value from a session variable into the
graphql query during the execution. If the `value` argument of the preset directive
is in the format of the session variable i.e. `x-hasura-*` it will be treated as a
session variable preset. During the execution of a query, which has a session variable
preset set, the session variable's will be looked up and the value will be constructed
into a GraphQL variable. Check out `resolveRemoteVariable` for more details about how
the session variable presets get resolved.
At the time of writing this note, session variable presets can **only** be specified at
named types and only for scalar and enum types. This is done because currently there's
no good way to specify array or object values through session variables.
-}
{- Note [Remote Schema Permissions Architecture]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Remote schema permissions feature is designed in the following way:
1. An user can configure remote schema permissions for a particular role using
the `add_remote_schema_permissions` API, note that this API will only work
when remote schema permissions are enabled while starting the graphql-engine,
which can be done either by the setting the server flag
`--enable-remote-schema-permissions` or the env variable
`HASURA_GRAPHQL_ENABLE_REMOTE_SCHEMA_PERMISSIONS` to `true`. Check the module
documentation of `Hasura.RQL.DDL.RemoteSchema.Permission` (this module) for
more details about how the `add_remote_schema_permissions` API works.
2. The given schema document is parsed into an `IntrospectionResult` object,
3. The schema is built with the `IntrospectionResult` parsed in #2 for the said role.
Check out the documentation in `argumentsParser` to know more about how the presets
are handled.
4. For a remote schema query, the schema will return a `RemoteField` which
contains unresolved session variables, the `RemoteField` is resolved using the
`resolveRemoteField` function. The `resolveRemoteVariable` function contains more
details about how the `RemoteVariable` is resolved.
5. After resolving the remote field, the remote server is queried with the resolved
remote field.
-}
showRoleBasedSchemaValidationError :: RoleBasedSchemaValidationError -> Text
showRoleBasedSchemaValidationError = \case
NonMatchingType fldName fldType expectedType providedType ->
"expected type of "
<> dquote fldName
<> "("
<> dquote fldType
<> ")"
<> " to be "
<> (G.showGT expectedType)
<> " but received "
<> (G.showGT providedType)
TypeDoesNotExist graphQLType typeName ->
graphQLType <<> ": " <> typeName <<> " does not exist in the upstream remote schema"
NonMatchingDefaultValue inpObjName inpValName expectedVal providedVal ->
"expected default value of input value: "
<> inpValName
<<> "of input object "
<> inpObjName
<<> " to be "
<> defaultValueToText expectedVal
<> " but received "
<> defaultValueToText providedVal
NonExistingInputArgument inpObjName inpArgName ->
"input argument " <> inpArgName <<> " does not exist in the input object:" <>> inpObjName
MissingNonNullableArguments fieldName nonNullableArgs ->
"field: "
<> fieldName
<<> " expects the following non nullable arguments to "
<> "be present: "
<> englishList "and" (fmap dquote nonNullableArgs)
NonExistingDirectiveArgument parentName parentType directiveName nonExistingArgs ->
"the following directive argument(s) defined in the directive: "
<> directiveName
<<> " defined with the type name: "
<> parentName
<<> " of type "
<> parentType
<<> " do not exist in the corresponding upstream directive: "
<> englishList "and" (fmap dquote nonExistingArgs)
NonExistingField (fldDefnType, parentTypeName) providedName ->
"field "
<> providedName
<<> " does not exist in the "
<> fldDefnType
<<> ": "
<>> parentTypeName
NonExistingUnionMemberTypes unionName nonExistingMembers ->
"union "
<> unionName
<<> " contains members which do not exist in the members"
<> " of the remote schema union :"
<> englishList "and" (fmap dquote nonExistingMembers)
CustomInterfacesNotAllowed objName customInterfaces ->
"custom interfaces are not supported. "
<> "Object"
<> objName
<<> " implements the following custom interfaces: "
<> englishList "and" (fmap dquote customInterfaces)
ObjectImplementsNonExistingInterfaces objName nonExistentInterfaces ->
"object "
<> objName
<<> " is trying to implement the following interfaces"
<> " that do not exist in the corresponding upstream remote object: "
<> englishList "and" (fmap dquote nonExistentInterfaces)
NonExistingEnumValues enumName nonExistentEnumVals ->
"enum "
<> enumName
<<> " contains the following enum values that do not exist "
<> "in the corresponding upstream remote enum: "
<> englishList "and" (fmap dquote nonExistentEnumVals)
MissingQueryRoot -> "query root does not exist in the schema definition"
MultipleSchemaDefinitionsFound -> "multiple schema definitions found"
DuplicateTypeNames typeNames ->
"duplicate type names found: "
<> englishList "and" (fmap dquote typeNames)
DuplicateDirectives (parentType, parentName) directiveNames ->
"duplicate directives: "
<> englishList "and" (fmap dquote directiveNames)
<> "found in the "
<> parentType
<<> " "
<>> parentName
DuplicateFields (parentType, parentName) fieldNames ->
"duplicate fields: "
<> englishList "and" (fmap dquote fieldNames)
<> "found in the "
<> parentType
<<> " "
<>> parentName
DuplicateArguments fieldName args ->
"duplicate arguments: "
<> englishList "and" (fmap dquote args)
<> "found in the field: "
<>> fieldName
DuplicateEnumValues enumName enumValues ->
"duplicate enum values: "
<> englishList "and" (fmap dquote enumValues)
<> " found in the "
<> enumName
<<> " enum"
InvalidPresetDirectiveLocation ->
"Preset directives can be defined only on INPUT_FIELD_DEFINITION or ARGUMENT_DEFINITION"
MultiplePresetDirectives (parentType, parentName) ->
"found multiple preset directives at " <> parentType <<> " " <>> parentName
NoPresetArgumentFound -> "no arguments found in the preset directive"
InvalidPresetArgument argName ->
"preset argument \"value\" not found at " <>> argName
ExpectedInputTypeButGotOutputType typeName -> "expected " <> typeName <<> " to be an input type, but it's an output type"
EnumValueNotFound enumName enumValue -> enumValue <<> " not found in the enum: " <>> enumName
ExpectedEnumValue typeName presetValue ->
"expected preset value "
<> presetValue
<<> " of type "
<> typeName
<<> " to be an enum value"
ExpectedScalarValue typeName presetValue ->
"expected preset value "
<> presetValue
<<> " of type "
<> typeName
<<> " to be a scalar value"
ExpectedInputObject typeName presetValue ->
"expected preset value "
<> presetValue
<<> " of type "
<> typeName
<<> " to be an input object value"
KeyDoesNotExistInInputObject key' inpObjTypeName ->
key' <<> " does not exist in the input object " <>> inpObjTypeName
DisallowSessionVarForListType name ->
"illegal preset value at " <> name <<> ". Session arguments can only be set for singleton values"
InvalidStaticValue ->
"expected preset static value to be a Boolean value"
UnexpectedNonMatchingNames providedName upstreamName gType ->
"unexpected: trying to compare "
<> gType
<<> " with name "
<> providedName
<<> " with "
<>> upstreamName
where
defaultValueToText = \case
Just defaultValue -> toTxt defaultValue
Nothing -> ""
{-
NOTE: Unused. Should we remove?
presetValueScalar :: G.ScalarTypeDefinition
presetValueScalar = G.ScalarTypeDefinition Nothing G._PresetValue mempty
presetDirectiveDefn :: G.DirectiveDefinition G.InputValueDefinition
presetDirectiveDefn =
G.DirectiveDefinition Nothing G._preset [directiveArg] directiveLocations
where
gType = G.TypeNamed (G.Nullability False) $ G._stdName presetValueScalar
directiveLocations = map G.DLTypeSystem [G.TSDLARGUMENT_DEFINITION, G.TSDLINPUT_FIELD_DEFINITION]
directiveArg = G.InputValueDefinition Nothing G._value gType Nothing mempty
presetDirectiveName :: G.Name
presetDirectiveName = G._preset
-}
lookupInputType ::
G.SchemaDocument ->
G.Name ->
Maybe PresetInputTypeInfo
lookupInputType (G.SchemaDocument types) name = go types
where
go :: [G.TypeSystemDefinition] -> Maybe PresetInputTypeInfo
go (tp : tps) =
case tp of
G.TypeSystemDefinitionSchema _ -> go tps
G.TypeSystemDefinitionType typeDef ->
case typeDef of
G.TypeDefinitionScalar (G.ScalarTypeDefinition _ scalarName _) ->
if
| name == scalarName -> Just $ PresetScalar scalarName
| otherwise -> go tps
G.TypeDefinitionEnum (G.EnumTypeDefinition _ enumName _ vals) ->
if
| name == enumName -> Just $ PresetEnum enumName $ map G._evdName vals
| otherwise -> go tps
G.TypeDefinitionInputObject (G.InputObjectTypeDefinition _ inpObjName _ vals) ->
if
| name == inpObjName -> Just $ PresetInputObject vals
| otherwise -> go tps
_ -> go tps
go [] = Nothing
-- | `parsePresetValue` constructs a GraphQL value when an input value definition
-- contains a preset with it. This function checks if the given preset value
-- is a legal value to the field that's specified it. For example: A scalar input
-- value cannot contain an input object value. When the preset value is a session
-- variable, we treat it as a session variable whose value will be resolved while
-- the query is executed. In the case of session variables preset, we make the GraphQL
-- value as a Variable value and during the execution we resolve all these
-- "session variable" variable(s) and then query the remote server.
parsePresetValue ::
forall m.
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.GType ->
G.Name ->
Bool ->
G.Value Void ->
m (G.Value RemoteSchemaVariable)
parsePresetValue gType varName isStatic value = do
schemaDoc <- ask
case gType of
G.TypeNamed _ typeName ->
case (lookupInputType schemaDoc typeName) of
Nothing -> refute $ pure $ ExpectedInputTypeButGotOutputType typeName
Just (PresetScalar scalarTypeName) ->
case value of
G.VEnum _ -> refute $ pure $ ExpectedScalarValue typeName value
G.VString t ->
case (isSessionVariable t && (not isStatic)) of
True ->
pure
$ G.VVariable
$ SessionPresetVariable (mkSessionVariable t) scalarTypeName
$ SessionArgumentPresetScalar
False -> pure $ G.VString t
G.VList _ -> refute $ pure $ ExpectedScalarValue typeName value
G.VObject _ -> refute $ pure $ ExpectedScalarValue typeName value
v -> pure $ G.literal v
Just (PresetEnum enumTypeName enumVals) ->
case value of
enumVal@(G.VEnum e) ->
case e `elem` enumVals of
True -> pure $ G.literal enumVal
False -> refute $ pure $ EnumValueNotFound typeName $ G.unEnumValue e
G.VString t ->
case isSessionVariable t of
True ->
pure
$ G.VVariable
$ SessionPresetVariable (mkSessionVariable t) enumTypeName
$ SessionArgumentPresetEnum
$ S.fromList enumVals
False -> refute $ pure $ ExpectedEnumValue typeName value
_ -> refute $ pure $ ExpectedEnumValue typeName value
Just (PresetInputObject inputValueDefinitions) ->
let inpValsMap = mapFromL G._ivdName inputValueDefinitions
parseInputObjectField k val = do
inpVal <- onNothing (HashMap.lookup k inpValsMap) (refute $ pure $ KeyDoesNotExistInInputObject k typeName)
parsePresetValue (G._ivdType inpVal) k isStatic val
in case value of
G.VObject obj ->
G.VObject <$> HashMap.traverseWithKey parseInputObjectField obj
_ -> refute $ pure $ ExpectedInputObject typeName value
G.TypeList _ gType' ->
case value of
G.VList lst -> G.VList <$> traverse (parsePresetValue gType' varName isStatic) lst
-- The below is valid because singleton GraphQL values can be "upgraded"
-- to array types. For ex: An `Int` value can be provided as input to
-- a type `[Int]` or `[[Int]]`
s'@(G.VString s) ->
case isSessionVariable s of
True -> refute $ pure $ DisallowSessionVarForListType varName
False -> parsePresetValue gType' varName isStatic s'
v -> parsePresetValue gType' varName isStatic v
parsePresetDirective ::
forall m.
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.GType ->
G.Name ->
G.Directive Void ->
m (G.Value RemoteSchemaVariable)
parsePresetDirective gType parentArgName (G.Directive _name args) = do
if
| HashMap.null args -> refute $ pure $ NoPresetArgumentFound
| otherwise -> do
val <-
onNothing (HashMap.lookup Name._value args)
$ refute
$ pure
$ InvalidPresetArgument parentArgName
isStatic <-
case (HashMap.lookup Name._static args) of
Nothing -> pure False
(Just (G.VBoolean b)) -> pure b
_ -> refute $ pure $ InvalidStaticValue
parsePresetValue gType parentArgName isStatic val
-- | validateDirective checks if the arguments of a given directive
-- is a subset of the corresponding upstream directive arguments
-- *NOTE*: This function assumes that the `providedDirective` and the
-- `upstreamDirective` have the same name.
validateDirective ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
-- | provided directive
G.Directive a ->
-- | upstream directive
G.Directive a ->
-- | parent type and name
(GraphQLType, G.Name) ->
m ()
validateDirective providedDirective upstreamDirective (parentType, parentTypeName) = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Directive
for_ (NE.nonEmpty $ HashMap.keys argsDiff) $ \argNames ->
dispute
$ pure
$ NonExistingDirectiveArgument parentTypeName parentType providedName argNames
where
argsDiff = HashMap.difference providedDirectiveArgs upstreamDirectiveArgs
G.Directive providedName providedDirectiveArgs = providedDirective
G.Directive upstreamName upstreamDirectiveArgs = upstreamDirective
-- | validateDirectives checks if the `providedDirectives`
-- are a subset of `upstreamDirectives` and then validate
-- each of the directives by calling the `validateDirective`
validateDirectives ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
[G.Directive a] ->
[G.Directive a] ->
G.TypeSystemDirectiveLocation ->
(GraphQLType, G.Name) ->
m (Maybe (G.Directive a))
validateDirectives providedDirectives upstreamDirectives directiveLocation parentType = do
for_ (NE.nonEmpty $ S.toList $ duplicates $ map G._dName nonPresetDirectives) $ \dups -> do
refute $ pure $ DuplicateDirectives parentType dups
for_ nonPresetDirectives $ \dir -> do
let directiveName = G._dName dir
upstreamDir <-
onNothing (HashMap.lookup directiveName upstreamDirectivesMap)
$ refute
$ pure
$ TypeDoesNotExist Directive directiveName
validateDirective dir upstreamDir parentType
case presetDirectives of
[] -> pure Nothing
[presetDirective] -> do
case directiveLocation of
G.TSDLINPUT_FIELD_DEFINITION -> pure ()
G.TSDLARGUMENT_DEFINITION -> pure ()
_ -> dispute $ pure $ InvalidPresetDirectiveLocation
pure $ Just presetDirective
_ ->
refute $ pure $ MultiplePresetDirectives parentType
where
upstreamDirectivesMap = mapFromL G._dName upstreamDirectives
presetFilterFn = (== Name._preset) . G._dName
presetDirectives = filter presetFilterFn providedDirectives
nonPresetDirectives = filter (not . presetFilterFn) providedDirectives
-- | `validateEnumTypeDefinition` checks the validity of an enum definition
-- provided by the user against the corresponding upstream enum.
-- The function does the following things:
-- 1. Validates the directives (if any)
-- 2. For each enum provided, check if the enum values are a subset of
-- the enum values of the corresponding upstream enum
-- *NOTE*: This function assumes that the `providedEnum` and the `upstreamEnum`
-- have the same name.
validateEnumTypeDefinition ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
-- | provided enum type definition
G.EnumTypeDefinition ->
-- | upstream enum type definition
G.EnumTypeDefinition ->
m G.EnumTypeDefinition
validateEnumTypeDefinition providedEnum upstreamEnum = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Enum
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLENUM $ (Enum, providedName)
for_ (NE.nonEmpty $ S.toList $ duplicates providedEnumValNames) $ \dups -> do
refute $ pure $ DuplicateEnumValues providedName dups
for_ (NE.nonEmpty $ S.toList fieldsDifference) $ \nonExistingEnumVals ->
dispute $ pure $ NonExistingEnumValues providedName nonExistingEnumVals
pure providedEnum
where
G.EnumTypeDefinition _ providedName providedDirectives providedValueDefns = providedEnum
G.EnumTypeDefinition _ upstreamName upstreamDirectives upstreamValueDefns = upstreamEnum
providedEnumValNames = map (G.unEnumValue . G._evdName) $ providedValueDefns
upstreamEnumValNames = map (G.unEnumValue . G._evdName) $ upstreamValueDefns
fieldsDifference = getDifference providedEnumValNames upstreamEnumValNames
-- | `validateInputValueDefinition` validates a given input value definition
-- , against the corresponding upstream input value definition. Two things
-- are validated to do the same, the type and the default value of the
-- input value definitions should be equal.
validateInputValueDefinition ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.InputValueDefinition ->
G.InputValueDefinition ->
G.Name ->
m RemoteSchemaInputValueDefinition
validateInputValueDefinition providedDefn upstreamDefn inputObjectName = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName (Argument InputObjectArgument)
presetDirective <-
validateDirectives providedDirectives upstreamDirectives G.TSDLINPUT_FIELD_DEFINITION
$ (Argument InputObjectArgument, inputObjectName)
when (providedType /= upstreamType)
$ dispute
$ pure
$ NonMatchingType providedName (Argument InputObjectArgument) upstreamType providedType
when (providedDefaultValue /= upstreamDefaultValue)
$ dispute
$ pure
$ NonMatchingDefaultValue
inputObjectName
providedName
upstreamDefaultValue
providedDefaultValue
presetArguments <- for presetDirective $ parsePresetDirective providedType providedName
pure $ RemoteSchemaInputValueDefinition providedDefn presetArguments
where
G.InputValueDefinition _ providedName providedType providedDefaultValue providedDirectives = providedDefn
G.InputValueDefinition _ upstreamName upstreamType upstreamDefaultValue upstreamDirectives = upstreamDefn
-- | `validateArguments` validates the provided arguments against the corresponding
-- upstream remote schema arguments.
validateArguments ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
(G.ArgumentsDefinition G.InputValueDefinition) ->
(G.ArgumentsDefinition RemoteSchemaInputValueDefinition) ->
G.Name ->
m [RemoteSchemaInputValueDefinition]
validateArguments providedArgs upstreamArgs parentTypeName = do
for_ (NE.nonEmpty $ S.toList $ duplicates $ map G._ivdName providedArgs) $ \dups -> do
refute $ pure $ DuplicateArguments parentTypeName dups
let argsDiff = getDifference nonNullableUpstreamArgs nonNullableProvidedArgs
for_ (NE.nonEmpty $ S.toList argsDiff) $ \nonNullableArgs -> do
refute $ pure $ MissingNonNullableArguments parentTypeName nonNullableArgs
for providedArgs $ \providedArg@(G.InputValueDefinition _ name _ _ _) -> do
upstreamArg <-
onNothing (HashMap.lookup name upstreamArgsMap)
$ refute
$ pure
$ NonExistingInputArgument parentTypeName name
validateInputValueDefinition providedArg upstreamArg parentTypeName
where
upstreamArgsMap = mapFromL G._ivdName $ map _rsitdDefinition upstreamArgs
nonNullableUpstreamArgs = map G._ivdName $ filter (not . G.isNullable . G._ivdType) $ map _rsitdDefinition upstreamArgs
nonNullableProvidedArgs = map G._ivdName $ filter (not . G.isNullable . G._ivdType) providedArgs
validateInputObjectTypeDefinition ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.InputObjectTypeDefinition G.InputValueDefinition ->
G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition ->
m (G.InputObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateInputObjectTypeDefinition providedInputObj upstreamInputObj = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName InputObject
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLINPUT_OBJECT $ (InputObject, providedName)
args <- validateArguments providedArgs upstreamArgs $ providedName
pure $ providedInputObj {G._iotdValueDefinitions = args}
where
G.InputObjectTypeDefinition _ providedName providedDirectives providedArgs = providedInputObj
G.InputObjectTypeDefinition _ upstreamName upstreamDirectives upstreamArgs = upstreamInputObj
validateFieldDefinition ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
(G.FieldDefinition G.InputValueDefinition) ->
(G.FieldDefinition RemoteSchemaInputValueDefinition) ->
(FieldDefinitionType, G.Name) ->
m (G.FieldDefinition RemoteSchemaInputValueDefinition)
validateFieldDefinition providedFieldDefinition upstreamFieldDefinition (parentType, parentTypeName) = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName (Field parentType)
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLFIELD_DEFINITION $ (Field parentType, parentTypeName)
when (providedType /= upstreamType)
$ dispute
$ pure
$ NonMatchingType providedName (Field parentType) upstreamType providedType
args <- validateArguments providedArgs upstreamArgs $ providedName
pure $ providedFieldDefinition {G._fldArgumentsDefinition = args}
where
G.FieldDefinition _ providedName providedArgs providedType providedDirectives = providedFieldDefinition
G.FieldDefinition _ upstreamName upstreamArgs upstreamType upstreamDirectives = upstreamFieldDefinition
validateFieldDefinitions ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
[(G.FieldDefinition G.InputValueDefinition)] ->
[(G.FieldDefinition RemoteSchemaInputValueDefinition)] ->
-- | parent type and name
(FieldDefinitionType, G.Name) ->
m [(G.FieldDefinition RemoteSchemaInputValueDefinition)]
validateFieldDefinitions providedFldDefnitions upstreamFldDefinitions parentType = do
for_ (NE.nonEmpty $ S.toList $ duplicates $ map G._fldName providedFldDefnitions) $ \dups -> do
refute $ pure $ DuplicateFields parentType dups
for providedFldDefnitions $ \fldDefn@(G.FieldDefinition _ name _ _ _) -> do
upstreamFldDefn <-
onNothing (HashMap.lookup name upstreamFldDefinitionsMap)
$ refute
$ pure
$ NonExistingField parentType name
validateFieldDefinition fldDefn upstreamFldDefn parentType
where
upstreamFldDefinitionsMap = mapFromL G._fldName upstreamFldDefinitions
validateInterfaceDefinition ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.InterfaceTypeDefinition () G.InputValueDefinition ->
G.InterfaceTypeDefinition [G.Name] RemoteSchemaInputValueDefinition ->
m (G.InterfaceTypeDefinition () RemoteSchemaInputValueDefinition)
validateInterfaceDefinition providedInterfaceDefn upstreamInterfaceDefn = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Interface
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLINTERFACE $ (Interface, providedName)
fieldDefinitions <- validateFieldDefinitions providedFieldDefns upstreamFieldDefns $ (InterfaceField, providedName)
pure $ providedInterfaceDefn {G._itdFieldsDefinition = fieldDefinitions}
where
G.InterfaceTypeDefinition _ providedName providedDirectives providedFieldDefns _ = providedInterfaceDefn
G.InterfaceTypeDefinition _ upstreamName upstreamDirectives upstreamFieldDefns _ = upstreamInterfaceDefn
validateScalarDefinition ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
G.ScalarTypeDefinition ->
G.ScalarTypeDefinition ->
m G.ScalarTypeDefinition
validateScalarDefinition providedScalar upstreamScalar = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Scalar
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLSCALAR $ (Scalar, providedName)
pure providedScalar
where
G.ScalarTypeDefinition _ providedName providedDirectives = providedScalar
G.ScalarTypeDefinition _ upstreamName upstreamDirectives = upstreamScalar
validateUnionDefinition ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
G.UnionTypeDefinition ->
G.UnionTypeDefinition ->
m G.UnionTypeDefinition
validateUnionDefinition providedUnion upstreamUnion = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Union
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLUNION $ (Union, providedName)
for_ (NE.nonEmpty $ S.toList memberTypesDiff) $ \nonExistingMembers ->
refute $ pure $ NonExistingUnionMemberTypes providedName nonExistingMembers
pure providedUnion
where
G.UnionTypeDefinition _ providedName providedDirectives providedMemberTypes = providedUnion
G.UnionTypeDefinition _ upstreamName upstreamDirectives upstreamMemberTypes = upstreamUnion
memberTypesDiff = getDifference providedMemberTypes upstreamMemberTypes
validateObjectDefinition ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
G.ObjectTypeDefinition G.InputValueDefinition ->
G.ObjectTypeDefinition RemoteSchemaInputValueDefinition ->
-- | Interfaces declared by in the role-based schema
S.HashSet G.Name ->
m (G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)
validateObjectDefinition providedObj upstreamObj interfacesDeclared = do
when (providedName /= upstreamName)
$ dispute
$ pure
$ UnexpectedNonMatchingNames providedName upstreamName Object
void $ validateDirectives providedDirectives upstreamDirectives G.TSDLOBJECT $ (Object, providedName)
for_ (NE.nonEmpty $ S.toList customInterfaces) $ \ifaces ->
dispute $ pure $ CustomInterfacesNotAllowed providedName ifaces
for_ (NE.nonEmpty nonExistingInterfaces) $ \ifaces ->
dispute $ pure $ ObjectImplementsNonExistingInterfaces providedName ifaces
fieldDefinitions <-
validateFieldDefinitions providedFldDefnitions upstreamFldDefnitions $ (ObjectField, providedName)
pure $ providedObj {G._otdFieldsDefinition = fieldDefinitions}
where
G.ObjectTypeDefinition
_
providedName
providedIfaces
providedDirectives
providedFldDefnitions = providedObj
G.ObjectTypeDefinition
_
upstreamName
upstreamIfaces
upstreamDirectives
upstreamFldDefnitions = upstreamObj
interfacesDiff = getDifference providedIfaces upstreamIfaces
providedIfacesSet = S.fromList providedIfaces
customInterfaces = S.intersection interfacesDiff interfacesDeclared
nonExistingInterfaces = S.toList $ S.difference interfacesDiff providedIfacesSet
-- | helper function to validate the schema definitions mentioned in the schema
-- document.
validateSchemaDefinitions ::
(MonadValidate [RoleBasedSchemaValidationError] m) =>
[G.SchemaDefinition] ->
m (Maybe G.Name, Maybe G.Name, Maybe G.Name)
validateSchemaDefinitions [] = pure $ (Nothing, Nothing, Nothing)
validateSchemaDefinitions [schemaDefn] = do
let G.SchemaDefinition _ rootOpsTypes = schemaDefn
rootOpsTypesMap = mapFromL G._rotdOperationType rootOpsTypes
mQueryRootName = G._rotdOperationTypeType <$> HashMap.lookup G.OperationTypeQuery rootOpsTypesMap
mMutationRootName = G._rotdOperationTypeType <$> HashMap.lookup G.OperationTypeMutation rootOpsTypesMap
mSubscriptionRootName = G._rotdOperationTypeType <$> HashMap.lookup G.OperationTypeSubscription rootOpsTypesMap
pure (mQueryRootName, mMutationRootName, mSubscriptionRootName)
validateSchemaDefinitions _ = refute $ pure $ MultipleSchemaDefinitionsFound
-- | Construction of the `possibleTypes` map for interfaces, while parsing the
-- user provided Schema document, it doesn't include the `possibleTypes`, so
-- constructing here, manually.
createPossibleTypesMap :: [(G.ObjectTypeDefinition RemoteSchemaInputValueDefinition)] -> HashMap G.Name [G.Name]
createPossibleTypesMap objectDefinitions = do
HashMap.fromListWith (<>) $ do
objectDefinition <- objectDefinitions
let objectName = G._otdName objectDefinition
interface <- G._otdImplementsInterfaces objectDefinition
pure (interface, [objectName])
partitionTypeSystemDefinitions ::
[G.TypeSystemDefinition] ->
([G.SchemaDefinition], [G.TypeDefinition () G.InputValueDefinition])
partitionTypeSystemDefinitions = foldr f ([], [])
where
f d (schemaDefinitions, typeDefinitions) = case d of
G.TypeSystemDefinitionSchema schemaDefinition -> ((schemaDefinition : schemaDefinitions), typeDefinitions)
G.TypeSystemDefinitionType typeDefinition -> (schemaDefinitions, (typeDefinition : typeDefinitions))
-- | getSchemaDocIntrospection converts the `PartitionedTypeDefinitions` to
-- `IntrospectionResult` because the function `buildRemoteParser` function which
-- builds the remote schema parsers accepts an `IntrospectionResult`. The
-- conversion involves converting `G.TypeDefinition ()` to `G.TypeDefinition
-- [G.Name]`. The `[G.Name]` here being the list of object names that an
-- interface implements. This is needed to be done here by-hand because while
-- specifying the `SchemaDocument` through the GraphQL DSL, it doesn't include
-- the `possibleTypes` along with an object.
getSchemaDocIntrospection ::
[G.TypeDefinition () RemoteSchemaInputValueDefinition] ->
(Maybe G.Name, Maybe G.Name, Maybe G.Name) ->
IntrospectionResult
getSchemaDocIntrospection providedTypeDefns (queryRoot, mutationRoot, subscriptionRoot) =
let objects = flip mapMaybe providedTypeDefns $ \case
G.TypeDefinitionObject obj -> Just obj
_ -> Nothing
possibleTypesMap = createPossibleTypesMap objects
modifiedTypeDefns = do
providedType <- providedTypeDefns
case providedType of
G.TypeDefinitionInterface interface@(G.InterfaceTypeDefinition _ name _ _ _) ->
pure
$ G.TypeDefinitionInterface
$ interface {G._itdPossibleTypes = concat $ maybeToList (HashMap.lookup name possibleTypesMap)}
G.TypeDefinitionScalar scalar -> pure $ G.TypeDefinitionScalar scalar
G.TypeDefinitionEnum enum -> pure $ G.TypeDefinitionEnum enum
G.TypeDefinitionObject obj -> pure $ G.TypeDefinitionObject obj
G.TypeDefinitionUnion union' -> pure $ G.TypeDefinitionUnion union'
G.TypeDefinitionInputObject inpObj -> pure $ G.TypeDefinitionInputObject inpObj
remoteSchemaIntrospection = RemoteSchemaIntrospection $ HashMap.fromListOn getTypeName modifiedTypeDefns
in IntrospectionResult remoteSchemaIntrospection (fromMaybe GName._Query queryRoot) mutationRoot subscriptionRoot
-- | validateRemoteSchema accepts two arguments, the `SchemaDocument` of
-- the role-based schema, that is provided by the user and the `SchemaIntrospection`
-- of the upstream remote schema. This function, in turn calls the other validation
-- functions for scalars, enums, unions, interfaces,input objects and objects.
validateRemoteSchema ::
( MonadValidate [RoleBasedSchemaValidationError] m,
MonadReader G.SchemaDocument m
) =>
RemoteSchemaIntrospection ->
m IntrospectionResult
validateRemoteSchema upstreamRemoteSchemaIntrospection = do
G.SchemaDocument providedTypeSystemDefinitions <- ask
let (providedSchemaDefinitions, providedTypeDefinitions) =
partitionTypeSystemDefinitions providedTypeSystemDefinitions
duplicateTypesList = S.toList $ duplicates (getTypeName <$> providedTypeDefinitions)
for_ (NE.nonEmpty duplicateTypesList) $ \duplicateTypeNames ->
refute $ pure $ DuplicateTypeNames duplicateTypeNames
rootTypeNames <- validateSchemaDefinitions providedSchemaDefinitions
let providedInterfacesTypes =
S.fromList
$ flip mapMaybe providedTypeDefinitions
$ \case
G.TypeDefinitionInterface interface -> Just $ G._itdName interface
_ -> Nothing
validatedTypeDefinitions <-
for providedTypeDefinitions $ \case
G.TypeDefinitionScalar providedScalarTypeDefn -> do
let nameTxt = G.unName $ G._stdName providedScalarTypeDefn
case nameTxt `elem` ["ID", "Int", "Float", "Boolean", "String"] of
True -> pure $ G.TypeDefinitionScalar providedScalarTypeDefn