Extend execute for deeper queries

The second graphql-js end-to-end test was ported and passed
successfully.
This commit is contained in:
Danny Navarro 2016-02-08 17:30:18 +01:00
parent 53e101f35e
commit 1561e62489
3 changed files with 117 additions and 32 deletions

View File

@ -1,34 +1,41 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Execute where module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>), pure) import Control.Applicative (Applicative, (<$>), pure)
import Data.Traversable (traverse)
#endif #endif
import Control.Applicative (Alternative, empty) import Control.Applicative (Alternative, empty)
import Data.Foldable (fold)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.GraphQL.AST import Data.GraphQL.AST
import Data.GraphQL.Schema 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 query :: Applicative f => Document -> f SelectionSet
execute (Schema resolv0) doc = go resolv0 =<< root doc query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels
where query _ = error "query: Not implemented yet"
root :: Applicative f => Document -> f Selection
root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = pure sel
root _ = error "root: Not implemented yet"
go :: (Alternative f, Monad f) => Resolver f -> Selection -> f Response selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value
go resolv (SelectionField (Field _ n _ _ sfs)) = selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels
resolv (InputField n) >>= \case
(OutputScalar s) -> selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object
if null sfs selection resolv (SelectionField (Field _ n _ _ sfs)) =
then (\s' -> Aeson.Object [(n, Aeson.toJSON s')]) <$> s fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n)
else empty selection _ _ = error "selection: Not implemented yet"
(OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
_ -> error "go case resolv: Not implemented yet" output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value
go _ _ = error "go: Not implemented yet" 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

View File

@ -31,7 +31,8 @@ library
build-depends: base >= 4.7 && < 5, build-depends: base >= 4.7 && < 5,
text >= 0.11.3.1, text >= 0.11.3.1,
aeson >= 0.7.0.3, aeson >= 0.7.0.3,
attoparsec >= 0.10.4.0 attoparsec >= 0.10.4.0,
unordered-containers >= 0.2.5.0
test-suite tasty test-suite tasty
default-language: Haskell2010 default-language: Haskell2010
@ -45,6 +46,7 @@ test-suite tasty
aeson >= 0.7.0.3, aeson >= 0.7.0.3,
text >= 0.11.3.1, text >= 0.11.3.1,
attoparsec >= 0.10.4.0, attoparsec >= 0.10.4.0,
raw-strings-qq >= 1.1,
tasty >= 0.10, tasty >= 0.10,
tasty-hunit >= 0.9, tasty-hunit >= 0.9,
graphql graphql

View File

@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Test.StarWars where module Test.StarWars where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>), pure) import Control.Applicative (Applicative, (<$>), pure)
import Data.Monoid (mempty)
import Data.Traversable (traverse) import Data.Traversable (traverse)
#endif #endif
import Control.Applicative (Alternative, (<|>), empty, liftA2) import Control.Applicative (Alternative, (<|>), empty, liftA2)
@ -12,6 +13,7 @@ import Data.Maybe (catMaybes)
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import Data.Text (Text) import Data.Text (Text)
import Text.RawString.QQ (r)
import Test.Tasty (TestTree, testGroup) import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.HUnit (testCase, (@?=))
@ -24,9 +26,39 @@ import Data.GraphQL.Schema
test :: TestTree test :: TestTree
test = testGroup "Basic Queries" test = testGroup "Basic Queries"
[testCase "R2-D2" [ testCase "R2-D2 hero" $ (@?=) (graphql schema [r|
$ graphql schema "query HeroNameQuery{hero{name}}" query HeroNameQuery {
@?= Just (object ["hero" .= object ["name" .= ("R2-D2" :: Text)]]) 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 -- * Schema
@ -65,7 +97,6 @@ characterOutput "id" char =
characterOutput "name" char = characterOutput "name" char =
pure $ OutputScalar . pure . ScalarString $ name char pure $ OutputScalar . pure . ScalarString $ name char
characterOutput "friends" char = characterOutput "friends" char =
-- TODO: Cleanup
pure . OutputList . pure $ OutputResolver . (\c (InputField f) -> pure . OutputList . pure $ OutputResolver . (\c (InputField f) ->
characterOutput f c) <$> getFriends char characterOutput f c) <$> getFriends char
characterOutput _ _ = empty characterOutput _ _ = empty
@ -96,6 +127,51 @@ luke = Character
, homePlanet = "Tatoonie" , 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
artoo = Character artoo = Character
{ id_ = "2001" { id_ = "2001"
@ -116,14 +192,14 @@ getHeroIO = getHero
getHuman :: Alternative f => ID -> f Character getHuman :: Alternative f => ID -> f Character
getHuman "1000" = pure luke getHuman "1000" = pure luke
-- getHuman "1001" = "vader" getHuman "1001" = pure vader
-- getHuman "1002" = "han" getHuman "1002" = pure han
-- getHuman "1003" = "leia" getHuman "1003" = pure leia
-- getHuman "1004" = "tarkin" getHuman "1004" = pure tarkin
getHuman _ = empty getHuman _ = empty
getDroid :: Alternative f => ID -> f Character getDroid :: Alternative f => ID -> f Character
-- getDroid "2000" = "threepio" getDroid "2000" = pure threepio
getDroid "2001" = pure artoo getDroid "2001" = pure artoo
getDroid _ = empty getDroid _ = empty