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.
This commit is contained in:
Eugen Wissner 2020-07-15 19:15:31 +02:00
parent ae2210f659
commit e24386402b
9 changed files with 132 additions and 81 deletions

View File

@ -5,7 +5,7 @@ title: GraphQL Haskell Tutorial
== Getting started == == Getting started ==
Welcome to graphql-haskell! Welcome to GraphQL!
We have written a small tutorial to help you (and ourselves) understand the We have written a small tutorial to help you (and ourselves) understand the
graphql package. 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. First we build a GraphQL schema.
> schema1 :: Schema IO > schema1 :: Schema IO
> schema1 = Schema queryType Nothing > schema1 = Schema
> { query = queryType , mutation = Nothing , subscription = Nothing }
> >
> queryType :: ObjectType IO > queryType :: ObjectType IO
> queryType = ObjectType "Query" Nothing [] > queryType = ObjectType "Query" Nothing []
> $ HashMap.singleton "hello" helloField > $ HashMap.singleton "hello"
> $ ValueResolver helloField hello
> >
> helloField :: Field IO > 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" > hello = pure $ String "it's me"
This defines a simple schema with one type and one field, that resolves to a 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. For this example, we're going to be using time.
> schema2 :: Schema IO > schema2 :: Schema IO
> schema2 = Schema queryType2 Nothing > schema2 = Schema
> { query = queryType2, mutation = Nothing, subscription = Nothing }
> >
> queryType2 :: ObjectType IO > queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query" Nothing [] > queryType2 = ObjectType "Query" Nothing []
> $ HashMap.singleton "time" timeField > $ HashMap.singleton "time"
> $ ValueResolver timeField time
> >
> timeField :: Field IO > 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 > time = do
> t <- liftIO getCurrentTime > t <- liftIO getCurrentTime
> pure $ String $ Text.pack $ show t > 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"}}``` ```{"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 === === Combining resolvers ===
Now that we have two resolvers, we can define a schema which uses them both. Now that we have two resolvers, we can define a schema which uses them both.
> schema3 :: Schema IO > schema3 :: Schema IO
> schema3 = Schema queryType3 Nothing > schema3 = Schema
> { query = queryType3, mutation = Nothing, subscription = Nothing }
> >
> queryType3 :: ObjectType IO > queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
> [ ("hello", helloField) > [ ("hello", ValueResolver helloField hello)
> , ("time", timeField) > , ("time", ValueResolver timeField time)
> ] > ]
> >
> query3 :: Text > 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. includes a more complex schema, and more complex queries.
> main :: IO () > main :: IO ()
> main = main1 >> main2 >> mainShouldFail >> main3 > main = main1 >> main2 >> main3

View File

@ -107,7 +107,13 @@ executeField :: (Monad m, Serialize a)
-> Type.Value -> Type.Value
-> NonEmpty (Transform.Field m) -> NonEmpty (Transform.Field m)
-> CollectErrsT m a -> CollectErrsT m a
executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do 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 Out.Field _ fieldType argumentDefinitions = fieldDefinition
let (Transform.Field _ _ arguments' _ :| []) = fields let (Transform.Field _ _ arguments' _ :| []) = fields
case coerceArgumentValues argumentDefinitions arguments' of case coerceArgumentValues argumentDefinitions arguments' of
@ -117,7 +123,6 @@ executeField (Out.ValueResolver fieldDefinition resolver) prev fields = do
case answer of case answer of
Right result -> completeValue fieldType fields result Right result -> completeValue fieldType fields result
Left errorMessage -> addErrMsg errorMessage Left errorMessage -> addErrMsg errorMessage
executeField _ _ _ = addErrMsg "No field value resolver specified."
completeValue :: (Monad m, Serialize a) completeValue :: (Monad m, Serialize a)
=> Out.Type m => Out.Type m

View File

@ -239,6 +239,10 @@ document schema operationName subs ast = do
| Just mutationType <- mutation schema -> | Just mutationType <- mutation schema ->
pure $ Document referencedTypes mutationType pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement $ operation chosenOperation replacement
OperationDefinition Full.Subscription _ _ _ _
| Just subscriptionType <- subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation _ -> Left UnsupportedRootOperation
defragment defragment

View File

@ -29,4 +29,5 @@ data Type m
data Schema m = Schema data Schema m = Schema
{ query :: Out.ObjectType m { query :: Out.ObjectType m
, mutation :: Maybe (Out.ObjectType m) , mutation :: Maybe (Out.ObjectType m)
, subscription :: Maybe (Out.ObjectType m)
} }

View File

@ -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 OverloadedStrings #-}
module Language.GraphQL.ExecuteSpec module Language.GraphQL.ExecuteSpec
( spec ( spec
@ -5,6 +9,7 @@ module Language.GraphQL.ExecuteSpec
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Conduit
import Data.Either (fromRight) import Data.Either (fromRight)
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@ -15,11 +20,15 @@ import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
import Language.GraphQL.Type as Type import Language.GraphQL.Type as Type
import Language.GraphQL.Type.Out as Out 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) import Text.Megaparsec (parse)
schema :: Schema Identity 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 Identity
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
@ -45,9 +54,28 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
lastNameResolver = pure $ Type.String "Nietzsche" 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 :: Spec
spec = spec =
describe "execute" $ do describe "execute" $ do
context "Query" $ do
it "skips unknown fields" $ it "skips unknown fields" $
let data'' = Aeson.object let data'' = Aeson.object
[ "philosopher" .= Aeson.object [ "philosopher" .= Aeson.object
@ -75,3 +103,17 @@ spec =
$ either (pure . parseError) execute' $ either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }" $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected 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

View File

@ -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 OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Test.DirectiveSpec module Test.DirectiveSpec
@ -14,7 +18,8 @@ import Test.Hspec (Spec, describe, it, shouldBe)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing } experimentalResolver = Schema
{ query = queryType, mutation = Nothing, subscription = Nothing }
where where
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"

View File

@ -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 OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Test.FragmentSpec module Test.FragmentSpec
@ -76,7 +80,7 @@ sizeFieldType
toSchema :: Text -> (Text, Value) -> Schema IO toSchema :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = Schema toSchema t (_, resolve) = Schema
{ query = queryType, mutation = Nothing } { query = queryType, mutation = Nothing, subscription = Nothing }
where where
unionMember = if t == "Hat" then hatType else shirtType unionMember = if t == "Hat" then hatType else shirtType
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty

View File

@ -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 OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Test.RootOperationSpec module Test.RootOperationSpec
@ -20,8 +24,10 @@ hatType = Out.ObjectType "Hat" Nothing []
schema :: Schema IO schema :: Schema IO
schema = Schema schema = Schema
(Out.ObjectType "Query" Nothing [] hatFieldResolver) { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
(Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver) , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
, subscription = Nothing
}
where where
garment = pure $ Object $ HashMap.fromList garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60) [ ("circumference", Int 60)

View File

@ -20,7 +20,11 @@ import Prelude hiding (id)
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
schema :: Schema Identity schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing } schema = Schema
{ query = queryType
, mutation = Nothing
, subscription = Nothing
}
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroFieldResolver) [ ("hero", heroFieldResolver)