Return a stream as well from graphql* functions

2 files changed, 50 insertions, 13 deletions

diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index 1b8c562..be375ed 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -10,7 +10,7 @@ module Language.GraphQL
 import Control.Monad.Catch (MonadCatch)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
-import Data.Either (fromRight)
+import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import Language.GraphQL.AST
@@ -24,7 +24,7 @@ import Text.Megaparsec (parse)
 graphql :: MonadCatch m
     => Schema m -- ^ Resolvers.
     -> Text -- ^ Text representing a @GraphQL@ request document.
-    -> m Aeson.Value -- ^ Response.
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
 graphql schema = graphqlSubs schema mempty mempty
 
 -- | If the text parses correctly as a @GraphQL@ query the substitution is
@@ -35,18 +35,15 @@ graphqlSubs :: MonadCatch m
     -> Maybe Text -- ^ Operation name.
     -> Aeson.Object -- ^ Variable substitution function.
     -> Text -- ^ Text representing a @GraphQL@ request document.
-    -> m Aeson.Value -- ^ Response.
-graphqlSubs schema operationName variableValues document'
-    = either parseError executeRequest (parse document "" document')
-    >>= formatResponse
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
+graphqlSubs schema operationName variableValues document' =
+    case parse document "" document' of
+        Left errorBundle -> pure . formatResponse <$> parseError errorBundle
+        Right parsed -> fmap formatResponse
+            <$> execute schema operationName variableValues parsed
   where
-    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
+    formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
+    formatResponse (Response data'' errors') = HashMap.fromList
         [ ("data", data'')
         , ("errors", Aeson.toJSON $ fromError <$> errors')
         ]
diff --git a/src/Test/Hspec/GraphQL.hs b/src/Test/Hspec/GraphQL.hs
new file mode 100644
index 0000000..093685b
--- /dev/null
+++ b/src/Test/Hspec/GraphQL.hs
@@ -0,0 +1,40 @@
+{- 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 #-}
+
+-- | Test helpers.
+module Test.Hspec.GraphQL
+    ( shouldResolve
+    , shouldResolveTo
+    ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Language.GraphQL.Error
+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
+
+-- | Asserts that a query resolves to some value.
+shouldResolveTo
+    :: Either (ResponseEventStream IO Aeson.Value) Aeson.Object
+    -> Aeson.Object
+    -> Expectation
+shouldResolveTo (Right actual) expected = actual `shouldBe` expected
+shouldResolveTo _ _ = expectationFailure
+    "the query is expected to resolve to a value, but it resolved to an event stream"
+
+-- | Asserts that the response doesn't contain any errors.
+shouldResolve
+    :: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object))
+    -> Text
+    -> Expectation
+shouldResolve executor query = do
+    actual <- executor query
+    case actual of
+        Right response ->
+            response `shouldNotSatisfy` HashMap.member "errors"
+        _ -> expectationFailure
+            "the query is expected to resolve to a value, but it resolved to an event stream"