diff --git a/graphql.cabal b/graphql.cabal index ea1d152..18c78fa 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -41,7 +41,9 @@ test-suite tasty main-is: tasty.hs ghc-options: -Wall other-modules: Paths_graphql - Test.StarWars + Test.StarWars.Data + Test.StarWars.Schema + Test.StarWars.QueryTests build-depends: base >= 4.6 && <5, aeson >= 0.7.0.3, text >= 0.11.3.1, diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs deleted file mode 100644 index 7e1d8ab..0000000 --- a/tests/Test/StarWars.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Test.StarWars where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) -import Data.Monoid (mempty) -import Data.Traversable (traverse) -#endif -import Control.Applicative (Alternative, (<|>), empty, liftA2) -import Data.Foldable (fold) -import Data.Maybe (catMaybes) - -import Data.Aeson (object, (.=)) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) -import Text.RawString.QQ (r) - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) - -import Data.GraphQL -import Data.GraphQL.Schema - --- * Test --- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js - -test :: TestTree -test = testGroup "Star Wars Query Tests" - [ testGroup "Basic Queries" - [ testCase "R2-D2 hero" $ (@?=) (graphql schema [r| - query HeroNameQuery { - hero { - id - } - }|]) . Just - $ object [ - "hero" .= object [ - "id" .= ("2001" :: Text) - ] - ] - - , testCase "R2-D2 ID and friends" $ (@?=) (graphql schema [r| - query HeroNameAndFriendsQuery { - hero { - id - name - friends { - name - } - } - }|]) . Just - $ object [ - "hero" .= object [ - "id" .= ("2001" :: Text) - , "name" .= ("R2-D2" :: Text) - , "friends" .= [ - object ["name" .= ("Luke Skywalker" :: Text)] - , object ["name" .= ("Han Solo" :: Text)] - , object ["name" .= ("Leia Organa" :: Text)] - ] - ] - ] - ] - , testGroup "Nested Queries" - [ testCase "R2-D2 friends" $ (@?=) (graphql schema [r| - query NestedQuery { - hero { - name - friends { - name - appearsIn - friends { - name - } - } - } - }|]) . Just - $ object [ - "hero" .= object [ - "name" .= ("R2-D2" :: Text) - , "friends" .= [ - object [ - "name" .= ("Luke Skywalker" :: Text) - , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text] - , "friends" .= [ - object ["name" .= ("Han Solo" :: Text)] - , object ["name" .= ("Leia Organa" :: Text)] - , object ["name" .= ("C-3PO" :: Text)] - , object ["name" .= ("R2-D2" :: Text)] - ] - ] - , object [ - "name" .= ("Han Solo" :: Text) - , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] - , "friends" .= [ - object ["name" .= ("Luke Skywalker" :: Text)] - , object ["name" .= ("Leia Organa" :: Text)] - , object ["name" .= ("R2-D2" :: Text)] - ] - ] - , object [ - "name" .= ("Leia Organa" :: Text) - , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] - , "friends" .= [ - object ["name" .= ("Luke Skywalker" :: Text)] - , object ["name" .= ("Han Solo" :: Text)] - , object ["name" .= ("C-3PO" :: Text)] - , object ["name" .= ("R2-D2" :: Text)] - ] - ] - ] - ] - ] - , testCase "Luke ID" $ (@?=) (graphql schema [r| -query FetchLukeQuery { - human(id: "1000") { - name - } -}|]) . Just - $ object [ - "human" .= object [ - "name" .= ("Luke Skywalker" :: Text) - ] - ] - ] - ] - --- * Schema --- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js - -type ID = Text - -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 - -hero :: Alternative f => [Argument] -> [Input] -> f Output -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) - --- * Data --- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js - --- ** Characters - -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 - --- I don't think this is cumbersome enough to make it worth using lens. - -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 - -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 = "Tatoonie" - } - -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 diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs new file mode 100644 index 0000000..2c1b323 --- /dev/null +++ b/tests/Test/StarWars/Data.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Test.StarWars.Data where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), pure) +import Data.Monoid (mempty) +#endif +import Control.Applicative (Alternative, (<|>), empty, liftA2) +import Data.Maybe (catMaybes) + +import Data.Text (Text) + +-- * 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 + +-- I don't think this is cumbersome enough to make it worth using lens. + +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 + +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 = "Tatoonie" + } + +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 diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs new file mode 100644 index 0000000..529c386 --- /dev/null +++ b/tests/Test/StarWars/QueryTests.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Test.StarWars.QueryTests where + +import Data.Aeson (object, (.=)) +import Data.Text (Text) +import Text.RawString.QQ (r) + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Data.GraphQL + +import Test.StarWars.Schema + +-- * Test +-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js + +test :: TestTree +test = testGroup "Star Wars Query Tests" + [ testGroup "Basic Queries" + [ testCase "R2-D2 hero" $ (@?=) (graphql schema [r| + query HeroNameQuery { + hero { + id + } + }|]) . Just + $ object [ + "hero" .= object [ + "id" .= ("2001" :: Text) + ] + ] + + , testCase "R2-D2 ID and friends" $ (@?=) (graphql schema [r| + query HeroNameAndFriendsQuery { + hero { + id + name + friends { + name + } + } + }|]) . Just + $ object [ + "hero" .= object [ + "id" .= ("2001" :: Text) + , "name" .= ("R2-D2" :: Text) + , "friends" .= [ + object ["name" .= ("Luke Skywalker" :: Text)] + , object ["name" .= ("Han Solo" :: Text)] + , object ["name" .= ("Leia Organa" :: Text)] + ] + ] + ] + ] + , testGroup "Nested Queries" + [ testCase "R2-D2 friends" $ (@?=) (graphql schema [r| + query NestedQuery { + hero { + name + friends { + name + appearsIn + friends { + name + } + } + } + }|]) . Just + $ object [ + "hero" .= object [ + "name" .= ("R2-D2" :: Text) + , "friends" .= [ + object [ + "name" .= ("Luke Skywalker" :: Text) + , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text] + , "friends" .= [ + object ["name" .= ("Han Solo" :: Text)] + , object ["name" .= ("Leia Organa" :: Text)] + , object ["name" .= ("C-3PO" :: Text)] + , object ["name" .= ("R2-D2" :: Text)] + ] + ] + , object [ + "name" .= ("Han Solo" :: Text) + , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] + , "friends" .= [ + object ["name" .= ("Luke Skywalker" :: Text)] + , object ["name" .= ("Leia Organa" :: Text)] + , object ["name" .= ("R2-D2" :: Text)] + ] + ] + , object [ + "name" .= ("Leia Organa" :: Text) + , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text] + , "friends" .= [ + object ["name" .= ("Luke Skywalker" :: Text)] + , object ["name" .= ("Han Solo" :: Text)] + , object ["name" .= ("C-3PO" :: Text)] + , object ["name" .= ("R2-D2" :: Text)] + ] + ] + ] + ] + ] + , testCase "Luke ID" $ (@?=) (graphql schema [r| +query FetchLukeQuery { + human(id: "1000") { + name + } +}|]) . Just + $ object [ + "human" .= object [ + "name" .= ("Luke Skywalker" :: Text) + ] + ] + ] + ] + diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs new file mode 100644 index 0000000..57c1b24 --- /dev/null +++ b/tests/Test/StarWars/Schema.hs @@ -0,0 +1,69 @@ +{-# 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 Data.GraphQL.Schema + +import Test.StarWars.Data + +-- * Schema +-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js + +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 + +hero :: Alternative f => [Argument] -> [Input] -> f Output +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) diff --git a/tests/tasty.hs b/tests/tasty.hs index f7ed522..791bfbb 100644 --- a/tests/tasty.hs +++ b/tests/tasty.hs @@ -14,7 +14,7 @@ import Test.Tasty.HUnit import qualified Data.GraphQL.Parser as Parser import qualified Data.GraphQL.Encoder as Encoder -import qualified Test.StarWars as SW +import qualified Test.StarWars.QueryTests as SW import Paths_graphql (getDataFileName) main :: IO ()