aboutsummaryrefslogtreecommitdiff
path: root/tests/Test/StarWars
diff options
context:
space:
mode:
Diffstat (limited to 'tests/Test/StarWars')
-rw-r--r--tests/Test/StarWars/Data.hs32
-rw-r--r--tests/Test/StarWars/QuerySpec.hs8
-rw-r--r--tests/Test/StarWars/Schema.hs129
3 files changed, 103 insertions, 66 deletions
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index 427371b..e3dd696 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Data
( Character
+ , StarWarsException(..)
, appearsIn
, artoo
, getDroid
@@ -16,12 +17,13 @@ module Test.StarWars.Data
, typeName
) where
-import Data.Functor.Identity (Identity)
+import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
import Control.Applicative (Alternative(..), liftA2)
-import Control.Monad.Trans.Except (throwE)
import Data.Maybe (catMaybes)
import Data.Text (Text)
-import Language.GraphQL.Trans
+import Data.Typeable (cast)
+import Language.GraphQL.Error
+import Language.GraphQL.Type
-- * Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -66,8 +68,20 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
-secretBackstory :: ActionT Identity Text
-secretBackstory = ActionT $ throwE "secretBackstory is secret."
+data StarWarsException = SecretBackstory | InvalidArguments
+
+instance Show StarWarsException where
+ show SecretBackstory = "secretBackstory is secret."
+ show InvalidArguments = "Invalid arguments."
+
+instance Exception StarWarsException where
+ toException = toException . ResolverException
+ fromException e = do
+ ResolverException resolverException <- fromException e
+ cast resolverException
+
+secretBackstory :: Resolve (Either SomeException)
+secretBackstory = throwM SecretBackstory
typeName :: Character -> Text
typeName = either (const "Droid") (const "Human")
@@ -161,10 +175,10 @@ getHero :: Int -> Character
getHero 5 = luke
getHero _ = artoo
-getHuman :: Alternative f => ID -> f Character
+getHuman :: ID -> Maybe Character
getHuman = fmap Right . getHuman'
-getHuman' :: Alternative f => ID -> f Human
+getHuman' :: ID -> Maybe Human
getHuman' "1000" = pure luke'
getHuman' "1001" = pure vader
getHuman' "1002" = pure han
@@ -172,10 +186,10 @@ getHuman' "1003" = pure leia
getHuman' "1004" = pure tarkin
getHuman' _ = empty
-getDroid :: Alternative f => ID -> f Character
+getDroid :: ID -> Maybe Character
getDroid = fmap Left . getDroid'
-getDroid' :: Alternative f => ID -> f Droid
+getDroid' :: ID -> Maybe Droid
getDroid' "2000" = pure threepio
getDroid' "2001" = pure artoo'
getDroid' _ = empty
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index cf451f8..95b18d3 100644
--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -6,7 +6,6 @@ module Test.StarWars.QuerySpec
import qualified Data.Aeson as Aeson
import Data.Aeson ((.=))
-import Data.Functor.Identity (Identity(..))
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL
@@ -357,8 +356,11 @@ spec = describe "Star Wars Query Tests" $ do
alderaan = "homePlanet" .= ("Alderaan" :: Text)
testQuery :: Text -> Aeson.Value -> Expectation
-testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
+testQuery q expected =
+ let Right (Right actual) = graphql schema q
+ in Aeson.Object actual `shouldBe` expected
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected =
- runIdentity (graphqlSubs schema f q) `shouldBe` expected
+ let Right (Right actual) = graphqlSubs schema Nothing f q
+ in Aeson.Object actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 5fcdf3e..cecd8eb 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -4,14 +4,11 @@ module Test.StarWars.Schema
( schema
) where
+import Control.Monad.Catch (MonadThrow(..), SomeException)
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
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
@@ -20,69 +17,97 @@ import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
-schema :: Schema Identity
-schema = Schema { query = queryType, mutation = Nothing }
+schema :: Schema (Either SomeException)
+schema = Schema
+ { query = queryType
+ , mutation = Nothing
+ , subscription = Nothing
+ }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
- [ ("hero", Out.Resolver heroField hero)
- , ("human", Out.Resolver humanField human)
- , ("droid", Out.Resolver droidField droid)
+ [ ("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 Identity
+heroObject :: Out.ObjectType (Either SomeException)
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
- [ ("id", Out.Resolver idFieldType (idField "id"))
- , ("name", Out.Resolver nameFieldType (idField "name"))
- , ("friends", Out.Resolver friendsFieldType (idField "friends"))
- , ("appearsIn", Out.Resolver appearsInField (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"))
+ [ ("id", idFieldType)
+ , ("name", nameFieldType)
+ , ("friends", friendsFieldType)
+ , ("appearsIn", appearsInField)
+ , ("homePlanet", homePlanetFieldType)
+ , ("secretBackstory", secretBackstoryFieldType)
+ , ("__typename", typenameFieldType)
]
where
- homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+ homePlanetFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "homePlanet"
-droidObject :: Out.ObjectType Identity
+droidObject :: Out.ObjectType (Either SomeException)
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
- [ ("id", Out.Resolver idFieldType (idField "id"))
- , ("name", Out.Resolver nameFieldType (idField "name"))
- , ("friends", Out.Resolver friendsFieldType (idField "friends"))
- , ("appearsIn", Out.Resolver appearsInField (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"))
+ [ ("id", idFieldType)
+ , ("name", nameFieldType)
+ , ("friends", friendsFieldType)
+ , ("appearsIn", appearsInField)
+ , ("primaryFunction", primaryFunctionFieldType)
+ , ("secretBackstory", secretBackstoryFieldType)
+ , ("__typename", typenameFieldType)
]
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
+ primaryFunctionFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "primaryFunction"
+
+typenameFieldType :: Resolver (Either SomeException)
+typenameFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "__typename"
+
+idFieldType :: Resolver (Either SomeException)
+idFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
+ $ idField "id"
+
+nameFieldType :: Resolver (Either SomeException)
+nameFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "name"
+
+friendsFieldType :: Resolver (Either SomeException)
+friendsFieldType
+ = ValueResolver (Out.Field Nothing fieldType mempty)
+ $ idField "friends"
+ where
+ fieldType = Out.ListType $ Out.NamedObjectType droidObject
-appearsInField :: Out.Field Identity
-appearsInField = Out.Field (Just description) fieldType mempty
+appearsInField :: Resolver (Either SomeException)
+appearsInField
+ = ValueResolver (Out.Field (Just description) fieldType mempty)
+ $ idField "appearsIn"
where
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
description = "Which movies they appear in."
-secretBackstoryFieldType :: Out.Field Identity
-secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+secretBackstoryFieldType :: Resolver (Either SomeException)
+secretBackstoryFieldType = ValueResolver field secretBackstory
+ where
+ field = Out.Field Nothing (Out.NamedScalarType string) mempty
-idField :: Text -> ActionT Identity Value
+idField :: Text -> Resolve (Either SomeException)
idField f = do
- v <- ActionT $ lift $ asks values
+ v <- asks values
let (Object v') = v
pure $ v' HashMap.! f
@@ -95,7 +120,7 @@ episodeEnum = EnumType "Episode" (Just description)
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
-hero :: ActionT Identity Value
+hero :: Resolve (Either SomeException)
hero = do
episode <- argument "episode"
pure $ character $ case episode of
@@ -104,23 +129,19 @@ hero = do
Enum "JEDI" -> getHero 6
_ -> artoo
-human :: ActionT Identity Value
+human :: Resolve (Either SomeException)
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
+ String i -> pure $ maybe Null character $ getHuman i >>= Just
+ _ -> throwM InvalidArguments
+
+droid :: Resolve (Either SomeException)
droid = do
id' <- argument "id"
case id' of
- String i -> character <$> getDroid i
- _ -> ActionT $ throwE "Invalid arguments."
+ String i -> pure $ maybe Null character $ getDroid i >>= Just
+ _ -> throwM InvalidArguments
character :: Character -> Value
character char = Object $ HashMap.fromList
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:38:10 +0000