forked from OSS/graphql
Rough implementation of execute
The first end-to-end test taken from `graphql-js` passes but this still needs to be extended to support more general cases. - `Data.GraphQL.Schema` has been heavily modified to support the execution model. More drastic changes are expected in this module. - When defining a `Schema` ordinary functions taking fields as input are being used instead of maps. This makes the implementation of `execute` easier, and, arguably, makes `Schema` definitions more *Haskellish*. - Drop explicit `unordered-containers` dependency. `Aeson.Value`s and field functions should be good enough for now.
This commit is contained in:
Danny Navarro
parent
4e5dc3433a
commit
bb685c9afa
@ -1,16 +1,32 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Data.GraphQL.Execute where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative (Applicative)
|
||||
#endif
|
||||
|
||||
import qualified Data.Aeson as Aeson (Value)
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import Data.GraphQL.AST
|
||||
import Data.GraphQL.Schema
|
||||
|
||||
type Response = Aeson.Value
|
||||
|
||||
execute :: Applicative f => Schema f -> Document -> f Response
|
||||
execute _schema _doc = undefined
|
||||
execute :: Schema -> Document -> Maybe Response
|
||||
execute (Schema resolv0) doc = go resolv0 =<< root doc
|
||||
where
|
||||
|
||||
root :: Document -> Maybe Selection
|
||||
root (Document [DefinitionOperation (Query (Node _ _ _ [sel]))]) = Just sel
|
||||
root _ = error "root: Not implemented yet"
|
||||
|
||||
go :: Resolver -> Selection -> Maybe Response
|
||||
go resolv (SelectionField (Field _ n _ _ sfs)) =
|
||||
case resolv (InputField n) of
|
||||
(OutputScalar s) -> if null sfs
|
||||
then Just $ Aeson.Object [(n, Aeson.toJSON s)]
|
||||
else Nothing
|
||||
(OutputResolver resolv') -> (\r-> Aeson.Object [(n, r)]) <$> go resolv' (head sfs)
|
||||
_ -> error "go case resolv: Not implemented yet"
|
||||
go _ _ = error "go: Not implemented yet"
|
||||
|
||||
@ -1,33 +1,48 @@
|
||||
module Data.GraphQL.Schema where
|
||||
|
||||
import Data.Maybe (catMaybes)
|
||||
import Text.Show.Functions ()
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.Aeson (ToJSON(toJSON))
|
||||
|
||||
data Schema f = Schema (QueryRoot f) (Maybe (MutationRoot f))
|
||||
data Schema = Schema QueryRoot -- (Maybe MutationRoot)
|
||||
|
||||
type QueryRoot f = Map f
|
||||
type QueryRoot = Resolver
|
||||
|
||||
type MutationRoot f = Map f
|
||||
type Resolver = Input -> Output
|
||||
|
||||
type Map f = HashMap Text (Resolver f)
|
||||
|
||||
type Resolver f = Input -> Output f
|
||||
|
||||
data Output f = OutputScalar (f Scalar)
|
||||
| OutputMap (Map f)
|
||||
| OutputUnion [Map f]
|
||||
| OutputEnum (f Scalar)
|
||||
| OutputList [Output f]
|
||||
| OutputNonNull (Output f)
|
||||
| InputError
|
||||
data Output = OutputResolver Resolver
|
||||
| OutputList [Output]
|
||||
| OutputScalar Scalar
|
||||
-- | OutputUnion [Output]
|
||||
-- | OutputEnum [Scalar]
|
||||
-- | OutputNonNull (Output)
|
||||
| OutputError
|
||||
deriving (Show)
|
||||
|
||||
data Input = InputScalar Scalar
|
||||
| InputEnum Scalar
|
||||
| InputField Text
|
||||
| InputList [Input]
|
||||
| InputNonNull Input
|
||||
deriving (Show)
|
||||
|
||||
data Scalar = ScalarInt Int
|
||||
| ScalarFloat Double
|
||||
| ScalarString Text
|
||||
| ScalarBool Bool
|
||||
| ScalarID Text
|
||||
field :: Input -> Maybe Text
|
||||
field (InputField x) = Just x
|
||||
field _ = Nothing
|
||||
|
||||
fields :: [Input] -> [Text]
|
||||
fields = catMaybes . fmap field
|
||||
|
||||
data Scalar = ScalarInt Int
|
||||
| ScalarFloat Double
|
||||
| ScalarString Text
|
||||
| ScalarBoolean Bool
|
||||
| ScalarID Text
|
||||
deriving (Show)
|
||||
|
||||
instance ToJSON Scalar where
|
||||
toJSON (ScalarInt x) = toJSON x
|
||||
toJSON (ScalarFloat x) = toJSON x
|
||||
toJSON (ScalarString x) = toJSON x
|
||||
toJSON (ScalarBoolean x) = toJSON x
|
||||
toJSON (ScalarID x) = toJSON x
|
||||
|
||||
@ -27,11 +27,10 @@ library
|
||||
Data.GraphQL.Execute
|
||||
Data.GraphQL.Schema
|
||||
Data.GraphQL.Parser
|
||||
build-depends: base >=4.7 && < 5,
|
||||
text >=0.11.3.1,
|
||||
aeson >=0.7.0.3,
|
||||
attoparsec >=0.10.4.0,
|
||||
unordered-containers >=0.2.5.0
|
||||
build-depends: base >= 4.7 && < 5,
|
||||
text >= 0.11.3.1,
|
||||
aeson >= 0.7.0.3,
|
||||
attoparsec >= 0.10.4.0
|
||||
|
||||
test-suite tasty
|
||||
default-language: Haskell2010
|
||||
@ -41,12 +40,12 @@ test-suite tasty
|
||||
ghc-options: -Wall
|
||||
other-modules: Paths_graphql
|
||||
Test.StarWars
|
||||
build-depends: base >=4.6 && <5,
|
||||
aeson >=0.7.0.3,
|
||||
text >=0.11.3.1,
|
||||
attoparsec >=0.10.4.0,
|
||||
tasty >=0.10,
|
||||
tasty-hunit >=0.9,
|
||||
build-depends: base >= 4.6 && <5,
|
||||
aeson >= 0.7.0.3,
|
||||
text >= 0.11.3.1,
|
||||
attoparsec >= 0.10.4.0,
|
||||
tasty >= 0.10,
|
||||
tasty-hunit >= 0.9,
|
||||
graphql
|
||||
|
||||
source-repository head
|
||||
|
||||
@ -1,13 +1,15 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Test.StarWars where
|
||||
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import Control.Applicative ((<|>), liftA2)
|
||||
import Data.Maybe (catMaybes)
|
||||
-- import Data.Functor.Identity (Identity(..))
|
||||
import Data.Text (Text)
|
||||
|
||||
import Data.Attoparsec.Text (parseOnly)
|
||||
-- import Data.Aeson (ToJSON(toJSON), genericToJSON, defaultOptions)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Attoparsec.Text (parseOnly)
|
||||
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.HUnit
|
||||
@ -17,119 +19,106 @@ import Data.GraphQL.Execute
|
||||
import qualified Data.GraphQL.Parser as Parser
|
||||
import Data.GraphQL.Schema
|
||||
|
||||
|
||||
-- * Test
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
|
||||
|
||||
test :: TestTree
|
||||
test = testCase "R2-D2" $ execute schema heroQuery @=? Identity expected
|
||||
test = testCase "R2-D2" $ execute schema heroQuery @?= expected
|
||||
where
|
||||
heroQuery :: Document
|
||||
heroQuery = either (error "Parsing error") id $ parseOnly Parser.document
|
||||
"{ query HeroNameQuery { hero { name } } }"
|
||||
"query HeroNameQuery{hero{name}}"
|
||||
|
||||
expected :: Response
|
||||
expected = Aeson.Object
|
||||
[ ( "hero" , Aeson.Object [ ("name", "R2-D2") ] ) ]
|
||||
expected :: Maybe Response
|
||||
expected = Just $ Aeson.Object [("hero", Aeson.Object [("name", "R2-D2")])]
|
||||
|
||||
-- * Schema
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
type ID = Text
|
||||
|
||||
schema :: Applicative f => Schema f
|
||||
schema = Schema query Nothing
|
||||
schema :: Schema
|
||||
schema = Schema query
|
||||
|
||||
query :: Applicative f => QueryRoot f
|
||||
query = [ ("hero", hero)
|
||||
, ("human", human)
|
||||
, ("droid", droid)
|
||||
]
|
||||
query :: QueryRoot
|
||||
query (InputField "hero") = OutputResolver hero
|
||||
query (InputField "human") = OutputResolver human
|
||||
query (InputField "droid") = OutputResolver droid
|
||||
query _ = OutputError
|
||||
|
||||
hero :: Applicative f => Resolver f
|
||||
hero (InputScalar (ScalarInt ep)) = OutputMap $ getHeroF ep
|
||||
hero _ = InputError
|
||||
hero :: Resolver
|
||||
hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
|
||||
maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHero ep
|
||||
hero (InputField fld) = characterOutput fld artoo
|
||||
hero _ = OutputError
|
||||
|
||||
human :: Applicative f => Resolver f
|
||||
human (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getHumanF id_
|
||||
human _ = InputError
|
||||
human :: Resolver
|
||||
human (InputList (InputScalar (ScalarID i) : inputFields)) =
|
||||
maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHuman i
|
||||
human _ = OutputError
|
||||
|
||||
droid :: Applicative f => Resolver f
|
||||
droid (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getDroidF id_
|
||||
droid _ = InputError
|
||||
droid :: Resolver
|
||||
droid (InputList (InputScalar (ScalarID i) : inputFields)) =
|
||||
maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getDroid i
|
||||
droid _ = OutputError
|
||||
|
||||
characterOutput :: Text -> Character -> Output
|
||||
characterOutput "id" char = OutputScalar . ScalarString $ id_ char
|
||||
characterOutput "name" char = OutputScalar . ScalarString $ name char
|
||||
characterOutput "friends" char = OutputList $ OutputResolver . (\c (InputField f) -> characterOutput f c) <$> getFriends char
|
||||
characterOutput _ _ = OutputError
|
||||
|
||||
-- * Data
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
|
||||
|
||||
-- ** Characters
|
||||
|
||||
data Character = Character
|
||||
{ id_ :: ID
|
||||
, name :: Text
|
||||
, friends :: [ID]
|
||||
, appearsIn :: [Int]
|
||||
{ id_ :: ID
|
||||
, name :: Text
|
||||
, friends :: [ID]
|
||||
, appearsIn :: [Int]
|
||||
, homePlanet :: Text
|
||||
}
|
||||
} deriving (Show)
|
||||
|
||||
luke :: Character
|
||||
luke = Character
|
||||
{ id_ = "1000"
|
||||
, name = "Luke Skywalker"
|
||||
, friends = ["1002","1003","2000","2001"]
|
||||
, appearsIn = [4,5,6]
|
||||
{ id_ = "1000"
|
||||
, name = "Luke Skywalker"
|
||||
, friends = ["1002","1003","2000","2001"]
|
||||
, appearsIn = [4,5,6]
|
||||
, homePlanet = "Tatoonie"
|
||||
}
|
||||
|
||||
artoo :: Character
|
||||
artoo = Character
|
||||
{ id_ = "2001"
|
||||
, name = "R2-D2"
|
||||
, friends = ["1000","1002","1003"]
|
||||
, appearsIn = [4,5,6]
|
||||
{ id_ = "2001"
|
||||
, name = "R2-D2"
|
||||
, friends = ["1000","1002","1003"]
|
||||
, appearsIn = [4,5,6]
|
||||
, homePlanet = "Astrometch"
|
||||
}
|
||||
|
||||
type CharacterMap f = Map f
|
||||
-- ** Helper functions
|
||||
|
||||
character :: Applicative f => Character -> CharacterMap f
|
||||
character (Character{..}) =
|
||||
[ ("id_", const . OutputScalar . pure $ ScalarID id_)
|
||||
, ("name", const . OutputScalar . pure $ ScalarString name)
|
||||
, ("friends", const . OutputList $ OutputScalar . pure . ScalarID <$> friends)
|
||||
, ("appearsIn", const . OutputList $ OutputScalar . pure . ScalarInt <$> appearsIn)
|
||||
, ("homePlanet", const . OutputScalar . pure $ ScalarString homePlanet)
|
||||
]
|
||||
getHero :: Int -> Maybe Character
|
||||
getHero 5 = Just luke
|
||||
getHero _ = Just artoo
|
||||
|
||||
-- ** Hero
|
||||
getHuman :: ID -> Maybe Character
|
||||
getHuman "1000" = Just luke
|
||||
-- getHuman "1001" = "vader"
|
||||
-- getHuman "1002" = "han"
|
||||
-- getHuman "1003" = "leia"
|
||||
-- getHuman "1004" = "tarkin"
|
||||
getHuman _ = Nothing
|
||||
|
||||
getHero :: Int -> Character
|
||||
getHero 5 = luke
|
||||
getHero _ = artoo
|
||||
getDroid :: ID -> Maybe Character
|
||||
-- getDroid "2000" = "threepio"
|
||||
getDroid "2001" = Just artoo
|
||||
getDroid _ = Nothing
|
||||
|
||||
getHeroF :: Applicative f => Int -> CharacterMap f
|
||||
getHeroF = character . getHero
|
||||
|
||||
-- ** Human
|
||||
|
||||
getHuman :: ID -> Text
|
||||
getHuman "1000" = "luke"
|
||||
getHuman "1001" = "vader"
|
||||
getHuman "1002" = "han"
|
||||
getHuman "1003" = "leia"
|
||||
getHuman "1004" = "tarkin"
|
||||
getHuman _ = ""
|
||||
|
||||
getHumanF :: Applicative f => ID -> f Text
|
||||
getHumanF = pure . getHuman
|
||||
|
||||
getHumanIO :: ID -> IO Text
|
||||
getHumanIO = getHumanF
|
||||
|
||||
-- ** Droid
|
||||
|
||||
getDroid :: ID -> Text
|
||||
getDroid "2000" = "threepio"
|
||||
getDroid "2001" = "artoo"
|
||||
getDroid _ = ""
|
||||
|
||||
getDroidF :: Applicative f => ID -> f Text
|
||||
getDroidF = pure . getDroid
|
||||
|
||||
getDroidIO :: ID -> IO Text
|
||||
getDroidIO = getDroidF
|
||||
getFriends :: Character -> [Character]
|
||||
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
|
||||
|
||||
Loading…
Reference in New Issue
Block a user