{- 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 :: HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> m (Either Name (ResponseEventStream m a))
subscribe types' :: HashMap Name (Type m)
types' objectType :: ObjectType m
objectType fields :: Seq (Selection m)
fields = do
    Either Name (SourceEventStream m)
sourceStream <- HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> m (Either Name (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> m (Either Name (SourceEventStream m))
createSourceEventStream HashMap Name (Type m)
types' ObjectType m
objectType Seq (Selection m)
fields
    (SourceEventStream m -> m (ResponseEventStream m a))
-> Either Name (SourceEventStream m)
-> m (Either Name (ResponseEventStream m a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent HashMap Name (Type m)
types' ObjectType m
objectType Seq (Selection m)
fields) Either Name (SourceEventStream m)
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 :: HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' :: HashMap Name (Type m)
types' subscriptionType :: ObjectType m
subscriptionType fields :: Seq (Selection m)
fields sourceStream :: 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 -> Seq (Selection m) -> Value -> m (Response a)
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m -> Seq (Selection m) -> Value -> m (Response a)
executeSubscriptionEvent HashMap Name (Type m)
types' ObjectType m
subscriptionType Seq (Selection m)
fields)

createSourceEventStream :: MonadCatch m
    => HashMap Name (Type m)
    -> Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> m (Either Text (Out.SourceEventStream m))
createSourceEventStream :: HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> m (Either Name (SourceEventStream m))
createSourceEventStream _types :: HashMap Name (Type m)
_types subscriptionType :: ObjectType m
subscriptionType@(Out.ObjectType _ _ _ fieldTypes :: HashMap Name (Resolver m)
fieldTypes) fields :: Seq (Selection m)
fields
    | [fieldGroup :: NonEmpty (Field m)
fieldGroup] <- Map Name (NonEmpty (Field m)) -> [NonEmpty (Field m)]
forall k a. Map k a -> [a]
Map.elems Map Name (NonEmpty (Field m))
groupedFieldSet
    , Transform.Field _ fieldName :: Name
fieldName arguments' :: HashMap Name Input
arguments' _ <- NonEmpty (Field m) -> Field m
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (Field m)
fieldGroup
    , 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 fieldDefinition :: Field m
fieldDefinition _ resolver :: Subscribe m
resolver <- Resolver m
resolverT
    , Out.Field _ _fieldType :: Type m
_fieldType argumentDefinitions :: Arguments
argumentDefinitions <- Field m
fieldDefinition =
        case Arguments -> HashMap Name Input -> Maybe Subs
coerceArgumentValues Arguments
argumentDefinitions HashMap Name Input
arguments' of
            Nothing -> Either Name (SourceEventStream m)
-> m (Either Name (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Name (SourceEventStream m)
 -> m (Either Name (SourceEventStream m)))
-> Either Name (SourceEventStream m)
-> m (Either Name (SourceEventStream m))
forall a b. (a -> b) -> a -> b
$ Name -> Either Name (SourceEventStream m)
forall a b. a -> Either a b
Left "Argument coercion failed."
            Just argumentValues :: Subs
argumentValues ->
                Value
-> Subs -> Subscribe m -> m (Either Name (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
Value
-> Subs -> Subscribe m -> m (Either Name (SourceEventStream m))
resolveFieldEventStream Value
Type.Null Subs
argumentValues Subscribe m
resolver
    | Bool
otherwise = Either Name (SourceEventStream m)
-> m (Either Name (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Name (SourceEventStream m)
 -> m (Either Name (SourceEventStream m)))
-> Either Name (SourceEventStream m)
-> m (Either Name (SourceEventStream m))
forall a b. (a -> b) -> a -> b
$ Name -> Either Name (SourceEventStream m)
forall a b. a -> Either a b
Left "Subscription contains more than one field."
  where
    groupedFieldSet :: Map Name (NonEmpty (Field m))
groupedFieldSet = ObjectType m -> Seq (Selection m) -> Map Name (NonEmpty (Field m))
forall (m :: * -> *).
Monad m =>
ObjectType m -> Seq (Selection m) -> Map Name (NonEmpty (Field m))
collectFields ObjectType m
subscriptionType Seq (Selection m)
fields

resolveFieldEventStream :: MonadCatch m
    => Type.Value
    -> Type.Subs
    -> Out.Subscribe m
    -> m (Either Text (Out.SourceEventStream m))
resolveFieldEventStream :: Value
-> Subs -> Subscribe m -> m (Either Name (SourceEventStream m))
resolveFieldEventStream result :: Value
result args :: Subs
args resolver :: Subscribe m
resolver =
    m (Either Name (SourceEventStream m))
-> (ResolverException -> m (Either Name (SourceEventStream m)))
-> m (Either Name (SourceEventStream m))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (SourceEventStream m -> Either Name (SourceEventStream m)
forall a b. b -> Either a b
Right (SourceEventStream m -> Either Name (SourceEventStream m))
-> m (SourceEventStream m) -> m (Either Name (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 Name (SourceEventStream m))
forall (m :: * -> *).
MonadCatch m =>
ResolverException -> m (Either Name (SourceEventStream m))
handleEventStreamError
  where
    handleEventStreamError :: MonadCatch m
        => ResolverException
        -> m (Either Text (Out.SourceEventStream m))
    handleEventStreamError :: ResolverException -> m (Either Name (SourceEventStream m))
handleEventStreamError = Either Name (SourceEventStream m)
-> m (Either Name (SourceEventStream m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Name (SourceEventStream m)
 -> m (Either Name (SourceEventStream m)))
-> (ResolverException -> Either Name (SourceEventStream m))
-> ResolverException
-> m (Either Name (SourceEventStream m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Either Name (SourceEventStream m)
forall a b. a -> Either a b
Left (Name -> Either Name (SourceEventStream m))
-> (ResolverException -> Name)
-> ResolverException
-> Either Name (SourceEventStream m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
Text.pack (String -> Name)
-> (ResolverException -> String) -> ResolverException -> Name
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
        }

-- 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 :: HashMap Name (Type m)
-> ObjectType m -> Seq (Selection m) -> Value -> m (Response a)
executeSubscriptionEvent types' :: HashMap Name (Type m)
types' objectType :: ObjectType m
objectType fields :: Seq (Selection m)
fields initialValue :: 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 -> Seq (Selection m) -> CollectErrsT m a
forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value -> ObjectType m -> Seq (Selection m) -> CollectErrsT m a
executeSelectionSet Value
initialValue ObjectType m
objectType Seq (Selection m)
fields