From e24386402be444e643d7d9c8ef82c1fe2205c7fc Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 15 Jul 2020 19:15:31 +0200 Subject: [PATCH] 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. --- docs/tutorial/tutorial.lhs | 56 +++++-------- src/Language/GraphQL/Execute/Execution.hs | 27 ++++--- src/Language/GraphQL/Execute/Transform.hs | 4 + src/Language/GraphQL/Type/Schema.hs | 1 + tests/Language/GraphQL/ExecuteSpec.hs | 96 ++++++++++++++++------- tests/Test/DirectiveSpec.hs | 7 +- tests/Test/FragmentSpec.hs | 6 +- tests/Test/RootOperationSpec.hs | 10 ++- tests/Test/StarWars/Schema.hs | 6 +- 9 files changed, 132 insertions(+), 81 deletions(-) diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 06494a2..00ad98d 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -5,7 +5,7 @@ title: GraphQL Haskell Tutorial == Getting started == -Welcome to graphql-haskell! +Welcome to GraphQL! We have written a small tutorial to help you (and ourselves) understand the graphql package. @@ -39,16 +39,18 @@ Now, as our first example, we are going to look at the example from First we build a GraphQL schema. > schema1 :: Schema IO -> schema1 = Schema queryType Nothing +> schema1 = Schema +> { query = queryType , mutation = Nothing , subscription = Nothing } > > queryType :: ObjectType IO > queryType = ObjectType "Query" Nothing [] -> $ HashMap.singleton "hello" helloField +> $ HashMap.singleton "hello" +> $ ValueResolver helloField hello > > helloField :: Field IO -> helloField = Field Nothing (Out.NamedScalarType string) mempty hello +> helloField = Field Nothing (Out.NamedScalarType string) mempty > -> hello :: ResolverT IO Value +> hello :: Resolve IO > hello = pure $ String "it's me" This defines a simple schema with one type and one field, that resolves to a @@ -74,16 +76,18 @@ This runs the query by fetching the one field defined, returning For this example, we're going to be using time. > schema2 :: Schema IO -> schema2 = Schema queryType2 Nothing +> schema2 = Schema +> { query = queryType2, mutation = Nothing, subscription = Nothing } > > queryType2 :: ObjectType IO > queryType2 = ObjectType "Query" Nothing [] -> $ HashMap.singleton "time" timeField +> $ HashMap.singleton "time" +> $ ValueResolver timeField time > > timeField :: Field IO -> timeField = Field Nothing (Out.NamedScalarType string) mempty time +> timeField = Field Nothing (Out.NamedScalarType string) mempty > -> time :: ResolverT IO Value +> time :: Resolve IO > time = do > t <- liftIO getCurrentTime > pure $ String $ Text.pack $ show t @@ -104,42 +108,18 @@ This runs the query, returning the current time ```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}``` -=== Errors === - -Errors are handled according to the spec, with fields that cause erros being -resolved to `null`, and an error being added to the error list. - -An example of this is the following query: - -> queryShouldFail :: Text -> queryShouldFail = "{ boyhowdy }" - -Since there is no `boyhowdy` field in our schema, it will not resolve, and the -query will fail, as we can see in the following example. - -> mainShouldFail :: IO () -> mainShouldFail = do -> failure <- graphql schema1 queryShouldFail -> putStrLn $ encode failure - -This outputs: - -``` -{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]} -``` - - === Combining resolvers === Now that we have two resolvers, we can define a schema which uses them both. > schema3 :: Schema IO -> schema3 = Schema queryType3 Nothing +> schema3 = Schema +> { query = queryType3, mutation = Nothing, subscription = Nothing } > > queryType3 :: ObjectType IO > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList -> [ ("hello", helloField) -> , ("time", timeField) +> [ ("hello", ValueResolver helloField hello) +> , ("time", ValueResolver timeField time) > ] > > query3 :: Text @@ -166,4 +146,4 @@ directory, in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries. > main :: IO () -> main = main1 >> main2 >> mainShouldFail >> main3 +> main = main1 >> main2 >> main3 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) } diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index f994482..7aab6c5 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -1,3 +1,7 @@ +{- 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 OverloadedStrings #-} module Language.GraphQL.ExecuteSpec ( spec @@ -5,6 +9,7 @@ module Language.GraphQL.ExecuteSpec import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson +import Data.Conduit import Data.Either (fromRight) import Data.Functor.Identity (Identity(..)) import Data.HashMap.Strict (HashMap) @@ -15,11 +20,15 @@ import Language.GraphQL.Error import Language.GraphQL.Execute import Language.GraphQL.Type as Type import Language.GraphQL.Type.Out as Out -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) schema :: Schema Identity -schema = Schema {query = queryType, mutation = Nothing} +schema = Schema + { query = queryType + , mutation = Nothing + , subscription = Just subscriptionType + } queryType :: Out.ObjectType Identity queryType = Out.ObjectType "Query" Nothing [] @@ -45,33 +54,66 @@ philosopherType = Out.ObjectType "Philosopher" Nothing [] = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty lastNameResolver = pure $ Type.String "Nietzsche" +subscriptionType :: Out.ObjectType Identity +subscriptionType = Out.ObjectType "Subscription" Nothing [] + $ HashMap.singleton "newQuote" + $ EventStreamResolver quoteField (pure $ Type.Object mempty) + $ pure $ yield $ Type.Object mempty + where + quoteField = + Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty + +quoteType :: Out.ObjectType Identity +quoteType = Out.ObjectType "Quote" Nothing [] + $ HashMap.singleton "quote" + $ ValueResolver quoteField + $ pure "Naturam expelles furca, tamen usque recurret." + where + quoteField = + Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + spec :: Spec spec = describe "execute" $ do - it "skips unknown fields" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) + context "Query" $ do + it "skips unknown fields" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + ] ] - ] - expected = Response data'' mempty - execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) - actual = fromRight (singleError "") - $ runIdentity - $ either (pure . parseError) execute' - $ parse document "" "{ philosopher { firstName surname } }" - in actual `shouldBe` expected - it "merges selections" $ - let data'' = Aeson.object - [ "philosopher" .= Aeson.object - [ "firstName" .= ("Friedrich" :: String) - , "lastName" .= ("Nietzsche" :: String) + expected = Response data'' mempty + execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) + actual = fromRight (singleError "") + $ runIdentity + $ either (pure . parseError) execute' + $ parse document "" "{ philosopher { firstName surname } }" + in actual `shouldBe` expected + it "merges selections" $ + let data'' = Aeson.object + [ "philosopher" .= Aeson.object + [ "firstName" .= ("Friedrich" :: String) + , "lastName" .= ("Nietzsche" :: String) + ] ] - ] - expected = Response data'' mempty - execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) - actual = fromRight (singleError "") - $ runIdentity - $ either (pure . parseError) execute' - $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" - in actual `shouldBe` expected + expected = Response data'' mempty + execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) + actual = fromRight (singleError "") + $ runIdentity + $ either (pure . parseError) execute' + $ parse document "" "{ philosopher { firstName } philosopher { lastName } }" + in actual `shouldBe` expected + context "Subscription" $ + it "subscribes" $ + let data'' = Aeson.object + [ "newQuote" .= Aeson.object + [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String) + ] + ] + expected = Response data'' mempty + execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value) + Left stream = runIdentity + $ either (pure . parseError) execute' + $ parse document "" "subscription { newQuote { quote } }" + Just actual = runConduitPure $ stream .| await + in actual `shouldBe` expected diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 4d31cb9..fb5c318 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -1,3 +1,7 @@ +{- 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 OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Test.DirectiveSpec @@ -14,7 +18,8 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) experimentalResolver :: Schema IO -experimentalResolver = Schema { query = queryType, mutation = Nothing } +experimentalResolver = Schema + { query = queryType, mutation = Nothing, subscription = Nothing } where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.singleton "experimentalField" diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index af1812c..71d7e9a 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -1,3 +1,7 @@ +{- 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 OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Test.FragmentSpec @@ -76,7 +80,7 @@ sizeFieldType toSchema :: Text -> (Text, Value) -> Schema IO toSchema t (_, resolve) = Schema - { query = queryType, mutation = Nothing } + { query = queryType, mutation = Nothing, subscription = Nothing } where unionMember = if t == "Hat" then hatType else shirtType typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 7202104..621d496 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -1,3 +1,7 @@ +{- 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 OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Test.RootOperationSpec @@ -20,8 +24,10 @@ hatType = Out.ObjectType "Hat" Nothing [] schema :: Schema IO schema = Schema - (Out.ObjectType "Query" Nothing [] hatFieldResolver) - (Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver) + { query = Out.ObjectType "Query" Nothing [] hatFieldResolver + , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver + , subscription = Nothing + } where garment = pure $ Object $ HashMap.fromList [ ("circumference", Int 60) diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index ed3c32c..99200ff 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -20,7 +20,11 @@ import Prelude hiding (id) -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js schema :: Schema Identity -schema = Schema { query = queryType, mutation = Nothing } +schema = Schema + { query = queryType + , mutation = Nothing + , subscription = Nothing + } where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("hero", heroFieldResolver)