Overhaul Schema DSL

Aside of making the definition of Schemas easier, it takes care of
issues like nested aliases which previously wasn't possible. The naming
of the DSL functions is still provisional.
This commit is contained in:
Danny Navarro 2016-02-17 18:13:10 +01:00
parent a6b2fd297b
commit 8ee50727bd
5 changed files with 183 additions and 133 deletions

View File

@ -2,64 +2,41 @@
module Data.GraphQL.Execute (execute) where module Data.GraphQL.Execute (execute) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), pure) import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif #endif
import Control.Applicative (Alternative, empty) import Control.Applicative (Alternative)
import Data.Foldable (fold)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Text as T
import Data.GraphQL.AST import Data.GraphQL.AST
import Data.GraphQL.Schema (Resolver, Schema(..)) import Data.GraphQL.Schema (Schema(..))
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
execute execute
:: (Alternative m, Monad m) :: Alternative m
=> Schema m -> Schema.Subs -> Document -> m Aeson.Value => Schema m -> Schema.Subs -> Document -> m Aeson.Value
execute (Schema resolv) f doc = selectionSet f resolv =<< query doc execute (Schema resolvm) subs =
fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs
query :: Alternative f => Document -> f SelectionSet rootFields :: Schema.Subs -> Document -> [Field]
query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
query _ = empty Schema.fields $ substitute subs <$> sels
rootFields _ _ = []
selectionSet substitute :: Schema.Subs -> Selection -> Selection
:: Alternative f substitute subs (SelectionField (Field alias name args directives sels)) =
=> Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value SelectionField $ Field
selectionSet f resolv = fmap (Aeson.Object . fold) alias
. traverse (selection f resolv) name
selection
:: Alternative f
=> Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
selection f resolv (SelectionField field@(Field alias name _ _ _)) =
fmap (HashMap.singleton aliasOrName)
$ Aeson.toJSON
<$> resolv (fieldToInput f field)
where
aliasOrName = if T.null alias then name else alias
selection _ _ _ = empty
-- * AST/Schema conversions
argument :: Schema.Subs -> Argument -> Maybe Schema.Argument
argument f (Argument n (ValueVariable (Variable v))) =
maybe Nothing (\v' -> Just (n, v')) $ f v
argument _ (Argument n (ValueInt v)) =
Just (n, Schema.ScalarInt $ fromIntegral v)
argument _ (Argument n (ValueString (StringValue v))) =
Just (n, Schema.ScalarString v)
argument _ _ = error "argument: not implemented yet"
fieldToInput :: Schema.Subs -> Field -> Schema.Input
fieldToInput f (Field _ n as _ sels) =
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
Schema.InputField n (catMaybes $ argument f <$> as) (catMaybes $ subsArg subs <$> args)
(fieldToInput f . selectionToField <$> sels) directives
(substitute subs <$> sels)
substitute _ sel = sel
selectionToField :: Selection -> Field -- TODO: Support different value types
selectionToField (SelectionField x) = x subsArg :: Schema.Subs -> Argument -> Maybe Argument
selectionToField _ = error "selectionField: not implemented yet" subsArg subs (Argument n (ValueVariable (Variable v))) =
Argument n . ValueString . StringValue <$> subs v
subsArg _ arg = Just arg

View File

@ -1,20 +1,46 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Data.GraphQL.Schema where module Data.GraphQL.Schema
( Schema(..)
, QueryRoot
, ResolverO
, ResolverM
, Output(..)
, Subs
, Scalar(..)
, withField
, withFieldFinal
, withFields
, withArgument
, outputTraverse
, fields
-- * Reexports
, Field
, Argument
) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Data.Traversable (traverse)
#endif #endif
import Control.Applicative
import Data.Maybe (catMaybes)
import Data.Foldable (fold)
import Data.String (IsString(fromString)) import Data.String (IsString(fromString))
import Data.Aeson (ToJSON(toJSON)) import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, pack) import Data.Text (Text, pack)
import qualified Data.Text as T (null)
import Data.GraphQL.AST
data Schema f = Schema (QueryRoot f) data Schema f = Schema (QueryRoot f)
type QueryRoot f = Resolver f type QueryRoot f = ResolverM f
type Resolver f = Input -> f Output -- TODO: Come up with a unique data type or better renaming
type ResolverM f = Field -> f (HashMap Text Output)
type ResolverO f = [Field] -> f Output
data Output = OutputObject (HashMap Text Output) data Output = OutputObject (HashMap Text Output)
| OutputList [Output] | OutputList [Output]
@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output)
| OutputEnum Text | OutputEnum Text
deriving (Show) deriving (Show)
type Argument = (Text, Scalar) type Subs = Text -> Maybe Text
type Subs = Text -> Maybe Scalar
data Input = InputField Text [Argument] [Input]
deriving (Show)
-- TODO: GraphQL spec for Integer Scalar is 32bits -- TODO: GraphQL spec for Integer Scalar is 32bits
data Scalar = ScalarInt Int data Scalar = ScalarInt Int
@ -53,3 +74,38 @@ instance ToJSON Output where
toJSON (OutputScalar x) = toJSON x toJSON (OutputScalar x) = toJSON x
toJSON (OutputEnum x) = toJSON x toJSON (OutputEnum x) = toJSON x
-- * Helpers
withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f
withField n f (Field alias name' args _ sels) =
if n == name'
then HashMap.singleton aliasOrName <$> f args (fields sels)
else empty
where
aliasOrName = if T.null alias then name' else alias
withFieldFinal :: Alternative f => Text -> Output -> ResolverM f
withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld
withFieldFinal _ _ _ = empty
withFields :: Alternative f => ResolverM f -> ResolverO f
withFields f = fmap (OutputObject . fold) . traverse f
outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output
outputTraverse f = fmap OutputList . traverse f
withArgument :: Text -> [Argument] -> Maybe Scalar
withArgument x [Argument n s] = if x == n then scalarValue s else Nothing
withArgument _ _ = Nothing
scalarValue :: Value -> Maybe Scalar
scalarValue (ValueInt x) = Just . ScalarInt $ fromIntegral x
scalarValue (ValueString (StringValue x)) = Just $ ScalarString x
scalarValue _ = Nothing
fields :: SelectionSet -> [Field]
fields = catMaybes . fmap field
field :: Selection -> Maybe Field
field (SelectionField x) = Just x
field _ = Nothing

View File

@ -38,7 +38,7 @@ data Droid = Droid
type Character = Either Droid Human type Character = Either Droid Human
-- I don't think this is cumbersome enough to make it worth using lens. -- I still don't think this is cumbersome enough to bring lens
id_ :: Character -> ID id_ :: Character -> ID
id_ (Left x) = _id_ . _droidChar $ x id_ (Left x) = _id_ . _droidChar $ x
@ -128,7 +128,6 @@ threepio = Droid
artoo :: Character artoo :: Character
artoo = Left artoo' artoo = Left artoo'
artoo' :: Droid artoo' :: Droid
artoo' = Droid artoo' = Droid
{ _droidChar = CharCommon { _droidChar = CharCommon
@ -149,7 +148,6 @@ getHero _ = artoo
getHeroIO :: Int -> IO Character getHeroIO :: Int -> IO Character
getHeroIO = pure . getHero getHeroIO = pure . getHero
getHuman :: Alternative f => ID -> f Character getHuman :: Alternative f => ID -> f Character
getHuman = fmap Right . getHuman' getHuman = fmap Right . getHuman'
@ -171,3 +169,9 @@ getDroid' _ = empty
getFriends :: Character -> [Character] getFriends :: Character -> [Character]
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
getEpisode :: Alternative f => Int -> f Text
getEpisode 4 = pure "NEWHOPE"
getEpisode 5 = pure "EMPIRE"
getEpisode 6 = pure "JEDI"
getEpisode _ = empty

View File

@ -18,12 +18,6 @@ import Test.StarWars.Schema
-- * Test -- * Test
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
testQuery :: Text -> Aeson.Value -> Assertion
testQuery q expected = graphql schema q @?= Just expected
testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
test :: TestTree test :: TestTree
test = testGroup "Star Wars Query Tests" test = testGroup "Star Wars Query Tests"
[ testGroup "Basic Queries" [ testGroup "Basic Queries"
@ -148,24 +142,23 @@ test = testGroup "Star Wars Query Tests"
$ object [ $ object [
"human" .= object ["name" .= ("Han Solo" :: Text)] "human" .= object ["name" .= ("Han Solo" :: Text)]
] ]
, testCase "Invalid ID" $ testFailParams
(\v -> if v == "id"
then Just "Not a valid ID"
else Nothing)
[r| query humanQuery($id: String!) {
human(id: $id) {
name
}
}
|]
-- TODO: This test is directly ported from `graphql-js`, however do we want -- TODO: This test is directly ported from `graphql-js`, however do we want
-- to mimic the same behavior? Is this part of the spec? Once proper -- to mimic the same behavior? Is this part of the spec? Once proper
-- exceptions are implemented this test might no longer be meaningful. -- exceptions are implemented this test might no longer be meaningful.
-- If the same behavior needs to be replicated, should it be implemented -- If the same behavior needs to be replicated, should it be implemented
-- when defining the `Schema` or when executing? -- when defining the `Schema` or when executing?
--
-- , testCase "Invalid ID" . testQueryParams
-- (\v -> if v == "id"
-- then Just "Not a valid ID"
-- else Nothing)
-- [r| query humanQuery($id: String!) {
-- human(id: $id) {
-- name
-- }
-- }
-- |]
-- $ object ["human" .= Aeson.Null] -- $ object ["human" .= Aeson.Null]
, testCase "Luke with alias" . testQuery , testCase "Luke aliased" . testQuery
[r| query FetchLukeAliased { [r| query FetchLukeAliased {
luke: human(id: "1000") { luke: human(id: "1000") {
name name
@ -177,6 +170,28 @@ test = testGroup "Star Wars Query Tests"
"name" .= ("Luke Skywalker" :: Text) "name" .= ("Luke Skywalker" :: Text)
] ]
] ]
, testCase "R2-D2 ID and friends aliased" . testQuery
[r| query HeroNameAndFriendsQuery {
hero {
id
name
friends {
friendName: name
}
}
}
|]
$ object [
"hero" .= object [
"id" .= ("2001" :: Text)
, "name" .= ("R2-D2" :: Text)
, "friends" .= [
object ["friendName" .= ("Luke Skywalker" :: Text)]
, object ["friendName" .= ("Han Solo" :: Text)]
, object ["friendName" .= ("Leia Organa" :: Text)]
]
]
]
, testCase "Luke and Leia aliased" . testQuery , testCase "Luke and Leia aliased" . testQuery
[r| query FetchLukeAndLeiaAliased { [r| query FetchLukeAndLeiaAliased {
luke: human(id: "1000") { luke: human(id: "1000") {
@ -196,3 +211,15 @@ test = testGroup "Star Wars Query Tests"
] ]
] ]
] ]
testQuery :: Text -> Aeson.Value -> Assertion
testQuery q expected = graphql schema q @?= Just expected
-- testFail :: Text -> Assertion
-- testFail q = graphql schema q @?= Nothing
testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
testFailParams :: Subs -> Text -> Assertion
testFailParams f q = graphqlSubs schema f q @?= Nothing

View File

@ -1,17 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where module Test.StarWars.Schema where
#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<|>), Alternative, empty)
import Control.Applicative (pure)
import Data.Traversable (traverse)
#endif
import Control.Applicative (Alternative, empty)
import Data.Foldable (fold)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import Data.GraphQL.Schema import Data.GraphQL.Schema
@ -23,47 +13,43 @@ import Test.StarWars.Data
schema :: (Alternative m, Monad m) => Schema m schema :: (Alternative m, Monad m) => Schema m
schema = Schema query schema = Schema query
query :: (Alternative m, Monad m) => QueryRoot m query :: (Alternative m, Monad m) => ResolverM m
query (InputField "hero" args ins) = hero args ins query fld =
query (InputField "human" args ins) = human args ins withField "hero" hero fld
query (InputField "droid" args ins) = droid args ins <|> withField "human" human fld
query _ = empty <|> withField "droid" droid fld
hero :: Alternative f => [Argument] -> [Input] -> f Output hero :: Alternative f => [Argument] -> ResolverO f
hero [] = characterFields artoo hero [] = characterFields artoo
hero [("episode", ScalarInt n)] = characterFields $ getHero n hero args =
hero _ = const empty case withArgument "episode" args of
Just (ScalarInt n) -> characterFields $ getHero n
_ -> const empty
human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output human :: (Alternative m, Monad m) => [Argument] -> ResolverO m
human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i human args flds =
human _ _ = empty case withArgument "id" args of
Just (ScalarString i) -> flip characterFields flds =<< getHuman i
_ -> empty
droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m
droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i droid args flds =
droid _ _ = empty case withArgument "id" args of
Just (ScalarString i) -> flip characterFields flds =<< getDroid i
_ -> empty
episode :: Alternative f => Int -> f Output characterField :: Alternative f => Character -> ResolverM f
episode 4 = pure $ OutputEnum "NEWHOPE" characterField char fld =
episode 5 = pure $ OutputEnum "EMPIRE" withFieldFinal "id" (OutputScalar . ScalarString . id_ $ char) fld
episode 6 = pure $ OutputEnum "JEDI" <|> withFieldFinal "name" (OutputScalar . ScalarString . name $ char) fld
episode _ = empty <|> withField "friends" friends' fld
<|> withField "appearsIn" appears' fld
where
friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char
friends' _ _ = empty
characterField :: Alternative f => Character -> Input -> f (HashMap Text Output) appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char
characterField char (InputField "id" [] []) = appears' _ _ = empty
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
characterFields :: Alternative f => Character -> [Input] -> f Output characterFields :: Alternative f => Character -> ResolverO f
characterFields char = fmap (OutputObject . fold) . traverse (characterField char) characterFields = withFields . characterField