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 + 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 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)