From ae2210f6598f166116abebc1163e1523d3bc627c Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 14 Jul 2020 19:37:56 +0200 Subject: Support subscriptions 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. --- tests/Test/DirectiveSpec.hs | 4 +- tests/Test/FragmentSpec.hs | 16 ++++---- tests/Test/RootOperationSpec.hs | 18 ++++----- tests/Test/StarWars/Data.hs | 12 +++--- tests/Test/StarWars/Schema.hs | 87 ++++++++++++++++++++++------------------- 5 files changed, 72 insertions(+), 65 deletions(-) (limited to 'tests/Test') diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 3243d2a..4d31cb9 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -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 diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 94cc76c..af1812c 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -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 diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 44b19a6..7202104 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -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 = diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index dacd0cd..00a89d9 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -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 diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index cf18eca..ed3c32c 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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." - -droid :: ResolverT Identity Value + String i -> pure $ maybe Null character $ getHuman i >>= Just + _ -> throwE "Invalid arguments." + +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 -- cgit v1.2.3