forked from OSS/graphql
Eugen Wissner
09135c581a
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.
98 lines
3.9 KiB
Haskell
98 lines
3.9 KiB
Haskell
{- 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
|