From 91679650b5fc387d59925f1c660af62ec3aa4b87 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 2 Jul 2019 20:07:26 +0200 Subject: [PATCH] Introduce monad transformer for resolvers 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. --- graphql.cabal | 3 +- src/Data/GraphQL/Schema.hs | 138 ++++++++++++++---------------- src/Language/GraphQL/Trans.hs | 35 ++++++++ tests/Test/StarWars/Data.hs | 28 +++--- tests/Test/StarWars/QueryTests.hs | 91 ++++++++++++-------- tests/Test/StarWars/Schema.hs | 38 ++++---- 6 files changed, 190 insertions(+), 143 deletions(-) create mode 100644 src/Language/GraphQL/Trans.hs diff --git a/graphql.cabal b/graphql.cabal index 1d40c1c..04536c7 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 4035f9ebd6df2085ad80f5918fc5a65f22b2699f620f7f03c2a3e58ac84827d6 +-- hash: 83313d55668f177f44fe72b0e590759e61e44093406bd0e7d41af66dd9199c92 name: graphql version: 0.3 @@ -47,6 +47,7 @@ library Data.GraphQL.Parser Data.GraphQL.Schema Language.GraphQL.Lexer + Language.GraphQL.Trans other-modules: Paths_graphql hs-source-dirs: diff --git a/src/Data/GraphQL/Schema.hs b/src/Data/GraphQL/Schema.hs index 0ff94f8..919235e 100644 --- a/src/Data/GraphQL/Schema.hs +++ b/src/Data/GraphQL/Schema.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} + -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating Schemas. module Data.GraphQL.Schema @@ -25,12 +25,9 @@ module Data.GraphQL.Schema , Value(..) ) where -import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus) +import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State ( get - , put - ) +import Control.Monad.Trans.Except (runExceptT) import Data.Foldable ( find , fold ) @@ -42,7 +39,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as T - +import Language.GraphQL.Trans import Data.GraphQL.AST.Core -- | A GraphQL schema. @@ -63,104 +60,93 @@ type Arguments = [Argument] type Subs = Name -> Maybe Value -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's. -object :: MonadPlus m => Name -> [Resolver m] -> Resolver m -object name resolvers = objectA name $ \case - [] -> resolvers - _ -> empty +object :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m +object name = objectA name . const -- | Like 'object' but also taking 'Argument's. -objectA - :: MonadPlus m - => Name -> (Arguments -> [Resolver m]) -> Resolver m -objectA name f = Resolver name go +objectA :: MonadPlus m + => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m +objectA name f = Resolver name $ resolveFieldValue f resolveRight 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. -object' :: MonadPlus m => Name -> m [Resolver m] -> Resolver m -object' name resolvs = objectA' name $ \case - [] -> resolvs - _ -> empty +object' :: MonadPlus m => Name -> ActionT m [Resolver m] -> Resolver m +object' name = objectA' name . const -- | Like 'object'' but also taking 'Argument's. -objectA' - :: MonadPlus m - => Name -> (Arguments -> m [Resolver m]) -> Resolver m -objectA' name f = Resolver name go +objectA' :: MonadPlus m + => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m +objectA' name f = Resolver name $ resolveFieldValue f resolveRight where - go fld@(Field _ _ args flds) = do - resolvs <- lift $ f args - withField name (resolve resolvs flds) fld + resolveRight fld@(Field _ _ _ flds) resolver = withField name (resolve resolver flds) fld -- | A scalar represents a primitive value, like a string or an integer. -scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> a -> Resolver m -scalar name s = scalarA name $ \case - [] -> pure s - _ -> empty +scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m +scalar name = scalarA name . const -- | Like 'scalar' but also taking 'Argument's. -scalarA - :: (MonadPlus m, Aeson.ToJSON a) - => Name -> (Arguments -> m a) -> Resolver m -scalarA name f = Resolver name go +scalarA :: (MonadPlus m, Aeson.ToJSON a) + => Name -> (Arguments -> ActionT m a) -> Resolver m +scalarA name f = Resolver name $ resolveFieldValue f resolveRight where - go fld@(Field _ _ args []) = withField name (lift $ f args) fld - go _ = empty + resolveRight fld@(Field _ _ _ []) result = withField name (return result) fld + resolveRight _ _ = mzero -array :: MonadPlus m => Name -> [[Resolver m]] -> Resolver m -array name resolvers = arrayA name $ \case - [] -> resolvers - _ -> empty +array :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m +array name = arrayA name . const -- | Like 'array' but also taking 'Argument's. -arrayA - :: MonadPlus m - => Name -> (Arguments -> [[Resolver m]]) -> Resolver m -arrayA name f = Resolver name go +arrayA :: MonadPlus m + => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m +arrayA name f = Resolver name $ resolveFieldValue f resolveRight 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. -array' :: MonadPlus m => Name -> m [[Resolver m]] -> Resolver m -array' name resolvs = arrayA' name $ \case - [] -> resolvs - _ -> empty +array' :: MonadPlus m => Name -> ActionT m [[Resolver m]] -> Resolver m +array' name = arrayA' name . const -- | Like 'array'' but also taking 'Argument's. -arrayA' - :: MonadPlus m - => Name -> (Arguments -> m [[Resolver m]]) -> Resolver m -arrayA' name f = Resolver name go +arrayA' :: MonadPlus m + => Name -> (Arguments -> ActionT m [[Resolver m]]) -> Resolver m +arrayA' name f = Resolver name $ resolveFieldValue f resolveRight where - go fld@(Field _ _ args sels) = do - resolvs <- lift $ f args - withField name (traverse (`resolve` sels) resolvs) fld + resolveRight fld@(Field _ _ _ sels) resolver + = withField name (traverse (`resolve` sels) resolver) fld -- | Represents one of a finite set of possible values. -- Used in place of a 'scalar' when the possible responses are easily enumerable. -enum :: MonadPlus m => Name -> m [Text] -> Resolver m -enum name enums = enumA name $ \case - [] -> enums - _ -> empty +enum :: MonadPlus m => Name -> ActionT m [Text] -> Resolver m +enum name = enumA name . const -- | Like 'enum' but also taking 'Argument's. -enumA :: MonadPlus m => Name -> (Arguments -> m [Text]) -> Resolver m -enumA name f = Resolver name go +enumA :: MonadPlus m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m +enumA name f = Resolver name $ resolveFieldValue f resolveRight where - go fld@(Field _ _ args []) = withField name (lift $ f args) fld - go _ = empty + resolveRight fld resolver = withField name (return resolver) fld + +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. withField :: (MonadPlus m, Aeson.ToJSON a) - => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) -withField name v (Field alias _ _ _) = do - collection <- HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v - errors <- get - if null errors - then return collection - -- TODO: Report error when Non-Nullable type for field argument. - else put [] >> return (HashMap.singleton aliasOrName Aeson.Null) + => Name -> CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) +withField name v (Field alias _ _ _) + = HashMap.singleton aliasOrName . Aeson.toJSON <$> runAppendErrs v + {- TODO: Report error when Non-Nullable type for field argument. + else return (HashMap.singleton aliasOrName Aeson.Null) -} where aliasOrName = fromMaybe name alias @@ -168,10 +154,10 @@ withField name v (Field alias _ _ _) = do -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. 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 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' tryResolver fld (Resolver _ resolver) = resolver fld errmsg (Field alias name _ _) = do diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs new file mode 100644 index 0000000..f0fcefb --- /dev/null +++ b/src/Language/GraphQL/Trans.hs @@ -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 = (<|>) diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index a710dd8..1305de3 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -2,10 +2,12 @@ module Test.StarWars.Data where 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.Text (Text) +import Language.GraphQL.Trans -- * Data -- 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 (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: Character -> Text -secretBackstory = error "secretBackstory is secret." +secretBackstory :: MonadPlus m => Character -> ActionT m Text +secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." typeName :: Character -> Text typeName = either (const "Droid") (const "Human") @@ -148,30 +150,30 @@ getHero _ = artoo getHeroIO :: Int -> IO Character getHeroIO = pure . getHero -getHuman :: Alternative f => ID -> f Character +getHuman :: MonadPlus m => ID -> m Character getHuman = fmap Right . getHuman' -getHuman' :: Alternative f => ID -> f Human +getHuman' :: MonadPlus m => ID -> m Human getHuman' "1000" = pure luke' getHuman' "1001" = pure vader getHuman' "1002" = pure han getHuman' "1003" = pure leia 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' :: Alternative f => ID -> f Droid +getDroid' :: MonadPlus m => ID -> m Droid getDroid' "2000" = pure threepio getDroid' "2001" = pure artoo' -getDroid' _ = empty +getDroid' _ = mzero 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 5 = pure "EMPIRE" getEpisode 6 = pure "JEDI" -getEpisode _ = empty +getEpisode _ = mzero diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs index 736f5b4..8dde8c2 100644 --- a/tests/Test/StarWars/QueryTests.hs +++ b/tests/Test/StarWars/QueryTests.hs @@ -2,8 +2,10 @@ {-# LANGUAGE QuasiQuotes #-} module Test.StarWars.QueryTests (test) where -import qualified Data.Aeson as Aeson (Value(Null), toJSON) -import Data.Aeson (object, (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson ( object + , (.=) + ) import Data.Text (Text) import Text.RawString.QQ (r) @@ -258,20 +260,26 @@ test = testGroup "Star Wars Query Tests" ] , testGroup "Errors in resolvers" [ testCase "error on secretBackstory" . testQuery - [r| query HeroNameQuery { - hero { - name + [r| + query HeroNameQuery { + hero { + name secretBackstory - } } - |] - $ object ["data" .= object [ - "hero" .= [r2d2Name, secretBackstory] - ] - , "errors" .= object [ - "message" .= Aeson.toJSON [secretText] - , "path" .= Aeson.toJSON [[ "hero" :: Text, "secretBackstory" :: Text ]] - ]] + } + |] + $ object + [ "data" .= object + [ "hero" .= object + [ "name" .= ("R2-D2" :: Text) + , "secretBackstory" .= Aeson.Null + ] + ] + , "errors" .= + [ object + ["message" .= ("secretBackstory is secret." :: Text)] + ] + ] , testCase "Error in a list" . testQuery [r| query HeroNameQuery { hero { @@ -283,17 +291,31 @@ test = testGroup "Star Wars Query Tests" } } |] - $ object ["data" .= object [ - "hero" .= [r2d2Name, "friends" .= [ - object [lukeName, secretBackstory] - , object [hanName, secretBackstory] - , object [leiaName, secretBackstory] - ]] + $ object ["data" .= object + [ "hero" .= object + [ "name" .= ("R2-D2" :: Text) + , "friends" .= + [ 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 [r| query HeroNameQuery { mainHero: hero { @@ -302,14 +324,18 @@ test = testGroup "Star Wars Query Tests" } } |] - $ object ["data" .= object [ - "mainHero" .= [r2d2Name, "story" .= ()] + $ object + [ "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 lukeName = "name" .= ("Luke Skywalker" :: Text) @@ -319,9 +345,6 @@ test = testGroup "Star Wars Query Tests" c3poName = "name" .= ("C-3PO" :: Text) tatooine = "homePlanet" .= ("Tatooine" :: 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 q expected = graphql schema q @?= Just expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 09344fc..0abda7b 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -2,17 +2,17 @@ {-# LANGUAGE OverloadedStrings #-} 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.GraphQL.Schema ( Schema , Resolver , Argument(..) , Value(..) ) import qualified Data.GraphQL.Schema as Schema - +import Language.GraphQL.Trans import Test.StarWars.Data -- * Schema @@ -28,25 +28,25 @@ hero = Schema.objectA "hero" $ \case [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4 [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5 [Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6 - _ -> empty + _ -> ActionT $ throwE "Invalid arguments." human :: MonadPlus m => Resolver m human = Schema.objectA "human" $ \case - [Argument "id" (ValueString i)] -> character =<< getHuman i - _ -> empty + [Argument "id" (ValueString i)] -> character =<< lift (getHuman i) + _ -> ActionT $ throwE "Invalid arguments." droid :: MonadPlus m => Resolver m droid = Schema.objectA "droid" $ \case - [Argument "id" (ValueString i)] -> character =<< getDroid i - _ -> empty + [Argument "id" (ValueString i)] -> character =<< lift (getDroid i) + _ -> ActionT $ throwE "Invalid arguments." -character :: MonadPlus m => Character -> [Resolver m] -character char = - [ Schema.scalar "id" $ id_ char - , Schema.scalar "name" $ name char - , Schema.array "friends" $ character <$> getFriends char - , Schema.enum "appearsIn" . traverse getEpisode $ appearsIn char - , Schema.scalar "secretBackstory" $ secretBackstory char - , Schema.scalar "homePlanet" $ either mempty homePlanet char - , Schema.scalar "__typename" $ typeName char - ] +character :: MonadPlus m => Character -> ActionT m [Resolver m] +character char = return + [ Schema.scalar "id" $ return $ id_ char + , Schema.scalar "name" $ return $ name char + , Schema.array "friends" $ traverse character $ getFriends char + , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char + , Schema.scalar "secretBackstory" $ secretBackstory char + , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char + , Schema.scalar "__typename" $ return $ typeName char + ]