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 CPP #-}
{-# LANGUAGE OverloadedLists #-}
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) import Control.Applicative (Applicative)
#endif #endif
import qualified Data.Aeson as Aeson (Value) import qualified Data.Aeson as Aeson
import Data.GraphQL.AST import Data.GraphQL.AST
import Data.GraphQL.Schema import Data.GraphQL.Schema
type Response = Aeson.Value type Response = Aeson.Value
execute :: Applicative f => Schema f -> Document -> f Response execute :: Schema -> Document -> Maybe Response
execute _schema _doc = undefined 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 module Data.GraphQL.Schema where
import Data.Maybe (catMaybes)
import Text.Show.Functions ()
import Data.Text (Text) 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) data Output = OutputResolver Resolver
| OutputList [Output]
type Resolver f = Input -> Output f | OutputScalar Scalar
-- | OutputUnion [Output]
data Output f = OutputScalar (f Scalar) -- | OutputEnum [Scalar]
| OutputMap (Map f) -- | OutputNonNull (Output)
| OutputUnion [Map f] | OutputError
| OutputEnum (f Scalar) deriving (Show)
| OutputList [Output f]
| OutputNonNull (Output f)
| InputError
data Input = InputScalar Scalar data Input = InputScalar Scalar
| InputEnum Scalar | InputField Text
| InputList [Input] | 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 data Scalar = ScalarInt Int
| ScalarFloat Double | ScalarFloat Double
| ScalarString Text | ScalarString Text
| ScalarBool Bool | ScalarBoolean Bool
| ScalarID Text | 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.Execute
Data.GraphQL.Schema Data.GraphQL.Schema
Data.GraphQL.Parser Data.GraphQL.Parser
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
@ -41,12 +40,12 @@ test-suite tasty
ghc-options: -Wall ghc-options: -Wall
other-modules: Paths_graphql other-modules: Paths_graphql
Test.StarWars Test.StarWars
build-depends: base >=4.6 && <5, build-depends: base >= 4.6 && <5,
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,
tasty >=0.10, tasty >= 0.10,
tasty-hunit >=0.9, tasty-hunit >= 0.9,
graphql graphql
source-repository head source-repository head

125
tests/Test/StarWars.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
module Test.StarWars where 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.Text (Text)
import Data.Attoparsec.Text (parseOnly) -- import Data.Aeson (ToJSON(toJSON), genericToJSON, defaultOptions)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.Attoparsec.Text (parseOnly)
import Test.Tasty (TestTree) import Test.Tasty (TestTree)
import Test.Tasty.HUnit import Test.Tasty.HUnit
@ -17,45 +19,58 @@ import Data.GraphQL.Execute
import qualified Data.GraphQL.Parser as Parser import qualified Data.GraphQL.Parser as Parser
import Data.GraphQL.Schema import Data.GraphQL.Schema
-- * Test -- * Test
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
test :: TestTree test :: TestTree
test = testCase "R2-D2" $ execute schema heroQuery @=? Identity expected test = testCase "R2-D2" $ execute schema heroQuery @?= expected
where where
heroQuery :: Document heroQuery :: Document
heroQuery = either (error "Parsing error") id $ parseOnly Parser.document heroQuery = either (error "Parsing error") id $ parseOnly Parser.document
"{ query HeroNameQuery { hero { name } } }" "query HeroNameQuery{hero{name}}"
expected :: Response expected :: Maybe Response
expected = Aeson.Object expected = Just $ Aeson.Object [("hero", Aeson.Object [("name", "R2-D2")])]
[ ( "hero" , Aeson.Object [ ("name", "R2-D2") ] ) ]
-- * Schema -- * Schema
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
type ID = Text type ID = Text
schema :: Applicative f => Schema f schema :: Schema
schema = Schema query Nothing schema = Schema query
query :: Applicative f => QueryRoot f query :: QueryRoot
query = [ ("hero", hero) query (InputField "hero") = OutputResolver hero
, ("human", human) query (InputField "human") = OutputResolver human
, ("droid", droid) query (InputField "droid") = OutputResolver droid
] query _ = OutputError
hero :: Applicative f => Resolver f hero :: Resolver
hero (InputScalar (ScalarInt ep)) = OutputMap $ getHeroF ep hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
hero _ = InputError maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHero ep
hero (InputField fld) = characterOutput fld artoo
hero _ = OutputError
human :: Applicative f => Resolver f human :: Resolver
human (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getHumanF id_ human (InputList (InputScalar (ScalarID i) : inputFields)) =
human _ = InputError maybe OutputError (\char -> OutputList $ (`characterOutput` char) <$> fields inputFields) $ getHuman i
human _ = OutputError
droid :: Applicative f => Resolver f droid :: Resolver
droid (InputScalar (ScalarString id_)) = OutputScalar $ ScalarString <$> getDroidF id_ droid (InputList (InputScalar (ScalarID i) : inputFields)) =
droid _ = InputError 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 -- * Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
-- ** Characters -- ** Characters
@ -65,7 +80,7 @@ data Character = Character
, friends :: [ID] , friends :: [ID]
, appearsIn :: [Int] , appearsIn :: [Int]
, homePlanet :: Text , homePlanet :: Text
} } deriving (Show)
luke :: Character luke :: Character
luke = Character luke = Character
@ -85,51 +100,25 @@ artoo = Character
, homePlanet = "Astrometch" , homePlanet = "Astrometch"
} }
type CharacterMap f = Map f -- ** Helper functions
character :: Applicative f => Character -> CharacterMap f getHero :: Int -> Maybe Character
character (Character{..}) = getHero 5 = Just luke
[ ("id_", const . OutputScalar . pure $ ScalarID id_) getHero _ = Just artoo
, ("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)
]
-- ** 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 getDroid :: ID -> Maybe Character
getHero 5 = luke -- getDroid "2000" = "threepio"
getHero _ = artoo getDroid "2001" = Just artoo
getDroid _ = Nothing
getHeroF :: Applicative f => Int -> CharacterMap f
getHeroF = character . getHero
-- ** Human getFriends :: Character -> [Character]
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
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