Handle Field arguments in Schema definition

The `Schema` has been overhauled to make `Output` monomorphic.
Traversing the `GraphQL` document is handled implicitly while defining
the `Schema`.

The 4th end-to-end test from `graphql-js` has been ported.
This commit is contained in:
Danny Navarro 2016-02-11 14:24:31 +01:00
parent 70fbaf359e
commit a088c81944
4 changed files with 120 additions and 88 deletions

View File

@ -3,7 +3,7 @@
module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>), pure)
import Control.Applicative ((<$>), pure)
import Data.Traversable (traverse)
#endif
import Control.Applicative (Alternative, empty)
@ -13,32 +13,35 @@ import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.GraphQL.AST
import Data.GraphQL.Schema
import Data.GraphQL.Schema (Resolver, Schema(..))
import qualified Data.GraphQL.Schema as Schema
execute :: (Alternative f, Monad f) => Schema f -> Document -> f Aeson.Value
execute :: (Alternative m, Monad m) => Schema m -> Document -> m Aeson.Value
execute (Schema resolv) doc = selectionSet resolv =<< query doc
query :: Applicative f => Document -> f SelectionSet
query :: Alternative f => Document -> f SelectionSet
query (Document [DefinitionOperation (Query (Node _ _ _ sels))]) = pure sels
query _ = error "query: Not implemented yet"
query _ = empty
selectionSet :: (Alternative f, Monad f) => Resolver f -> SelectionSet -> f Aeson.Value
selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels
selectionSet :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value
selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv)
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"
selection :: Alternative f => Resolver f -> Selection -> f Aeson.Object
selection resolv (SelectionField field@(Field _ name _ _ _)) =
fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field)
selection _ _ = empty
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 (OutputEnum e)
| null sels = Aeson.toJSON <$> e
| otherwise = empty
output sels (OutputScalar s)
| null sels = Aeson.toJSON <$> s
| otherwise = empty
-- * AST/Schema conversions
array :: [Aeson.Value] -> Aeson.Value
array = Aeson.toJSON
argument :: Argument -> Schema.Argument
argument (Argument n (ValueInt v)) = (n, Schema.ScalarInt $ fromIntegral v)
argument (Argument n (ValueString (StringValue v))) = (n, Schema.ScalarString v)
argument _ = error "argument: not implemented yet"
fieldToInput :: Field -> Schema.Input
fieldToInput (Field _ n as _ sels) =
Schema.InputField n (argument <$> as) (fieldToInput . selectionToField <$> sels)
selectionToField :: Selection -> Field
selectionToField (SelectionField x) = x
selectionToField _ = error "selectionField: not implemented yet"

View File

@ -1,35 +1,34 @@
{-# LANGUAGE CPP #-}
module Data.GraphQL.Schema where
import Data.Maybe (catMaybes)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Text (Text)
import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot)
type QueryRoot f = Resolver f
type Resolver f = Input -> f (Output f)
type Resolver f = Input -> f Output
data Output f = OutputResolver (Resolver f)
| OutputList (f [Output f])
| OutputScalar (f Scalar)
| OutputEnum (f Text)
data Output = OutputObject (HashMap Text Output)
| OutputList [Output]
| OutputScalar Scalar
| OutputEnum Text
deriving (Show)
-- | OutputUnion [Output]
-- | OutputNonNull (Output)
data Input = InputScalar Scalar
| InputField Text
| InputList [Input]
type Argument = (Text, Scalar)
data Input = InputField Text [Argument] [Input]
deriving (Show)
field :: Input -> Maybe Text
field (InputField x) = Just x
field _ = Nothing
fields :: [Input] -> [Text]
fields = catMaybes . fmap field
-- TODO: Make ScalarInt Int32
data Scalar = ScalarInt Int
| ScalarFloat Double
| ScalarString Text
@ -43,3 +42,10 @@ instance ToJSON Scalar where
toJSON (ScalarString x) = toJSON x
toJSON (ScalarBoolean x) = toJSON x
toJSON (ScalarID x) = toJSON x
instance ToJSON Output where
toJSON (OutputObject x) = toJSON $ toJSON <$> x
toJSON (OutputList x) = toJSON $ toJSON <$> x
toJSON (OutputScalar x) = toJSON x
toJSON (OutputEnum x) = toJSON x

View File

@ -49,6 +49,7 @@ test-suite tasty
raw-strings-qq >= 1.1,
tasty >= 0.10,
tasty-hunit >= 0.9,
unordered-containers >= 0.2.5.0,
graphql
source-repository head

View File

@ -4,14 +4,17 @@
module Test.StarWars where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>), pure)
import Control.Applicative ((<$>), pure)
import Data.Monoid (mempty)
import Data.Traversable (traverse)
#endif
import Control.Applicative (Alternative, (<|>), empty, liftA2)
import Data.Foldable (fold)
import Data.Maybe (catMaybes)
import Data.Aeson (object, (.=))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Text.RawString.QQ (r)
@ -111,6 +114,17 @@ test = testGroup "Star Wars Query Tests"
]
]
]
, testCase "Luke ID" $ (@?=) (graphql schema [r|
query FetchLukeQuery {
human(id: "1000") {
name
}
}|]) . Just
$ object [
"human" .= object [
"name" .= ("Luke Skywalker" :: Text)
]
]
]
]
@ -119,52 +133,53 @@ test = testGroup "Star Wars Query Tests"
type ID = Text
schema :: Alternative f => Schema f
schema :: (Alternative m, Monad m) => Schema m
schema = Schema query
query :: Alternative f => QueryRoot f
query (InputField "hero") = pure $ OutputResolver hero
query (InputField "human") = pure $ OutputResolver human
query (InputField "droid") = pure $ OutputResolver droid
query :: (Alternative m, Monad m) => QueryRoot m
query (InputField "hero" args ins) = hero args ins
query (InputField "human" args ins) = human args ins
query (InputField "droid" args ins) = droid args ins
query _ = empty
hero :: Alternative f => Resolver f
hero (InputList (InputScalar (ScalarInt ep) : inputFields)) =
withFields inputFields <$> getHero ep
hero (InputField fld) = characterOutput fld $ Left artoo
hero _ = empty
hero :: Alternative f => [Argument] -> [Input] -> f Output
hero [] = characterFields artoo
hero [("episode", ScalarInt n)] = characterFields $ getHero n
hero _ = const empty
human :: Alternative f => Resolver f
human (InputList (InputScalar (ScalarID i) : inputFields)) =
withFields inputFields <$> getHuman i
human _ = empty
human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i
human _ _ = empty
droid :: Alternative f => Resolver f
droid (InputList (InputScalar (ScalarID i) : inputFields)) =
withFields inputFields <$> getDroid i
droid _ = empty
droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output
droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i
droid _ _ = empty
episode :: Alternative f => Int -> Output f
episode 4 = OutputEnum $ pure "NEWHOPE"
episode 5 = OutputEnum $ pure "EMPIRE"
episode 6 = OutputEnum $ pure "JEDI"
episode _ = OutputEnum empty
episode :: Alternative f => Int -> f Output
episode 4 = pure $ OutputEnum "NEWHOPE"
episode 5 = pure $ OutputEnum "EMPIRE"
episode 6 = pure $ OutputEnum "JEDI"
episode _ = empty
characterOutput :: Alternative f => Text -> Character -> f (Output f)
characterOutput "id" char =
pure $ OutputScalar . pure . ScalarString $ id_ char
characterOutput "name" char =
pure $ OutputScalar . pure . ScalarString $ name char
characterOutput "friends" char =
pure . OutputList . pure $ OutputResolver . (\c (InputField f) ->
characterOutput f c) <$> getFriends char
characterOutput "appearsIn" char =
pure $ OutputList . pure . fmap episode $ appearsIn char
characterOutput _ _ = empty
characterField :: Alternative f => Character -> Input -> f (HashMap Text Output)
characterField char (InputField "id" [] []) =
pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char
characterField char (InputField "name" [] []) =
pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char
characterField char (InputField "friends" [] ins) =
fmap (HashMap.singleton "friends" . OutputList)
. traverse (`characterFields` ins)
. getFriends
$ char
characterField char (InputField "appearsIn" [] []) =
fmap (HashMap.singleton "appearsIn" . OutputList)
. traverse episode
. appearsIn
$ char
characterField _ _ = empty
withFields :: Alternative f => [Input] -> Character -> Output f
withFields inputFields char =
OutputList . traverse (`characterOutput` char) $ fields inputFields
characterFields :: Alternative f => Character -> [Input] -> f Output
characterFields char = fmap (OutputObject . fold) . traverse (characterField char)
-- * Data
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@ -209,8 +224,11 @@ appearsIn :: Character -> [Int]
appearsIn (Left x) = _appearsIn . _droidChar $ x
appearsIn (Right x) = _appearsIn . _humanChar $ x
luke :: Human
luke = Human
luke :: Character
luke = Right luke'
luke' :: Human
luke' = Human
{ _humanChar = CharCommon
{ _id_ = "1000"
, _name = "Luke Skywalker"
@ -275,8 +293,12 @@ threepio = Droid
, primaryFunction = "Protocol"
}
artoo :: Droid
artoo = Droid
artoo :: Character
artoo = Left artoo'
artoo' :: Droid
artoo' = Droid
{ _droidChar = CharCommon
{ _id_ = "2001"
, _name = "R2-D2"
@ -288,19 +310,19 @@ artoo = Droid
-- ** Helper functions
getHero :: Applicative f => Int -> f Character
getHero 5 = pure $ Right luke
getHero _ = pure $ Left artoo
getHero :: Int -> Character
getHero 5 = luke
getHero _ = artoo
getHeroIO :: Int -> IO Character
getHeroIO = getHero
getHeroIO = pure . getHero
getHuman :: Alternative f => ID -> f Character
getHuman = fmap Right . getHuman'
getHuman' :: Alternative f => ID -> f Human
getHuman' "1000" = pure luke
getHuman' "1000" = pure luke'
getHuman' "1001" = pure vader
getHuman' "1002" = pure han
getHuman' "1003" = pure leia
@ -312,7 +334,7 @@ getDroid = fmap Left . getDroid'
getDroid' :: Alternative f => ID -> f Droid
getDroid' "2000" = pure threepio
getDroid' "2001" = pure artoo
getDroid' "2001" = pure artoo'
getDroid' _ = empty
getFriends :: Character -> [Character]