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
parent
70fbaf359e
commit
a088c81944
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,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
|
||||
@ -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]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user