forked from OSS/graphql
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:
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
Reference in New Issue
Block a user