OSS/graphql
1
1
Fork 1
Code Issues 4 Pull Requests Actions Releases 22 Wiki Activity

Support subscriptions

Browse Source 
This is experimental support.
The implementation is based on conduit and is boring. There is a new
resolver data constructor that should create a source event stream. The
executor receives the events, pipes them through the normal execution
and puts them into the response stream which is returned to the user.

- Tests are missing.
- The executor should check field value resolver on subscription types.
- The graphql function should probably return (Either
  ResponseEventStream Response), but I'm not sure about this. It will
  make the usage more complicated if no subscriptions are involved, but
  with the current API implementing subscriptions is more
  difficult than it should be.
This commit is contained in:
Eugen Wissner
2020-07-14 19:37:56 +02:00
parent 840e129c44
commit ae2210f659
18 changed files with 288 additions and 158 deletions
Download Patch File Download Diff File Expand all files Collapse all files

32
tests/Language/GraphQL/ExecuteSpec.hs
View File

@ -5,6 +5,7 @@ module Language.GraphQL.ExecuteSpec
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.Either (fromRight)
import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@ -22,26 +23,27 @@ schema = Schema {query = queryType, mutation = Nothing}
queryType :: Out.ObjectType Identity
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "philosopher" philosopherField
$ HashMap.singleton "philosopher"
$ ValueResolver philosopherField
$ pure $ Type.Object mempty
where
philosopherField
= Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
$ pure $ Type.Object mempty
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
philosopherType :: Out.ObjectType Identity
philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers
where
resolvers =
[ ("firstName", firstNameField)
, ("lastName", lastNameField)
[ ("firstName", ValueResolver firstNameField firstNameResolver)
, ("lastName", ValueResolver lastNameField lastNameResolver)
]
firstNameField
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
$ pure $ Type.String "Friedrich"
firstNameField =
Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
firstNameResolver = pure $ Type.String "Friedrich"
lastNameField
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
$ pure $ Type.String "Nietzsche"
lastNameResolver = pure $ Type.String "Nietzsche"
spec :: Spec
spec =
@ -54,8 +56,9 @@ spec =
]
expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity
$ either parseError execute'
actual = fromRight (singleError "")
$ runIdentity
$ either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected
it "merges selections" $
@ -67,7 +70,8 @@ spec =
]
expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity
$ either parseError execute'
actual = fromRight (singleError "")
$ runIdentity
$ either (pure . parseError) execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
in actual `shouldBe` expected

4
tests/Test/DirectiveSpec.hs
View File

@ -16,10 +16,10 @@ import Text.RawString.QQ (r)
experimentalResolver :: Schema IO
experimentalResolver = Schema { query = queryType, mutation = Nothing }
where
resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField"
$ Out.Field Nothing (Out.NamedScalarType int) mempty resolver
$ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 5
emptyObject :: Aeson.Value
emptyObject = object

16
tests/Test/FragmentSpec.hs
View File

@ -64,12 +64,14 @@ hatType = Out.ObjectType "Hat" Nothing []
, ("circumference", circumferenceFieldType)
]
circumferenceFieldType :: Out.Field IO
circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
circumferenceFieldType :: Out.Resolver IO
circumferenceFieldType
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ snd circumference
sizeFieldType :: Out.Field IO
sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
sizeFieldType :: Out.Resolver IO
sizeFieldType
= Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ pure $ snd size
toSchema :: Text -> (Text, Value) -> Schema IO
@ -78,17 +80,15 @@ toSchema t (_, resolve) = Schema
where
unionMember = if t == "Hat" then hatType else shirtType
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
$ pure $ String "Shirt"
garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
$ pure resolve
queryType =
case t of
"circumference" -> hatType
"size" -> shirtType
_ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList
[ ("garment", garmentField)
, ("__typename", typeNameField)
[ ("garment", ValueResolver garmentField (pure resolve))
, ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
]
spec :: Spec

18
tests/Test/RootOperationSpec.hs
View File

@ -15,23 +15,23 @@ import qualified Language.GraphQL.Type.Out as Out
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton "circumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
$ pure
$ Int 60
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 60
schema :: Schema IO
schema = Schema
(Out.ObjectType "Query" Nothing [] hatField)
(Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
(Out.ObjectType "Query" Nothing [] hatFieldResolver)
(Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver)
where
garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60)
]
incrementField = HashMap.singleton "incrementCircumference"
$ Out.Field Nothing (Out.NamedScalarType int) mempty
incrementFieldResolver = HashMap.singleton "incrementCircumference"
$ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
$ pure $ Int 61
hatField = HashMap.singleton "garment"
$ Out.Field Nothing (Out.NamedObjectType hatType) mempty garment
hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
hatFieldResolver =
HashMap.singleton "garment" $ ValueResolver hatField garment
spec :: Spec
spec =

12
tests/Test/StarWars/Data.hs
View File

@ -66,8 +66,8 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
secretBackstory :: ResolverT Identity Text
secretBackstory = ResolverT $ throwE "secretBackstory is secret."
secretBackstory :: Resolve Identity
secretBackstory = throwE "secretBackstory is secret."
typeName :: Character -> Text
typeName = either (const "Droid") (const "Human")
@ -161,10 +161,10 @@ getHero :: Int -> Character
getHero 5 = luke
getHero _ = artoo
getHuman :: Alternative f => ID -> f Character
getHuman :: ID -> Maybe Character
getHuman = fmap Right . getHuman'
getHuman' :: Alternative f => ID -> f Human
getHuman' :: ID -> Maybe Human
getHuman' "1000" = pure luke'
getHuman' "1001" = pure vader
getHuman' "1002" = pure han
@ -172,10 +172,10 @@ getHuman' "1003" = pure leia
getHuman' "1004" = pure tarkin
getHuman' _ = empty
getDroid :: Alternative f => ID -> f Character
getDroid :: ID -> Maybe Character
getDroid = fmap Left . getDroid'
getDroid' :: Alternative f => ID -> f Droid
getDroid' :: ID -> Maybe Droid
getDroid' "2000" = pure threepio
getDroid' "2001" = pure artoo'
getDroid' _ = empty

85
tests/Test/StarWars/Schema.hs
View File

@ -23,19 +23,20 @@ schema :: Schema Identity
schema = Schema { query = queryType, mutation = Nothing }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroField)
, ("human", humanField)
, ("droid", droidField)
[ ("hero", heroFieldResolver)
, ("human", humanFieldResolver)
, ("droid", droidFieldResolver)
]
heroArguments = HashMap.singleton "episode"
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "episode"
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
heroField =
Out.Field Nothing (Out.NamedObjectType heroObject) heroArguments hero
humanArguments = HashMap.singleton "id"
heroFieldResolver = ValueResolver heroField hero
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
humanField =
Out.Field Nothing (Out.NamedObjectType heroObject) humanArguments human
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty droid
humanFieldResolver = ValueResolver humanField human
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
droidFieldResolver = ValueResolver droidField droid
heroObject :: Out.ObjectType Identity
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
@ -48,8 +49,9 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
, ("__typename", typenameFieldType)
]
where
homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
$ idField "homePlanet"
homePlanetFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "homePlanet"
droidObject :: Out.ObjectType Identity
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
@ -62,39 +64,48 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
, ("__typename", typenameFieldType)
]
where
primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
primaryFunctionFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "primaryFunction"
typenameFieldType :: Out.Field Identity
typenameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
typenameFieldType :: Resolver Identity
typenameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "__typename"
idFieldType :: Out.Field Identity
idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
idFieldType :: Resolver Identity
idFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
$ idField "id"
nameFieldType :: Out.Field Identity
nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
nameFieldType :: Resolver Identity
nameFieldType
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
$ idField "name"
friendsFieldType :: Out.Field Identity
friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
friendsFieldType :: Resolver Identity
friendsFieldType
= ValueResolver (Out.Field Nothing fieldType mempty)
$ idField "friends"
where
fieldType = Out.ListType $ Out.NamedObjectType droidObject
appearsInField :: Out.Field Identity
appearsInField = Out.Field (Just description) fieldType mempty
appearsInField :: Resolver Identity
appearsInField
= ValueResolver (Out.Field (Just description) fieldType mempty)
$ idField "appearsIn"
where
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
description = "Which movies they appear in."
secretBackstoryFieldType :: Out.Field Identity
secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
$ String <$> secretBackstory
secretBackstoryFieldType :: Resolver Identity
secretBackstoryFieldType = ValueResolver field secretBackstory
where
field = Out.Field Nothing (Out.NamedScalarType string) mempty
idField :: Text -> ResolverT Identity Value
idField :: Text -> Resolve Identity
idField f = do
v <- ResolverT $ lift $ asks values
v <- lift $ asks values
let (Object v') = v
pure $ v' HashMap.! f
@ -107,7 +118,7 @@ episodeEnum = EnumType "Episode" (Just description)
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
hero :: ResolverT Identity Value
hero :: Resolve Identity
hero = do
episode <- argument "episode"
pure $ character $ case episode of
@ -116,23 +127,19 @@ hero = do
Enum "JEDI" -> getHero 6
_ -> artoo
human :: ResolverT Identity Value
human :: Resolve Identity
human = do
id' <- argument "id"
case id' of
String i -> do
humanCharacter <- lift $ return $ getHuman i >>= Just
case humanCharacter of
Nothing -> pure Null
Just e -> pure $ character e
_ -> ResolverT $ throwE "Invalid arguments."
String i -> pure $ maybe Null character $ getHuman i >>= Just
_ -> throwE "Invalid arguments."
droid :: ResolverT Identity Value
droid :: Resolve Identity
droid = do
id' <- argument "id"
case id' of
String i -> character <$> getDroid i
_ -> ResolverT $ throwE "Invalid arguments."
String i -> pure $ maybe Null character $ getDroid i >>= Just
_ -> throwE "Invalid arguments."
character :: Character -> Value
character char = Object $ HashMap.fromList