diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Execution.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 82 |
1 files changed, 47 insertions, 35 deletions
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 0c10419..d8d5b13 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -3,11 +3,13 @@ {-# LANGUAGE ViewPatterns #-} module Language.GraphQL.Execute.Execution - ( executeSelectionSet + ( coerceArgumentValues + , collectFields + , 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(..)) @@ -17,28 +19,35 @@ 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.AST.Core import Language.GraphQL.Error import Language.GraphQL.Execute.Coerce import qualified Language.GraphQL.Execute.Transform as Transform -import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Schema import Prelude hiding (null) -resolveFieldValue :: Monad m +resolveFieldValue :: MonadCatch m => Type.Value -> Type.Subs - -> ActionT m a - -> m (Either Text a) -resolveFieldValue result args = - flip runReaderT (Context {arguments = Arguments args, values = result}) - . runExceptT - . runActionT + -> Type.Resolve m + -> CollectErrsT m Type.Value +resolveFieldValue result args 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 + } collectFields :: Monad m => Out.ObjectType m @@ -98,23 +107,27 @@ 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) -> CollectErrsT m a -executeField (Out.Resolver fieldDefinition resolver) prev fields = do - let Out.Field _ fieldType argumentDefinitions = fieldDefinition - let (Transform.Field _ _ arguments' _ :| []) = fields - case coerceArgumentValues argumentDefinitions arguments' of - Nothing -> errmsg "Argument coercing failed." - Just argumentValues -> do - answer <- lift $ resolveFieldValue prev argumentValues resolver - case answer of - Right result -> completeValue fieldType fields result - Left errorMessage -> errmsg errorMessage +executeField fieldResolver prev fields + | Out.ValueResolver fieldDefinition resolver <- fieldResolver = + executeField' fieldDefinition resolver + | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver = + executeField' fieldDefinition resolver + where + executeField' fieldDefinition resolver = do + let Out.Field _ fieldType argumentDefinitions = fieldDefinition + let (Transform.Field _ _ arguments' _ :| []) = fields + case coerceArgumentValues argumentDefinitions arguments' of + Nothing -> addErrMsg "Argument coercing failed." + Just argumentValues -> do + 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 @@ -135,7 +148,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = let Type.EnumType _ _ enumMembers = enumType in if HashMap.member enum enumMembers then coerceResult outputType $ Enum enum - else errmsg "Value completion failed." + else addErrMsg "Value completion failed." completeValue (Out.ObjectBaseType objectType) fields result = executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result @@ -145,7 +158,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields - Nothing -> errmsg "Value completion failed." + Nothing -> addErrMsg "Value completion failed." completeValue (Out.UnionBaseType unionType) fields result | Type.Object objectMap <- result = do let abstractType = AbstractUnionType unionType @@ -153,30 +166,29 @@ completeValue (Out.UnionBaseType unionType) fields result case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields - Nothing -> errmsg "Value completion failed." -completeValue _ _ _ = errmsg "Value completion failed." + 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 -errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a -errmsg errorMessage = addErrMsg errorMessage >> pure null - -coerceResult :: (Monad m, Serialize a) +coerceResult :: (MonadCatch m, Serialize a) => Out.Type m -> Output a -> CollectErrsT m a coerceResult outputType result | Just serialized <- serialize outputType result = pure serialized - | otherwise = errmsg "Result coercion failed." + | otherwise = addErrMsg "Result coercion failed." -- | 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) |