Constrain base monad to MonadCatch
Let's try MonadThrow/MonadCatch. It looks nice at a first glance. The monad transformer stack contains only the ReaderT, less lifts are required. Exception subtyping is easier, the user can (and should) define custom error types and throw them. And it is still possible to use pure error handling, if someone doesn't like runtime exceptions or need to run a query in a pure environment. Fixes #42.
This commit is contained in:
@ -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
|
||||
|
||||
@ -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")
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user