prescientmoon/graphql
1
0
Fork 0
forked from OSS/graphql
Code Pull Requests Activity

Overhaul Schema DSL

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

71
Data/GraphQL/Execute.hs
View File

@ -2,64 +2,41 @@
module Data.GraphQL.Execute (execute) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), pure)
import Data.Traversable (traverse)
import Control.Applicative ((<$>))
#endif
import Control.Applicative (Alternative, empty)
import Data.Foldable (fold)
import Control.Applicative (Alternative)
import Data.Maybe (catMaybes)
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.Schema (Resolver, Schema(..))
import Data.GraphQL.Schema (Schema(..))
import qualified Data.GraphQL.Schema as Schema
execute
:: (Alternative m, Monad m)
:: Alternative m
=> 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
query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels
query _ = empty
rootFields :: Schema.Subs -> Document -> [Field]
rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
Schema.fields $ substitute subs <$> sels
rootFields _ _ = []
selectionSet
:: Alternative f
=> Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value
selectionSet f resolv = fmap (Aeson.Object . fold)
. traverse (selection f resolv)
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) =
substitute :: Schema.Subs -> Selection -> Selection
substitute subs (SelectionField (Field alias name args directives sels)) =
SelectionField $ Field
alias
name
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
Schema.InputField n (catMaybes $ argument f <$> as)
(fieldToInput f . selectionToField <$> sels)
(catMaybes $ subsArg subs <$> args)
directives
(substitute subs <$> sels)
substitute _ sel = sel
selectionToField :: Selection -> Field
selectionToField (SelectionField x) = x
selectionToField _ = error "selectionField: not implemented yet"
-- TODO: Support different value types
subsArg :: Schema.Subs -> Argument -> Maybe Argument
subsArg subs (Argument n (ValueVariable (Variable v))) =
Argument n . ValueString . StringValue <$> subs v
subsArg _ arg = Just arg

76
Data/GraphQL/Schema.hs
View File

@ -1,20 +1,46 @@
{-# 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)
import Control.Applicative ((<$>))
import Data.Traversable (traverse)
#endif
import Control.Applicative
import Data.Maybe (catMaybes)
import Data.Foldable (fold)
import Data.String (IsString(fromString))
import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text, pack)
import qualified Data.Text as T (null)
import Data.GraphQL.AST
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)
| OutputList [Output]
@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output)
| OutputEnum Text
deriving (Show)
type Argument = (Text, Scalar)
type Subs = Text -> Maybe Scalar
data Input = InputField Text [Argument] [Input]
deriving (Show)
type Subs = Text -> Maybe Text
-- TODO: GraphQL spec for Integer Scalar is 32bits
data Scalar = ScalarInt Int
@ -53,3 +74,38 @@ instance ToJSON Output where
toJSON (OutputScalar 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

10
tests/Test/StarWars/Data.hs
View File

@ -38,7 +38,7 @@ data Droid = Droid
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_ (Left x) = _id_ . _droidChar $ x
@ -128,7 +128,6 @@ threepio = Droid
artoo :: Character
artoo = Left artoo'
artoo' :: Droid
artoo' = Droid
{ _droidChar = CharCommon
@ -149,7 +148,6 @@ getHero _ = artoo
getHeroIO :: Int -> IO Character
getHeroIO = pure . getHero
getHuman :: Alternative f => ID -> f Character
getHuman = fmap Right . getHuman'
@ -171,3 +169,9 @@ getDroid' _ = empty
getFriends :: Character -> [Character]
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

63
tests/Test/StarWars/QueryTests.hs
View File

@ -18,12 +18,6 @@ import Test.StarWars.Schema
-- * Test
-- 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 = testGroup "Star Wars Query Tests"
[ testGroup "Basic Queries"
@ -148,24 +142,23 @@ test = testGroup "Star Wars Query Tests"
$ object [
"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
-- to mimic the same behavior? Is this part of the spec? Once proper
-- exceptions are implemented this test might no longer be meaningful.
-- If the same behavior needs to be replicated, should it be implemented
-- 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]
, testCase "Luke with alias" . testQuery
, testCase "Luke aliased" . testQuery
[r| query FetchLukeAliased {
luke: human(id: "1000") {
name
@ -177,6 +170,28 @@ test = testGroup "Star Wars Query Tests"
"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
[r| query FetchLukeAndLeiaAliased {
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

82
tests/Test/StarWars/Schema.hs
View File

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