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

Handle Field arguments in Schema definition

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
Data/GraphQL/Execute.hs
View File

@ -3,7 +3,7 @@
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, (<$>), pure) import Control.Applicative ((<$>), pure)
import Data.Traversable (traverse) import Data.Traversable (traverse)
#endif #endif
import Control.Applicative (Alternative, empty) import Control.Applicative (Alternative, empty)
@ -13,32 +13,35 @@ import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.GraphQL.AST 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 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 (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 :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value
selectionSet resolv sels = Aeson.Object . fold <$> traverse (selection resolv) sels selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv)
selection :: (Alternative f, Monad f) => Resolver f -> Selection -> f Aeson.Object selection :: Alternative f => Resolver f -> Selection -> f Aeson.Object
selection resolv (SelectionField (Field _ n _ _ sfs)) = selection resolv (SelectionField field@(Field _ name _ _ _)) =
fmap (HashMap.singleton n) $ output sfs =<< resolv (InputField n) fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field)
selection _ _ = error "selection: Not implemented yet" selection _ _ = empty
output :: (Alternative f, Monad f) => SelectionSet -> Output f -> f Aeson.Value -- * AST/Schema conversions
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
array :: [Aeson.Value] -> Aeson.Value argument :: Argument -> Schema.Argument
array = Aeson.toJSON 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"

40
Data/GraphQL/Schema.hs
View File

@ -1,35 +1,34 @@
{-# LANGUAGE CPP #-}
module Data.GraphQL.Schema where 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.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot) data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot)
type QueryRoot f = Resolver f type QueryRoot f = Resolver f
type Resolver f = Input -> f (Output f) type Resolver f = Input -> f Output
data Output f = OutputResolver (Resolver f) data Output = OutputObject (HashMap Text Output)
| OutputList (f [Output f]) | OutputList [Output]
| OutputScalar (f Scalar) | OutputScalar Scalar
| OutputEnum (f Text) | OutputEnum Text
deriving (Show)
-- | OutputUnion [Output] -- | OutputUnion [Output]
-- | OutputNonNull (Output) -- | OutputNonNull (Output)
data Input = InputScalar Scalar type Argument = (Text, Scalar)
| InputField Text
| InputList [Input] data Input = InputField Text [Argument] [Input]
deriving (Show) deriving (Show)
field :: Input -> Maybe Text -- TODO: Make ScalarInt Int32
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
@ -43,3 +42,10 @@ instance ToJSON Scalar where
toJSON (ScalarString x) = toJSON x toJSON (ScalarString x) = toJSON x
toJSON (ScalarBoolean x) = toJSON x toJSON (ScalarBoolean x) = toJSON x
toJSON (ScalarID 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

1
graphql.cabal
View File

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

120
tests/Test/StarWars.hs
View File

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