From 09135c581aaae471f7d964bc2a3a141bef299097 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Fri, 17 Jul 2020 07:05:03 +0200 Subject: 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. --- tests/Language/GraphQL/ExecuteSpec.hs | 26 ++++++++++--------------- tests/Test/StarWars/Data.hs | 22 +++++++++++++++++---- tests/Test/StarWars/QuerySpec.hs | 8 +++++--- tests/Test/StarWars/Schema.hs | 36 +++++++++++++++++------------------ 4 files changed, 50 insertions(+), 42 deletions(-) (limited to 'tests') 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 -- cgit v1.2.3