graphql/tests/Test/StarWars/Schema.hs

167 lines
6.0 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
2019-07-14 05:58:05 +02:00
module Test.StarWars.Schema
2020-09-28 07:06:15 +02:00
( starWarsSchema
2019-07-14 05:58:05 +02:00
) where
import Control.Monad.Catch (MonadThrow(..), SomeException)
import Control.Monad.Trans.Reader (asks)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import Data.Text (Text)
2020-06-19 10:53:41 +02:00
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In
2020-05-24 13:51:00 +02:00
import qualified Language.GraphQL.Type.Out as Out
import Test.StarWars.Data
import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
2020-09-28 07:06:15 +02:00
starWarsSchema :: Schema (Either SomeException)
starWarsSchema = schema queryType Nothing Nothing mempty
2020-05-14 09:17:14 +02:00
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroFieldResolver)
, ("human", humanFieldResolver)
, ("droid", droidFieldResolver)
]
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "episode"
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
heroFieldResolver = ValueResolver heroField hero
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
humanFieldResolver = ValueResolver humanField human
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
droidFieldResolver = ValueResolver droidField droid
heroObject :: Out.ObjectType (Either SomeException)
heroObject = Out.ObjectType "Human" Nothing [characterType] $ HashMap.fromList
[ ("id", idFieldType)
, ("name", nameFieldType)
, ("friends", friendsFieldResolver)
, ("appearsIn", appearsInFieldResolver)
, ("homePlanet", homePlanetFieldType)
, ("secretBackstory", secretBackstoryFieldResolver)
, ("__typename", typenameFieldResolver)
]
where
homePlanetFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ defaultResolver "homePlanet"
droidObject :: Out.ObjectType (Either SomeException)
droidObject = Out.ObjectType "Droid" Nothing [characterType] $ HashMap.fromList
[ ("id", idFieldType)
, ("name", nameFieldType)
, ("friends", friendsFieldResolver)
, ("appearsIn", appearsInFieldResolver)
, ("primaryFunction", primaryFunctionFieldType)
, ("secretBackstory", secretBackstoryFieldResolver)
, ("__typename", typenameFieldResolver)
]
where
primaryFunctionFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ defaultResolver "primaryFunction"
typenameFieldResolver :: Resolver (Either SomeException)
typenameFieldResolver
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ defaultResolver "__typename"
idFieldType :: Resolver (Either SomeException)
idFieldType = ValueResolver idField $ defaultResolver "id"
nameFieldType :: Resolver (Either SomeException)
nameFieldType = ValueResolver nameField $ defaultResolver "name"
friendsFieldResolver :: Resolver (Either SomeException)
friendsFieldResolver = ValueResolver friendsField $ defaultResolver "friends"
characterType :: InterfaceType (Either SomeException)
characterType = InterfaceType "Character" Nothing [] $ HashMap.fromList
[ ("id", idField)
, ("name", nameField)
, ("friends", friendsField)
, ("appearsIn", appearsInField)
, ("secretBackstory", secretBackstoryField)
]
idField :: Field (Either SomeException)
idField = Field Nothing (Out.NonNullScalarType id) mempty
nameField :: Field (Either SomeException)
nameField = Field Nothing (Out.NamedScalarType string) mempty
friendsField :: Field (Either SomeException)
friendsField = Field Nothing friendsFieldType mempty
2020-06-13 07:20:19 +02:00
where
friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType)
appearsInField :: Field (Either SomeException)
appearsInField = Field appearsInDescription appearsInFieldType mempty
where
appearsInDescription = Just "Which movies they appear in."
appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum
secretBackstoryField :: Field (Either SomeException)
secretBackstoryField =
Out.Field Nothing (Out.NamedScalarType string) mempty
appearsInFieldResolver :: Resolver (Either SomeException)
appearsInFieldResolver = ValueResolver appearsInField
$ defaultResolver "appearsIn"
secretBackstoryFieldResolver :: Resolver (Either SomeException)
secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory
defaultResolver :: Text -> Resolve (Either SomeException)
defaultResolver f = do
v <- asks values
let (Object v') = v
pure $ v' HashMap.! f
episodeEnum :: EnumType
episodeEnum = EnumType "Episode" (Just description)
$ HashMap.fromList [newHope, empire, jedi]
where
description = "One of the films in the Star Wars Trilogy"
newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
hero :: Resolve (Either SomeException)
2020-05-24 13:51:00 +02:00
hero = do
episode <- argument "episode"
pure $ character $ case episode of
2020-06-13 07:20:19 +02:00
Enum "NEW_HOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6
_ -> artoo
human :: Resolve (Either SomeException)
2020-05-24 13:51:00 +02:00
human = do
id' <- argument "id"
case id' of
String i -> pure $ maybe Null character $ getHuman i >>= Just
_ -> throwM InvalidArguments
droid :: Resolve (Either SomeException)
2020-05-24 13:51:00 +02:00
droid = do
id' <- argument "id"
case id' of
String i -> pure $ maybe Null character $ getDroid i >>= Just
_ -> throwM InvalidArguments
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)
]