Overhaul Schema DSL
Aside of making the definition of Schemas easier, it takes care of issues like nested aliases which previously wasn't possible. The naming of the DSL functions is still provisional.
This commit is contained in:
Danny Navarro
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
hero args =
|
||||
case withArgument "episode" args of
|
||||
Just (ScalarInt n) -> characterFields $ getHero n
|
||||
_ -> const empty
|
||||
|
||||
human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
|
||||
human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
|
||||
human _ _ = 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] -> [Input] -> m Output
|
||||
droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
|
||||
droid _ _ = 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
|
||||
|
||||
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 -> 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
|
||||
|
||||
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
|
||||
appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
|
||||
appears' _ _ = empty
|
||||
|
||||
characterFields :: Alternative f => Character -> [Input] -> f Output
|
||||
characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
|
||||
characterFields :: Alternative f => Character -> ResolverO f
|
||||
characterFields = withFields . characterField
|
||||
|
||||
Reference in New Issue
Block a user