graphql/tests/Test/StarWars/Schema.hs

96 lines
3.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
2019-07-14 05:58:05 +02:00
module Test.StarWars.Schema
( schema
2019-07-14 05:58:05 +02:00
) 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 Data.Text (Text)
import Language.GraphQL.Trans
2020-05-14 09:17:14 +02:00
import Language.GraphQL.Type.Definition
2020-05-24 13:51:00 +02:00
import qualified Language.GraphQL.Type.Out as Out
2020-05-14 09:17:14 +02:00
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
2020-05-14 09:17:14 +02:00
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)
]
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
2020-05-24 13:51:00 +02:00
hero = do
episode <- argument "episode"
pure $ character $ case episode of
Enum "NEWHOPE" -> getHero 4
Enum "EMPIRE" -> getHero 5
Enum "JEDI" -> getHero 6
_ -> artoo
human :: ActionT Identity Value
2020-05-24 13:51:00 +02:00
human = do
id' <- argument "id"
case id' of
String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> pure Null
Just e -> pure $ character e
_ -> ActionT $ throwE "Invalid arguments."
droid :: ActionT Identity Value
2020-05-24 13:51:00 +02:00
droid = do
id' <- argument "id"
case id' of
String i -> character <$> getDroid i
_ -> ActionT $ throwE "Invalid arguments."
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)
]