OSS/graphql
1
1
Fork 1
Code Issues 5 Pull Requests Actions Releases 22 Wiki Activity

Extend execute for deeper queries

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
Data/GraphQL/Execute.hs
View File

@ -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

4
graphql.cabal
View File

@ -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

96
tests/Test/StarWars.hs
View File

@ -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