OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Resolve abstract types

Browse Source 
Objects that can be a part of an union or interface should return
__typename as string.
This commit is contained in:
Eugen Wissner 2020-06-03 07:20:38 +02:00
parent d12577ae71
commit 93a0403288
14 changed files with 217 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
CHANGELOG.md
View File

@ -17,8 +17,8 @@ and this project adheres to
* Invalid (recusrive or non-existing) fragments should be skipped.
### Changed
- `Schema.Resolver` cannot return arbitrary JSON anymore, but only
`Type.Definition.Value`.
- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
pair.
- `AST.Core.Value` was moved into `Type.Definition`. These values are used only
in the execution and type system, it is not a part of the parsing tree.
- `Type` module is superseded by `Type.Out`. This module contains now only
@ -46,6 +46,7 @@ and this project adheres to
- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
need in special functions to construct field resolvers anymore, resolvers are
normal functions attached to the fields in the schema representation.
- `Schema.resolve` is superseded by `Execute.Execution`.
- `Error.runAppendErrs` isn't used anywhere.
- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`
`TypeCondition` were modified, moved into `Execute.Transform.Document` and

14
docs/tutorial/tutorial.lhs
View File

@ -42,7 +42,10 @@ First we build a GraphQL schema.
> queryType :: ObjectType IO
> queryType = ObjectType "Query" Nothing []
> $ HashMap.singleton "hello"
> $ Field Nothing (Out.NamedScalarType string) mempty hello
> $ Out.Resolver helloField hello
>
> helloField :: Field IO
> helloField = Field Nothing (Out.NamedScalarType string) mempty
>
> hello :: ActionT IO Value
> hello = pure $ String "it's me"
@ -77,7 +80,10 @@ For this example, we're going to be using time.
> queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query" Nothing []
> $ HashMap.singleton "time"
> $ Field Nothing (Out.NamedScalarType string) mempty time
> $ Out.Resolver timeField time
>
> timeField :: Field IO
> timeField = Field Nothing (Out.NamedScalarType string) mempty
>
> time :: ActionT IO Value
> time = do
@ -140,8 +146,8 @@ Now that we have two resolvers, we can define a schema which uses them both.
>
> queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
> [ ("hello", Field Nothing (Out.NamedScalarType string) mempty hello)
> , ("time", Field Nothing (Out.NamedScalarType string) mempty time)
> [ ("hello", Out.Resolver helloField hello)
> , ("time", Out.Resolver timeField time)
> ]
>
> query3 :: Text

4
src/Language/GraphQL.hs
View File

@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema.Resolver's.
-- executed using the given 'Schema'.
graphql :: Monad m
=> Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
@ -25,7 +25,7 @@ graphql = flip graphqlSubs (mempty :: Aeson.Object)
-- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given
-- 'Schema.Resolver's.
-- 'Schema'.
graphqlSubs :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers.
-> HashMap Name a -- ^ Variable substitution function.

1
src/Language/GraphQL/Error.hs
View File

@ -29,6 +29,7 @@ import Text.Megaparsec
, unPos
)
-- | Executor context.
data Resolution m = Resolution
{ errors :: [Aeson.Value]
, types :: HashMap Name (Type m)

4
src/Language/GraphQL/Execute.hs
View File

@ -11,10 +11,10 @@ import Data.Sequence (Seq(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Document, Name)
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@ -68,4 +68,4 @@ executeOperation :: Monad m
-> Seq (Transform.Selection m)
-> m Aeson.Value
executeOperation types' objectType fields =
runCollectErrs types' $ Schema.resolve Null objectType fields
runCollectErrs types' $ executeSelectionSet Null objectType fields

129
src/Language/GraphQL/Execute/Execution.hs
View File

@ -1,20 +1,38 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.Execute.Execution
( aliasOrName
, collectFields
( executeSelectionSet
) where
import qualified Data.Aeson as Aeson
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.Map.Strict (Map)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
resolveFieldValue result (Field _ _ args _) =
flip runReaderT (Context {arguments=args, values=result})
. runExceptT
. runActionT
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
@ -34,6 +52,21 @@ collectFields objectType = foldl forEach Map.empty
aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> AbstractType m
-> HashMap Name Value
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
Just (ObjectType objectType) ->
if instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
| otherwise = pure Nothing
doesFragmentTypeApply :: forall m
. CompositeType m
-> Out.ObjectType m
@ -43,16 +76,88 @@ doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr instanceOf False interfaces
where
instanceOf (Out.InterfaceType that _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = fragmentType
in acc || foldr instanceOf (this == that) interfaces
instanceOf objectType $ AbstractInterfaceType fragmentType
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
let Out.UnionType _ _ members = fragmentType
in foldr instanceOf False members
instanceOf objectType $ AbstractUnionType fragmentType
instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
instanceOf objectType (AbstractInterfaceType interfaceType) =
let Out.ObjectType _ _ interfaces _ = objectType
in foldr go False interfaces
where
instanceOf (Out.ObjectType that _ _ _) acc =
go (Out.InterfaceType that _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = interfaceType
in acc || foldr go (this == that) interfaces
instanceOf objectType (AbstractUnionType unionType) =
let Out.UnionType _ _ members = unionType
in foldr go False members
where
go (Out.ObjectType that _ _ _) acc =
let Out.ObjectType this _ _ _ = objectType
in acc || this == that
executeField :: Monad m
=> Value
-> Out.Resolver m
-> Field m
-> CollectErrsT m Aeson.Value
executeField prev (Out.Resolver fieldDefinition resolver) field = do
let Out.Field _ fieldType _ = fieldDefinition
answer <- lift $ resolveFieldValue prev field resolver
case answer of
Right result -> completeValue fieldType field result
Left errorMessage -> errmsg errorMessage
completeValue :: Monad m
=> Out.Type m
-> Field m
-> Value
-> CollectErrsT m Aeson.Value
completeValue _ _ Null = pure Aeson.Null
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
completeValue _ _ (Enum enum) = pure $ Aeson.String enum
completeValue _ _ (String string') = pure $ Aeson.String string'
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
executeSelectionSet result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection
Nothing -> errmsg "Value completion failed."
completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
| Object objectMap <- result = do
abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
case abstractType of
Just objectType -> executeSelectionSet result objectType seqSelection
Nothing -> errmsg "Value completion failed."
completeValue _ _ _ = errmsg "Value completion failed."
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field
-- to each 'Selection'. Resolves into a value containing the resolved
-- 'Selection', or a null value and error information.
executeSelectionSet :: Monad m
=> Value
-> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
resolvedValues <- Map.traverseMaybeWithKey forEach
$ collectFields objectType selectionSet
pure $ Aeson.toJSON resolvedValues
where
forEach _responseKey (field :<| _) =
tryResolvers field >>= lift . pure . pure
forEach _ _ = pure Nothing
lookupResolver = flip HashMap.lookup resolvers
tryResolvers fld@(Field _ name _ _)
| Just typeField <- lookupResolver name =
executeField result typeField fld
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]

105
src/Language/GraphQL/Schema.hs
View File

@ -1,105 +0,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.Schema
( Resolver(..)
, resolve
) where
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq(..))
import Data.Text (Text)
import qualified Data.Text as Text
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Execution
import Language.GraphQL.Execute.Transform
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'.
--
-- Resolving a field can result in a leaf value or an object, which is
-- represented as a list of nested resolvers, used to resolve the fields of that
-- object.
data Resolver m = Resolver Name (ActionT m Value)
resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
resolveFieldValue result (Field _ _ args _) =
flip runReaderT (Context {arguments=args, values=result})
. runExceptT
. runActionT
executeField :: Monad m
=> Value
-> Out.Field m
-> Field m
-> CollectErrsT m Aeson.Value
executeField prev (Out.Field _ fieldType _ resolver) field = do
answer <- lift $ resolveFieldValue prev field resolver
case answer of
Right result -> completeValue fieldType field result
Left errorMessage -> errmsg errorMessage
completeValue :: Monad m
=> Out.Type m
-> Field m
-> Value
-> CollectErrsT m Aeson.Value
completeValue _ _ Null = pure Aeson.Null
completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
completeValue _ _ (Enum enum) = pure $ Aeson.String enum
completeValue _ _ (String string') = pure $ Aeson.String string'
completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
resolve result objectType seqSelection
completeValue (Out.ListBaseType listType) selectionField (List list) =
Aeson.toJSON <$> traverse (completeValue listType selectionField) list
completeValue _ _ _ = errmsg "Value completion failed."
errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-- | Takes a list of 'Resolver's and a list of 'Field's and applies each
-- 'Resolver' to each 'Field'. Resolves into a value containing the
-- resolved 'Field', or a null value and error information.
resolve :: Monad m -- executeSelectionSet
=> Value
-> Out.ObjectType m
-> Seq (Selection m)
-> CollectErrsT m Aeson.Value
resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
resolvedValues <- Map.traverseMaybeWithKey forEach
$ collectFields objectType selectionSet
pure $ Aeson.toJSON resolvedValues
where
forEach _responseKey (field :<| _) =
tryResolvers field >>= lift . pure . pure
forEach _ _ = pure Nothing
lookupResolver = flip HashMap.lookup resolvers
tryResolvers fld@(Field _ name _ _)
| Just typeField <- lookupResolver name =
executeField result typeField fld
| otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
{-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
| Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
let fakeField = Out.Field Nothing "__typename" mempty mempty
that <- lift $ resolveFieldValue result fakeField resolver
case that of
Right (String typeCondition')
| (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
, typeCondition' == n ->
fmap fold . traverse tryResolvers $ selections'
_ -> pure mempty
| otherwise = fmap fold . traverse tryResolvers $ selections'-}

13
src/Language/GraphQL/Type/Out.hs
View File

@ -10,6 +10,7 @@ module Language.GraphQL.Type.Out
( Field(..)
, InterfaceType(..)
, ObjectType(..)
, Resolver(..)
, Type(..)
, UnionType(..)
, isNonNullType
@ -27,13 +28,22 @@ import Language.GraphQL.AST.Core
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
-- information (if an error has occurred). @m@ is an arbitrary monad, usually
-- 'IO'.
--
-- Resolving a field can result in a leaf value or an object, which is
-- represented as a list of nested resolvers, used to resolve the fields of that
-- object.
data Resolver m = Resolver (Field m) (ActionT m Value)
-- | Object type definition.
--
-- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
-- | Interface Type Definition.
--
@ -54,7 +64,6 @@ data Field m = Field
(Maybe Text) -- ^ Description.
(Type m) -- ^ Field type.
(HashMap Name In.Argument) -- ^ Arguments.
(ActionT m Value) -- ^ Resolver.
-- | These types may be used as output types as the result of fields.
--

23
src/Language/GraphQL/Type/Schema.hs
View File

@ -1,8 +1,10 @@
{-# LANGUAGE ExplicitForAll #-}
-- | Schema Definition.
-- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
( CompositeType(..)
( AbstractType(..)
, CompositeType(..)
, Schema(..)
, Type(..)
, collectReferencedTypes
@ -30,6 +32,11 @@ data CompositeType m
| CompositeObjectType (Out.ObjectType m)
| CompositeInterfaceType (Out.InterfaceType m)
-- | These types may describe the parent context of a selection set.
data AbstractType m
= AbstractUnionType (Out.UnionType m)
| AbstractInterfaceType (Out.InterfaceType m)
-- | A Schema is created by supplying the root types of each type of operation,
-- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor.
@ -51,7 +58,7 @@ collectReferencedTypes schema =
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes
visitFields (Out.Field _ outputType arguments _) foundTypes
visitFields (Out.Field _ outputType arguments) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
@ -86,15 +93,17 @@ collectReferencedTypes schema =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
let (Out.ObjectType typeName _ interfaces fields) = objectType
let (Out.ObjectType typeName _ interfaces resolvers) = objectType
element = ObjectType objectType
traverser = polymorphicTypeTraverser interfaces fields
fields = extractObjectField <$> resolvers
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
element = InterfaceType interfaceType
traverser = polymorphicTypeTraverser interfaces fields
traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
polymorphicTypeTraverser interfaces fields
polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces
extractObjectField (Out.Resolver field _) = field

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-15.14
resolver: lts-15.15
packages:
- .

2
tests/Test/DirectiveSpec.hs
View File

@ -20,7 +20,7 @@ experimentalResolver = Schema { query = queryType, mutation = Nothing }
resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField"
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver
emptyObject :: Aeson.Value
emptyObject = object

22
tests/Test/FragmentSpec.hs
View File

@ -54,32 +54,38 @@ hasErrors _ = True
shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing []
$ HashMap.fromList
[ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
, ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
[ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
, ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
]
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.fromList
[ ("size", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ snd size)
, ("circumference", Out.Field Nothing (Out.NamedScalarType int) mempty $ pure $ snd circumference)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Hat")
[ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
, ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
]
circumferenceFieldType :: Out.Field IO
circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
sizeFieldType :: Out.Field IO
sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
toSchema :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = Schema
{ query = queryType, mutation = Nothing }
where
unionMember = if t == "Hat" then hatType else shirtType
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
queryType =
case t of
"circumference" -> hatType
"size" -> shirtType
_ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList
[ ("garment", Out.Field Nothing (Out.NamedObjectType unionMember) mempty $ pure resolve)
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty $ pure $ String "Shirt")
[ ("garment", Out.Resolver garmentField $ pure resolve)
, ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
]
spec :: Spec

6
tests/Test/RootOperationSpec.hs
View File

@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 60
schema :: Schema IO
@ -28,10 +28,10 @@ schema = Schema
[ ("circumference", Int 60)
]
incrementField = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
$ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 61
hatField = HashMap.singleton "garment"
$ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
$ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment
spec :: Spec
spec =

53
tests/Test/StarWars/Schema.hs
View File

@ -24,32 +24,51 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Field Nothing (Out.NamedObjectType heroObject) mempty hero)
, ("human", Out.Field Nothing (Out.NamedObjectType heroObject) mempty human)
, ("droid", Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid)
[ ("hero", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) hero)
, ("human", Out.Resolver (Out.Field Nothing (Out.NamedObjectType heroObject) mempty) human)
, ("droid", Out.Resolver (Out.Field Nothing (Out.NamedObjectType droidObject) mempty) droid)
]
heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType heroObject) mempty (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
, ("homePlanet", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "homePlanet"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
[ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
]
where
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
droidObject :: Out.ObjectType Identity
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
[ ("id", Out.Field Nothing (Out.NamedScalarType id) mempty (idField "id"))
, ("name", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "name"))
, ("friends", Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty (idField "friends"))
, ("appearsIn", Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty (idField "appearsIn"))
, ("primaryFunction", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "primaryFunction"))
, ("secretBackstory", Out.Field Nothing (Out.NamedScalarType string) mempty (String <$> secretBackstory))
, ("__typename", Out.Field Nothing (Out.NamedScalarType string) mempty (idField "__typename"))
[ ("id", Out.Resolver idFieldType (idField "id"))
, ("name", Out.Resolver nameFieldType (idField "name"))
, ("friends", Out.Resolver friendsFieldType (idField "friends"))
, ("appearsIn", Out.Resolver appearsInFieldType (idField "appearsIn"))
, ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
, ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
, ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
]
where
primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
idFieldType :: Out.Field Identity
idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
nameFieldType :: Out.Field Identity
nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
friendsFieldType :: Out.Field Identity
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
appearsInFieldType :: Out.Field Identity
appearsInFieldType = Out.Field Nothing (Out.ListType $ Out.NamedScalarType int) mempty
secretBackstoryFieldType :: Out.Field Identity
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
idField :: Text -> ActionT Identity Value
idField f = do