summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--docs/tutorial/tutorial.lhs56
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs27
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs4
-rw-r--r--src/Language/GraphQL/Type/Schema.hs1
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs96
-rw-r--r--tests/Test/DirectiveSpec.hs7
-rw-r--r--tests/Test/FragmentSpec.hs6
-rw-r--r--tests/Test/RootOperationSpec.hs10
-rw-r--r--tests/Test/StarWars/Schema.hs6
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
+ 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)
- 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)
+ 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)
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 23:43:12 +0000