aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL/Execute
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL/Execute')
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs82
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs97
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs26
3 files changed, 160 insertions, 45 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)
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
new file mode 100644
index 0000000..0bd274f
--- /dev/null
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -0,0 +1,97 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Execute.Subscribe
+ ( subscribe
+ ) where
+
+import Conduit
+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
+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
+import qualified Language.GraphQL.Execute.Transform as Transform
+import Language.GraphQL.Error
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Schema
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+subscribe :: (MonadCatch m, Serialize a)
+ => HashMap Name (Type m)
+ -> Out.ObjectType m
+ -> Seq (Transform.Selection m)
+ -> m (Either Text (ResponseEventStream m a))
+subscribe types' objectType fields = do
+ sourceStream <- createSourceEventStream types' objectType fields
+ traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+
+mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
+ => HashMap Name (Type m)
+ -> Out.ObjectType m
+ -> Seq (Transform.Selection m)
+ -> Out.SourceEventStream m
+ -> m (ResponseEventStream m a)
+mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+ $ sourceStream
+ .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+
+createSourceEventStream :: MonadCatch m
+ => HashMap Name (Type m)
+ -> Out.ObjectType m
+ -> Seq (Transform.Selection m)
+ -> m (Either Text (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
+ | [fieldGroup] <- Map.elems groupedFieldSet
+ , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+ , resolverT <- fieldTypes HashMap.! fieldName
+ , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
+ , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
+ case coerceArgumentValues argumentDefinitions arguments' of
+ Nothing -> pure $ Left "Argument coercion failed."
+ Just argumentValues ->
+ resolveFieldEventStream Type.Null argumentValues resolver
+ | otherwise = pure $ Left "Subscription contains more than one field."
+ where
+ groupedFieldSet = collectFields subscriptionType fields
+
+resolveFieldEventStream :: MonadCatch m
+ => Type.Value
+ -> Type.Subs
+ -> Out.Subscribe m
+ -> m (Either Text (Out.SourceEventStream m))
+resolveFieldEventStream result args 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
+ }
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+executeSubscriptionEvent :: (MonadCatch m, Serialize a)
+ => HashMap Name (Type m)
+ -> Out.ObjectType m
+ -> Seq (Transform.Selection m)
+ -> Definition.Value
+ -> m (Response a)
+executeSubscriptionEvent types' objectType fields initialValue =
+ runCollectErrs types' $ executeSelectionSet initialValue objectType fields
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 733ac8c..76d1fe7 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -44,12 +44,11 @@ import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Core
import qualified Language.GraphQL.Execute.Coerce as Coerce
-import Language.GraphQL.Type.Directive (Directive(..))
-import qualified Language.GraphQL.Type.Directive as Directive
+import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
+import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@@ -78,6 +77,7 @@ data Selection m
data Operation m
= Query (Maybe Text) (Seq (Selection m))
| Mutation (Maybe Text) (Seq (Selection m))
+ | Subscription (Maybe Text) (Seq (Selection m))
-- | Single GraphQL field.
data Field m = Field
@@ -239,6 +239,10 @@ document schema operationName subs ast = do
| Just mutationType <- mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
+ OperationDefinition Full.Subscription _ _ _ _
+ | Just subscriptionType <- subscription schema ->
+ pure $ Document referencedTypes subscriptionType
+ $ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation
defragment
@@ -251,10 +255,10 @@ defragment ast =
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
where
defragment' definition (operations, fragments')
- | (Full.ExecutableDefinition executable) <- definition
+ | (Full.ExecutableDefinition executable _) <- definition
, (Full.DefinitionOperation operation') <- executable =
(transform operation' : operations, fragments')
- | (Full.ExecutableDefinition executable) <- definition
+ | (Full.ExecutableDefinition executable _) <- definition
, (Full.DefinitionFragment fragment) <- executable
, (Full.FragmentDefinition name _ _ _) <- fragment =
(operations, HashMap.insert name fragment fragments')
@@ -276,6 +280,8 @@ operation operationDefinition replacement
Query name <$> appendSelection sels
transform (OperationDefinition Full.Mutation name _ _ sels) =
Mutation name <$> appendSelection sels
+ transform (OperationDefinition Full.Subscription name _ _ sels) =
+ Subscription name <$> appendSelection sels
-- * Selection
@@ -286,7 +292,7 @@ selection (Full.Field alias name arguments' directives' selections) =
maybe (Left mempty) (Right . SelectionField) <$> do
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
- fieldDirectives <- Directive.selection <$> directives directives'
+ fieldDirectives <- Definition.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections
pure $ field' <$ fieldDirectives
where
@@ -295,7 +301,7 @@ selection (Full.Field alias name arguments' directives' selections) =
selection (Full.FragmentSpread name directives') =
maybe (Left mempty) (Right . SelectionFragment) <$> do
- spreadDirectives <- Directive.selection <$> directives directives'
+ spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments
fragmentDefinitions' <- gets fragmentDefinitions
@@ -309,7 +315,7 @@ selection (Full.FragmentSpread name directives') =
_ -> lift $ pure Nothing
| otherwise -> lift $ pure Nothing
selection (Full.InlineFragment type' directives' selections) = do
- fragmentDirectives <- Directive.selection <$> directives directives'
+ fragmentDirectives <- Definition.selection <$> directives directives'
case fragmentDirectives of
Nothing -> pure $ Left mempty
_ -> do
@@ -337,11 +343,11 @@ appendSelection = foldM go mempty
append acc (Left list) = list >< acc
append acc (Right one) = one <| acc
-directives :: [Full.Directive] -> State (Replacement m) [Directive]
+directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive
where
directive (Full.Directive directiveName directiveArguments)
- = Directive directiveName . Arguments
+ = Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
go arguments (Full.Argument name value') = do
substitutedValue <- value value'
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:56 +0000