OSS/graphql
1
1
Fork 1
Code Issues 4 Pull Requests Actions Releases 22 Wiki Activity

Constrain base monad to MonadCatch

Browse Source 
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:
Eugen Wissner
2020-07-17 07:05:03 +02:00
parent e24386402b
commit 09135c581a
13 changed files with 115 additions and 75 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/Language/GraphQL.hs
View File

@ -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.

12
src/Language/GraphQL/Error.hs
View File

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

7
src/Language/GraphQL/Execute.hs
View File

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

33
src/Language/GraphQL/Execute/Execution.hs
View File

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

21
src/Language/GraphQL/Execute/Subscribe.hs
View File

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

7
src/Language/GraphQL/Type/Out.hs
View File

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