summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md8
-rw-r--r--graphql.cabal4
-rw-r--r--package.yaml1
-rw-r--r--src/Language/GraphQL.hs5
-rw-r--r--src/Language/GraphQL/Error.hs12
-rw-r--r--src/Language/GraphQL/Execute.hs7
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs33
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs21
-rw-r--r--src/Language/GraphQL/Type/Out.hs7
-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
13 files changed, 115 insertions, 75 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 224f936..79cf9c7 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -24,12 +24,16 @@ and this project adheres to
- Parsing subscriptions (the execution always fails yet).
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
`Type.Out.SourceEventStream` define subscription resolvers.
+- `Error.ResolverException` is an exception that can be thrown by (field value
+ and event stream) resolvers to signalize an error. Other exceptions will
+ escape.
## Changed
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
have value resolvers, root subscription type resolvers need an additional
resolver that creates an event stream. `Resolver` represents these differences
- now and pairs a field with the function(s).
+ now and pairs a field with the function(s). Resolvers don't have `ExceptT`,
+ errors are handled with `MonadThrow`/`MonadCatch`.
- All code from `Trans` is moved to `Type.Out` and exported by `Type` and
`Type.Out`.
- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
@@ -43,6 +47,8 @@ and this project adheres to
variable names is changed back to JSON since it is a common format and it
saves additional conversions. Custom format still can be used with the
underlying functions (in the `Execute` module).
+- The constraint of the base monad was changed to `MonadCatch` (and it implies
+ `MonadThrow`).
## Removed
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
diff --git a/graphql.cabal b/graphql.cabal
index 5f3c8ea..ea38140 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: 38e16611476c6163a049a4ddbaef34cf3fdef8f85d25f7bcaed839372c9fdf75
+-- hash: f3469205f704a81ee0f55655758cf588a9e9eb52303dadd58def32a2eb207696
name: graphql
version: 0.8.0.0
@@ -64,6 +64,7 @@ library
, base >=4.7 && <5
, conduit
, containers
+ , exceptions
, megaparsec
, parser-combinators
, scientific
@@ -100,6 +101,7 @@ test-suite tasty
, base >=4.7 && <5
, conduit
, containers
+ , exceptions
, graphql
, hspec
, hspec-expectations
diff --git a/package.yaml b/package.yaml
index 1c855e1..be2aad8 100644
--- a/package.yaml
+++ b/package.yaml
@@ -30,6 +30,7 @@ dependencies:
- base >= 4.7 && < 5
- conduit
- containers
+- exceptions
- megaparsec
- parser-combinators
- scientific
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index 6ee2dd7..1b8c562 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -7,6 +7,7 @@ module Language.GraphQL
, graphqlSubs
) where
+import Control.Monad.Catch (MonadCatch)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Either (fromRight)
@@ -20,7 +21,7 @@ import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema'.
-graphql :: Monad m
+graphql :: MonadCatch m
=> Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response.
@@ -29,7 +30,7 @@ graphql schema = graphqlSubs schema mempty mempty
-- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given
-- 'Schema'.
-graphqlSubs :: Monad m
+graphqlSubs :: MonadCatch m
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> Aeson.Object -- ^ Variable substitution function.
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index 474ddc7..9df69de 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@@ -8,6 +9,7 @@ module Language.GraphQL.Error
, CollectErrsT
, Error(..)
, Resolution(..)
+ , ResolverException(..)
, Response(..)
, ResponseEventStream
, addErr
@@ -17,6 +19,7 @@ module Language.GraphQL.Error
) where
import Conduit
+import Control.Exception (Exception(..))
import Control.Monad.Trans.State (StateT, modify, runStateT)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..), (|>))
@@ -102,6 +105,15 @@ data Response a = Response
-- Stream.
type ResponseEventStream m a = ConduitT () (Response a) m ()
+-- | Only exceptions that inherit from 'ResolverException' a cought by the
+-- executor.
+data ResolverException = forall e. Exception e => ResolverException e
+
+instance Show ResolverException where
+ show (ResolverException e) = show e
+
+instance Exception ResolverException
+
-- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data.
runCollectErrs :: (Monad m, Serialize a)
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 08aa5ab..2b615f4 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -6,6 +6,7 @@ module Language.GraphQL.Execute
, module Language.GraphQL.Execute.Coerce
) where
+import Control.Monad.Catch (MonadCatch)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..))
import Data.Text (Text)
@@ -25,7 +26,7 @@ import Language.GraphQL.Type.Schema
--
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
-execute :: (Monad m, VariableValue a, Serialize b)
+execute :: (MonadCatch m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> HashMap Name a -- ^ Variable substitution function.
@@ -39,7 +40,7 @@ execute schema operationName subs document =
$ Transform.queryError queryError
Right transformed -> executeRequest transformed
-executeRequest :: (Monad m, Serialize a)
+executeRequest :: (MonadCatch m, Serialize a)
=> Transform.Document m
-> m (Either (ResponseEventStream m a) (Response a))
executeRequest (Transform.Document types' rootObjectType operation)
@@ -53,7 +54,7 @@ executeRequest (Transform.Document types' rootObjectType operation)
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
-executeOperation :: (Monad m, Serialize a)
+executeOperation :: (MonadCatch m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 22f3595..d8d5b13 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -8,8 +8,8 @@ module Language.GraphQL.Execute.Execution
, executeSelectionSet
) where
+import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
@@ -19,7 +19,7 @@ import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
-import Data.Text (Text)
+import qualified Data.Text as Text
import Language.GraphQL.AST (Name)
import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
@@ -31,14 +31,19 @@ import Language.GraphQL.Type.Internal
import Language.GraphQL.Type.Schema
import Prelude hiding (null)
-resolveFieldValue :: Monad m
+resolveFieldValue :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Type.Resolve m
- -> m (Either Text Type.Value)
+ -> CollectErrsT m Type.Value
resolveFieldValue result args resolver =
- flip runReaderT context $ runExceptT resolver
+ catch (lift $ runReaderT resolver context) handleFieldError
where
+ handleFieldError :: MonadCatch m
+ => ResolverException
+ -> CollectErrsT m Type.Value
+ handleFieldError e =
+ addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -102,7 +107,7 @@ instanceOf objectType (AbstractUnionType unionType) =
where
go unionMemberType acc = acc || objectType == unionMemberType
-executeField :: (Monad m, Serialize a)
+executeField :: (MonadCatch m, Serialize a)
=> Out.Resolver m
-> Type.Value
-> NonEmpty (Transform.Field m)
@@ -119,12 +124,10 @@ executeField fieldResolver prev fields
case coerceArgumentValues argumentDefinitions arguments' of
Nothing -> addErrMsg "Argument coercing failed."
Just argumentValues -> do
- answer <- lift $ resolveFieldValue prev argumentValues resolver
- case answer of
- Right result -> completeValue fieldType fields result
- Left errorMessage -> addErrMsg errorMessage
+ answer <- resolveFieldValue prev argumentValues resolver
+ completeValue fieldType fields answer
-completeValue :: (Monad m, Serialize a)
+completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m
-> NonEmpty (Transform.Field m)
-> Type.Value
@@ -166,13 +169,15 @@ completeValue (Out.UnionBaseType unionType) fields result
Nothing -> addErrMsg "Value completion failed."
completeValue _ _ _ = addErrMsg "Value completion failed."
-mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
+mergeSelectionSets :: MonadCatch m
+ => NonEmpty (Transform.Field m)
+ -> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
selectionSet <> fieldSelectionSet
-coerceResult :: (Monad m, Serialize a)
+coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m
-> Output a
-> CollectErrsT m a
@@ -183,7 +188,7 @@ coerceResult outputType result
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing
-- the resolved 'Transform.Selection', or a null value and error information.
-executeSelectionSet :: (Monad m, Serialize a)
+executeSelectionSet :: (MonadCatch m, Serialize a)
=> Type.Value
-> Out.ObjectType m
-> Seq (Transform.Selection m)
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index ee9b116..0bd274f 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -9,7 +9,7 @@ module Language.GraphQL.Execute.Subscribe
) where
import Conduit
-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
+import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -17,6 +17,7 @@ import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq(..))
import Data.Text (Text)
+import qualified Data.Text as Text
import Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
@@ -29,7 +30,7 @@ import Language.GraphQL.Type.Schema
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
-subscribe :: (Monad m, Serialize a)
+subscribe :: (MonadCatch m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
@@ -38,7 +39,7 @@ subscribe types' objectType fields = do
sourceStream <- createSourceEventStream types' objectType fields
traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
-mapSourceToResponseEvent :: (Monad m, Serialize a)
+mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
@@ -48,7 +49,7 @@ mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
$ sourceStream
.| mapMC (executeSubscriptionEvent types' subscriptionType fields)
-createSourceEventStream :: Monad m
+createSourceEventStream :: MonadCatch m
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
@@ -67,14 +68,18 @@ createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes
where
groupedFieldSet = collectFields subscriptionType fields
-resolveFieldEventStream :: Monad m
+resolveFieldEventStream :: MonadCatch m
=> Type.Value
-> Type.Subs
- -> ExceptT Text (ReaderT Out.Context m) (Out.SourceEventStream m)
+ -> Out.Subscribe m
-> m (Either Text (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
- flip runReaderT context $ runExceptT resolver
+ catch (Right <$> runReaderT resolver context) handleEventStreamError
where
+ handleEventStreamError :: MonadCatch m
+ => ResolverException
+ -> m (Either Text (Out.SourceEventStream m))
+ handleEventStreamError = pure . Left . Text.pack . displayException
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -82,7 +87,7 @@ resolveFieldEventStream result args resolver =
-- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet.
-executeSubscriptionEvent :: (Monad m, Serialize a)
+executeSubscriptionEvent :: (MonadCatch m, Serialize a)
=> HashMap Name (Type m)
-> Out.ObjectType m
-> Seq (Transform.Selection m)
diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs
index d094b4d..89bbf1d 100644
--- a/src/Language/GraphQL/Type/Out.hs
+++ b/src/Language/GraphQL/Type/Out.hs
@@ -33,7 +33,6 @@ module Language.GraphQL.Type.Out
) where
import Conduit
-import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Reader (ReaderT, asks)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -180,11 +179,11 @@ data Context = Context
-- | Monad transformer stack used by the resolvers for determining the resolved
-- value of a field.
-type Resolve m = ExceptT Text (ReaderT Context m) Value
+type Resolve m = ReaderT Context m Value
-- | Monad transformer stack used by the resolvers for determining the resolved
-- event stream of a subscription field.
-type Subscribe m = ExceptT Text (ReaderT Context m) (SourceEventStream m)
+type Subscribe m = ReaderT Context m (SourceEventStream m)
-- | A source stream represents the sequence of events, each of which will
-- trigger a GraphQL execution corresponding to that event.
@@ -206,7 +205,7 @@ data Resolver m
-- be optional then).
argument :: Monad m => Name -> Resolve m
argument argumentName = do
- argumentValue <- lift $ asks $ lookupArgument . arguments
+ argumentValue <- asks $ lookupArgument . arguments
pure $ fromMaybe Null argumentValue
where
lookupArgument (Arguments argumentMap) =
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-26 22:22:41 +0000