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

Rough implementation of execute

Browse Source 
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 2016-01-26 12:43:18 +01:00
parent 4e5dc3433a
commit bb685c9afa
4 changed files with 135 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
Data/GraphQL/Execute.hs
View File

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

51
Data/GraphQL/Schema.hs
View File

@ -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)
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
| ScalarBool Bool
| 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

21
graphql.cabal
View File

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

125
tests/Test/StarWars.hs
View File

@ -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,45 +19,58 @@ 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
@ -65,7 +80,7 @@ data Character = Character
, friends :: [ID]
, appearsIn :: [Int]
, homePlanet :: Text
}
} deriving (Show)
luke :: Character
luke = Character
@ -85,51 +100,25 @@ artoo = Character
, 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