summaryrefslogtreecommitdiff
path: root/tests/Test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/Test')
-rw-r--r--tests/Test/StarWars/Data.hs10
-rw-r--r--tests/Test/StarWars/QueryTests.hs75
-rw-r--r--tests/Test/StarWars/Schema.hs92
3 files changed, 97 insertions, 80 deletions
diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs
index 2c1b323..a898cea 100644
--- a/tests/Test/StarWars/Data.hs
+++ b/tests/Test/StarWars/Data.hs
@@ -38,7 +38,7 @@ data Droid = Droid
type Character = Either Droid Human
--- I don't think this is cumbersome enough to make it worth using lens.
+-- I still don't think this is cumbersome enough to bring lens
id_ :: Character -> ID
id_ (Left x) = _id_ . _droidChar $ x
@@ -128,7 +128,6 @@ threepio = Droid
artoo :: Character
artoo = Left artoo'
-
artoo' :: Droid
artoo' = Droid
{ _droidChar = CharCommon
@@ -149,7 +148,6 @@ getHero _ = artoo
getHeroIO :: Int -> IO Character
getHeroIO = pure . getHero
-
getHuman :: Alternative f => ID -> f Character
getHuman = fmap Right . getHuman'
@@ -171,3 +169,9 @@ 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/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs
index 5ffb4b0..ccaf481 100644
--- a/tests/Test/StarWars/QueryTests.hs
+++ b/tests/Test/StarWars/QueryTests.hs
@@ -18,12 +18,6 @@ import Test.StarWars.Schema
-- * Test
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
-testQuery :: Text -> Aeson.Value -> Assertion
-testQuery q expected = graphql schema q @?= Just expected
-
-testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
-testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
-
test :: TestTree
test = testGroup "Star Wars Query Tests"
[ testGroup "Basic Queries"
@@ -148,24 +142,23 @@ test = testGroup "Star Wars Query Tests"
$ object [
"human" .= object ["name" .= ("Han Solo" :: Text)]
]
- -- TODO: This test is directly ported from `graphql-js`, however do we want
- -- to mimic the same behavior? Is this part of the spec? Once proper
- -- exceptions are implemented this test might no longer be meaningful.
- -- If the same behavior needs to be replicated, should it be implemented
- -- when defining the `Schema` or when executing?
- --
- -- , testCase "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 ["human" .= Aeson.Null]
- , testCase "Luke with alias" . testQuery
+ , testCase "Invalid ID" $ testFailParams
+ (\v -> if v == "id"
+ then Just "Not a valid ID"
+ else Nothing)
+ [r| query humanQuery($id: String!) {
+ human(id: $id) {
+ name
+ }
+ }
+ |]
+ -- TODO: This test is directly ported from `graphql-js`, however do we want
+ -- to mimic the same behavior? Is this part of the spec? Once proper
+ -- exceptions are implemented this test might no longer be meaningful.
+ -- If the same behavior needs to be replicated, should it be implemented
+ -- when defining the `Schema` or when executing?
+ -- $ object ["human" .= Aeson.Null]
+ , testCase "Luke aliased" . testQuery
[r| query FetchLukeAliased {
luke: human(id: "1000") {
name
@@ -177,6 +170,28 @@ test = testGroup "Star Wars Query Tests"
"name" .= ("Luke Skywalker" :: Text)
]
]
+ , testCase "R2-D2 ID and friends aliased" . testQuery
+ [r| query HeroNameAndFriendsQuery {
+ hero {
+ id
+ name
+ friends {
+ friendName: name
+ }
+ }
+ }
+ |]
+ $ object [
+ "hero" .= object [
+ "id" .= ("2001" :: Text)
+ , "name" .= ("R2-D2" :: Text)
+ , "friends" .= [
+ object ["friendName" .= ("Luke Skywalker" :: Text)]
+ , object ["friendName" .= ("Han Solo" :: Text)]
+ , object ["friendName" .= ("Leia Organa" :: Text)]
+ ]
+ ]
+ ]
, testCase "Luke and Leia aliased" . testQuery
[r| query FetchLukeAndLeiaAliased {
luke: human(id: "1000") {
@@ -196,3 +211,15 @@ test = testGroup "Star Wars Query Tests"
]
]
]
+
+testQuery :: Text -> Aeson.Value -> Assertion
+testQuery q expected = graphql schema q @?= Just expected
+
+-- testFail :: Text -> Assertion
+-- testFail q = graphql schema q @?= Nothing
+
+testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
+testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
+
+testFailParams :: Subs -> Text -> Assertion
+testFailParams f q = graphqlSubs schema f q @?= Nothing
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 57c1b24..1cd8f42 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -1,17 +1,7 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative (pure)
-import Data.Traversable (traverse)
-#endif
-import Control.Applicative (Alternative, empty)
-import Data.Foldable (fold)
-
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
+import Control.Applicative ((<|>), Alternative, empty)
import Data.GraphQL.Schema
@@ -23,47 +13,43 @@ import Test.StarWars.Data
schema :: (Alternative m, Monad m) => Schema m
schema = Schema query
-query :: (Alternative m, Monad m) => QueryRoot m
-query (InputField "hero" args ins) = hero args ins
-query (InputField "human" args ins) = human args ins
-query (InputField "droid" args ins) = droid args ins
-query _ = empty
+query :: (Alternative m, Monad m) => ResolverM m
+query fld =
+ withField "hero" hero fld
+ <|> withField "human" human fld
+ <|> withField "droid" droid fld
-hero :: Alternative f => [Argument] -> [Input] -> f Output
+hero :: Alternative f => [Argument] -> ResolverO f
hero [] = characterFields artoo
-hero [("episode", ScalarInt n)] = characterFields $ getHero n
-hero _ = const empty
-
-human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
-human _ _ = empty
-
-droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
-droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
-droid _ _ = empty
-
-episode :: Alternative f => Int -> f Output
-episode 4 = pure $ OutputEnum "NEWHOPE"
-episode 5 = pure $ OutputEnum "EMPIRE"
-episode 6 = pure $ OutputEnum "JEDI"
-episode _ = empty
-
-characterField :: Alternative f => Character -> Input -> f (HashMap Text Output)
-characterField char (InputField "id" [] []) =
- pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char
-characterField char (InputField "name" [] []) =
- pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char
-characterField char (InputField "friends" [] ins) =
- fmap (HashMap.singleton "friends" . OutputList)
- . traverse (`characterFields` ins)
- . getFriends
- $ char
-characterField char (InputField "appearsIn" [] []) =
- fmap (HashMap.singleton "appearsIn" . OutputList)
- . traverse episode
- . appearsIn
- $ char
-characterField _ _ = empty
-
-characterFields :: Alternative f => Character -> [Input] -> f Output
-characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
+hero args =
+ case withArgument "episode" args of
+ Just (ScalarInt n) -> characterFields $ getHero n
+ _ -> const empty
+
+human :: (Alternative m, Monad m) => [Argument] -> ResolverO m
+human args flds =
+ case withArgument "id" args of
+ Just (ScalarString i) -> flip characterFields flds =<< getHuman i
+ _ -> empty
+
+droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
+droid args flds =
+ case withArgument "id" args of
+ Just (ScalarString i) -> flip characterFields flds =<< getDroid i
+ _ -> empty
+
+characterField :: Alternative f => Character -> ResolverM f
+characterField char fld =
+ withFieldFinal "id" (OutputScalar . ScalarString . id_ $ char) fld
+ <|> withFieldFinal "name" (OutputScalar . ScalarString . name $ char) fld
+ <|> withField "friends" friends' fld
+ <|> withField "appearsIn" appears' fld
+ where
+ friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
+ friends' _ _ = empty
+
+ appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
+ appears' _ _ = empty
+
+characterFields :: Alternative f => Character -> ResolverO f
+characterFields = withFields . characterField
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-27 02:31:58 +0000