From 09135c581aaae471f7d964bc2a3a141bef299097 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
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.
---
 src/Language/GraphQL/Execute/Subscribe.hs | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

(limited to 'src/Language/GraphQL/Execute/Subscribe.hs')

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)
-- 
cgit v1.2.3