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.

6 files changed, 54 insertions, 31 deletions

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) =