Respect subscriptions in the executor

After the last commit there were a few places needed to be adjusted to
support subscriptions. This is done and a test case is added.

It is important to implement subscriptions now, because they require
changes to the library API, and they are a big missing part to finish
the executor. When the executor is finished, we can start to provide
more stable API without breaking everything every release. Validation
and introspection shouldn't require much changes to the API; AST would
require some changes to report good errors after the validation - this
is one thing I can think of.

Fixes #5.

3 files changed, 21 insertions, 11 deletions

diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index fe4ad82..22f3595 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -107,17 +107,22 @@ executeField :: (Monad m, Serialize a)
     -> Type.Value
     -> NonEmpty (Transform.Field m)
     -> CollectErrsT m a
-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."
-        Just argumentValues -> do
-            answer <- lift $ resolveFieldValue prev argumentValues resolver
-            case answer of
-                Right result -> completeValue fieldType fields result
-                Left errorMessage -> addErrMsg errorMessage
-executeField _ _ _ = addErrMsg "No field value resolver specified."
+executeField fieldResolver prev fields
+    | Out.ValueResolver fieldDefinition resolver <- fieldResolver =
+        executeField' fieldDefinition resolver
+    | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
+        executeField' fieldDefinition resolver
+  where
+    executeField' fieldDefinition resolver = do
+        let Out.Field _ fieldType argumentDefinitions = fieldDefinition
+        let (Transform.Field _ _ arguments' _ :| []) = fields
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Nothing -> addErrMsg "Argument coercing failed."
+            Just argumentValues -> do
+                answer <- lift $ resolveFieldValue prev argumentValues resolver
+                case answer of
+                    Right result -> completeValue fieldType fields result
+                    Left errorMessage -> addErrMsg errorMessage
 
 completeValue :: (Monad m, Serialize a)
     => Out.Type m
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 086af5c..0c29368 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -239,6 +239,10 @@ document schema operationName subs ast = do
             | Just mutationType <- mutation schema ->
                 pure $ Document referencedTypes mutationType
                     $ operation chosenOperation replacement
+        OperationDefinition Full.Subscription _ _ _ _
+            | Just subscriptionType <- subscription schema ->
+                pure $ Document referencedTypes subscriptionType
+                    $ operation chosenOperation replacement
         _ -> Left UnsupportedRootOperation
 
 defragment
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index 8cf0383..c5cc6fd 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -29,4 +29,5 @@ data Type m
 data Schema m = Schema
     { query :: Out.ObjectType m
     , mutation :: Maybe (Out.ObjectType m)
+    , subscription :: Maybe (Out.ObjectType m)
     }