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.
2020-07-15 19:15:31 +02:00
parent ae2210f659
commit e24386402b
9 changed files with 132 additions and 81 deletions
--- 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
--- 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"
--- 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
--- 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)
--- 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)