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

Introduce monad transformer for resolvers

Browse Source 
Now the errors in the resolvers can be handled and 3 tests throwing
errors pass now. Another test fail but it requires distinguisching
nullable and non-nullable values.
This commit is contained in:
Eugen Wissner 2019-07-02 20:07:26 +02:00
parent 1017b728d9
commit 91679650b5
6 changed files with 190 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
graphql.cabal
View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 4035f9ebd6df2085ad80f5918fc5a65f22b2699f620f7f03c2a3e58ac84827d6 -- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92
name: graphql name: graphql
version: 0.3 version: 0.3
@ -47,6 +47,7 @@ library
Data.GraphQL.Parser Data.GraphQL.Parser
Data.GraphQL.Schema Data.GraphQL.Schema
Language.GraphQL.Lexer Language.GraphQL.Lexer
Language.GraphQL.Trans
other-modules: other-modules:
Paths_graphql Paths_graphql
hs-source-dirs: hs-source-dirs:

134
src/Data/GraphQL/Schema.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating Schemas. -- functions for defining and manipulating Schemas.
module Data.GraphQL.Schema module Data.GraphQL.Schema
@ -25,12 +25,9 @@ module Data.GraphQL.Schema
, Value(..) , Value(..)
) where ) where
import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus(..))
import Control.Monad (MonadPlus)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State ( get import Control.Monad.Trans.Except (runExceptT)
, put
)
import Data.Foldable ( find import Data.Foldable ( find
, fold , fold
) )
@ -42,7 +39,7 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Language.GraphQL.Trans
import Data.GraphQL.AST.Core import Data.GraphQL.AST.Core
-- | A GraphQL schema. -- | A GraphQL schema.
@ -63,104 +60,93 @@ type Arguments = [Argument]
type Subs = Name -> Maybe Value type Subs = Name -> Maybe Value
-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
object :: MonadPlus m => Name -> [Resolver m] -> Resolver m object :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m
object name resolvers = objectA name $ \case object name = objectA name . const
[] -> resolvers
_ -> empty
-- | Like 'object' but also taking 'Argument's. -- | Like 'object' but also taking 'Argument's.
objectA objectA :: MonadPlus m
:: MonadPlus m => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
=> Name -> (Arguments -> [Resolver m]) -> Resolver m objectA name f = Resolver name $ resolveFieldValue f resolveRight
objectA name f = Resolver name go
where where
go fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld resolveRight fld@(Field _ _ _ flds) resolver = withField name (resolve resolver flds) fld
-- | Create a named 'Resolver' from a list of 'Resolver's. -- | Create a named 'Resolver' from a list of 'Resolver's.
object' :: MonadPlus m => Name -> m [Resolver m] -> Resolver m object' :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m
object' name resolvs = objectA' name $ \case object' name = objectA' name . const
[] -> resolvs
_ -> empty
-- | Like 'object'' but also taking 'Argument's. -- | Like 'object'' but also taking 'Argument's.
objectA' objectA' :: MonadPlus m
:: MonadPlus m => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
=> Name -> (Arguments -> m [Resolver m]) -> Resolver m objectA' name f = Resolver name $ resolveFieldValue f resolveRight
objectA' name f = Resolver name go
where where
go fld@(Field _ _ args flds) = do resolveRight fld@(Field _ _ _ flds) resolver = withField name (resolve resolver flds) fld
resolvs <- lift $ f args
withField name (resolve resolvs flds) fld
-- | A scalar represents a primitive value, like a string or an integer. -- | A scalar represents a primitive value, like a string or an integer.
scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> a -> Resolver m scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
scalar name s = scalarA name $ \case scalar name = scalarA name . const
[] -> pure s
_ -> empty
-- | Like 'scalar' but also taking 'Argument's. -- | Like 'scalar' but also taking 'Argument's.
scalarA scalarA :: (MonadPlus m, Aeson.ToJSON a)
:: (MonadPlus m, Aeson.ToJSON a) => Name -> (Arguments -> ActionT m a) -> Resolver m
=> Name -> (Arguments -> m a) -> Resolver m scalarA name f = Resolver name $ resolveFieldValue f resolveRight
scalarA name f = Resolver name go
where where
go fld@(Field _ _ args []) = withField name (lift $ f args) fld resolveRight fld@(Field _ _ _ []) result = withField name (return result) fld
go _ = empty resolveRight _ _ = mzero
array :: MonadPlus m => Name -> [[Resolver m]] -> Resolver m array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
array name resolvers = arrayA name $ \case array name = arrayA name . const
[] -> resolvers
_ -> empty
-- | Like 'array' but also taking 'Argument's. -- | Like 'array' but also taking 'Argument's.
arrayA arrayA :: MonadPlus m
:: MonadPlus m => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
=> Name -> (Arguments -> [[Resolver m]]) -> Resolver m arrayA name f = Resolver name $ resolveFieldValue f resolveRight
arrayA name f = Resolver name go
where where
go fld@(Field _ _ args sels) = withField name (traverse (`resolve` sels) $ f args) fld resolveRight fld@(Field _ _ _ sels) resolver
= withField name (traverse (`resolve` sels) resolver) fld
-- | Like 'object'' but taking lists of 'Resolver's instead of a single list. -- | Like 'object'' but taking lists of 'Resolver's instead of a single list.
array' :: MonadPlus m => Name -> m [[Resolver m]] -> Resolver m array' :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m
array' name resolvs = arrayA' name $ \case array' name = arrayA' name . const
[] -> resolvs
_ -> empty
-- | Like 'array'' but also taking 'Argument's. -- | Like 'array'' but also taking 'Argument's.
arrayA' arrayA' :: MonadPlus m
:: MonadPlus m => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m
=> Name -> (Arguments -> m [[Resolver m]]) -> Resolver m arrayA' name f = Resolver name $ resolveFieldValue f resolveRight
arrayA' name f = Resolver name go
where where
go fld@(Field _ _ args sels) = do resolveRight fld@(Field _ _ _ sels) resolver
resolvs <- lift $ f args = withField name (traverse (`resolve` sels) resolver) fld
withField name (traverse (`resolve` sels) resolvs) fld
-- | Represents one of a finite set of possible values. -- | Represents one of a finite set of possible values.
-- Used in place of a 'scalar' when the possible responses are easily enumerable. -- Used in place of a 'scalar' when the possible responses are easily enumerable.
enum :: MonadPlus m => Name -> m [Text] -> Resolver m enum :: MonadPlus m => Name -> ActionT m [Text] -> Resolver m
enum name enums = enumA name $ \case enum name = enumA name . const
[] -> enums
_ -> empty
-- | Like 'enum' but also taking 'Argument's. -- | Like 'enum' but also taking 'Argument's.
enumA :: MonadPlus m => Name -> (Arguments -> m [Text]) -> Resolver m enumA :: MonadPlus m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
enumA name f = Resolver name go enumA name f = Resolver name $ resolveFieldValue f resolveRight
where where
go fld@(Field _ _ args []) = withField name (lift $ f args) fld resolveRight fld resolver = withField name (return resolver) fld
go _ = empty
resolveFieldValue :: MonadPlus m
=> ([Argument] -> ActionT m a)
-> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
-> Field
-> CollectErrsT m (HashMap Text Aeson.Value)
resolveFieldValue f resolveRight fld@(Field alias name args _) = do
result <- lift $ runExceptT . runActionT $ f args
either resolveLeft (resolveRight fld) result
where
resolveLeft err = do
_ <- addErrMsg err
return $ HashMap.singleton (fromMaybe name alias) Aeson.Null
-- | Helper function to facilitate 'Argument' handling. -- | Helper function to facilitate 'Argument' handling.
withField :: (MonadPlus m, Aeson.ToJSON a) withField :: (MonadPlus m, Aeson.ToJSON a)
=> Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
withField name v (Field alias _ _ _) = do withField name v (Field alias _ _ _)
collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v = HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v
errors <- get {- TODO: Report error when Non-Nullable type for field argument.
if null errors else return (HashMap.singleton aliasOrName Aeson.Null) -}
then return collection
-- TODO: Report error when Non-Nullable type for field argument.
else put [] >> return (HashMap.singleton aliasOrName Aeson.Null)
where where
aliasOrName = fromMaybe name alias aliasOrName = fromMaybe name alias
@ -171,7 +157,7 @@ resolve :: MonadPlus m
=> [Resolver m] -> Fields -> CollectErrsT m Aeson.Value => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
where where
tryResolvers fld = maybe empty (tryResolver fld) (find (compareResolvers fld) resolvers) <|> errmsg fld tryResolvers fld = mplus (maybe mzero (tryResolver fld) $ find (compareResolvers fld) resolvers) $ errmsg fld
compareResolvers (Field _ name _ _) (Resolver name' _) = name == name' compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
tryResolver fld (Resolver _ resolver) = resolver fld tryResolver fld (Resolver _ resolver) = resolver fld
errmsg (Field alias name _ _) = do errmsg (Field alias name _ _) = do

35
src/Language/GraphQL/Trans.hs Normal file
View File

@ -0,0 +1,35 @@
module Language.GraphQL.Trans where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT)
import Data.Text (Text)
newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
instance Functor m => Functor (ActionT m) where
fmap f = ActionT . fmap f . runActionT
instance Monad m => Applicative (ActionT m) where
pure = ActionT . pure
(ActionT f) <*> (ActionT x) = ActionT $ f <*> x
instance Monad m => Monad (ActionT m) where
return = pure
(ActionT action) >>= f = ActionT $ action >>= runActionT . f
instance MonadTrans ActionT where
lift = ActionT . lift
instance MonadIO m => MonadIO (ActionT m) where
liftIO = lift . liftIO
instance Monad m => Alternative (ActionT m) where
empty = ActionT empty
(ActionT x) <|> (ActionT y) = ActionT $ x <|> y
instance Monad m => MonadPlus (ActionT m) where
mzero = empty
mplus = (<|>)

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

@ -2,10 +2,12 @@
module Test.StarWars.Data where module Test.StarWars.Data where
import Data.Monoid (mempty) import Data.Monoid (mempty)
import Control.Applicative (Alternative, (<|>), empty, liftA2) import Control.Applicative (liftA2)
import Control.Monad (MonadPlus(..))
import Control.Monad.Trans.Except (throwE)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.Trans
-- * 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
@ -50,8 +52,8 @@ 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
secretBackstory :: Character -> Text secretBackstory :: MonadPlus m => Character -> ActionT m Text
secretBackstory = error "secretBackstory is secret." secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
typeName :: Character -> Text typeName :: Character -> Text
typeName = either (const "Droid") (const "Human") typeName = either (const "Droid") (const "Human")
@ -148,30 +150,30 @@ getHero _ = artoo
getHeroIO :: Int -> IO Character getHeroIO :: Int -> IO Character
getHeroIO = pure . getHero getHeroIO = pure . getHero
getHuman :: Alternative f => ID -> f Character getHuman :: MonadPlus m => ID -> m Character
getHuman = fmap Right . getHuman' getHuman = fmap Right . getHuman'
getHuman' :: Alternative f => ID -> f Human getHuman' :: MonadPlus m => ID -> m 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
getHuman' "1004" = pure tarkin getHuman' "1004" = pure tarkin
getHuman' _ = empty getHuman' _ = mzero
getDroid :: Alternative f => ID -> f Character getDroid :: MonadPlus m => ID -> m Character
getDroid = fmap Left . getDroid' getDroid = fmap Left . getDroid'
getDroid' :: Alternative f => ID -> f Droid getDroid' :: MonadPlus m => ID -> m Droid
getDroid' "2000" = pure threepio getDroid' "2000" = pure threepio
getDroid' "2001" = pure artoo' getDroid' "2001" = pure artoo'
getDroid' _ = empty getDroid' _ = mzero
getFriends :: Character -> [Character] getFriends :: Character -> [Character]
getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char getFriends char = catMaybes $ liftA2 mplus getDroid getHuman <$> friends char
getEpisode :: Alternative f => Int -> f Text getEpisode :: MonadPlus m => Int -> m Text
getEpisode 4 = pure "NEWHOPE" getEpisode 4 = pure "NEWHOPE"
getEpisode 5 = pure "EMPIRE" getEpisode 5 = pure "EMPIRE"
getEpisode 6 = pure "JEDI" getEpisode 6 = pure "JEDI"
getEpisode _ = empty getEpisode _ = mzero

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

@ -2,8 +2,10 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Test.StarWars.QueryTests (test) where module Test.StarWars.QueryTests (test) where
import qualified Data.Aeson as Aeson (Value(Null), toJSON) import qualified Data.Aeson as Aeson
import Data.Aeson (object, (.=)) import Data.Aeson ( object
, (.=)
)
import Data.Text (Text) import Data.Text (Text)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
@ -258,20 +260,26 @@ test = testGroup "Star Wars Query Tests"
] ]
, testGroup "Errors in resolvers" , testGroup "Errors in resolvers"
[ testCase "error on secretBackstory" . testQuery [ testCase "error on secretBackstory" . testQuery
[r| query HeroNameQuery { [r|
query HeroNameQuery {
hero { hero {
name name
secretBackstory secretBackstory
} }
} }
|] |]
$ object ["data" .= object [ $ object
"hero" .= [r2d2Name, secretBackstory] [ "data" .= object
[ "hero" .= object
[ "name" .= ("R2-D2" :: Text)
, "secretBackstory" .= Aeson.Null
]
]
, "errors" .=
[ object
["message" .= ("secretBackstory is secret." :: Text)]
]
] ]
, "errors" .= object [
"message" .= Aeson.toJSON [secretText]
, "path" .= Aeson.toJSON [[ "hero" :: Text, "secretBackstory" :: Text ]]
]]
, testCase "Error in a list" . testQuery , testCase "Error in a list" . testQuery
[r| query HeroNameQuery { [r| query HeroNameQuery {
hero { hero {
@ -283,17 +291,31 @@ test = testGroup "Star Wars Query Tests"
} }
} }
|] |]
$ object ["data" .= object [ $ object ["data" .= object
"hero" .= [r2d2Name, "friends" .= [ [ "hero" .= object
object [lukeName, secretBackstory] [ "name" .= ("R2-D2" :: Text)
, object [hanName, secretBackstory] , "friends" .=
, object [leiaName, secretBackstory] [ object
]] [ "name" .= ("Luke Skywalker" :: Text)
, "secretBackstory" .= Aeson.Null
]
, object
[ "name" .= ("Han Solo" :: Text)
, "secretBackstory" .= Aeson.Null
]
, object
[ "name" .= ("Leia Organa" :: Text)
, "secretBackstory" .= Aeson.Null
]
]
]
]
, "errors" .=
[ object ["message" .= ("secretBackstory is secret." :: Text)]
, object ["message" .= ("secretBackstory is secret." :: Text)]
, object ["message" .= ("secretBackstory is secret." :: Text)]
]
] ]
, "errors" .= object [
"message" .= Aeson.toJSON [secretText, secretText, secretText]
, "path" .= Aeson.toJSON [secretPath 0, secretPath 1, secretPath 2]
]]
, testCase "error on secretBackstory with alias" . testQuery , testCase "error on secretBackstory with alias" . testQuery
[r| query HeroNameQuery { [r| query HeroNameQuery {
mainHero: hero { mainHero: hero {
@ -302,13 +324,17 @@ test = testGroup "Star Wars Query Tests"
} }
} }
|] |]
$ object ["data" .= object [ $ object
"mainHero" .= [r2d2Name, "story" .= ()] [ "data" .= object
[ "mainHero" .= object
[ "name" .= ("R2-D2" :: Text)
, "story" .= Aeson.Null
]
]
, "errors" .=
[ object ["message" .= ("secretBackstory is secret." :: Text)]
]
] ]
, "errors" .= object [
"message" .= Aeson.toJSON [secretText]
, "path" .= Aeson.toJSON [[ "mainHero" :: Text, "story" :: Text ]]
]]
] ]
] ]
where where
@ -319,9 +345,6 @@ test = testGroup "Star Wars Query Tests"
c3poName = "name" .= ("C-3PO" :: Text) c3poName = "name" .= ("C-3PO" :: Text)
tatooine = "homePlanet" .= ("Tatooine" :: Text) tatooine = "homePlanet" .= ("Tatooine" :: Text)
alderaan = "homePlanet" .= ("Alderaan" :: Text) alderaan = "homePlanet" .= ("Alderaan" :: Text)
secretBackstory = "secretBackstory" .= ()
secretText = "secretBackstory is secret" :: Text
secretPath n = ("hero", "friends", n, "secretBackstory") :: (Text, Text, Int, Text)
testQuery :: Text -> Aeson.Value -> Assertion testQuery :: Text -> Aeson.Value -> Assertion
testQuery q expected = graphql schema q @?= Just expected testQuery q expected = graphql schema q @?= Just expected

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

@ -2,17 +2,17 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Test.StarWars.Schema where module Test.StarWars.Schema where
import Control.Applicative (Alternative(..)) import Control.Monad (MonadPlus(..))
import Control.Monad (MonadPlus) import Control.Monad.Trans.Except (throwE)
import Control.Monad.Trans.Class (lift)
import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty (NonEmpty((:|)))
import Data.GraphQL.Schema ( Schema import Data.GraphQL.Schema ( Schema
, Resolver , Resolver
, Argument(..) , Argument(..)
, Value(..) , Value(..)
) )
import qualified Data.GraphQL.Schema as Schema import qualified Data.GraphQL.Schema as Schema
import Language.GraphQL.Trans
import Test.StarWars.Data import Test.StarWars.Data
-- * Schema -- * Schema
@ -28,25 +28,25 @@ hero = Schema.objectA "hero" $ \case
[Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4 [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
[Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5 [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
[Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6 [Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6
_ -> empty _ -> ActionT $ throwE "Invalid arguments."
human :: MonadPlus m => Resolver m human :: MonadPlus m => Resolver m
human = Schema.objectA "human" $ \case human = Schema.objectA "human" $ \case
[Argument "id" (ValueString i)] -> character =<< getHuman i [Argument "id" (ValueString i)] -> character =<< lift (getHuman i)
_ -> empty _ -> ActionT $ throwE "Invalid arguments."
droid :: MonadPlus m => Resolver m droid :: MonadPlus m => Resolver m
droid = Schema.objectA "droid" $ \case droid = Schema.objectA "droid" $ \case
[Argument "id" (ValueString i)] -> character =<< getDroid i [Argument "id" (ValueString i)] -> character =<< lift (getDroid i)
_ -> empty _ -> ActionT $ throwE "Invalid arguments."
character :: MonadPlus m => Character -> [Resolver m] character :: MonadPlus m => Character -> ActionT m [Resolver m]
character char = character char = return
[ Schema.scalar "id" $ id_ char [ Schema.scalar "id" $ return $ id_ char
, Schema.scalar "name" $ name char , Schema.scalar "name" $ return $ name char
, Schema.array "friends" $ character <$> getFriends char , Schema.array "friends" $ traverse character $ getFriends char
, Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
, Schema.scalar "secretBackstory" $ secretBackstory char , Schema.scalar "secretBackstory" $ secretBackstory char
, Schema.scalar "homePlanet" $ either mempty homePlanet char , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
, Schema.scalar "__typename" $ typeName char , Schema.scalar "__typename" $ return $ typeName char
] ]