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.

6 files changed, 90 insertions, 79 deletions

diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index e7ab9f8..f994482 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -5,6 +5,7 @@ module Language.GraphQL.ExecuteSpec
 
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
+import Data.Either (fromRight)
 import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -22,26 +23,27 @@ schema = Schema {query = queryType, mutation = Nothing}
 
 queryType :: Out.ObjectType Identity
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "philosopher" philosopherField
+    $ HashMap.singleton "philosopher" 
+    $ ValueResolver philosopherField
+    $ pure $ Type.Object mempty
   where
-    philosopherField
-        = Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
-        $ pure $ Type.Object mempty
+    philosopherField =
+        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
 
 philosopherType :: Out.ObjectType Identity
 philosopherType = Out.ObjectType "Philosopher" Nothing []
     $ HashMap.fromList resolvers
   where
     resolvers =
-        [ ("firstName", firstNameField)
-        , ("lastName", lastNameField)
+        [ ("firstName", ValueResolver firstNameField firstNameResolver)
+        , ("lastName", ValueResolver lastNameField lastNameResolver)
         ]
-    firstNameField
-        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-        $ pure $ Type.String "Friedrich"
+    firstNameField =
+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    firstNameResolver = pure $ Type.String "Friedrich"
     lastNameField
         = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-        $ pure $ Type.String "Nietzsche"
+    lastNameResolver = pure $ Type.String "Nietzsche"
 
 spec :: Spec
 spec =
@@ -54,8 +56,9 @@ spec =
                     ]
                 expected = Response data'' mempty
                 execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
-                    $ either parseError execute'
+                actual = fromRight (singleError "")
+                    $ runIdentity
+                    $ either (pure . parseError) execute'
                     $ parse document "" "{ philosopher { firstName surname } }"
              in actual `shouldBe` expected
         it "merges selections" $
@@ -67,7 +70,8 @@ spec =
                     ]
                 expected = Response data'' mempty
                 execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
-                    $ either parseError execute'
+                actual = fromRight (singleError "")
+                    $ runIdentity
+                    $ either (pure . parseError) execute'
                     $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
              in actual `shouldBe` expected
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
index 3243d2a..4d31cb9 100644
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@@ -16,10 +16,10 @@ import Text.RawString.QQ (r)
 experimentalResolver :: Schema IO
 experimentalResolver = Schema { query = queryType, mutation = Nothing }
   where
-    resolver = pure $ Int 5
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 5
 
 emptyObject :: Aeson.Value
 emptyObject = object
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 94cc76c..af1812c 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -64,12 +64,14 @@ hatType = Out.ObjectType "Hat" Nothing []
         , ("circumference", circumferenceFieldType)
         ]
 
-circumferenceFieldType :: Out.Field IO
-circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
+circumferenceFieldType :: Out.Resolver IO
+circumferenceFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
     $ pure $ snd circumference
 
-sizeFieldType :: Out.Field IO
-sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+sizeFieldType :: Out.Resolver IO
+sizeFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ pure $ snd size
 
 toSchema :: Text -> (Text, Value) -> Schema IO
@@ -78,17 +80,15 @@ toSchema t (_, resolve) = Schema
   where
     unionMember = if t == "Hat" then hatType else shirtType
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
-        $ pure $ String "Shirt"
     garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
-        $ pure resolve
     queryType =
         case t of
             "circumference" -> hatType
             "size" -> shirtType
             _ -> Out.ObjectType "Query" Nothing []
                 $ HashMap.fromList
-                    [ ("garment", garmentField)
-                    , ("__typename", typeNameField)
+                    [ ("garment", ValueResolver garmentField (pure resolve))
+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
                     ]
 
 spec :: Spec
diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs
index 44b19a6..7202104 100644
--- a/tests/Test/RootOperationSpec.hs
+++ b/tests/Test/RootOperationSpec.hs
@@ -15,23 +15,23 @@ import qualified Language.GraphQL.Type.Out as Out
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.singleton "circumference"
-    $ Out.Field Nothing (Out.NamedScalarType int) mempty
-    $ pure
-    $ Int 60
+    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ pure $ Int 60
 
 schema :: Schema IO
 schema = Schema
-    (Out.ObjectType "Query" Nothing [] hatField)
-    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
+    (Out.ObjectType "Query" Nothing [] hatFieldResolver)
+    (Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver)
   where
     garment = pure $ Object $ HashMap.fromList
         [ ("circumference", Int 60)
         ]
-    incrementField = HashMap.singleton "incrementCircumference"
-        $ Out.Field Nothing (Out.NamedScalarType int) mempty
+    incrementFieldResolver = HashMap.singleton "incrementCircumference"
+        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 61
-    hatField = HashMap.singleton "garment"
-        $ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
+    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
+    hatFieldResolver =
+        HashMap.singleton "garment" $ ValueResolver hatField garment
 
 spec :: Spec
 spec =
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index dacd0cd..00a89d9 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-secretBackstory :: ResolverT Identity Text
-secretBackstory = ResolverT $ throwE "secretBackstory is secret."
+secretBackstory :: Resolve Identity
+secretBackstory = throwE "secretBackstory is secret."
 
 typeName :: Character -> Text
 typeName = either (const "Droid") (const "Human")
@@ -161,10 +161,10 @@ getHero :: Int -> Character
 getHero 5 = luke
 getHero _ = artoo
 
-getHuman :: Alternative f => ID -> f Character
+getHuman :: ID -> Maybe Character
 getHuman = fmap Right . getHuman'
 
-getHuman' :: Alternative f => ID -> f Human
+getHuman' :: ID -> Maybe Human
 getHuman' "1000" = pure luke'
 getHuman' "1001" = pure vader
 getHuman' "1002" = pure han
@@ -172,10 +172,10 @@ getHuman' "1003" = pure leia
 getHuman' "1004" = pure tarkin
 getHuman' _      = empty
 
-getDroid :: Alternative f => ID -> f Character
+getDroid :: ID -> Maybe Character
 getDroid = fmap Left . getDroid'
 
-getDroid' :: Alternative f => ID -> f Droid
+getDroid' :: ID -> Maybe Droid
 getDroid' "2000" = pure threepio
 getDroid' "2001" = pure artoo'
 getDroid' _      = empty
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index cf18eca..ed3c32c 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -23,19 +23,20 @@ schema :: Schema Identity
 schema = Schema { query = queryType, mutation = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", heroField)
-        , ("human", humanField)
-        , ("droid", droidField)
+        [ ("hero", heroFieldResolver)
+        , ("human", humanFieldResolver)
+        , ("droid", droidFieldResolver)
         ]
-    heroArguments = HashMap.singleton "episode"
+    heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
+        $ HashMap.singleton "episode"
         $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
-    heroField =
-        Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero
-    humanArguments = HashMap.singleton "id"
+    heroFieldResolver = ValueResolver heroField hero
+    humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
+        $ HashMap.singleton "id"
         $ In.Argument Nothing (In.NonNullScalarType string) Nothing
-    humanField =
-        Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human
-    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid
+    humanFieldResolver = ValueResolver humanField human
+    droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
+    droidFieldResolver = ValueResolver droidField droid
 
 heroObject :: Out.ObjectType Identity
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@@ -48,8 +49,9 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
     , ("__typename", typenameFieldType)
     ]
   where
-    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
-        $ idField "homePlanet"
+    homePlanetFieldType
+      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+      $ idField "homePlanet"
 
 droidObject :: Out.ObjectType Identity
 droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
@@ -62,39 +64,48 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
     , ("__typename", typenameFieldType)
     ]
   where
-    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    primaryFunctionFieldType
+        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
         $ idField "primaryFunction"
 
-typenameFieldType :: Out.Field Identity
-typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+typenameFieldType :: Resolver Identity
+typenameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ idField "__typename"
 
-idFieldType :: Out.Field Identity
-idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
+idFieldType :: Resolver Identity
+idFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
     $ idField "id"
 
-nameFieldType :: Out.Field Identity
-nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+nameFieldType :: Resolver  Identity
+nameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
     $ idField "name"
 
-friendsFieldType :: Out.Field Identity
-friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+friendsFieldType :: Resolver Identity
+friendsFieldType
+    = ValueResolver (Out.Field Nothing fieldType mempty)
     $ idField "friends"
+  where
+    fieldType = Out.ListType $ Out.NamedObjectType droidObject
 
-appearsInField :: Out.Field Identity
-appearsInField = Out.Field (Just description) fieldType mempty
+appearsInField :: Resolver Identity
+appearsInField
+    = ValueResolver (Out.Field (Just description) fieldType mempty)
     $ idField "appearsIn"
   where
     fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
     description = "Which movies they appear in."
 
-secretBackstoryFieldType :: Out.Field Identity
-secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
-    $ String <$> secretBackstory
+secretBackstoryFieldType :: Resolver Identity
+secretBackstoryFieldType = ValueResolver field secretBackstory
+  where
+    field = Out.Field Nothing (Out.NamedScalarType string) mempty
 
-idField :: Text -> ResolverT Identity Value
+idField :: Text -> Resolve Identity
 idField f = do
-    v <- ResolverT $ lift $ asks values
+    v <- lift $ asks values
     let (Object v') = v
     pure $ v' HashMap.! f
 
@@ -107,7 +118,7 @@ episodeEnum = EnumType "Episode" (Just description)
     empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
     jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
 
-hero :: ResolverT Identity Value
+hero :: Resolve Identity
 hero = do
   episode <- argument "episode"
   pure $ character $ case episode of
@@ -116,23 +127,19 @@ hero = do
       Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: ResolverT Identity Value
+human :: Resolve Identity
 human = do
     id' <- argument "id"
     case id' of
-        String i -> do
-            humanCharacter <- lift $ return $ getHuman i >>= Just
-            case humanCharacter of
-                Nothing -> pure Null
-                Just e -> pure $ character e
-        _ -> ResolverT $ throwE "Invalid arguments."
-
-droid :: ResolverT Identity Value
+        String i -> pure $ maybe Null character $ getHuman i >>= Just
+        _ -> throwE "Invalid arguments."
+
+droid :: Resolve Identity
 droid = do
     id' <- argument "id"
     case id' of
-        String i -> character <$> getDroid i
-        _ -> ResolverT $ throwE "Invalid arguments."
+        String i -> pure $ maybe Null character $ getDroid i >>= Just
+        _ -> throwE "Invalid arguments."
 
 character :: Character -> Value
 character char = Object $ HashMap.fromList