aboutsummaryrefslogtreecommitdiff
path: root/tests/Test/StarWars
diff options
context:
space:
mode:
Diffstat (limited to 'tests/Test/StarWars')
-rw-r--r--tests/Test/StarWars/Data.hs197
-rw-r--r--tests/Test/StarWars/QuerySpec.hs351
-rw-r--r--tests/Test/StarWars/Schema.hs63
3 files changed, 611 insertions, 0 deletions
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
new file mode 100644
index 0000000..55ff207
--- /dev/null
+++ b/tests/Test/StarWars/Data.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Test.StarWars.Data
+ ( Character
+ , appearsIn
+ , artoo
+ , getDroid
+ , getDroid'
+ , getEpisode
+ , getFriends
+ , getHero
+ , getHeroIO
+ , getHuman
+ , id_
+ , homePlanet
+ , name
+ , secretBackstory
+ , typeName
+ ) where
+
+import Data.Monoid (mempty)
+import Control.Applicative ( Alternative(..)
+ , liftA2
+ )
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Except (throwE)
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import Language.GraphQL.Trans
+
+-- * Data
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
+
+-- ** Characters
+
+type ID = Text
+
+data CharCommon = CharCommon
+ { _id_ :: ID
+ , _name :: Text
+ , _friends :: [ID]
+ , _appearsIn :: [Int]
+ } deriving (Show)
+
+
+data Human = Human
+ { _humanChar :: CharCommon
+ , homePlanet :: Text
+ }
+
+data Droid = Droid
+ { _droidChar :: CharCommon
+ , primaryFunction :: Text
+ }
+
+type Character = Either Droid Human
+
+id_ :: Character -> ID
+id_ (Left x) = _id_ . _droidChar $ x
+id_ (Right x) = _id_ . _humanChar $ x
+
+name :: Character -> Text
+name (Left x) = _name . _droidChar $ x
+name (Right x) = _name . _humanChar $ x
+
+friends :: Character -> [ID]
+friends (Left x) = _friends . _droidChar $ x
+friends (Right x) = _friends . _humanChar $ x
+
+appearsIn :: Character -> [Int]
+appearsIn (Left x) = _appearsIn . _droidChar $ x
+appearsIn (Right x) = _appearsIn . _humanChar $ x
+
+secretBackstory :: MonadIO m => Character -> ActionT m Text
+secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
+
+typeName :: Character -> Text
+typeName = either (const "Droid") (const "Human")
+
+luke :: Character
+luke = Right luke'
+
+luke' :: Human
+luke' = Human
+ { _humanChar = CharCommon
+ { _id_ = "1000"
+ , _name = "Luke Skywalker"
+ , _friends = ["1002","1003","2000","2001"]
+ , _appearsIn = [4,5,6]
+ }
+ , homePlanet = "Tatooine"
+ }
+
+vader :: Human
+vader = Human
+ { _humanChar = CharCommon
+ { _id_ = "1001"
+ , _name = "Darth Vader"
+ , _friends = ["1004"]
+ , _appearsIn = [4,5,6]
+ }
+ , homePlanet = "Tatooine"
+ }
+
+han :: Human
+han = Human
+ { _humanChar = CharCommon
+ { _id_ = "1002"
+ , _name = "Han Solo"
+ , _friends = ["1000","1003","2001" ]
+ , _appearsIn = [4,5,6]
+ }
+ , homePlanet = mempty
+ }
+
+leia :: Human
+leia = Human
+ { _humanChar = CharCommon
+ { _id_ = "1003"
+ , _name = "Leia Organa"
+ , _friends = ["1000","1002","2000","2001"]
+ , _appearsIn = [4,5,6]
+ }
+ , homePlanet = "Alderaan"
+ }
+
+tarkin :: Human
+tarkin = Human
+ { _humanChar = CharCommon
+ { _id_ = "1004"
+ , _name = "Wilhuff Tarkin"
+ , _friends = ["1001"]
+ , _appearsIn = [4]
+ }
+ , homePlanet = mempty
+ }
+
+threepio :: Droid
+threepio = Droid
+ { _droidChar = CharCommon
+ { _id_ = "2000"
+ , _name = "C-3PO"
+ , _friends = ["1000","1002","1003","2001" ]
+ , _appearsIn = [ 4, 5, 6 ]
+ }
+ , primaryFunction = "Protocol"
+ }
+
+artoo :: Character
+artoo = Left artoo'
+
+artoo' :: Droid
+artoo' = Droid
+ { _droidChar = CharCommon
+ { _id_ = "2001"
+ , _name = "R2-D2"
+ , _friends = ["1000","1002","1003"]
+ , _appearsIn = [4,5,6]
+ }
+ , primaryFunction = "Astrometch"
+ }
+
+-- ** Helper functions
+
+getHero :: Int -> Character
+getHero 5 = luke
+getHero _ = artoo
+
+getHeroIO :: Int -> IO Character
+getHeroIO = pure . getHero
+
+getHuman :: Alternative f => ID -> f Character
+getHuman = fmap Right . getHuman'
+
+getHuman' :: Alternative f => ID -> f Human
+getHuman' "1000" = pure luke'
+getHuman' "1001" = pure vader
+getHuman' "1002" = pure han
+getHuman' "1003" = pure leia
+getHuman' "1004" = pure tarkin
+getHuman' _ = empty
+
+getDroid :: Alternative f => ID -> f Character
+getDroid = fmap Left . getDroid'
+
+getDroid' :: Alternative f => ID -> f Droid
+getDroid' "2000" = pure threepio
+getDroid' "2001" = pure artoo'
+getDroid' _ = empty
+
+getFriends :: Character -> [Character]
+getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
+
+getEpisode :: Alternative f => Int -> f Text
+getEpisode 4 = pure "NEWHOPE"
+getEpisode 5 = pure "EMPIRE"
+getEpisode 6 = pure "JEDI"
+getEpisode _ = empty
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
new file mode 100644
index 0000000..0f6a2ef
--- /dev/null
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -0,0 +1,351 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.StarWars.QuerySpec
+ ( spec
+ ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Aeson ( object
+ , (.=)
+ )
+import Data.Text (Text)
+import Language.GraphQL
+import Language.GraphQL.Schema (Subs)
+import Text.RawString.QQ (r)
+import Test.Hspec.Expectations ( Expectation
+ , shouldBe
+ )
+import Test.Hspec ( Spec
+ , describe
+ , it
+ )
+import Test.StarWars.Schema
+
+-- * Test
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
+
+spec :: Spec
+spec = describe "Star Wars Query Tests" $ do
+ describe "Basic Queries" $ do
+ it "R2-D2 hero" $ testQuery
+ [r| query HeroNameQuery {
+ hero {
+ id
+ }
+ }
+ |]
+ $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
+ it "R2-D2 ID and friends" $ testQuery
+ [r| query HeroNameAndFriendsQuery {
+ hero {
+ id
+ name
+ friends {
+ name
+ }
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "hero" .= object
+ [ "id" .= ("2001" :: Text)
+ , r2d2Name
+ , "friends" .=
+ [ object [lukeName]
+ , object [hanName]
+ , object [leiaName]
+ ]
+ ]
+ ]]
+
+ describe "Nested Queries" $ do
+ it "R2-D2 friends" $ testQuery
+ [r| query NestedQuery {
+ hero {
+ name
+ friends {
+ name
+ appearsIn
+ friends {
+ name
+ }
+ }
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "hero" .= object [
+ "name" .= ("R2-D2" :: Text)
+ , "friends" .= [
+ object [
+ "name" .= ("Luke Skywalker" :: Text)
+ , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
+ , "friends" .= [
+ object [hanName]
+ , object [leiaName]
+ , object [c3poName]
+ , object [r2d2Name]
+ ]
+ ]
+ , object [
+ hanName
+ , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+ , "friends" .= [
+ object [lukeName]
+ , object [leiaName]
+ , object [r2d2Name]
+ ]
+ ]
+ , object [
+ leiaName
+ , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+ , "friends" .= [
+ object [lukeName]
+ , object [hanName]
+ , object [c3poName]
+ , object [r2d2Name]
+ ]
+ ]
+ ]
+ ]
+ ]]
+ it "Luke ID" $ testQuery
+ [r| query FetchLukeQuery {
+ human(id: "1000") {
+ name
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "human" .= object [lukeName]
+ ]]
+
+ it "Luke ID with variable" $ testQueryParams
+ (\v -> if v == "someId" then Just "1000" else Nothing)
+ [r| query FetchSomeIDQuery($someId: String!) {
+ human(id: $someId) {
+ name
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "human" .= object [lukeName]
+ ]]
+ it "Han ID with variable" $ testQueryParams
+ (\v -> if v == "someId" then Just "1002" else Nothing)
+ [r| query FetchSomeIDQuery($someId: String!) {
+ human(id: $someId) {
+ name
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "human" .= object [hanName]
+ ]]
+ it "Invalid ID" $ testQueryParams
+ (\v -> if v == "id" then Just "Not a valid ID" else Nothing)
+ [r| query humanQuery($id: String!) {
+ human(id: $id) {
+ name
+ }
+ }
+ |] $ object ["data" .= object ["human" .= Aeson.Null]]
+ it "Luke aliased" $ testQuery
+ [r| query FetchLukeAliased {
+ luke: human(id: "1000") {
+ name
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "luke" .= object [lukeName]
+ ]]
+ it "R2-D2 ID and friends aliased" $ testQuery
+ [r| query HeroNameAndFriendsQuery {
+ hero {
+ id
+ name
+ friends {
+ friendName: name
+ }
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "hero" .= object [
+ "id" .= ("2001" :: Text)
+ , r2d2Name
+ , "friends" .= [
+ object ["friendName" .= ("Luke Skywalker" :: Text)]
+ , object ["friendName" .= ("Han Solo" :: Text)]
+ , object ["friendName" .= ("Leia Organa" :: Text)]
+ ]
+ ]
+ ]]
+ it "Luke and Leia aliased" $ testQuery
+ [r| query FetchLukeAndLeiaAliased {
+ luke: human(id: "1000") {
+ name
+ }
+ leia: human(id: "1003") {
+ name
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "luke" .= object [lukeName]
+ , "leia" .= object [leiaName]
+ ]]
+
+ describe "Fragments for complex queries" $ do
+ it "Aliases to query for duplicate content" $ testQuery
+ [r| query DuplicateFields {
+ luke: human(id: "1000") {
+ name
+ homePlanet
+ }
+ leia: human(id: "1003") {
+ name
+ homePlanet
+ }
+ }
+ |]
+ $ object [ "data" .= object [
+ "luke" .= object [lukeName, tatooine]
+ , "leia" .= object [leiaName, alderaan]
+ ]]
+ it "Fragment for duplicate content" $ testQuery
+ [r| query UseFragment {
+ luke: human(id: "1000") {
+ ...HumanFragment
+ }
+ leia: human(id: "1003") {
+ ...HumanFragment
+ }
+ }
+ fragment HumanFragment on Human {
+ name
+ homePlanet
+ }
+ |]
+ $ object [ "data" .= object [
+ "luke" .= object [lukeName, tatooine]
+ , "leia" .= object [leiaName, alderaan]
+ ]]
+
+ describe "__typename" $ do
+ it "R2D2 is a Droid" $ testQuery
+ [r| query CheckTypeOfR2 {
+ hero {
+ __typename
+ name
+ }
+ }
+ |]
+ $ object ["data" .= object [
+ "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
+ ]]
+ it "Luke is a human" $ testQuery
+ [r| query CheckTypeOfLuke {
+ hero(episode: EMPIRE) {
+ __typename
+ name
+ }
+ }
+ |]
+ $ object ["data" .= object [
+ "hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
+ ]]
+
+ describe "Errors in resolvers" $ do
+ it "error on secretBackstory" $ testQuery
+ [r|
+ query HeroNameQuery {
+ hero {
+ name
+ secretBackstory
+ }
+ }
+ |]
+ $ object
+ [ "data" .= object
+ [ "hero" .= object
+ [ "name" .= ("R2-D2" :: Text)
+ , "secretBackstory" .= Aeson.Null
+ ]
+ ]
+ , "errors" .=
+ [ object
+ ["message" .= ("secretBackstory is secret." :: Text)]
+ ]
+ ]
+ it "Error in a list" $ testQuery
+ [r| query HeroNameQuery {
+ hero {
+ name
+ friends {
+ name
+ secretBackstory
+ }
+ }
+ }
+ |]
+ $ object ["data" .= object
+ [ "hero" .= object
+ [ "name" .= ("R2-D2" :: Text)
+ , "friends" .=
+ [ object
+ [ "name" .= ("Luke Skywalker" :: Text)
+ , "secretBackstory" .= Aeson.Null
+ ]
+ , object
+ [ "name" .= ("Han Solo" :: Text)
+ , "secretBackstory" .= Aeson.Null
+ ]
+ , object
+ [ "name" .= ("Leia Organa" :: Text)
+ , "secretBackstory" .= Aeson.Null
+ ]
+ ]
+ ]
+ ]
+ , "errors" .=
+ [ object ["message" .= ("secretBackstory is secret." :: Text)]
+ , object ["message" .= ("secretBackstory is secret." :: Text)]
+ , object ["message" .= ("secretBackstory is secret." :: Text)]
+ ]
+ ]
+ it "error on secretBackstory with alias" $ testQuery
+ [r| query HeroNameQuery {
+ mainHero: hero {
+ name
+ story: secretBackstory
+ }
+ }
+ |]
+ $ object
+ [ "data" .= object
+ [ "mainHero" .= object
+ [ "name" .= ("R2-D2" :: Text)
+ , "story" .= Aeson.Null
+ ]
+ ]
+ , "errors" .=
+ [ object ["message" .= ("secretBackstory is secret." :: Text)]
+ ]
+ ]
+
+ where
+ lukeName = "name" .= ("Luke Skywalker" :: Text)
+ leiaName = "name" .= ("Leia Organa" :: Text)
+ hanName = "name" .= ("Han Solo" :: Text)
+ r2d2Name = "name" .= ("R2-D2" :: Text)
+ c3poName = "name" .= ("C-3PO" :: Text)
+ tatooine = "homePlanet" .= ("Tatooine" :: Text)
+ alderaan = "homePlanet" .= ("Alderaan" :: Text)
+
+testQuery :: Text -> Aeson.Value -> Expectation
+testQuery q expected = graphql schema q >>= flip shouldBe expected
+
+testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
+testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
new file mode 100644
index 0000000..101bbdf
--- /dev/null
+++ b/tests/Test/StarWars/Schema.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Test.StarWars.Schema
+ ( character
+ , droid
+ , hero
+ , human
+ , schema
+ ) where
+
+import Control.Monad.Trans.Except (throwE)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Language.GraphQL.Schema ( Schema
+ , Resolver
+ , Argument(..)
+ , Value(..)
+ )
+import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Trans
+import Language.GraphQL.Type
+import Test.StarWars.Data
+
+-- * Schema
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
+
+schema :: MonadIO m => Schema m
+schema = hero :| [human, droid]
+
+hero :: MonadIO m => Resolver m
+hero = Schema.objectA "hero" $ \case
+ [] -> character artoo
+ [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
+ [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
+ [Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6
+ _ -> ActionT $ throwE "Invalid arguments."
+
+human :: MonadIO m => Resolver m
+human = Schema.wrappedObjectA "human" $ \case
+ [Argument "id" (ValueString i)] -> do
+ humanCharacter <- lift $ return $ getHuman i >>= Just
+ case humanCharacter of
+ Nothing -> return Null
+ Just e -> Named <$> character e
+ _ -> ActionT $ throwE "Invalid arguments."
+
+droid :: MonadIO m => Resolver m
+droid = Schema.objectA "droid" $ \case
+ [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)
+ _ -> ActionT $ throwE "Invalid arguments."
+
+character :: MonadIO m => Character -> ActionT m [Resolver m]
+character char = return
+ [ Schema.scalar "id" $ return $ id_ char
+ , Schema.scalar "name" $ return $ name char
+ , Schema.wrappedObject "friends"
+ $ traverse character $ List $ Named <$> getFriends char
+ , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
+ , Schema.scalar "secretBackstory" $ secretBackstory char
+ , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
+ , Schema.scalar "__typename" $ return $ typeName char
+ ]
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:52:56 +0000