Define resolvers on type fields

Returning resolvers from other resolvers isn't supported anymore. Since
we have a type system now, we define the resolvers in the object type
fields and pass an object with the previous result to them.
This commit is contained in:
2020-05-27 23:18:35 +02:00
parent c06d0b8e95
commit d12577ae71
25 changed files with 534 additions and 516 deletions

View File

@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
secretBackstory :: Character -> ActionT Identity Text
secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
secretBackstory :: ActionT Identity Text
secretBackstory = ActionT $ throwE "secretBackstory is secret."
typeName :: Character -> Text
typeName = either (const "Droid") (const "Human")

View File

@ -1,24 +1,22 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.StarWars.Schema
( character
, droid
, hero
, human
, schema
( schema
) where
import Control.Monad.Trans.Reader (asks)
import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Data.Functor.Identity (Identity)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import qualified Language.GraphQL.Schema as Schema
import Data.Text (Text)
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
import Test.StarWars.Data
import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
@ -26,50 +24,72 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", Out.Field Nothing (Out.NamedScalarType string) mempty hero)
, ("human", Out.Field Nothing (Out.NamedScalarType string) mempty human)
, ("droid", Out.Field Nothing (Out.NamedScalarType string) mempty droid)
[ ("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 :: ActionT Identity (Out.Value Identity)
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"))
]
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"))
]
idField :: Text -> ActionT Identity Value
idField f = do
v <- ActionT $ lift $ asks values
let (Object v') = v
pure $ v' HashMap.! f
hero :: ActionT Identity Value
hero = do
episode <- argument "episode"
pure $ character $ case episode of
In.Enum "NEWHOPE" -> getHero 4
In.Enum "EMPIRE" -> getHero 5
In.Enum "JEDI" -> getHero 6
Enum "NEWHOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6
_ -> artoo
human :: ActionT Identity (Out.Value Identity)
human :: ActionT Identity Value
human = do
id' <- argument "id"
case id' of
In.String i -> do
String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> pure Out.Null
Nothing -> pure Null
Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: ActionT Identity (Out.Value Identity)
droid :: ActionT Identity Value
droid = do
id' <- argument "id"
case id' of
In.String i -> character <$> getDroid i
String i -> character <$> getDroid i
_ -> ActionT $ throwE "Invalid arguments."
character :: Character -> Out.Value Identity
character char = Schema.object
[ Schema.Resolver "id" $ pure $ Out.String $ id_ char
, Schema.Resolver "name" $ pure $ Out.String $ name_ char
, Schema.Resolver "friends"
$ pure $ Out.List $ character <$> getFriends char
, Schema.Resolver "appearsIn" $ pure
$ Out.List $ Out.Enum <$> catMaybes (getEpisode <$> appearsIn char)
, Schema.Resolver "secretBackstory" $ Out.String
<$> secretBackstory char
, Schema.Resolver "homePlanet" $ pure $ Out.String
$ either mempty homePlanet char
, Schema.Resolver "__typename" $ pure $ Out.String
$ typeName char
character :: Character -> Value
character char = Object $ HashMap.fromList
[ ("id", String $ id_ char)
, ("name", String $ name_ char)
, ("friends", List $ character <$> getFriends char)
, ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
, ("homePlanet", String $ either mempty homePlanet char)
, ("__typename", String $ typeName char)
]