diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index b843f07..df6b506 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -1,34 +1,41 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE LambdaCase #-} module Data.GraphQL.Execute where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative, (<$>), pure) +import Data.Traversable (traverse) #endif import Control.Applicative (Alternative, empty) +import Data.Foldable (fold) import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap import Data.GraphQL.AST import Data.GraphQL.Schema -type Response = Aeson.Value +execute :: (Alternative f, Monad f) => Schema f -> Document -> f Aeson.Value +execute (Schema resolv) doc = selectionSet resolv =<< query doc -execute :: (Alternative f, Monad f) => Schema f -> Document -> f Response -execute (Schema resolv0) doc = go resolv0 =<< root doc - where - root :: Applicative f => Document -> f Selection - root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = pure sel - root _ = error "root: Not implemented yet" +query :: Applicative f => Document -> f SelectionSet +query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels +query _ = error "query: Not implemented yet" - go :: (Alternative f, Monad f) => Resolver f -> Selection -> f Response - go resolv (SelectionField (Field _ n _ _ sfs)) = - resolv (InputField n) >>= \case - (OutputScalar s) -> - if null sfs - then (\s' -> Aeson.Object [(n, Aeson.toJSON s')]) <$> s - else empty - (OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs) - _ -> error "go case resolv: Not implemented yet" - go _ _ = error "go: Not implemented yet" +selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value +selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels + +selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object +selection resolv (SelectionField (Field _ n _ _ sfs)) = + fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n) +selection _ _ = error "selection: Not implemented yet" + +output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value +output sels (OutputResolver resolv) = selectionSet resolv sels +output sels (OutputList os) = fmap array . traverse (output sels) =<< os +output sels (OutputScalar s) + | null sels = Aeson.toJSON <$> s + | otherwise = empty + +array :: [Aeson.Value] -> Aeson.Value +array = Aeson.toJSON diff --git a/graphql.cabal b/graphql.cabal index 40da990..bd3bbd8 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -31,7 +31,8 @@ library build-depends: base >= 4.7 && < 5, text >= 0.11.3.1, aeson >= 0.7.0.3, - attoparsec >= 0.10.4.0 + attoparsec >= 0.10.4.0, + unordered-containers >= 0.2.5.0 test-suite tasty default-language: Haskell2010 @@ -45,6 +46,7 @@ test-suite tasty aeson >= 0.7.0.3, text >= 0.11.3.1, attoparsec >= 0.10.4.0, + raw-strings-qq >= 1.1, tasty >= 0.10, tasty-hunit >= 0.9, graphql diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs index a6fa9ee..b3ab99e 100644 --- a/tests/Test/StarWars.hs +++ b/tests/Test/StarWars.hs @@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} module Test.StarWars where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative, (<$>), pure) +import Data.Monoid (mempty) import Data.Traversable (traverse) #endif import Control.Applicative (Alternative, (<|>), empty, liftA2) @@ -12,6 +13,7 @@ import Data.Maybe (catMaybes) import Data.Aeson (object, (.=)) import Data.Text (Text) +import Text.RawString.QQ (r) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -24,10 +26,40 @@ import Data.GraphQL.Schema test :: TestTree test = testGroup "Basic Queries" - [testCase "R2-D2" - $ graphql schema "query HeroNameQuery{hero{name}}" - @?= Just (object ["hero" .= object ["name" .= ("R2-D2" :: Text)]]) - ] + [ 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)] + ] + ] + ] + ] -- * Schema -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js @@ -45,7 +77,7 @@ query _ = empty hero :: Alternative f => Resolver f hero (InputList (InputScalar (ScalarInt ep) : inputFields)) = - withFields inputFields <$> getHero ep + withFields inputFields <$> getHero ep hero (InputField fld) = characterOutput fld artoo hero _ = empty @@ -65,7 +97,6 @@ characterOutput "id" char = characterOutput "name" char = pure $ OutputScalar . pure . ScalarString $ name char characterOutput "friends" char = - -- TODO: Cleanup pure . OutputList . pure $ OutputResolver . (\c (InputField f) -> characterOutput f c) <$> getFriends char characterOutput _ _ = empty @@ -96,6 +127,51 @@ luke = Character , homePlanet = "Tatoonie" } +vader :: Character +vader = Character + { id_ = "1001" + , name = "Darth Vader" + , friends = ["1004"] + , appearsIn = [4,5,6] + , homePlanet = "Tatooine" + } + +han :: Character +han = Character + { id_ = "1002" + , name = "Han Solo" + , friends = ["1000","1003","2001" ] + , appearsIn = [4,5,6] + , homePlanet = mempty + } + +leia :: Character +leia = Character + { id_ = "1003" + , name = "Leia Organa" + , friends = ["1000","1002","2000","2001"] + , appearsIn = [4,5,6] + , homePlanet = "Alderaan" + } + +tarkin :: Character +tarkin = Character + { id_ = "1004" + , name = "Wilhuff Tarkin" + , friends = ["1001"] + , appearsIn = [4] + , homePlanet = mempty + } + +threepio :: Character +threepio = Character + { id_ = "2000" + , name = "C-3PO" + , friends = ["1000","1002","1003","2001" ] + , appearsIn = [ 4, 5, 6 ] + , homePlanet = "Protocol" + } + artoo :: Character artoo = Character { id_ = "2001" @@ -116,16 +192,16 @@ getHeroIO = getHero getHuman :: Alternative f => ID -> f Character getHuman "1000" = pure luke --- getHuman "1001" = "vader" --- getHuman "1002" = "han" --- getHuman "1003" = "leia" --- getHuman "1004" = "tarkin" +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 "2000" = "threepio" +getDroid "2000" = pure threepio getDroid "2001" = pure artoo -getDroid _ = empty +getDroid _ = empty getFriends :: Character -> [Character] getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char