From b9d5b1fb1bdf634137f463186585bc51e540353b Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 19 Jul 2020 07:36:06 +0200 Subject: [PATCH] Return a stream as well from graphql* functions --- CHANGELOG.md | 5 ++- docs/tutorial/tutorial.lhs | 9 ++-- graphql.cabal | 4 +- package.yaml | 2 +- src/Language/GraphQL.hs | 23 +++++----- src/Test/Hspec/GraphQL.hs | 40 +++++++++++++++++ tests/Test/DirectiveSpec.hs | 25 +++++------ tests/Test/FragmentSpec.hs | 77 ++++++++++++-------------------- tests/Test/RootOperationSpec.hs | 17 ++++--- tests/Test/StarWars/QuerySpec.hs | 8 ++-- 10 files changed, 116 insertions(+), 94 deletions(-) create mode 100644 src/Test/Hspec/GraphQL.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 79cf9c7..0f7f370 100644 --- a/CHANGELOG.md +++ b/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`). diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 00ad98d..dc44c1e 100644 --- a/docs/tutorial/tutorial.lhs +++ b/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 diff --git a/graphql.cabal b/graphql.cabal index ea38140..bb78d22 100644 --- a/graphql.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index be2aad8..ac3b114 100644 --- a/package.yaml +++ b/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 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" diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index fb5c318..e6b6cea 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 71d7e9a..089b721 100644 --- a/tests/Test/FragmentSpec.hs +++ b/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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 621d496..ea89279 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/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 diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index 301fb7c..95b18d3 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/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