From bb685c9afa740091864220616ecd84d9329bee98 Mon Sep 17 00:00:00 2001 From: Danny Navarro Date: Tue, 26 Jan 2016 12:43:18 +0100 Subject: [PATCH] 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. --- Data/GraphQL/Execute.hs | 22 +++++- Data/GraphQL/Schema.hs | 59 ++++++++++------ graphql.cabal | 21 +++--- tests/Test/StarWars.hs | 149 +++++++++++++++++++--------------------- 4 files changed, 135 insertions(+), 116 deletions(-) diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 06dc9a6..40eb122 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -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" diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 37938ee..08ddaa1 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -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 diff --git a/graphql.cabal b/graphql.cabal index e32b593..267f3eb 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -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 diff --git a/tests/Test/StarWars.hs b/tests/Test/StarWars.hs index ffafd66..b75e6b6 100644 --- a/tests/Test/StarWars.hs +++ b/tests/Test/StarWars.hs @@ -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