forked from OSS/graphql
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
parent
53e101f35e
commit
1561e62489
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,9 +26,39 @@ 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
|
||||
@ -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,14 +192,14 @@ 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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user