From 840e129c4496b4e8145480d2b3c3cb34f505702e Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sat, 11 Jul 2020 06:34:10 +0200
Subject: [PATCH] Parse subscriptions

---
 CHANGELOG.md                              |  1 +
 src/Language/GraphQL/AST/Document.hs      |  4 +---
 src/Language/GraphQL/AST/Encoder.hs       | 17 ++++++++++-------
 src/Language/GraphQL/AST/Parser.hs        |  3 ++-
 src/Language/GraphQL/Execute.hs           |  4 ++++
 src/Language/GraphQL/Execute/Transform.hs |  3 +++
 tests/Language/GraphQL/AST/ParserSpec.hs  |  9 +++++++++
 7 files changed, 30 insertions(+), 11 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 6267247..862667c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -21,6 +21,7 @@ and this project adheres to
 - `Error.Error` is an error representation with a message and source location.
 - `Error.Response` represents a result of running a GraphQL query.
 - `Type.Schema` exports `Type` which lists all types possible in the schema.
+- Parsing subscriptions (the execution always fails yet).
 
 ## Changed
 - `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index ed473b7..cd1dbc6 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -99,9 +99,7 @@ data OperationDefinition
 -- * mutation - a write operation followed by a fetch.
 -- * subscription - a long-lived request that fetches data in response to
 -- source events.
---
--- Currently only queries and mutations are supported.
-data OperationType = Query | Mutation deriving (Eq, Show)
+data OperationType = Query | Mutation | Subscription deriving (Eq, Show)
 
 -- ** Selection Sets
 
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index a9f91ec..b55566d 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- | This module defines a minifier and a printer for the @GraphQL@ language.
 module Language.GraphQL.AST.Encoder
@@ -65,12 +66,14 @@ definition formatter x
 
 -- | Converts a 'OperationDefinition into a string.
 operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
-operationDefinition formatter (SelectionSet sels)
-    = selectionSet formatter sels
-operationDefinition formatter (OperationDefinition Query name vars dirs sels)
-    = "query " <> node formatter name vars dirs sels
-operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
-    = "mutation " <> node formatter name vars dirs sels
+operationDefinition formatter = \case
+    SelectionSet sels -> selectionSet formatter sels
+    OperationDefinition Query name vars dirs sels ->
+        "query " <> node formatter name vars dirs sels
+    OperationDefinition Mutation name vars dirs sels ->
+        "mutation " <> node formatter name vars dirs sels
+    OperationDefinition Subscription name vars dirs sels ->
+        "subscription " <> node formatter name vars dirs sels
 
 -- | Converts a Query or Mutation into a string.
 node :: Formatter ->
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 150586e..ea517da 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -334,7 +334,8 @@ operationDefinition = SelectionSet <$> selectionSet
 operationType :: Parser OperationType
 operationType = Query <$ symbol "query"
     <|> Mutation <$ symbol "mutation"
-    -- <?> Keep default error message
+    <|> Subscription <$ symbol "subscription"
+    <?> "OperationType"
 
 selectionSet :: Parser SelectionSet
 selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index ff1078c..471cd00 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | This module provides functions to execute a @GraphQL@ request.
 module Language.GraphQL.Execute
     ( execute
@@ -42,6 +44,8 @@ executeRequest (Transform.Document types' rootObjectType operation)
         executeOperation types' rootObjectType fields
     | (Transform.Mutation _ fields) <- operation =
         executeOperation types' rootObjectType fields
+    | otherwise =
+        pure $ singleError "This service does not support subscriptions."
 
 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 30d5130..086af5c 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -77,6 +77,7 @@ data Selection m
 data Operation m
     = Query (Maybe Text) (Seq (Selection m))
     | Mutation (Maybe Text) (Seq (Selection m))
+    | Subscription (Maybe Text) (Seq (Selection m))
 
 -- | Single GraphQL field.
 data Field m = Field
@@ -275,6 +276,8 @@ operation operationDefinition replacement
         Query name <$> appendSelection sels
     transform (OperationDefinition Full.Mutation name _ _ sels) =
         Mutation name <$> appendSelection sels
+    transform (OperationDefinition Full.Subscription name _ _ sels) =
+        Subscription name <$> appendSelection sels
 
 -- * Selection
 
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 0d3a8de..e463996 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -159,3 +159,12 @@ spec = describe "Parser" $ do
                 queryField: String
             }
         |]
+
+    it "parses subscriptions" $
+        parse document "" `shouldSucceedOn` [r|
+            subscription NewMessages {
+              newMessage(roomId: 123) {
+                sender
+              }
+            }
+        |]