summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/GraphQL.hs5
-rw-r--r--src/Language/GraphQL/Error.hs12
-rw-r--r--src/Language/GraphQL/Execute.hs7
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs33
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs21
-rw-r--r--src/Language/GraphQL/Type/Out.hs7
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) =
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 14:03:28 +0000