Return a stream as well from graphql* functions

CHANGELOG.md

@@ -27,6 +27,7 @@ and this project adheres to
 - `Error.ResolverException` is an exception that can be thrown by (field value
   and event stream) resolvers to signalize an error. Other exceptions will
   escape.
+- `Test.Hspec.GraphQL` contains some test helpers.
 
 ## Changed
 - `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
@@ -46,7 +47,9 @@ and this project adheres to
 - `graphqlSubs` takes an additional argument, the operation name. The type of
   variable names is changed back to JSON since it is a common format and it
   saves additional conversions. Custom format still can be used with the
-  underlying functions (in the `Execute` module).
+  underlying functions (in the `Execute` module). The function returns either a
+  a stream or the resolved value.
+- `graphql` returns either a stream or the resolved value.
 - The constraint of the base monad was changed to `MonadCatch` (and it implies
   `MonadThrow`).
 

docs/tutorial/tutorial.lhs

@@ -64,7 +64,8 @@ Next we define our query.
 To run the query, we call the `graphql` with the schema and the query.
 
 > main1 :: IO ()
-> main1 = graphql schema1 query1 >>= putStrLn . encode
+> main1 = graphql schema1 query1
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
 This runs the query by fetching the one field defined, returning
 
@@ -101,7 +102,8 @@ Next we define our query.
 > query2 = "{ time }"
 >
 > main2 :: IO ()
-> main2 = graphql schema2 query2 >>= putStrLn . encode
+> main2 = graphql schema2 query2
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
 This runs the query, returning the current time
 
@@ -126,7 +128,8 @@ Now that we have two resolvers, we can define a schema which uses them both.
 > query3 = "query timeAndHello { time hello }"
 >
 > main3 :: IO ()
-> main3 = graphql schema3 query3 >>= putStrLn . encode
+> main3 = graphql schema3 query3
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
 This queries for both time and hello, returning
 

graphql.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: f3469205f704a81ee0f55655758cf588a9e9eb52303dadd58def32a2eb207696
+-- hash: ca820b1bb2b81ffca4a3e2563bfa2be5381d80eaf4085595e07cf7db2aa3c6a9
 
 name:           graphql
 version:        0.8.0.0
@@ -51,6 +51,7 @@ library
       Language.GraphQL.Type.In
       Language.GraphQL.Type.Out
       Language.GraphQL.Type.Schema
+      Test.Hspec.GraphQL
   other-modules:
       Language.GraphQL.Execute.Execution
       Language.GraphQL.Execute.Subscribe
@@ -65,6 +66,7 @@ library
     , conduit
     , containers
     , exceptions
+    , hspec-expectations
     , megaparsec
     , parser-combinators
     , scientific

package.yaml

@@ -31,6 +31,7 @@ dependencies:
 - conduit
 - containers
 - exceptions
+- hspec-expectations
 - megaparsec
 - parser-combinators
 - scientific
@@ -58,7 +59,6 @@ tests:
     dependencies:
     - graphql
     - hspec
-    - hspec-expectations
     - hspec-megaparsec
     - QuickCheck
     - raw-strings-qq

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
-  where
-    executeRequest parsed
-      = fromRight streamReturned
+    -> 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
-    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
+  where
+    formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
+    formatResponse (Response data'' errors') = HashMap.fromList
         [ ("data", data'')
         , ("errors", Aeson.toJSON $ fromError <$> errors')
         ]

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"

tests/Test/DirectiveSpec.hs

@@ -14,7 +14,8 @@ import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
 import Text.RawString.QQ (r)
 
 experimentalResolver :: Schema IO
@@ -26,10 +27,8 @@ experimentalResolver = Schema
         $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 5
 
-emptyObject :: Aeson.Value
-emptyObject = object
-    [ "data" .= object []
-    ]
+emptyObject :: Aeson.Object
+emptyObject = HashMap.singleton "data" $ object []
 
 spec :: Spec
 spec =
@@ -42,7 +41,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should not skip fields if @skip is false" $ do
             let sourceQuery = [r|
@@ -50,14 +49,12 @@ spec =
                 experimentalField @skip(if: false)
               }
             |]
-                expected = object
-                    [ "data" .= object
+                expected = HashMap.singleton "data"
+                    $ object
                         [ "experimentalField" .= (5 :: Int)
                         ]
-                    ]
-
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "should skip fields if @include is false" $ do
             let sourceQuery = [r|
@@ -67,7 +64,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip a fragment spread" $ do
             let sourceQuery = [r|
@@ -81,7 +78,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip an inline fragment" $ do
             let sourceQuery = [r|
@@ -93,4 +90,4 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject

tests/Test/FragmentSpec.hs

@@ -8,20 +8,15 @@ module Test.FragmentSpec
     ( spec
     ) where
 
-import Data.Aeson (object, (.=))
+import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import Language.GraphQL
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec
-    ( Spec
-    , describe
-    , it
-    , shouldBe
-    , shouldNotSatisfy
-    )
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
 import Text.RawString.QQ (r)
 
 size :: (Text, Value)
@@ -50,10 +45,6 @@ inlineQuery = [r|{
   }
 }|]
 
-hasErrors :: Aeson.Value -> Bool
-hasErrors (Aeson.Object object') = HashMap.member "errors" object'
-hasErrors _ = True
-
 shirtType :: Out.ObjectType IO
 shirtType = Out.ObjectType "Shirt" Nothing []
     $ HashMap.fromList
@@ -100,25 +91,23 @@ spec = do
     describe "Inline fragment executor" $ do
         it "chooses the first selection if the type matches" $ do
             actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
-            let expected = object
-                    [ "data" .= object
-                        [ "garment" .= object
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
-             in actual `shouldBe` expected
+             in actual `shouldResolveTo` expected
 
         it "chooses the last selection if the type matches" $ do
             actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
-            let expected = object
-                    [ "data" .= object
-                        [ "garment" .= object
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
                             [ "size" .= ("L" :: Text)
                             ]
                         ]
-                    ]
-             in actual `shouldBe` expected
+             in actual `shouldResolveTo` expected
 
         it "embeds inline fragments without type" $ do
             let sourceQuery = [r|{
@@ -132,15 +121,14 @@ spec = do
                 resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])
 
             actual <- graphql (toSchema "garment" resolvers) sourceQuery
-            let expected = object
-                    [ "data" .= object
-                        [ "garment" .= object
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             , "size" .= ("L" :: Text)
                             ]
                         ]
-                    ]
-             in actual `shouldBe` expected
+             in actual `shouldResolveTo` expected
 
         it "evaluates fragments on Query" $ do
             let sourceQuery = [r|{
@@ -148,9 +136,7 @@ spec = do
                 size
               }
             }|]
-
-            actual <- graphql (toSchema "size" size) sourceQuery
-            actual `shouldNotSatisfy` hasErrors
+             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
 
     describe "Fragment spread executor" $ do
         it "evaluates fragment spreads" $ do
@@ -165,12 +151,11 @@ spec = do
             |]
 
             actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = object
-                    [ "data" .= object
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
                         [ "circumference" .= (60 :: Int)
                         ]
-                    ]
-             in actual `shouldBe` expected
+             in actual `shouldResolveTo` expected
 
         it "evaluates nested fragments" $ do
             let sourceQuery = [r|
@@ -190,19 +175,16 @@ spec = do
             |]
 
             actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            let expected = object
-                    [ "data" .= object
-                        [ "garment" .= object
+            let expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
-             in actual `shouldBe` expected
+             in actual `shouldResolveTo` expected
 
         it "rejects recursive fragments" $ do
-            let expected = object
-                    [ "data" .= object []
-                    ]
+            let expected = HashMap.singleton "data" $ Aeson.object []
                 sourceQuery = [r|
               {
                 ...circumferenceFragment
@@ -214,7 +196,7 @@ spec = do
             |]
 
             actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "considers type condition" $ do
             let sourceQuery = [r|
@@ -231,12 +213,11 @@ spec = do
                 size
               }
             |]
-                expected = object
-                    [ "data" .= object
-                        [ "garment" .= object
+                expected = HashMap.singleton "data"
+                    $ Aeson.object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
             actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected

tests/Test/RootOperationSpec.hs

@@ -11,10 +11,11 @@ module Test.RootOperationSpec
 import Data.Aeson ((.=), object)
 import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
 import Text.RawString.QQ (r)
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
+import Test.Hspec.GraphQL
 
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
@@ -50,15 +51,14 @@ spec =
                 }
               }
             |]
-                expected = object
-                    [ "data" .= object
+                expected = HashMap.singleton "data"
+                    $ object
                         [ "garment" .= object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
             actual <- graphql schema querySource
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "chooses Mutation" $ do
             let querySource = [r|
@@ -66,10 +66,9 @@ spec =
                 incrementCircumference
               }
             |]
-                expected = object
-                    [ "data" .= object
+                expected = HashMap.singleton "data"
+                    $ object
                         [ "incrementCircumference" .= (61 :: Int)
                         ]
-                    ]
             actual <- graphql schema querySource
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected

tests/Test/StarWars/QuerySpec.hs

@@ -357,10 +357,10 @@ spec = describe "Star Wars Query Tests" $ do
 
 testQuery :: Text -> Aeson.Value -> Expectation
 testQuery q expected =
-    let Right actual = graphql schema q
-     in actual `shouldBe` expected
+    let Right (Right actual) = graphql schema q
+     in Aeson.Object actual `shouldBe` expected
 
 testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
 testQueryParams f q expected =
-    let Right actual = graphqlSubs schema Nothing f q
-     in actual `shouldBe` expected
+    let Right (Right actual) = graphqlSubs schema Nothing f q
+     in Aeson.Object actual `shouldBe` expected