@@ -1,1023 +1,17 @@
1−module GraphQL.Type where
2−
3−import Prelude
4−
5−import Control.Lazy (class Lazy)
6−import Control.Monad.Error.Class (class MonadError, catchError, throwError)
7−import Data.Argonaut as Json
8−import Data.Array as Array
9−import Data.Bifunctor (lmap)
10−import Data.Either (Either(..), note)
11−import Data.Enum (class Enum, enumFromTo)
12−import Data.List (List, fromFoldable, singleton, filter)
13−import Data.Map (Map, empty, insert, lookup)
14−import Data.Maybe (Maybe(..), fromMaybe)
15−import Data.Newtype (class Newtype, unwrap)
16−import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
17−import Data.Traversable (class Traversable, find, traverse)
18−import Data.Tuple (Tuple(..))
19−import Data.Variant as Variant
20−import Effect.Exception (Error, error, message)
21−import GraphQL.Execution.Result (Result(..))
22−import GraphQL.Language.AST as AST
23−import GraphQL.Language.AST.Util (nameFromNameNode)
24−import GraphQL.Type.Introspection.Datatypes as IntrospectionTypes
25−import Prim.Row (class Lacks, class Cons)
26−import Record as Record
27−import Type.Data.RowList (RLProxy(..))
28−import Type.Row as Row
29−import Type.RowList as RL
30−import Unsafe.Coerce (unsafeCoerce)
31−
32−-- | The schema contains the central entry points for GraphQL queries.
33−newtype Schema m a = Schema { query :: ObjectType m a, mutation :: Maybe (ObjectType m a) }
34−
35−type ExecutionContext =
36− { variables :: Map String Json.Json
37− , fragments :: Map String AST.DefinitionNode
38− }
39−
40−-- | The type class for all GraphQL types
41−class GraphQLType t where
42− introspect :: forall a. t a -> IntrospectionTypes.TypeIntrospection
43−
44−-- | The input type class is used for all GraphQL types that can be used as input types.
45−class GraphQLType t <= InputType t where
46− input :: forall a. t a -> Maybe AST.ValueNode -> ExecutionContext -> Either String a
47−
48−-- | The output type class is used for all GraphQL types that can be used as output types.
49−-- | It has instances for GraphQL types that can resolve a value within a certain monad error.
50−class (MonadError Error m, GraphQLType t) <= OutputType m t where
51− output :: forall a. t a -> Maybe AST.SelectionSetNode -> ExecutionContext -> m a -> m Result
52−
53−-- | Scalar types are the leaf nodes of a GraphQL schema. Scalar types can be serialised into JSON
54−-- | or obtained from a JSON when read from the variables provided by a query. Furthermore values
55−-- | can be read from literals in a GraphQL document. To create a scalar type a name and optionally
56−-- | a description need to be provided.
57−-- | The functions `parseLiteral`, `parseValue` and `serialize` are used to convert between the
58−-- | GraphQL transport formats and PureScript representations.
59−-- |
60−-- | The GraphQL PureScript implementation comes with the five default scalars defined in the
61−-- | specification.
62−newtype ScalarType a =
63− ScalarType
64− { name :: String
65− , description :: Maybe String
66− , parseLiteral :: AST.ValueNode -> Either String a
67− , parseValue :: Json.Json -> Either String a
68− , serialize :: a -> Json.Json
69− }
70−
71−instance graphqlTypeScalarType :: GraphQLType ScalarType where
72− introspect (ScalarType { name, description }) =
73− IntrospectionTypes.ScalarTypeIntrospection { name, description }
74−
75−instance inputTypeScalarType :: InputType ScalarType where
76− input (ScalarType config) (Just node) execCtx = case node of
77− (AST.VariableNode { name: AST.NameNode { value }}) -> do
78− json <- note ("Required variable `" <> value <> "` was not provided.") $
79− lookup value execCtx.variables
80− config.parseValue json
81− _ -> config.parseLiteral node
82− input _ Nothing _ = Left "Must provide value for required scalar."
83−
84−instance outputTypeScalarType :: (MonadError Error m) => OutputType m ScalarType where
85− output (ScalarType s) Nothing _ val = ResultLeaf <$> map s.serialize val
86− output _ _ _ _ = pure $ ResultError "Invalid subselection on scalar type!"
87−
88−instance showScalarType :: Show (ScalarType a) where
89− show (ScalarType { name }) = "scalar " <> name
90−
91−newtype ObjectType m a =
92− ObjectType (Unit ->
93− { name :: String
94− , fields :: Map String (ExecutableField m a)
95− , introspection :: IntrospectionTypes.TypeIntrospection
96− }
97− )
98−
99−instance graphqlTypeObjectType :: GraphQLType (ObjectType m) where
100− introspect (ObjectType configFn) = (configFn unit).introspection
101−
102−instance outputTypeObjectType :: (MonadError Error m) => OutputType m (ObjectType m) where
103− output (ObjectType fno) (Just (AST.SelectionSetNode { selections })) execCtx mValue = do
104− value <- mValue
105− let serializeField node@(AST.FieldNode fld) =
106− let (AST.NameNode { value: name }) = fld.name
107− (AST.NameNode { value: alias }) = fromMaybe fld.name fld.alias
108− o = fno unit
109− in case lookup name o.fields of
110− Just (ExecutableField { execute }) ->
111− Tuple alias <$>
112− (flip catchError (message >>> ResultError >>> pure) $
113− execute value node execCtx)
114− Nothing ->
115− if
116− name == "__typename"
117− then
118− pure $ Tuple alias $ ResultLeaf $ Json.fromString o.name
119− else
120− pure $ Tuple alias $
121− ResultError ("Unknown field `" <> name <> "` on type `" <> o.name <> "`.")
122− -- TODO: This branch needs fixing. It is for fragment spreads and so on. Maybe normalise
123− -- the query first and completely eliminate the branch...
124− serializeField _ = pure $ Tuple "unknown" $ ResultError "Unexpected fragment spread!"
125− ResultObject <$> traverse serializeField (selections >>= collectField)
126− where
127− -- Flatten the selection node structure by spreading all fragments into the list
128− collectField :: AST.SelectionNode -> List AST.SelectionNode
129− collectField n@(AST.FieldNode _) = singleton n
130− collectField (AST.InlineFragmentNode {
131− selectionSet: (AST.SelectionSetNode { selections: s })
132− }) = collectField =<< s
133− collectField (AST.FragmentSpreadNode { name: AST.NameNode n }) =
134− case lookup n.value execCtx.fragments of
135− Just (AST.FragmentDefinitionNode {
136− selectionSet: AST.SelectionSetNode { selections: s }
137− }) -> collectField =<< s
138− _ -> mempty
139−
140−
141− output _ _ _ _ = pure $ ResultError "Missing subselection on object type."
142−
143−
144−instance showObjectType :: Show (ObjectType m a) where
145− show (ObjectType config) = "type " <> (config unit).name
146−
147−derive instance newtypeObjectType :: Newtype (ObjectType m a) _
148−
149−instance lazyObjectType :: Lazy (ObjectType m a) where
150− defer fn = ObjectType $ \_ -> unwrap (fn unit) unit
151−
152−-- | The executable field loses the information about it's arguments types. This is needed to add it
153−-- | to the map of arguments of the object type. The execute function will extract the arguments of
154−-- | the field from the AST.
155−newtype ExecutableField m a =
156− ExecutableField { execute :: a -> AST.SelectionNode -> ExecutionContext -> m Result }
157−
158−-- | Object types can have fields. Fields are constructed using the `field` function from this
159−-- | module and added to object types using the `:>` operator.
160−newtype Field m a argsd argsp =
161− Field
162− { name :: String
163− , description :: Maybe String
164− , typeIntrospection :: Unit -> IntrospectionTypes.TypeIntrospection
165− , argumentIntrospections :: Array IntrospectionTypes.InputValueIntrospection
166− , args :: Record argsd
167− , serialize :: AST.SelectionNode -> ExecutionContext -> Record argsp -> a -> m Result
168− }
169−
170−-- | Fields can have multiple arguments. Arguments are constructed using the `arg` function from
171−-- | this module and the `?>` operator.
172−newtype Argument a =
173− Argument
174− { description :: Maybe String
175− , typeIntrospection :: Unit -> IntrospectionTypes.TypeIntrospection
176− , resolveValue :: Maybe AST.ValueNode -> ExecutionContext -> Either String a
177− }
178−
179−derive instance newtypeArgument :: Newtype (Argument a) _
180−
181−newtype EnumType a =
182− EnumType
183− { name :: String
184− , description :: Maybe String
185− , values :: Array (EnumValue a)
186− }
187−
188−newtype EnumValue a =
189− EnumValue
190− { name :: String
191− , description :: Maybe String
192− , value :: a
193− , isValue :: a -> Boolean }
194−
195−instance graphqlTypeEnumType :: GraphQLType EnumType where
196− introspect (EnumType { name, description, values }) =
197− IntrospectionTypes.EnumTypeIntrospection
198− { name
199− , description
200− , enumValues: values <#> \(EnumValue val) ->
201− IntrospectionTypes.EnumValueIntrospection
202− { name: val.name
203− , description: val.description
204− , deprecationReason: Nothing
205− }
206− }
207−
208−instance inputTypeEnumType :: InputType EnumType where
209− input (EnumType config) (Just node) execContext =
210− let lookupName name =
211− note ("Unknown enum value `" <> name <> "` for type `" <> config.name <> "`.") $
212− find (\(EnumValue val) -> val.name == name) config.values
213− in case node of
214− AST.VariableNode { name: AST.NameNode { value: name } } -> do
215− json <- note ("Required variable `" <> name <> "` was not provided.") $
216− lookup name execContext.variables
217− EnumValue val <- Json.caseJsonString (Left "Enum values must be strings.") lookupName json
218− pure val.value
219−
220− AST.EnumValueNode { name: AST.NameNode { value: name } } -> do
221− EnumValue val <- lookupName name
222− pure val.value
223−
224− _ -> Left "Unexpected non-enum value node for enum value."
225−
226− input _ _ _ = Left "Missing value for required argument."
227−
228−instance outputTypeEnumType :: MonadError Error m => OutputType m EnumType where
229− output :: forall a. EnumType a -> Maybe AST.SelectionSetNode -> ExecutionContext -> m a -> m Result
230− output (EnumType config) Nothing _ mValue = do
231− value <- mValue
232− case find (\(EnumValue { isValue }) -> isValue value) config.values of
233− Nothing ->
234− throwError $ error "Could not select enum value representation from provided value."
235−
236− Just (EnumValue val) ->
237− pure $ ResultLeaf $ Json.fromString val.name
238−
239− output _ _ _ _ = pure $ ResultError "Invalid subselection on enum type!"
240−
241−newtype UnionType m a = UnionType (Unit ->
242− { name :: String
243− , description :: Maybe String
244− , typeIntrospections :: Array IntrospectionTypes.TypeIntrospection
245− , output :: Maybe AST.SelectionSetNode -> ExecutionContext -> m a -> m Result
246− }
247−)
248−
249−instance graphqlTypeUnionType :: GraphQLType (UnionType m) where
250− introspect (UnionType config) = IntrospectionTypes.UnionTypeIntrospection
251− { name: (config unit).name
252− , description: (config unit).description
253− , possibleTypes: \_ -> (config unit).typeIntrospections
254− }
255−
256−-- Takes a string and only returns part of the selection set that matches the return type
257−-- TODO: Throw under certain cases, e.g. if there is a field selected in the root that is not
258−-- `__typename`
259−filterSelectionSet :: String -> AST.SelectionSetNode -> ExecutionContext -> AST.SelectionSetNode
260−filterSelectionSet typeName (AST.SelectionSetNode { selections }) ctx =
261− AST.SelectionSetNode { selections: filter filterFn selections }
262− where
263− -- Only the __typename field is allowed on the root selection
264− filterFn (AST.FieldNode { name: AST.NameNode { value }}) = value == "__typename"
265−
266− -- If we find a fragment we only include it into the selection if it matches the type
267− filterFn (AST.FragmentSpreadNode { name: AST.NameNode { value }}) =
268− case lookup value ctx.fragments of
269− Just (AST.FragmentDefinitionNode { typeCondition: AST.SimpleNamedTypeNode { name }}) ->
270− nameFromNameNode name == typeName
271− _ -> false
272−
273− -- Same thing for inline fragment only here we don't have to lookup the fragment
274− filterFn (AST.InlineFragmentNode { typeCondition: AST.SimpleNamedTypeNode { name } }) =
275− nameFromNameNode name == typeName
276−
277−instance outputTypeUnionType :: (MonadError Error m) => OutputType m (UnionType m) where
278− output :: forall a. UnionType m a -> Maybe AST.SelectionSetNode -> ExecutionContext -> m a -> m Result
279− output (UnionType config) = (config unit).output
280−
281−union :: forall ctx def var. UnionDefinition def var ctx => String -> Record def -> UnionType ctx (Variant.Variant var)
282−union = createUnionFromDefinition
283−
284−class UnionDefinition (defRow :: # Type) (varRow :: # Type) (ctx :: Type -> Type)
285− | defRow -> varRow
286− , varRow -> defRow where
287− createUnionFromDefinition ::
288− String ->
289− Record defRow ->
290− UnionType ctx (Variant.Variant varRow)
291−
292−-- This instance is only to get the row list type from the record
293−instance unionDefinitionInstance ::
294− ( RL.RowToList defRow defRowList
295− , RL.RowToList varRow varRowList
296− , UnionIntrospection defRowList defRow
297− , UnionResolver defRowList varRowList defRow varRow ctx
298− , MonadError Error ctx
299− , RL.ListToRow defRowList defRow
300− , RL.ListToRow varRowList varRow ) => UnionDefinition defRow varRow ctx where
301− createUnionFromDefinition name defRecord =
302− let
303− typeIntrospections = unionIntrospection (RLProxy :: RLProxy defRowList) defRecord
304− output selectionSetNode execCtx ctxValue = ctxValue >>=
305− unionResolver
306− (RLProxy :: RLProxy defRowList)
307− (RLProxy :: RLProxy varRowList)
308− defRecord
309− selectionSetNode
310− execCtx
311− in
312− UnionType $ \_ -> { name, description: Nothing, typeIntrospections, output }
313−
314−class UnionIntrospection
315− (defRowList :: RL.RowList)
316− (defRow :: # Type)
317− where
318− unionIntrospection ::
319− RLProxy defRowList ->
320− Record defRow ->
321− Array IntrospectionTypes.TypeIntrospection
322−
323−instance unionIntrospectionCons ::
324− ( Row.Cons l (ObjectType ctx a) defRowTail defRow
325− , Row.Lacks l defRowTail
326− , UnionIntrospection defRowListTail defRowTail
327− , IsSymbol l
328− ) =>
329− UnionIntrospection (RL.Cons l (ObjectType ctx a) defRowListTail) defRow
330− where
331− unionIntrospection defRLProxy defRecord =
332− let
333− ObjectType configFn = Record.get (SProxy :: SProxy l) defRecord
334− config = configFn unit
335− in
336− -- Recursively call function
337− Array.cons config.introspection $
338− unionIntrospection
339− (RLProxy :: RLProxy defRowListTail)
340− -- We will just read from this value
341− (unsafeCoerce defRecord :: Record defRowTail)
342−
343−else instance unionIntrospectionNil :: UnionIntrospection RL.Nil defRow where
344− unionIntrospection _ _ = []
345−
346−class UnionResolver
347− (defRowList :: RL.RowList)
348− (varRowList :: RL.RowList)
349− (defRow :: # Type)
350− (varRow :: # Type)
351− (ctx :: Type -> Type)
352− where
353− unionResolver ::
354− RLProxy defRowList ->
355− RLProxy varRowList ->
356− Record defRow ->
357− Maybe AST.SelectionSetNode ->
358− ExecutionContext ->
359− (Variant.Variant varRow) ->
360− ctx Result
361−
362−instance unionResolverCons ::
363− ( Row.Cons l (ObjectType ctx a) defRowTail defRow
364− , Row.Cons l a varRowTail varRow
365− , Row.Lacks l defRowTail
366− , Row.Lacks l varRowTail
367− , UnionResolver defRowListTail varRowListTail defRowTail varRowTail ctx
368− , MonadError Error ctx
369− , IsSymbol l
370− ) =>
371− UnionResolver
372− (RL.Cons l (ObjectType ctx a) defRowListTail)
373− (RL.Cons l a varRowListTail)
374− defRow
375− varRow
376− ctx
377− where
378− unionResolver ::
379− RLProxy (RL.Cons l (ObjectType ctx a) defRowListTail) ->
380− RLProxy (RL.Cons l a varRowListTail) ->
381− Record defRow ->
382− Maybe AST.SelectionSetNode ->
383− ExecutionContext ->
384− (Variant.Variant varRow) ->
385− ctx Result
386− unionResolver defRLProxy varRLProxy defRecord Nothing execCtx =
387− const $ throwError $ error "Missing selection set for union type"
388− unionResolver defRLProxy varRLProxy defRecord (Just selection) execCtx =
389− let
390− objectType@(ObjectType config) = Record.get (SProxy :: SProxy l) defRecord
391− typename = (config unit).name
392− filteredSelection = filterSelectionSet typename selection execCtx
393− recResolver ::
394− (Variant.Variant varRowTail) ->
395− ctx Result
396− recResolver =
397− unionResolver
398− (RLProxy :: RLProxy defRowListTail)
399− (RLProxy :: RLProxy varRowListTail)
400− (unsafeCoerce defRecord :: Record defRowTail)
401− (Just selection)
402− execCtx
403− in
404− recResolver
405− # Variant.on (SProxy :: SProxy l)
406− (pure >>> output objectType (Just filteredSelection) execCtx)
407−
408−else instance unionResolverNil :: Functor ctx => UnionResolver RL.Nil RL.Nil defRow varRow ctx where
409− unionResolver _ _ _ _ _ = unsafeCoerce >>> Variant.case_
410−
411−newtype InputObjectType a = InputObjectType (Unit ->
412− { name :: String
413− , description :: Maybe String
414− , fieldIntrospection :: Array IntrospectionTypes.InputValueIntrospection
415− , input :: Maybe AST.ValueNode -> ExecutionContext -> Either String a
416− }
417−)
418−
419−instance graphqlTypeInputObjectType :: GraphQLType InputObjectType where
420− introspect (InputObjectType config) =
421− IntrospectionTypes.InputObjectTypeIntrospection
422− { name: (config unit).name
423− , description: (config unit).description
424− , inputFields: (config unit).fieldIntrospection
425− }
426−
427−instance inputTypeInputObjectType :: InputType InputObjectType where
428− input (InputObjectType config) = (config unit).input
429−
430−derive instance newtypeInputObjectType :: Newtype (InputObjectType a) _
431−
432−instance lazyInputObjectType :: Lazy (InputObjectType a) where
433− defer fn = InputObjectType $ \_ -> unwrap (fn unit) unit
434−
435−newtype InputField l a = InputField
436− { name :: SProxy l
437− , introspection :: IntrospectionTypes.InputValueIntrospection
438− , input :: Maybe AST.ValueNode -> ExecutionContext -> Either String a
439− }
440−
441−-- * DSL Creator functions
442−
443−-- | Creates an empty object type with the given name. Fields can be added to the object type using
444−-- | the `:>` operator from this module and the `field` functions. Object types should have at least
445−-- | one field to confirm to the GraphQL specification.
446−-- |
447−-- | *Example:*
448−-- | ```purescript
449−-- | queryType :: ObjectType Unit
450−-- | queryType = objectType "Query"
451−-- | ```
452−objectType :: forall m a. String -> ObjectType m a
453−objectType name =
454− let
455− introspection = IntrospectionTypes.ObjectTypeIntrospection
456− { name, description: Nothing, fields: [] }
457− in
458− ObjectType (\_ -> { name, fields: empty, introspection })
459−
460−-- | Create a new field for an object type. This function is typically used together with the
461−-- | `:>` operator that automatically converts the field into an executable field.
462−field :: forall m t a. OutputType m t => MonadError Error m => String -> t a -> Field m a () ()
463−field name t =
464− Field
465− { name
466− , description: Nothing
467− , args: {}
468− , serialize
469− , argumentIntrospections: []
470− , typeIntrospection }
471− where
472− serialize (AST.FieldNode node) execCtx _ val = output t node.selectionSet execCtx (pure val)
473− serialize _ _ _ _ = pure $ ResultError "Obtained non FieldNode for field serialisation."
474−
475− typeIntrospection _ =
476− IntrospectionTypes.NonNullTypeIntrospection { ofType: \_ -> introspect t }
477−
478−-- | Create a new field for an object type that is a list. You can return any `Traversable` from the
479−-- | resolver.
480−listField :: forall m f t a.
481− MonadError Error m =>
482− Traversable f =>
483− OutputType m t =>
484− String ->
485− t a ->
486− Field m (f a) () ()
487−listField name t =
488− Field
489− { name
490− , description: Nothing
491− , args: {}
492− , serialize
493− , argumentIntrospections: []
494− , typeIntrospection }
495− where
496− serialize (AST.FieldNode node) execCtx _ vals = do
497− ResultList <$> fromFoldable <$> traverse (output t node.selectionSet execCtx) (pure <$> vals)
498−
499− serialize _ _ _ _ =
500− pure $ ResultError "Obtained non FieldNode for field serialisation."
501−
502− typeIntrospection _ =
503− IntrospectionTypes.NonNullTypeIntrospection
504− { ofType: \_ ->
505− IntrospectionTypes.ListTypeIntrospection { ofType: \_ -> introspect t }
506− }
507−
508−-- | Create a new field for an object type that is optional (i.e. it can be null). The resolver
509−-- | must now return a `Maybe`.
510−nullableField :: forall m t a.
511− MonadError Error m =>
512− OutputType m t =>
513− String ->
514− t a ->
515− Field m (Maybe a) () ()
516−nullableField name t =
517− Field
518− { name
519− , description: Nothing
520− , args: {}
521− , serialize
522− , argumentIntrospections: []
523− , typeIntrospection }
524− where
525− serialize (AST.FieldNode node) execCtx _ value = do
526− case value of
527− Nothing ->
528− pure $ ResultNullable Nothing
529−
530− Just val ->
531− ResultNullable <$> Just <$> output t node.selectionSet execCtx (pure val)
532−
533− serialize _ _ _ _ =
534− pure $ ResultError "Obtained non FieldNode for field serialisation."
535−
536− typeIntrospection _ = introspect t
537−
538−-- | Create a new field for an object type that is optional (i.e. it can be null) and returns a
539−-- | list. The resolver must now return a `Maybe`.
540−nullableListField :: forall m f t a.
541− MonadError Error m =>
542− Traversable f =>
543− OutputType m t =>
544− String ->
545− t a ->
546− Field m (Maybe (f a)) () ()
547−nullableListField name t =
548− Field
549− { name
550− , description: Nothing
551− , args: {}
552− , serialize
553− , argumentIntrospections: []
554− , typeIntrospection }
555− where
556− serialize (AST.FieldNode node) variables _ values = do
557− case values of
558− Nothing ->
559− pure $ ResultNullable Nothing
560−
561− Just vals ->
562− ResultNullable <$>
563− Just <$>
564− ResultList <$>
565− fromFoldable <$>
566− traverse (output t node.selectionSet variables) (pure <$> vals)
567− serialize _ _ _ _ =
568− pure $ ResultError "Obtained non FieldNode for field serialisation."
569−
570− typeIntrospection _ =
571− IntrospectionTypes.ListTypeIntrospection { ofType: \_ -> introspect t }
572−
573−-- | Create a tuple with a given name and a plain argument of the given type. Arguments are passed
574−-- | into the resolver. Arguments created with this function are required and the query fails if
575−-- | no value or a `null` value is supplied for this argument. To make an argument optional use
576−-- | `optionalArg` instead.
577−-- | The name argument tuple can then be used to be added to a field using the `?>` operator.
578−-- |
579−-- | *Example:*
580−-- | ```purescript
581−-- | objectType "Query"
582−-- | :> field "hello" Scalar.string
583−-- | ?> arg Scalar.string (SProxy :: _ "name")
584−-- | !> \{ name } parent -> pure $ "Hello " <> name
585−-- | ```
586−arg :: forall t a n. InputType t => IsSymbol n => t a -> SProxy n -> Tuple (SProxy n) (Argument a)
587−arg t name =
588− Tuple (SProxy :: _ n) $
589− Argument
590− { description: Nothing
591− , resolveValue: input t
592− , typeIntrospection: \_ -> introspect t
593− }
594−
595−-- | Create a tuple with a given name and a plain argument of the given type, that is optional.
596−-- | If the argument is supplied for the field the value is available in the arguments wrapped in
597−-- | `Just`. If the argument is not supplied or the supplied value is `null` the arguments field
598−-- | in the resolver is set to `Nothing`.
599−-- | The name argument tuple can then be used to be added to a field using the `?>` operator.
600−-- |
601−-- | *Example:*
602−-- | ```purescript
603−-- | objectType "Query"
604−-- | :> field "hello" Scalar.string
605−-- | ?> optionalArg Scalar.string (SProxy :: _ "name")
606−-- | !> (\{ name } parent -> case name of
607−-- | Just n -> pure $ "Hello " <> name
608−-- | Nothing -> pure "Hello stranger"
609−-- | )
610−-- | ```
611−optionalArg ::
612− forall t a n.
613− InputType t =>
614− IsSymbol n =>
615− t a ->
616− SProxy n ->
617− Tuple (SProxy n) (Argument (Maybe a))
618−optionalArg t name =
619− Tuple (SProxy :: _ n) $
620− Argument
621− { description: Nothing
622− , resolveValue
623− , typeIntrospection: \_ -> introspect t
624− }
625− where
626− -- I am not really happy with this function and it is a bit of a hack:
627− -- We are basically proxying the input function and prevent it from failing if null is
628− -- supplied as the variable value. It is easy to remove the Nothing case from the literal
629− -- case but hard to remove the JSON null from the possible JSON values. I think this is the
630− -- right place to implement this logic but I don't know how to remove this case completely
631− -- from the input function.
632− resolveValue Nothing execCtx = Right Nothing
633− resolveValue (Just AST.NullValueNode) execCtx = Right Nothing
634− resolveValue a@(Just (AST.VariableNode { name: AST.NameNode n})) execCtx = do
635− variableValue <- note ("Unknown variable \"" <> n.value <> "\".") $
636− lookup n.value execCtx.variables
637− if Json.isNull variableValue then pure Nothing else Just <$> input t a execCtx
638− resolveValue a execCtx = Just <$> input t a execCtx
639−
640−
641−inputObjectType :: String -> InputObjectType {}
642−inputObjectType name = InputObjectType \_ ->
643− { name
644− , description: Nothing
645− , fieldIntrospection: []
646− , input: \_ _ -> Right {}
647− }
648−
649−
650−inputField :: forall t l a. IsSymbol l => InputType t => t a -> SProxy l -> InputField l a
651−inputField inputType label = InputField
652− { name: label
653− , introspection:
654− IntrospectionTypes.InputValueIntrospection
655− { name: reflectSymbol label
656− , description: Nothing
657− , defaultValue: Nothing
658− , type: \_ -> introspect inputType
659− }
660− , input: input inputType }
661−
662−-- * DSL Combinator operators
663−
664−-- | The describe type class is used to allow adding descriptions to various parts of a GraphQL
665−-- | schema that can have a description. The `.>` operator can be used with the GraphQL object
666−-- | type DSL to easily add descriptions in various places.
667−-- |
668−-- | *Example:*
669−-- | ```purescript
670−-- | objectType "User"
671−-- | .> "A user of the product."
672−-- | :> field "id" Scalar.id
673−-- | .> "A unique identifier for this user."
674−-- | ```
675−class Describe a where
676− describe :: a -> String -> a
677−
678−infixl 8 describe as .>
679−
680−instance describeObjectType :: Describe (ObjectType m a) where
681− describe (ObjectType configFn) s =
682− ObjectType $ \_ ->
683− let
684− config = configFn unit
685− updateDescription (IntrospectionTypes.ObjectTypeIntrospection introspection) =
686− IntrospectionTypes.ObjectTypeIntrospection $
687− introspection { description = Just s }
688− updateDescription other = other
689− in
690− config { introspection = updateDescription config.introspection }
691−
692−instance describeField :: Describe (Field m a argsd argsp) where
693− describe (Field config) s = Field (config { description = Just s })
694−
695−instance describeArgument :: Describe (Argument a) where
696− describe (Argument config) s = Argument (config { description = Just s })
697−
698−instance describeArgumentTuple :: Describe (Tuple s (Argument a)) where
699− describe (Tuple p (Argument config)) s = Tuple p (Argument (config { description = Just s }))
700−
701−instance describeEnumType :: Describe (EnumType a) where
702− describe (EnumType config) s = EnumType ( config { description = Just s })
703−
704−instance describeEnumValue :: Describe (EnumValue a) where
705− describe (EnumValue config) s = EnumValue ( config { description = Just s })
706−
707−instance describeInputObjectType :: Describe (InputObjectType a) where
708− describe (InputObjectType configFn) s =
709− InputObjectType $ \_ -> (configFn unit) { description = Just s }
710−
711−instance describeInputField :: Describe (InputField s a) where
712− describe (InputField config) s =
713− InputField $ config { introspection = i }
714− where
715− { introspection: (IntrospectionTypes.InputValueIntrospection introspection)} = config
716− i = IntrospectionTypes.InputValueIntrospection $ introspection { description = Just s }
717−
718−-- | The `withField` function is used to add fields to an object type.
719−-- |
720−-- | When added to an object type the information about the field's arguments are hidden in the
721−-- | closure by being converted to the `ExecutableField` type.
722−withField :: forall m a argsd argsp.
723− ArgsDefToArgsParam argsd argsp =>
724− MonadError Error m =>
725− ObjectType m a ->
726− Field m a argsd argsp ->
727− ObjectType m a
728−withField (ObjectType objectConfigFn) fld@(
729− Field { name, description, typeIntrospection, argumentIntrospections }
730−) =
731− ObjectType updated
732− where
733− updated _ =
734− let
735− objectConfig = objectConfigFn unit
736− updatedFields = insert name (makeExecutable fld) objectConfig.fields
737−
738− fieldIntrospection = IntrospectionTypes.FieldIntrospection
739− { name
740− , description
741− , args: argumentIntrospections
742− , type: typeIntrospection
743− , deprecationReason: Nothing
744− }
745−
746− updateIntrospection (IntrospectionTypes.ObjectTypeIntrospection introspection) =
747− IntrospectionTypes.ObjectTypeIntrospection $
748− introspection { fields = Array.snoc introspection.fields fieldIntrospection }
749− updateIntrospection other = other
750−
751− updatedIntrospection = updateIntrospection objectConfig.introspection
752− in
753− objectConfig { fields = updatedFields, introspection = updatedIntrospection }
754−
755− makeExecutable :: Field m a argsd argsp -> ExecutableField m a
756− makeExecutable (Field { args, serialize: serialize' }) = ExecutableField { execute: execute' }
757− where
758− execute' :: a -> AST.SelectionNode -> ExecutionContext -> m Result
759− execute' val node@(AST.FieldNode { arguments: argumentNodes }) variables =
760− case argsFromDefinition argumentNodes variables args of
761− Right argumentValues -> serialize' node variables argumentValues val
762− Left err -> pure (ResultError err)
763− execute' _ _ _ = pure (ResultError "Unexpected non field node field execution...")
764−
765−-- | Operator for the `withField` function: Add a field to an object type.
766−-- |
767−-- | *Example:*
768−-- | ```purescript
769−-- | objectType "Query"
770−-- | :> field "hello" Scalar.string
771−-- | ```
772−infixl 5 withField as :>
773−
774−-- | A type class that contrains the relationship between defined arguments and the _argument_
775−-- | parameter of a resolver.
776−class ArgsDefToArgsParam (argsd :: # Type) (argsp :: # Type)
777− | argsd -> argsp
778− , argsp -> argsd where
779− argsFromDefinition ::
780− List AST.ArgumentNode ->
781− ExecutionContext ->
782− Record argsd ->
783− Either String (Record argsp)
784−
785−instance argsDefToArgsParamImpl ::
786− ( RL.RowToList argsd largsd
787− , RL.RowToList argsp largsp
788− , ArgsFromRows largsd largsp argsd argsp
789− , RL.ListToRow largsd argsd
790− , RL.ListToRow largsp argsp ) => ArgsDefToArgsParam argsd argsp where
791− argsFromDefinition = argsFromRows (RLProxy :: RLProxy largsd) (RLProxy :: RLProxy largsp)
792−
793−-- | ArgsDefToArgsParam that works on row lists for matching implementations
794−class ArgsFromRows
795− (largsd :: RL.RowList)
796− (largsp :: RL.RowList)
797− (argsd :: # Type)
798− (argsp :: # Type)
799− where
800− argsFromRows ::
801− RLProxy largsd ->
802− RLProxy largsp ->
803− List AST.ArgumentNode ->
804− ExecutionContext ->
805− Record argsd ->
806− Either String (Record argsp)
807−
808−instance argsFromRowsCons ::
809− ( Row.Cons l (Argument a) targsd argsd
810− , Row.Cons l a targsp argsp
811− , Row.Lacks l targsd
812− , Row.Lacks l targsp
813− , ArgsFromRows ltargsd ltargsp targsd targsp
814− , IsSymbol l ) =>
815− ArgsFromRows
816− (RL.Cons l (Argument a) ltargsd)
817− (RL.Cons l a ltargsp)
818− argsd
819− argsp
820− where
821− argsFromRows argsdProxy argspProxy nodes variables argsd =
822− let key = SProxy :: SProxy l
823− Argument argConfig = Record.get key argsd
824− tailArgsDef = Record.delete key argsd :: Record targsd
825− nameEquals (AST.ArgumentNode { name: AST.NameNode { value } }) =
826− value == reflectSymbol key
827− argumentNode = find nameEquals nodes
828− -- Extract the argument value if the node can be found. If not use null value
829− -- TODO: Implement default values where we would try to use the default value first
830− valueNode = map (\(AST.ArgumentNode { value }) -> value) argumentNode
831− improveInputError err = "Error when reading argument '" <> reflectSymbol key <> "': " <> err
832− resolvedValue = lmap improveInputError $ argConfig.resolveValue valueNode variables
833− tail =
834− argsFromRows
835− (RLProxy :: RLProxy ltargsd)
836− (RLProxy :: RLProxy ltargsp)
837− nodes
838− variables
839− tailArgsDef
840− in Record.insert key <$> resolvedValue <*> tail
841−
842−else instance argsFromRowsNil :: ArgsFromRows RL.Nil RL.Nil argsd argsp where
843− argsFromRows _ _ _ _ _ = pure $ unsafeCoerce {}
844−
845−-- | The `withArgument` function adds an argument to a field. The argument can then be used in
846−-- | resolvers that are added to the field. The old resolver of the field is still valid until it is
847−-- | overwritten by `withResolver.`
848−withArgument :: forall m a arg n argsdold argsdnew argspold argspnew.
849− IsSymbol n =>
850− Row.Cons n (Argument arg) argsdold argsdnew =>
851− Row.Cons n arg argspold argspnew =>
852− Row.Lacks n argsdold =>
853− Row.Lacks n argspold =>
854− ArgsDefToArgsParam argsdold argspold =>
855− ArgsDefToArgsParam argsdnew argspnew =>
856− Field m a argsdold argspold ->
857− Tuple (SProxy n) (Argument arg) ->
858− Field m a argsdnew argspnew
859−withArgument (Field fieldConfig) (Tuple proxy argument) =
860− Field $ fieldConfig { args = args', serialize = serialize', argumentIntrospections = intros' }
861− where
862− args' :: Record argsdnew
863− args' = Record.insert proxy argument fieldConfig.args
864−
865− serialize' ::
866− AST.SelectionNode ->
867− ExecutionContext ->
868− Record argspnew ->
869− a ->
870− m Result
871− serialize' node variables argsnew val =
872− fieldConfig.serialize node variables (Record.delete proxy argsnew) val
873−
874− intros' :: Array IntrospectionTypes.InputValueIntrospection
875− intros' = Array.snoc fieldConfig.argumentIntrospections
876− (
877− IntrospectionTypes.InputValueIntrospection
878− { name: reflectSymbol proxy
879− , description: _.description $ unwrap argument
880− , type: _.typeIntrospection $ unwrap argument
881− , defaultValue: Nothing
882− }
883− )
884−
885−-- | Adds an argument to a field that can be used in the resolver.
886−-- |
887−-- | *Example:*
888−-- | ```purescript
889−-- | objectType "Query"
890−-- | :> field "hello" Scalar.string
891−-- | ?> arg (SProxy :: SProxy "name") Scalar.string
892−-- | !> (\{ name } parent -> "Hello " <> name <> "!")
893−-- | ```
894−infixl 7 withArgument as ?>
895−
896−-- | The `withResolver` function adds a resolver to a field.
897−-- |
898−-- | _Note: When used multiple times on a field the resolvers are chained._
899−withResolver :: forall m a b argsd argsp.
900− MonadError Error m =>
901− Field m a argsd argsp ->
902− (Record argsp -> b -> m a) ->
903− Field m b argsd argsp
904−withResolver (Field fieldConfig) resolver =
905− Field $ fieldConfig { serialize = serialize }
906− where
907− serialize :: AST.SelectionNode -> ExecutionContext -> Record argsp -> b -> m Result
908− serialize node variables args = resolver args >=> fieldConfig.serialize node variables args
909−
910−-- | Add a resolver to a field that receives the arguments in a record and the parent value.
911−-- |
912−-- | *Example:*
913−-- | ```purescript
914−-- | objectType "User"
915−-- | :> field "friends" Scalar.string
916−-- | !> (\_ user -> user >>= loadUserFriends)
917−-- | ```
918−infixl 6 withResolver as !>
919−
920−-- | Add a resolver to a field that does not take the arguments. This is useful in the very common
921−-- | case that your field has no arguments.
922−withSimpleResolver :: forall m a b.
923− MonadError Error m =>
924− Field m a () () ->
925− (b -> m a) ->
926− Field m b () ()
927−withSimpleResolver fld resolver = withResolver fld (const resolver)
928−
929−-- | Add a resolver to a field that receives only the parent value and ignores the arguments.
930−-- |
931−-- | *Example:*
932−-- | ```purescript
933−-- | objectType "User"
934−-- | :> field "friends" Scalar.string
935−-- | !!> (\user -> user >>= loadUserFriends)
936−-- | ```
937−infixl 6 withSimpleResolver as !!>
938−
939−-- | Add a resolver that simply maps over the parent value. This is useful when you have a pure
940−-- | resolver that does not run effects.
941−withMappingResolver :: forall m a b.
942− MonadError Error m =>
943− Field m a () () ->
944− (b -> a) ->
945− Field m b () ()
946−withMappingResolver fld resolver = withSimpleResolver fld (resolver >>> pure)
947−
948−-- | Add a pure resolver to a field that simply maps the parent value.
949−-- |
950−-- | *Example:*
951−-- | ```purescript
952−-- | objectType "User"
953−-- | :> field "id" Scalar.string
954−-- | !#> _.id
955−-- | ```
956−infixl 6 withMappingResolver as !#>
957−
958−-- | Add a field to an input object type.
959−-- | Usually this functions operator alias
960−withInputField :: forall l a r1 r2.
961− IsSymbol l
962− => Lacks l r1
963− => Cons l a r1 r2
964− => InputObjectType { | r1 }
965− -> InputField l a
966− -> InputObjectType { | r2 }
967−withInputField (InputObjectType objConfig) (InputField inputConfig) = InputObjectType (\_ ->
968− let
969− config = (objConfig unit)
970− fieldLabel = (SProxy :: SProxy l)
971− fieldName = reflectSymbol fieldLabel
972−
973− input :: Maybe AST.ValueNode -> ExecutionContext -> Either String (Record r2)
974− input variableNode execCtx = do
975− let readField = Json.caseJsonObject (Right Nothing) (flip Json.getFieldOptional' fieldName)
976− recValue <- config.input variableNode execCtx
977− case variableNode of
978− (Just (AST.VariableNode { name: AST.NameNode n })) ->
979− case lookup n.value execCtx.variables of
980− Just json -> do
981− maybeValue <- readField json
982− let hackedVariables = insert "variable_hack" (fromMaybe Json.jsonNull maybeValue) empty
983− let hackedCtx = { fragments: execCtx.fragments, variables: hackedVariables }
984− fieldValue <-
985− inputConfig.input
986− (Just (AST.VariableNode { name: (AST.NameNode { value: "variable_hack" }) }))
987− hackedCtx
988− pure $ Record.insert fieldLabel fieldValue recValue
989− Nothing -> Left ("Unknown variable \"" <> n.value <> "\".")
990−
991− (Just (AST.ObjectValueNode { fields })) ->
992− case find (\(AST.ObjectFieldNode { name: AST.NameNode n }) -> n.value == fieldName) fields of
993− Just (AST.ObjectFieldNode { value }) -> do
994− fieldValue <- inputConfig.input (Just value) execCtx
995− pure $ Record.insert fieldLabel fieldValue recValue
996− Nothing -> Left ("Field '" <> fieldName <> "' is required in object type.")
997−
998− _ -> Left "Must provide value for required input object value."
999−
1000− fieldIntrospection = Array.cons inputConfig.introspection config.fieldIntrospection
1001−
1002− in config { input = input, fieldIntrospection = fieldIntrospection }
1003− )
1004−
1005−-- | Add a field to an input object type.
1006−-- |
1007−-- | *Example:*
1008−-- | ```purescript
1009−-- | inputObjectType "User"
1010−-- | :?> inputField "name" Scalar.string
1011−-- | .> "The name of the user"
1012−-- | ```
1013−infixl 6 withInputField as :?>
1014−
1015−-- | Take a bounded enum and infer an enum type from that value using it's show instance to
1016−-- | represent the enum string. The show function cannot return values that are not valid GraphQL
1017−-- | indentifier strings. For practical reasons this is not checked at compile time. Please refer to
1018−-- | the tutorial for best practices around enum values.
1019−enumType :: forall a. Bounded a => Enum a => Show a => String -> EnumType a
1020−enumType name = EnumType { name, description: Nothing, values }
1021− where
1022− values = enumFromTo top bottom <#> \value ->
1023− EnumValue { name: show value, description: Nothing, value, isValue: eq value }
1+module GraphQL.Type
2+ ( module Schema
3+ , module Class
4+ , module ScalarType
5+ , module ObjectType
6+ , module EnumType
7+ , module UnionType
8+ , module InputObjectType
9+ ) where
10+
11+import GraphQL.Type.Schema (Schema(..)) as Schema
12+import GraphQL.Type.Class (class GraphQLType, class InputType, class OutputType, ExecutionContext, input, introspect, output) as Class
13+import GraphQL.Type.ScalarType (ScalarType(..)) as ScalarType
14+import GraphQL.Type.ObjectType (Argument, Field, ObjectType) as ObjectType
15+import GraphQL.Type.EnumType (EnumType) as EnumType
16+import GraphQL.Type.UnionType (UnionType) as UnionType
17+import GraphQL.Type.InputObjectType (InputField(..), InputObjectType(..)) as InputObjectType