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.

2 files changed, 40 insertions, 46 deletions

diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 07dabe6..9121d13 100644
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/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
diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs
index 97107ca..d094b4d 100644
--- a/src/Language/GraphQL/Type/Out.hs
+++ b/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).
---
--- 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
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- value of a field.
+type Resolve m = ExceptT Text (ReaderT Context m) Value
 
-instance MonadTrans ResolverT where
-    lift = ResolverT . lift . lift
+-- | 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)
 
-instance MonadIO m => MonadIO (ResolverT m) where
-    liftIO = lift . liftIO
+-- | 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 ()
 
-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 = (<|>)
+-- | '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.
+--
+-- 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) =