diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Subscribe.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Subscribe.hs | 78 |
1 files changed, 47 insertions, 31 deletions
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs index 0bd274f..5d8d294 100644 --- a/src/Language/GraphQL/Execute/Subscribe.hs +++ b/src/Language/GraphQL/Execute/Subscribe.hs @@ -9,62 +9,78 @@ module Language.GraphQL.Execute.Subscribe ) where import Conduit +import Control.Arrow (left) 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 qualified Language.GraphQL.AST as Full import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Execution +import Language.GraphQL.Execute.Internal +import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error + ( Error(..) + , ResolverException + , Response + , ResponseEventStream + , runCollectErrs + ) 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) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> 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 + -> m (Either Error (ResponseEventStream m a)) +subscribe types' objectType objectLocation fields = do + sourceStream <- + createSourceEventStream types' objectType objectLocation fields + let traverser = + mapSourceToResponseEvent types' objectType objectLocation fields + traverse traverser sourceStream mapSourceToResponseEvent :: (MonadCatch m, Serialize a) - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> Out.SourceEventStream m -> m (ResponseEventStream m a) -mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure +mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream + = pure $ sourceStream - .| mapMC (executeSubscriptionEvent types' subscriptionType fields) + .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields) createSourceEventStream :: MonadCatch m - => HashMap Name (Type m) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> 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 + -> m (Either Error (Out.SourceEventStream m)) +createSourceEventStream _types subscriptionType objectLocation fields + | [fieldGroup] <- OrderedMap.elems groupedFieldSet + , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup + , Out.ObjectType _ _ _ fieldTypes <- subscriptionType , 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." + Left _ -> pure + $ Left + $ Error "Argument coercion failed." [errorLocation] [] + Right argumentValues -> left (singleError [errorLocation]) + <$> resolveFieldEventStream Type.Null argumentValues resolver + | otherwise = pure + $ Left + $ Error "Subscription contains more than one field." [objectLocation] [] where groupedFieldSet = collectFields subscriptionType fields @@ -72,26 +88,26 @@ resolveFieldEventStream :: MonadCatch m => Type.Value -> Type.Subs -> Out.Subscribe m - -> m (Either Text (Out.SourceEventStream m)) + -> m (Either String (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 + -> m (Either String (Out.SourceEventStream m)) + handleEventStreamError = pure . Left . 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) + => HashMap Full.Name (Type m) -> Out.ObjectType m + -> Full.Location -> Seq (Transform.Selection m) -> Definition.Value -> m (Response a) -executeSubscriptionEvent types' objectType fields initialValue = - runCollectErrs types' $ executeSelectionSet initialValue objectType fields +executeSubscriptionEvent types' objectType objectLocation fields initialValue + = runCollectErrs types' + $ executeSelectionSet initialValue objectType objectLocation fields |