summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs26
-rw-r--r--tests/Test/StarWars/Data.hs22
-rw-r--r--tests/Test/StarWars/QuerySpec.hs8
-rw-r--r--tests/Test/StarWars/Schema.hs36
4 files changed, 50 insertions, 42 deletions
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 7aab6c5..8fbb55b 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -7,11 +7,10 @@ module Language.GraphQL.ExecuteSpec
( spec
) where
+import Control.Exception (SomeException)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.Conduit
-import Data.Either (fromRight)
-import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST (Name)
@@ -23,14 +22,14 @@ import Language.GraphQL.Type.Out as Out
import Test.Hspec (Spec, context, describe, it, shouldBe)
import Text.Megaparsec (parse)
-schema :: Schema Identity
+schema :: Schema (Either SomeException)
schema = Schema
{ query = queryType
, mutation = Nothing
, subscription = Just subscriptionType
}
-queryType :: Out.ObjectType Identity
+queryType :: Out.ObjectType (Either SomeException)
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "philosopher"
$ ValueResolver philosopherField
@@ -39,7 +38,7 @@ queryType = Out.ObjectType "Query" Nothing []
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
-philosopherType :: Out.ObjectType Identity
+philosopherType :: Out.ObjectType (Either SomeException)
philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers
where
@@ -54,7 +53,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
lastNameResolver = pure $ Type.String "Nietzsche"
-subscriptionType :: Out.ObjectType Identity
+subscriptionType :: Out.ObjectType (Either SomeException)
subscriptionType = Out.ObjectType "Subscription" Nothing []
$ HashMap.singleton "newQuote"
$ EventStreamResolver quoteField (pure $ Type.Object mempty)
@@ -63,7 +62,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
quoteField =
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
-quoteType :: Out.ObjectType Identity
+quoteType :: Out.ObjectType (Either SomeException)
quoteType = Out.ObjectType "Quote" Nothing []
$ HashMap.singleton "quote"
$ ValueResolver quoteField
@@ -84,9 +83,7 @@ spec =
]
expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
- actual = fromRight (singleError "")
- $ runIdentity
- $ either (pure . parseError) execute'
+ Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected
it "merges selections" $
@@ -98,9 +95,7 @@ spec =
]
expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
- actual = fromRight (singleError "")
- $ runIdentity
- $ either (pure . parseError) execute'
+ Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected
context "Subscription" $
@@ -112,8 +107,7 @@ spec =
]
expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
- Left stream = runIdentity
- $ either (pure . parseError) execute'
+ Right (Left stream) = either (pure . parseError) execute'
$ parse document "" "subscription { newQuote { quote } }"
- Just actual = runConduitPure $ stream .| await
+ Right (Just actual) = runConduit $ stream .| await
in actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index 00a89d9..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,11 +17,12 @@ 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 Data.Typeable (cast)
+import Language.GraphQL.Error
import Language.GraphQL.Type
-- * Data
@@ -66,8 +68,20 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
-secretBackstory :: Resolve Identity
-secretBackstory = 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")
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index 4e48dbf..301fb7c 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 actual = graphql schema q
+ in actual `shouldBe` expected
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected =
- runIdentity (graphqlSubs schema Nothing f q) `shouldBe` expected
+ let Right actual = graphqlSubs schema Nothing f q
+ in actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 99200ff..cecd8eb 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -4,10 +4,8 @@ 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)
@@ -19,7 +17,7 @@ import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
-schema :: Schema Identity
+schema :: Schema (Either SomeException)
schema = Schema
{ query = queryType
, mutation = Nothing
@@ -42,7 +40,7 @@ schema = Schema
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", idFieldType)
, ("name", nameFieldType)
@@ -57,7 +55,7 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
= 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", idFieldType)
, ("name", nameFieldType)
@@ -72,29 +70,29 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "primaryFunction"
-typenameFieldType :: Resolver Identity
+typenameFieldType :: Resolver (Either SomeException)
typenameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "__typename"
-idFieldType :: Resolver Identity
+idFieldType :: Resolver (Either SomeException)
idFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
$ idField "id"
-nameFieldType :: Resolver Identity
+nameFieldType :: Resolver (Either SomeException)
nameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "name"
-friendsFieldType :: Resolver Identity
+friendsFieldType :: Resolver (Either SomeException)
friendsFieldType
= ValueResolver (Out.Field Nothing fieldType mempty)
$ idField "friends"
where
fieldType = Out.ListType $ Out.NamedObjectType droidObject
-appearsInField :: Resolver Identity
+appearsInField :: Resolver (Either SomeException)
appearsInField
= ValueResolver (Out.Field (Just description) fieldType mempty)
$ idField "appearsIn"
@@ -102,14 +100,14 @@ appearsInField
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
description = "Which movies they appear in."
-secretBackstoryFieldType :: Resolver Identity
+secretBackstoryFieldType :: Resolver (Either SomeException)
secretBackstoryFieldType = ValueResolver field secretBackstory
where
field = Out.Field Nothing (Out.NamedScalarType string) mempty
-idField :: Text -> Resolve Identity
+idField :: Text -> Resolve (Either SomeException)
idField f = do
- v <- lift $ asks values
+ v <- asks values
let (Object v') = v
pure $ v' HashMap.! f
@@ -122,7 +120,7 @@ episodeEnum = EnumType "Episode" (Just description)
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
-hero :: Resolve Identity
+hero :: Resolve (Either SomeException)
hero = do
episode <- argument "episode"
pure $ character $ case episode of
@@ -131,19 +129,19 @@ hero = do
Enum "JEDI" -> getHero 6
_ -> artoo
-human :: Resolve Identity
+human :: Resolve (Either SomeException)
human = do
id' <- argument "id"
case id' of
String i -> pure $ maybe Null character $ getHuman i >>= Just
- _ -> throwE "Invalid arguments."
+ _ -> throwM InvalidArguments
-droid :: Resolve Identity
+droid :: Resolve (Either SomeException)
droid = do
id' <- argument "id"
case id' of
String i -> pure $ maybe Null character $ getDroid i >>= Just
- _ -> throwE "Invalid arguments."
+ _ -> throwM InvalidArguments
character :: Character -> Value
character char = Object $ HashMap.fromList
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 00:08:35 +0000