Support subscriptions

This is experimental support.
The implementation is based on conduit and is boring. There is a new
resolver data constructor that should create a source event stream. The
executor receives the events, pipes them through the normal execution
and puts them into the response stream which is returned to the user.

- Tests are missing.
- The executor should check field value resolver on subscription types.
- The graphql function should probably return (Either
  ResponseEventStream Response), but I'm not sure about this. It will
  make the usage more complicated if no subscriptions are involved, but
  with the current API implementing subscriptions is more
  difficult than it should be.

src/Language/GraphQL.hs

@@ -9,6 +9,7 @@ module Language.GraphQL
 
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
+import Data.Either (fromRight)
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import Language.GraphQL.AST
@@ -34,10 +35,14 @@ graphqlSubs :: Monad m
     -> Aeson.Object -- ^ Variable substitution function.
     -> Text -- ^ Text representing a @GraphQL@ request document.
     -> m Aeson.Value -- ^ Response.
-graphqlSubs schema operationName variableValues document' =
-    either parseError executeRequest parsed >>= formatResponse
+graphqlSubs schema operationName variableValues document'
+    = either parseError executeRequest (parse document "" document')
+    >>= formatResponse
   where
-    parsed = parse document "" document'
+    executeRequest parsed
+      = fromRight streamReturned
+      <$> execute schema operationName variableValues parsed
+    streamReturned = singleError "This service does not support subscriptions."
     formatResponse (Response data'' Seq.Empty) =
         pure $ Aeson.object [("data", data'')]
     formatResponse (Response data'' errors') = pure $ Aeson.object
@@ -54,4 +59,3 @@ graphqlSubs schema operationName variableValues document' =
         [ ("line", Aeson.toJSON line)
         , ("column", Aeson.toJSON column)
         ]
-    executeRequest = execute schema operationName variableValues

src/Language/GraphQL/Error.hs

@@ -9,19 +9,20 @@ module Language.GraphQL.Error
     , Error(..)
     , Resolution(..)
     , Response(..)
+    , ResponseEventStream
     , addErr
     , addErrMsg
     , runCollectErrs
     , singleError
     ) where
 
+import Conduit
 import Control.Monad.Trans.State (StateT, modify, runStateT)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
-import Data.Void (Void)
 import Language.GraphQL.AST (Location(..), Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Type.Schema
@@ -96,6 +97,11 @@ data Response a = Response
     , errors :: Seq Error
     } deriving (Eq, Show)
 
+-- | Each event in the underlying Source Stream triggers execution of the
+-- subscription selection set. The results of the execution generate a Response
+-- Stream.
+type ResponseEventStream m a = ConduitT () (Response a) m ()
+
 -- | Runs the given query computation, but collects the errors into an error
 -- list, which is then sent back with the data.
 runCollectErrs :: (Monad m, Serialize a)

src/Language/GraphQL/Execute.hs

@@ -7,13 +7,13 @@ module Language.GraphQL.Execute
     ) where
 
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import Language.GraphQL.AST.Document (Document, Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.Transform as Transform
+import qualified Language.GraphQL.Execute.Subscribe as Subscribe
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Out as Out
@@ -28,24 +28,28 @@ import Language.GraphQL.Type.Schema
 execute :: (Monad m, VariableValue a, Serialize b)
     => Schema m -- ^ Resolvers.
     -> Maybe Text -- ^ Operation name.
-    -> HashMap.HashMap Name a -- ^ Variable substitution function.
+    -> HashMap Name a -- ^ Variable substitution function.
     -> Document -- @GraphQL@ document.
-    -> m (Response b)
+    -> m (Either (ResponseEventStream m b) (Response b))
 execute schema operationName subs document =
     case Transform.document schema operationName subs document of
-        Left queryError -> pure $ singleError $ Transform.queryError queryError
+        Left queryError -> pure
+            $ Right
+            $ singleError
+            $ Transform.queryError queryError
         Right transformed -> executeRequest transformed
 
 executeRequest :: (Monad m, Serialize a)
     => Transform.Document m
-    -> m (Response a)
+    -> m (Either (ResponseEventStream m a) (Response a))
 executeRequest (Transform.Document types' rootObjectType operation)
     | (Transform.Query _ fields) <- operation =
-        executeOperation types' rootObjectType fields
+        Right <$> executeOperation types' rootObjectType fields
     | (Transform.Mutation _ fields) <- operation =
-        executeOperation types' rootObjectType fields
-    | otherwise =
-        pure $ singleError "This service does not support subscriptions."
+        Right <$> executeOperation types' rootObjectType fields
+    | (Transform.Subscription _ fields) <- operation
+        = either (Right . singleError) Left
+        <$> Subscribe.subscribe types' rootObjectType fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.

src/Language/GraphQL/Execute/Execution.hs

@@ -3,7 +3,9 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module Language.GraphQL.Execute.Execution
-    ( executeSelectionSet
+    ( coerceArgumentValues
+    , collectFields
+    , executeSelectionSet
     ) where
 
 import Control.Monad.Trans.Class (lift)
@@ -32,10 +34,10 @@ import Prelude hiding (null)
 resolveFieldValue :: Monad m
     => Type.Value
     -> Type.Subs
-    -> Type.ResolverT m a
-    -> m (Either Text a)
-resolveFieldValue result args =
-    flip runReaderT context . runExceptT . Type.runResolverT
+    -> Type.Resolve m
+    -> m (Either Text Type.Value)
+resolveFieldValue result args resolver =
+    flip runReaderT context $ runExceptT resolver
   where
     context = Type.Context
         { Type.arguments = Type.Arguments args
@@ -101,12 +103,12 @@ instanceOf objectType (AbstractUnionType unionType) =
     go unionMemberType acc = acc || objectType == unionMemberType
 
 executeField :: (Monad m, Serialize a)
-    => Out.Field m
+    => Out.Resolver m
     -> Type.Value
     -> NonEmpty (Transform.Field m)
     -> CollectErrsT m a
-executeField fieldDefinition prev fields = do
-    let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition
+executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do
+    let Out.Field _ fieldType argumentDefinitions = fieldDefinition
     let (Transform.Field _ _ arguments' _ :| []) = fields
     case coerceArgumentValues argumentDefinitions arguments' of
         Nothing -> addErrMsg "Argument coercing failed."
@@ -115,6 +117,7 @@ executeField fieldDefinition prev fields = do
             case answer of
                 Right result -> completeValue fieldType fields result
                 Left errorMessage -> addErrMsg errorMessage
+executeField _ _ _ = addErrMsg "No field value resolver specified."
 
 completeValue :: (Monad m, Serialize a)
     => Out.Type m

src/Language/GraphQL/Execute/Subscribe.hs

@@ -0,0 +1,92 @@
+{- 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.Trans.Except (ExceptT(..), runExceptT)
+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 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 :: (Monad 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 :: (Monad 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 :: Monad 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 :: Monad m
+    => Type.Value
+    -> Type.Subs
+    -> ExceptT Text (ReaderT Out.Context m) (Out.SourceEventStream m)
+    -> m (Either Text (Out.SourceEventStream m))
+resolveFieldEventStream result args resolver =
+    flip runReaderT context $ runExceptT resolver
+  where
+    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 :: (Monad 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

src/Language/GraphQL/Type.hs

@@ -1,3 +1,7 @@
+{- 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/. -}
+
 -- | Reexports non-conflicting type system and schema definitions.
 module Language.GraphQL.Type
     ( In.InputField(..)
@@ -6,7 +10,10 @@ module Language.GraphQL.Type
     , Out.Field(..)
     , Out.InterfaceType(..)
     , Out.ObjectType(..)
-    , Out.ResolverT(..)
+    , Out.Resolve
+    , Out.Resolver(..)
+    , Out.SourceEventStream
+    , Out.Subscribe
     , Out.UnionType(..)
     , Out.argument
     , module Language.GraphQL.Type.Definition

src/Language/GraphQL/Type/Internal.hs

@@ -1,3 +1,7 @@
+{- 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 #-}
 
 module Language.GraphQL.Type.Internal
@@ -36,11 +40,13 @@ collectReferencedTypes schema =
     collect traverser typeName element foundTypes
         | HashMap.member typeName foundTypes = foundTypes
         | otherwise = traverser $ HashMap.insert typeName element foundTypes
-    visitFields (Out.Field _ outputType arguments _) foundTypes
+    visitFields (Out.Field _ outputType arguments) foundTypes
         = traverseOutputType outputType
         $ foldr visitArguments foundTypes arguments
     visitArguments (In.Argument _ inputType _) = traverseInputType inputType
     visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
+    getField (Out.ValueResolver field _) = field
+    getField (Out.EventStreamResolver field _ _) = field
     traverseInputType (In.InputObjectBaseType objectType) =
         let (In.InputObjectType typeName _ inputFields) = objectType
             element = InputObjectType objectType
@@ -73,7 +79,7 @@ collectReferencedTypes schema =
     traverseObjectType objectType foundTypes =
         let (Out.ObjectType typeName _ interfaces fields) = objectType
             element = ObjectType objectType
-            traverser = polymorphicTraverser interfaces fields
+            traverser = polymorphicTraverser interfaces (getField <$> fields)
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
         let (Out.InterfaceType typeName _ interfaces fields) = interfaceType

src/Language/GraphQL/Type/Out.hs

@@ -1,3 +1,7 @@
+{- 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 PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -12,7 +16,10 @@ module Language.GraphQL.Type.Out
     , Field(..)
     , InterfaceType(..)
     , ObjectType(..)
-    , ResolverT(..)
+    , Resolve
+    , Subscribe
+    , Resolver(..)
+    , SourceEventStream
     , Type(..)
     , UnionType(..)
     , argument
@@ -25,10 +32,7 @@ module Language.GraphQL.Type.Out
     , pattern UnionBaseType
     ) where
 
-import Control.Applicative (Alternative(..))
-import Control.Monad (MonadPlus(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.Class (MonadTrans(..))
+import Conduit
 import Control.Monad.Trans.Except (ExceptT)
 import Control.Monad.Trans.Reader (ReaderT, asks)
 import Data.HashMap.Strict (HashMap)
@@ -44,7 +48,7 @@ import qualified Language.GraphQL.Type.In as In
 -- Almost all of the GraphQL types you define will be object types. Object
 -- types have a name, but most importantly describe their fields.
 data ObjectType m = ObjectType
-    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
 
 instance forall a. Eq (ObjectType a) where
     (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
@@ -74,7 +78,6 @@ data Field m = Field
     (Maybe Text) -- ^ Description.
     (Type m) -- ^ Field type.
     (HashMap Name In.Argument) -- ^ Arguments.
-    (ResolverT m Value) -- ^ Resolver.
 
 -- | These types may be used as output types as the result of fields.
 --
@@ -169,56 +172,41 @@ isNonNullType (NonNullUnionType _) = True
 isNonNullType (NonNullListType _) = True
 isNonNullType _ = False
 
--- | Resolution context holds resolver arguments.
+-- | Resolution context holds resolver arguments and the root value.
 data Context = Context
     { arguments :: Arguments
     , values :: Value
     }
 
--- | Monad transformer stack used by the resolvers to provide error handling
--- and resolution context (resolver arguments).
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- value of a field.
+type Resolve m = ExceptT Text (ReaderT Context m) Value
+
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- event stream of a subscription field.
+type Subscribe m = ExceptT Text (ReaderT Context m) (SourceEventStream m)
+
+-- | A source stream represents the sequence of events, each of which will
+-- trigger a GraphQL execution corresponding to that event.
+type SourceEventStream m = ConduitT () Value m ()
+
+-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'
+-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves
+-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a
+-- root subscription type.
 --
--- Resolves a 'Field' into a 'Value' with error information (if an error has
--- occurred). @m@ is an arbitrary monad, usually 'IO'.
---
--- Resolving a field can result in a leaf value or an object, which is
--- represented as a list of nested resolvers, used to resolve the fields of that
--- object.
-newtype ResolverT m a = ResolverT
-    { runResolverT :: ExceptT Text (ReaderT Context m) a
-    }
-
-instance Functor m => Functor (ResolverT m) where
-    fmap f = ResolverT . fmap f . runResolverT
-
-instance Monad m => Applicative (ResolverT m) where
-    pure = ResolverT . pure
-    (ResolverT f) <*> (ResolverT x) = ResolverT $ f <*> x
-
-instance Monad m => Monad (ResolverT m) where
-    return = pure
-    (ResolverT action) >>= f = ResolverT $ action >>= runResolverT . f
-
-instance MonadTrans ResolverT where
-    lift = ResolverT . lift . lift
-
-instance MonadIO m => MonadIO (ResolverT m) where
-    liftIO = lift . liftIO
-
-instance Monad m => Alternative (ResolverT m) where
-    empty = ResolverT empty
-    (ResolverT x) <|> (ResolverT y) = ResolverT $ x <|> y
-
-instance Monad m => MonadPlus (ResolverT m) where
-    mzero = empty
-    mplus = (<|>)
+-- The resolvers aren't part of the 'Field' itself because not all fields
+-- have resolvers (interface fields don't have an implementation).
+data Resolver m
+    = ValueResolver (Field m) (Resolve m)
+    | EventStreamResolver (Field m) (Resolve m) (Subscribe m)
 
 -- | Retrieves an argument by its name. If the argument with this name couldn't
 -- be found, returns 'Null' (i.e. the argument is assumed to
 -- be optional then).
-argument :: Monad m => Name -> ResolverT m Value
+argument :: Monad m => Name -> Resolve m
 argument argumentName = do
-    argumentValue <- ResolverT $ lift $ asks $ lookupArgument . arguments
+    argumentValue <- lift $ asks $ lookupArgument . arguments
     pure $ fromMaybe Null argumentValue
   where
     lookupArgument (Arguments argumentMap) =