aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs24
-rw-r--r--tests/Language/GraphQL/ErrorSpec.hs10
-rw-r--r--tests/Language/GraphQL/ExecuteSpec.hs106
-rw-r--r--tests/Language/GraphQL/ValidateSpec.hs171
-rw-r--r--tests/Test/DirectiveSpec.hs36
-rw-r--r--tests/Test/FragmentSpec.hs107
-rw-r--r--tests/Test/RootOperationSpec.hs38
-rw-r--r--tests/Test/StarWars/Data.hs32
-rw-r--r--tests/Test/StarWars/QuerySpec.hs8
-rw-r--r--tests/Test/StarWars/Schema.hs129
10 files changed, 460 insertions, 201 deletions
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 2801b57..f59e5a9 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -129,10 +129,11 @@ spec = describe "Parser" $ do
it "parses schema extension with an operation type and directive" $
let newDirective = Directive "newDirective" []
- testSchemaExtension = TypeSystemExtension
- $ SchemaExtension
+ schemaExtension = SchemaExtension
$ SchemaOperationExtension [newDirective]
$ OperationTypeDefinition Query "Query" :| []
+ testSchemaExtension = TypeSystemExtension schemaExtension
+ $ Location 1 1
query = [r|extend schema @newDirective { query: Query }|]
in parse document "" query `shouldParse` (testSchemaExtension :| [])
@@ -149,3 +150,22 @@ spec = describe "Parser" $ do
title
}
|]
+
+ it "parses documents beginning with a comment" $
+ parse document "" `shouldSucceedOn` [r|
+ """
+ Query
+ """
+ type Query {
+ queryField: String
+ }
+ |]
+
+ it "parses subscriptions" $
+ parse document "" `shouldSucceedOn` [r|
+ subscription NewMessages {
+ newMessage(roomId: 123) {
+ sender
+ }
+ }
+ |]
diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs
index 8bb39ed..482dc3a 100644
--- a/tests/Language/GraphQL/ErrorSpec.hs
+++ b/tests/Language/GraphQL/ErrorSpec.hs
@@ -4,6 +4,7 @@ module Language.GraphQL.ErrorSpec
) where
import qualified Data.Aeson as Aeson
+import qualified Data.Sequence as Seq
import Language.GraphQL.Error
import Test.Hspec ( Spec
, describe
@@ -14,11 +15,6 @@ import Test.Hspec ( Spec
spec :: Spec
spec = describe "singleError" $
it "constructs an error with the given message" $
- let expected = Aeson.object
- [
- ("errors", Aeson.toJSON
- [ Aeson.object [("message", "Message.")]
- ]
- )
- ]
+ let errors'' = Seq.singleton $ Error "Message." []
+ expected = Response Aeson.Null errors''
in singleError "Message." `shouldBe` expected
diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 30568be..8fbb55b 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -1,11 +1,16 @@
+{- 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
) where
+import Control.Exception (SomeException)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
-import Data.Functor.Identity (Identity(..))
+import Data.Conduit
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL.AST (Name)
@@ -14,62 +19,95 @@ 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 (Either SomeException)
+schema = Schema
+ { query = queryType
+ , mutation = Nothing
+ , subscription = Just subscriptionType
+ }
-queryType :: Out.ObjectType Identity
+queryType :: Out.ObjectType (Either SomeException)
queryType = Out.ObjectType "Query" Nothing []
- $ HashMap.singleton "philosopher"
- $ Out.Resolver philosopherField
- $ pure
- $ Type.Object mempty
+ $ HashMap.singleton "philosopher"
+ $ ValueResolver philosopherField
+ $ pure $ Type.Object mempty
where
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
-philosopherType :: Out.ObjectType Identity
+philosopherType :: Out.ObjectType (Either SomeException)
philosopherType = Out.ObjectType "Philosopher" Nothing []
$ HashMap.fromList resolvers
where
resolvers =
- [ ("firstName", firstNameResolver)
- , ("lastName", lastNameResolver)
+ [ ("firstName", ValueResolver firstNameField firstNameResolver)
+ , ("lastName", ValueResolver lastNameField lastNameResolver)
]
- firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"
- lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"
- firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
- lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+ firstNameField =
+ Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+ firstNameResolver = pure $ Type.String "Friedrich"
+ lastNameField
+ = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+ lastNameResolver = pure $ Type.String "Nietzsche"
+
+subscriptionType :: Out.ObjectType (Either SomeException)
+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 (Either SomeException)
+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 expected = Aeson.object
- [ "data" .= Aeson.object
+ context "Query" $ do
+ it "skips unknown fields" $
+ let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "firstName" .= ("Friedrich" :: String)
]
]
- ]
- execute' = execute schema (mempty :: HashMap Name Aeson.Value)
- actual = runIdentity
- $ either parseError execute'
- $ parse document "" "{ philosopher { firstName surname } }"
- in actual `shouldBe` expected
- it "merges selections" $
- let expected = Aeson.object
- [ "data" .= Aeson.object
+ expected = Response data'' mempty
+ execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+ Right (Right actual) = 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)
]
]
- ]
- execute' = execute schema (mempty :: HashMap Name Aeson.Value)
- actual = runIdentity
- $ either 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)
+ Right (Right actual) = 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)
+ Right (Left stream) = either (pure . parseError) execute'
+ $ parse document "" "subscription { newQuote { quote } }"
+ Right (Just actual) = runConduit $ stream .| await
+ in actual `shouldBe` expected
diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
new file mode 100644
index 0000000..f84322d
--- /dev/null
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -0,0 +1,171 @@
+{- 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 Language.GraphQL.ValidateSpec
+ ( spec
+ ) where
+
+import Data.Sequence (Seq(..))
+import qualified Data.Sequence as Seq
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Language.GraphQL.AST as AST
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Validate
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
+
+schema :: Schema IO
+schema = Schema
+ { query = queryType
+ , mutation = Nothing
+ , subscription = Nothing
+ }
+
+queryType :: ObjectType IO
+queryType = ObjectType "Query" Nothing []
+ $ HashMap.singleton "dog" dogResolver
+ where
+ dogField = Field Nothing (Out.NamedObjectType dogType) mempty
+ dogResolver = ValueResolver dogField $ pure Null
+
+dogCommandType :: EnumType
+dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
+ [ ("SIT", EnumValue Nothing)
+ , ("DOWN", EnumValue Nothing)
+ , ("HEEL", EnumValue Nothing)
+ ]
+
+dogType :: ObjectType IO
+dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
+ [ ("name", nameResolver)
+ , ("nickname", nicknameResolver)
+ , ("barkVolume", barkVolumeResolver)
+ , ("doesKnowCommand", doesKnowCommandResolver)
+ , ("isHousetrained", isHousetrainedResolver)
+ , ("owner", ownerResolver)
+ ]
+ where
+ nameField = Field Nothing (Out.NonNullScalarType string) mempty
+ nameResolver = ValueResolver nameField $ pure "Name"
+ nicknameField = Field Nothing (Out.NamedScalarType string) mempty
+ nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
+ barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty
+ barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3
+ doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
+ $ HashMap.singleton "dogCommand"
+ $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
+ doesKnowCommandResolver = ValueResolver doesKnowCommandField
+ $ pure $ Boolean True
+ isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)
+ $ HashMap.singleton "atOtherHomes"
+ $ In.Argument Nothing (In.NamedScalarType boolean) Nothing
+ isHousetrainedResolver = ValueResolver isHousetrainedField
+ $ pure $ Boolean True
+ ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
+ ownerResolver = ValueResolver ownerField $ pure Null
+
+sentientType :: InterfaceType IO
+sentientType = InterfaceType "Sentient" Nothing []
+ $ HashMap.singleton "name"
+ $ Field Nothing (Out.NonNullScalarType string) mempty
+
+petType :: InterfaceType IO
+petType = InterfaceType "Pet" Nothing []
+ $ HashMap.singleton "name"
+ $ Field Nothing (Out.NonNullScalarType string) mempty
+{-
+alienType :: ObjectType IO
+alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
+ [ ("name", nameResolver)
+ , ("homePlanet", homePlanetResolver)
+ ]
+ where
+ nameField = Field Nothing (Out.NonNullScalarType string) mempty
+ nameResolver = ValueResolver nameField $ pure "Name"
+ homePlanetField =
+ Field Nothing (Out.NamedScalarType string) mempty
+ homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
+-}
+humanType :: ObjectType IO
+humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
+ [ ("name", nameResolver)
+ , ("pets", petsResolver)
+ ]
+ where
+ nameField = Field Nothing (Out.NonNullScalarType string) mempty
+ nameResolver = ValueResolver nameField $ pure "Name"
+ petsField =
+ Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
+ petsResolver = ValueResolver petsField $ pure $ List []
+{-
+catCommandType :: EnumType
+catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
+ [ ("JUMP", EnumValue Nothing)
+ ]
+
+catType :: ObjectType IO
+catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
+ [ ("name", nameResolver)
+ , ("nickname", nicknameResolver)
+ , ("doesKnowCommand", doesKnowCommandResolver)
+ , ("meowVolume", meowVolumeResolver)
+ ]
+ where
+ nameField = Field Nothing (Out.NonNullScalarType string) mempty
+ nameResolver = ValueResolver nameField $ pure "Name"
+ nicknameField = Field Nothing (Out.NamedScalarType string) mempty
+ nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
+ doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
+ $ HashMap.singleton "catCommand"
+ $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
+ doesKnowCommandResolver = ValueResolver doesKnowCommandField
+ $ pure $ Boolean True
+ meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
+ meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
+
+catOrDogType :: UnionType IO
+catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
+
+dogOrHumanType :: UnionType IO
+dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]
+
+humanOrAlienType :: UnionType IO
+humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]
+-}
+validate :: Text -> Seq Error
+validate queryString =
+ case parse AST.document "" queryString of
+ Left _ -> Seq.empty
+ Right ast -> document schema specifiedRules ast
+
+spec :: Spec
+spec =
+ describe "document" $
+ it "rejects type definitions" $
+ let queryString = [r|
+ query getDogName {
+ dog {
+ name
+ color
+ }
+ }
+
+ extend type Dog {
+ color: String
+ }
+ |]
+ expected = Error
+ { message =
+ "Definition must be OperationDefinition or FragmentDefinition."
+ , locations = [AST.Location 9 15]
+ , path = []
+ }
+ in validate queryString `shouldBe` Seq.singleton expected
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
index b147d77..e6b6cea 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
@@ -10,21 +14,21 @@ import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
import Text.RawString.QQ (r)
experimentalResolver :: Schema IO
-experimentalResolver = Schema { query = queryType, mutation = Nothing }
+experimentalResolver = Schema
+ { query = queryType, mutation = Nothing, subscription = Nothing }
where
- resolver = pure $ Int 5
queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField"
- $ Out.Resolver (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
- [ "data" .= object []
- ]
+emptyObject :: Aeson.Object
+emptyObject = HashMap.singleton "data" $ object []
spec :: Spec
spec =
@@ -37,7 +41,7 @@ spec =
|]
actual <- graphql experimentalResolver sourceQuery
- actual `shouldBe` emptyObject
+ actual `shouldResolveTo` emptyObject
it "should not skip fields if @skip is false" $ do
let sourceQuery = [r|
@@ -45,14 +49,12 @@ spec =
experimentalField @skip(if: false)
}
|]
- expected = object
- [ "data" .= object
+ expected = HashMap.singleton "data"
+ $ object
[ "experimentalField" .= (5 :: Int)
]
- ]
-
actual <- graphql experimentalResolver sourceQuery
- actual `shouldBe` expected
+ actual `shouldResolveTo` expected
it "should skip fields if @include is false" $ do
let sourceQuery = [r|
@@ -62,7 +64,7 @@ spec =
|]
actual <- graphql experimentalResolver sourceQuery
- actual `shouldBe` emptyObject
+ actual `shouldResolveTo` emptyObject
it "should be able to @skip a fragment spread" $ do
let sourceQuery = [r|
@@ -76,7 +78,7 @@ spec =
|]
actual <- graphql experimentalResolver sourceQuery
- actual `shouldBe` emptyObject
+ actual `shouldResolveTo` emptyObject
it "should be able to @skip an inline fragment" $ do
let sourceQuery = [r|
@@ -88,4 +90,4 @@ spec =
|]
actual <- graphql experimentalResolver sourceQuery
- actual `shouldBe` emptyObject
+ actual `shouldResolveTo` emptyObject
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 2924e63..089b721 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -1,23 +1,22 @@
+{- 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
( spec
) where
-import Data.Aeson (object, (.=))
+import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec
- ( Spec
- , describe
- , it
- , shouldBe
- , shouldNotSatisfy
- )
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
import Text.RawString.QQ (r)
size :: (Text, Value)
@@ -46,33 +45,33 @@ inlineQuery = [r|{
}
}|]
-hasErrors :: Aeson.Value -> Bool
-hasErrors (Aeson.Object object') = HashMap.member "errors" object'
-hasErrors _ = True
-
shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing []
$ HashMap.fromList
- [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
- , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+ [ ("size", sizeFieldType)
+ , ("circumference", circumferenceFieldType)
]
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.fromList
- [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
- , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+ [ ("size", sizeFieldType)
+ , ("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
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
@@ -83,8 +82,8 @@ toSchema t (_, resolve) = Schema
"size" -> shirtType
_ -> Out.ObjectType "Query" Nothing []
$ HashMap.fromList
- [ ("garment", Out.Resolver garmentField $ pure resolve)
- , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
+ [ ("garment", ValueResolver garmentField (pure resolve))
+ , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
]
spec :: Spec
@@ -92,25 +91,23 @@ spec = do
describe "Inline fragment executor" $ do
it "chooses the first selection if the type matches" $ do
actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
- let expected = object
- [ "data" .= object
- [ "garment" .= object
+ let expected = HashMap.singleton "data"
+ $ Aeson.object
+ [ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int)
]
]
- ]
- in actual `shouldBe` expected
+ in actual `shouldResolveTo` expected
it "chooses the last selection if the type matches" $ do
actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
- let expected = object
- [ "data" .= object
- [ "garment" .= object
+ let expected = HashMap.singleton "data"
+ $ Aeson.object
+ [ "garment" .= Aeson.object
[ "size" .= ("L" :: Text)
]
]
- ]
- in actual `shouldBe` expected
+ in actual `shouldResolveTo` expected
it "embeds inline fragments without type" $ do
let sourceQuery = [r|{
@@ -124,15 +121,14 @@ spec = do
resolvers = ("garment", Object $ HashMap.fromList [circumference, size])
actual <- graphql (toSchema "garment" resolvers) sourceQuery
- let expected = object
- [ "data" .= object
- [ "garment" .= object
+ let expected = HashMap.singleton "data"
+ $ Aeson.object
+ [ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int)
, "size" .= ("L" :: Text)
]
]
- ]
- in actual `shouldBe` expected
+ in actual `shouldResolveTo` expected
it "evaluates fragments on Query" $ do
let sourceQuery = [r|{
@@ -140,9 +136,7 @@ spec = do
size
}
}|]
-
- actual <- graphql (toSchema "size" size) sourceQuery
- actual `shouldNotSatisfy` hasErrors
+ in graphql (toSchema "size" size) `shouldResolve` sourceQuery
describe "Fragment spread executor" $ do
it "evaluates fragment spreads" $ do
@@ -157,12 +151,11 @@ spec = do
|]
actual <- graphql (toSchema "circumference" circumference) sourceQuery
- let expected = object
- [ "data" .= object
+ let expected = HashMap.singleton "data"
+ $ Aeson.object
[ "circumference" .= (60 :: Int)
]
- ]
- in actual `shouldBe` expected
+ in actual `shouldResolveTo` expected
it "evaluates nested fragments" $ do
let sourceQuery = [r|
@@ -182,19 +175,16 @@ spec = do
|]
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
- let expected = object
- [ "data" .= object
- [ "garment" .= object
+ let expected = HashMap.singleton "data"
+ $ Aeson.object
+ [ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int)
]
]
- ]
- in actual `shouldBe` expected
+ in actual `shouldResolveTo` expected
it "rejects recursive fragments" $ do
- let expected = object
- [ "data" .= object []
- ]
+ let expected = HashMap.singleton "data" $ Aeson.object []
sourceQuery = [r|
{
...circumferenceFragment
@@ -206,7 +196,7 @@ spec = do
|]
actual <- graphql (toSchema "circumference" circumference) sourceQuery
- actual `shouldBe` expected
+ actual `shouldResolveTo` expected
it "considers type condition" $ do
let sourceQuery = [r|
@@ -223,12 +213,11 @@ spec = do
size
}
|]
- expected = object
- [ "data" .= object
- [ "garment" .= object
+ expected = HashMap.singleton "data"
+ $ Aeson.object
+ [ "garment" .= Aeson.object
[ "circumference" .= (60 :: Int)
]
]
- ]
actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
- actual `shouldBe` expected
+ actual `shouldResolveTo` expected
diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs
index 0e534fc..ea89279 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
@@ -7,30 +11,34 @@ module Test.RootOperationSpec
import Data.Aeson ((.=), object)
import qualified Data.HashMap.Strict as HashMap
import Language.GraphQL
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
import Text.RawString.QQ (r)
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.Out as Out
+import Test.Hspec.GraphQL
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.singleton "circumference"
- $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+ $ 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)
+ { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
+ , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
+ , subscription = Nothing
+ }
where
garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60)
]
- incrementField = HashMap.singleton "incrementCircumference"
- $ Out.Resolver (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.Resolver (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 =
@@ -43,15 +51,14 @@ spec =
}
}
|]
- expected = object
- [ "data" .= object
+ expected = HashMap.singleton "data"
+ $ object
[ "garment" .= object
[ "circumference" .= (60 :: Int)
]
]
- ]
actual <- graphql schema querySource
- actual `shouldBe` expected
+ actual `shouldResolveTo` expected
it "chooses Mutation" $ do
let querySource = [r|
@@ -59,10 +66,9 @@ spec =
incrementCircumference
}
|]
- expected = object
- [ "data" .= object
+ expected = HashMap.singleton "data"
+ $ object
[ "incrementCircumference" .= (61 :: Int)
]
- ]
actual <- graphql schema querySource
- actual `shouldBe` expected
+ actual `shouldResolveTo` expected
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index 427371b..e3dd696 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Data
( Character
+ , StarWarsException(..)
, appearsIn
, artoo
, getDroid
@@ -16,12 +17,13 @@ module Test.StarWars.Data
, typeName
) where
-import Data.Functor.Identity (Identity)
+import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
import Control.Applicative (Alternative(..), liftA2)
-import Control.Monad.Trans.Except (throwE)
import Data.Maybe (catMaybes)
import Data.Text (Text)
-import Language.GraphQL.Trans
+import Data.Typeable (cast)
+import Language.GraphQL.Error
+import Language.GraphQL.Type
-- * Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -66,8 +68,20 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
-secretBackstory :: ActionT Identity Text
-secretBackstory = ActionT $ throwE "secretBackstory is secret."
+data StarWarsException = SecretBackstory | InvalidArguments
+
+instance Show StarWarsException where
+ show SecretBackstory = "secretBackstory is secret."
+ show InvalidArguments = "Invalid arguments."
+
+instance Exception StarWarsException where
+ toException = toException . ResolverException
+ fromException e = do
+ ResolverException resolverException <- fromException e
+ cast resolverException
+
+secretBackstory :: Resolve (Either SomeException)
+secretBackstory = throwM SecretBackstory
typeName :: Character -> Text
typeName = either (const "Droid") (const "Human")
@@ -161,10 +175,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 +186,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/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index cf451f8..95b18d3 100644
--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -6,7 +6,6 @@ module Test.StarWars.QuerySpec
import qualified Data.Aeson as Aeson
import Data.Aeson ((.=))
-import Data.Functor.Identity (Identity(..))
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Language.GraphQL
@@ -357,8 +356,11 @@ spec = describe "Star Wars Query Tests" $ do
alderaan = "homePlanet" .= ("Alderaan" :: Text)
testQuery :: Text -> Aeson.Value -> Expectation
-testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
+testQuery q expected =
+ let Right (Right actual) = graphql schema q
+ in Aeson.Object actual `shouldBe` expected
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected =
- runIdentity (graphqlSubs schema f q) `shouldBe` expected
+ let Right (Right actual) = graphqlSubs schema Nothing f q
+ in Aeson.Object actual `shouldBe` expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 5fcdf3e..cecd8eb 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -4,14 +4,11 @@ module Test.StarWars.Schema
( schema
) where
+import Control.Monad.Catch (MonadThrow(..), SomeException)
import Control.Monad.Trans.Reader (asks)
-import Control.Monad.Trans.Except (throwE)
-import Control.Monad.Trans.Class (lift)
-import Data.Functor.Identity (Identity)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import Data.Text (Text)
-import Language.GraphQL.Trans
import Language.GraphQL.Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
@@ -20,69 +17,97 @@ 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 (Either SomeException)
+schema = Schema
+ { query = queryType
+ , mutation = Nothing
+ , subscription = Nothing
+ }
where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
- [ ("hero", Out.Resolver heroField hero)
- , ("human", Out.Resolver humanField human)
- , ("droid", Out.Resolver droidField droid)
+ [ ("hero", heroFieldResolver)
+ , ("human", humanFieldResolver)
+ , ("droid", droidFieldResolver)
]
heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "episode"
$ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
+ heroFieldResolver = ValueResolver heroField hero
humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NonNullScalarType string) Nothing
+ humanFieldResolver = ValueResolver humanField human
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
+ droidFieldResolver = ValueResolver droidField droid
-heroObject :: Out.ObjectType Identity
+heroObject :: Out.ObjectType (Either SomeException)
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
- [ ("id", Out.Resolver idFieldType (idField "id"))
- , ("name", Out.Resolver nameFieldType (idField "name"))
- , ("friends", Out.Resolver friendsFieldType (idField "friends"))
- , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
- , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
- , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
- , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+ [ ("id", idFieldType)
+ , ("name", nameFieldType)
+ , ("friends", friendsFieldType)
+ , ("appearsIn", appearsInField)
+ , ("homePlanet", homePlanetFieldType)
+ , ("secretBackstory", secretBackstoryFieldType)
+ , ("__typename", typenameFieldType)
]
where
- homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+ homePlanetFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "homePlanet"
-droidObject :: Out.ObjectType Identity
+droidObject :: Out.ObjectType (Either SomeException)
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
- [ ("id", Out.Resolver idFieldType (idField "id"))
- , ("name", Out.Resolver nameFieldType (idField "name"))
- , ("friends", Out.Resolver friendsFieldType (idField "friends"))
- , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
- , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
- , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
- , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+ [ ("id", idFieldType)
+ , ("name", nameFieldType)
+ , ("friends", friendsFieldType)
+ , ("appearsIn", appearsInField)
+ , ("primaryFunction", primaryFunctionFieldType)
+ , ("secretBackstory", secretBackstoryFieldType)
+ , ("__typename", typenameFieldType)
]
where
- primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
-
-idFieldType :: Out.Field Identity
-idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
-
-nameFieldType :: Out.Field Identity
-nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
-
-friendsFieldType :: Out.Field Identity
-friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+ primaryFunctionFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "primaryFunction"
+
+typenameFieldType :: Resolver (Either SomeException)
+typenameFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "__typename"
+
+idFieldType :: Resolver (Either SomeException)
+idFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
+ $ idField "id"
+
+nameFieldType :: Resolver (Either SomeException)
+nameFieldType
+ = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+ $ idField "name"
+
+friendsFieldType :: Resolver (Either SomeException)
+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 (Either SomeException)
+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
+secretBackstoryFieldType :: Resolver (Either SomeException)
+secretBackstoryFieldType = ValueResolver field secretBackstory
+ where
+ field = Out.Field Nothing (Out.NamedScalarType string) mempty
-idField :: Text -> ActionT Identity Value
+idField :: Text -> Resolve (Either SomeException)
idField f = do
- v <- ActionT $ lift $ asks values
+ v <- asks values
let (Object v') = v
pure $ v' HashMap.! f
@@ -95,7 +120,7 @@ episodeEnum = EnumType "Episode" (Just description)
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
-hero :: ActionT Identity Value
+hero :: Resolve (Either SomeException)
hero = do
episode <- argument "episode"
pure $ character $ case episode of
@@ -104,23 +129,19 @@ hero = do
Enum "JEDI" -> getHero 6
_ -> artoo
-human :: ActionT Identity Value
+human :: Resolve (Either SomeException)
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
- _ -> ActionT $ throwE "Invalid arguments."
-
-droid :: ActionT Identity Value
+ String i -> pure $ maybe Null character $ getHuman i >>= Just
+ _ -> throwM InvalidArguments
+
+droid :: Resolve (Either SomeException)
droid = do
id' <- argument "id"
case id' of
- String i -> character <$> getDroid i
- _ -> ActionT $ throwE "Invalid arguments."
+ String i -> pure $ maybe Null character $ getDroid i >>= Just
+ _ -> throwM InvalidArguments
character :: Character -> Value
character char = Object $ HashMap.fromList
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:52:58 +0000