{- 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 :: HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (ResponseEventStream m a))
subscribe HashMap Name (Type m)
types' ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields = do
    Either Error (SourceEventStream m)
sourceStream <-
        HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (SourceEventStream m))
createSourceEventStream HashMap Name (Type m)
types' ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields
    let traverser :: SourceEventStream m -> m (ResponseEventStream m a)
traverser =
            HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent HashMap Name (Type m)
types' ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields
    (SourceEventStream m -> m (ResponseEventStream m a))
-> Either Error (SourceEventStream m)
-> m (Either Error (ResponseEventStream m a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SourceEventStream m -> m (ResponseEventStream m a)
traverser Either Error (SourceEventStream m)
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 :: HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent HashMap Name (Type m)
types' ObjectType m
subscriptionType Location
objectLocation Seq (Selection m)
fields SourceEventStream m
sourceStream
    = ResponseEventStream m a -> m (ResponseEventStream m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ResponseEventStream m a -> m (ResponseEventStream m a))
-> ResponseEventStream m a -> m (ResponseEventStream m a)
forall a b. (a -> b) -> a -> b
$ SourceEventStream m
sourceStream
    SourceEventStream m
-> ConduitM Value (Response a) m () -> ResponseEventStream m a
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Value -> m (Response a)) -> ConduitM Value (Response a) m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> Value
-> m (Response a)
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> Value
-> m (Response a)
executeSubscriptionEvent HashMap Name (Type m)
types' ObjectType m
subscriptionType Location
objectLocation Seq (Selection m)
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 :: HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (SourceEventStream m))
createSourceEventStream HashMap Name (Type m)
_types ObjectType m
subscriptionType Location
objectLocation Seq (Selection m)
fields
    | [NonEmpty (Field m)
fieldGroup] <- OrderedMap (NonEmpty (Field m)) -> [NonEmpty (Field m)]
forall v. OrderedMap v -> [v]
OrderedMap.elems OrderedMap (NonEmpty (Field m))
groupedFieldSet
    , Transform.Field Maybe Name
_ Name
fieldName HashMap Name (Node Input)
arguments' Seq (Selection m)
_ Location
errorLocation <- NonEmpty (Field m) -> Field m
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (Field m)
fieldGroup
    , Out.ObjectType Name
_ Maybe Name
_ [InterfaceType m]
_ HashMap Name (Resolver m)
fieldTypes <- ObjectType m
subscriptionType
    , Resolver m
resolverT <- HashMap Name (Resolver m)
fieldTypes HashMap Name (Resolver m) -> Name -> Resolver m
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! Name
fieldName
    , Out.EventStreamResolver Field m
fieldDefinition Resolve m
_ Subscribe m
resolver <- Resolver m
resolverT
    , Out.Field Maybe Name
_ Type m
_fieldType Arguments
argumentDefinitions <- Field m
fieldDefinition =
        case Arguments -> HashMap Name (Node Input) -> Either [Location] Subs
coerceArgumentValues Arguments
argumentDefinitions HashMap Name (Node Input)
arguments' of
            Left [Location]
_ -> Either Error (SourceEventStream m)
-> m (Either Error (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Either Error (SourceEventStream m)
 -> m (Either Error (SourceEventStream m)))
-> Either Error (SourceEventStream m)
-> m (Either Error (SourceEventStream m))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (SourceEventStream m)
forall a b. a -> Either a b
Left
                (Error -> Either Error (SourceEventStream m))
-> Error -> Either Error (SourceEventStream m)
forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Argument coercion failed." [Location
errorLocation] []
            Right  Subs
argumentValues -> (String -> Error)
-> Either String (SourceEventStream m)
-> Either Error (SourceEventStream m)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ([Location] -> String -> Error
singleError [Location
errorLocation])
                (Either String (SourceEventStream m)
 -> Either Error (SourceEventStream m))
-> m (Either String (SourceEventStream m))
-> m (Either Error (SourceEventStream m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value
-> Subs -> Subscribe m -> m (Either String (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
Value
-> Subs -> Subscribe m -> m (Either String (SourceEventStream m))
resolveFieldEventStream Value
Type.Null Subs
argumentValues Subscribe m
resolver
    | Bool
otherwise = Either Error (SourceEventStream m)
-> m (Either Error (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either Error (SourceEventStream m)
 -> m (Either Error (SourceEventStream m)))
-> Either Error (SourceEventStream m)
-> m (Either Error (SourceEventStream m))
forall a b. (a -> b) -> a -> b
$ Error -> Either Error (SourceEventStream m)
forall a b. a -> Either a b
Left
        (Error -> Either Error (SourceEventStream m))
-> Error -> Either Error (SourceEventStream m)
forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Subscription contains more than one field." [Location
objectLocation] []
  where
    groupedFieldSet :: OrderedMap (NonEmpty (Field m))
groupedFieldSet = ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
subscriptionType Seq (Selection m)
fields

resolveFieldEventStream :: MonadCatch m
    => Type.Value
    -> Type.Subs
    -> Out.Subscribe m
    -> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream :: Value
-> Subs -> Subscribe m -> m (Either String (SourceEventStream m))
resolveFieldEventStream Value
result Subs
args Subscribe m
resolver =
    m (Either String (SourceEventStream m))
-> (ResolverException -> m (Either String (SourceEventStream m)))
-> m (Either String (SourceEventStream m))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (SourceEventStream m -> Either String (SourceEventStream m)
forall a b. b -> Either a b
Right (SourceEventStream m -> Either String (SourceEventStream m))
-> m (SourceEventStream m)
-> m (Either String (SourceEventStream m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Subscribe m -> Context -> m (SourceEventStream m)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Subscribe m
resolver Context
context) ResolverException -> m (Either String (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
ResolverException -> m (Either String (SourceEventStream m))
handleEventStreamError
  where
    handleEventStreamError :: MonadCatch m
        => ResolverException
        -> m (Either String (Out.SourceEventStream m))
    handleEventStreamError :: ResolverException -> m (Either String (SourceEventStream m))
handleEventStreamError = Either String (SourceEventStream m)
-> m (Either String (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (SourceEventStream m)
 -> m (Either String (SourceEventStream m)))
-> (ResolverException -> Either String (SourceEventStream m))
-> ResolverException
-> m (Either String (SourceEventStream m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (SourceEventStream m)
forall a b. a -> Either a b
Left (String -> Either String (SourceEventStream m))
-> (ResolverException -> String)
-> ResolverException
-> Either String (SourceEventStream m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverException -> String
forall e. Exception e => e -> String
displayException
    context :: Context
context = Context :: Arguments -> Value -> Context
Type.Context
        { arguments :: Arguments
Type.arguments = Subs -> Arguments
Type.Arguments Subs
args
        , values :: Value
Type.values = Value
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 :: HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> Value
-> m (Response a)
executeSubscriptionEvent HashMap Name (Type m)
types' ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields Value
initialValue
    = HashMap Name (Type m) -> CollectErrsT m a -> m (Response a)
forall (m :: * -> *) a.
(Monad m, Serialize a) =>
HashMap Name (Type m) -> CollectErrsT m a -> m (Response a)
runCollectErrs HashMap Name (Type m)
types'
    (CollectErrsT m a -> m (Response a))
-> CollectErrsT m a -> m (Response a)
forall a b. (a -> b) -> a -> b
$ Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> ObjectType m
-> Location
-> Seq (Selection m)
-> CollectErrsT m a
executeSelectionSet Value
initialValue ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields