114 lines
4.3 KiB
Haskell
114 lines
4.3 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.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.List.NonEmpty as NonEmpty
|
|
import Data.Sequence (Seq(..))
|
|
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
|
|
|
|
subscribe :: (MonadCatch m, Serialize a)
|
|
=> HashMap Full.Name (Type m)
|
|
-> Out.ObjectType m
|
|
-> Full.Location
|
|
-> Seq (Transform.Selection m)
|
|
-> 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 Full.Name (Type m)
|
|
-> Out.ObjectType m
|
|
-> Full.Location
|
|
-> Seq (Transform.Selection m)
|
|
-> Out.SourceEventStream m
|
|
-> m (ResponseEventStream m a)
|
|
mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
|
|
= pure
|
|
$ sourceStream
|
|
.| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
|
|
|
|
createSourceEventStream :: MonadCatch m
|
|
=> HashMap Full.Name (Type m)
|
|
-> Out.ObjectType m
|
|
-> Full.Location
|
|
-> Seq (Transform.Selection m)
|
|
-> 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
|
|
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
|
|
|
|
resolveFieldEventStream :: MonadCatch m
|
|
=> Type.Value
|
|
-> Type.Subs
|
|
-> Out.Subscribe m
|
|
-> m (Either String (Out.SourceEventStream m))
|
|
resolveFieldEventStream result args resolver =
|
|
catch (Right <$> runReaderT resolver context) handleEventStreamError
|
|
where
|
|
handleEventStreamError :: MonadCatch m
|
|
=> ResolverException
|
|
-> m (Either String (Out.SourceEventStream m))
|
|
handleEventStreamError = pure . Left . displayException
|
|
context = Type.Context
|
|
{ Type.arguments = Type.Arguments args
|
|
, Type.values = result
|
|
}
|
|
|
|
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
|
|
=> HashMap Full.Name (Type m)
|
|
-> Out.ObjectType m
|
|
-> Full.Location
|
|
-> Seq (Transform.Selection m)
|
|
-> Definition.Value
|
|
-> m (Response a)
|
|
executeSubscriptionEvent types' objectType objectLocation fields initialValue
|
|
= runCollectErrs types'
|
|
$ executeSelectionSet initialValue objectType objectLocation fields
|