From 61879fb12437302d6b14e0e0297e3a8742d91f8b Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 8 Jul 2019 10:15:47 +0200 Subject: [PATCH] Constrain the resolvers with MonadIO This replaces the most usages of MonadPlus, which is not appropriate for the resolvers, since a resolver is unambiguously chosen by the name (no need for 'mplus'), and the resolvers are often doing IO. --- src/Language/GraphQL.hs | 7 +++--- src/Language/GraphQL/Execute.hs | 22 +++++++++++------- src/Language/GraphQL/Schema.hs | 38 +++++++++++++++---------------- tests/Test/StarWars/Data.hs | 26 +++++++++++---------- tests/Test/StarWars/QueryTests.hs | 15 +++++------- tests/Test/StarWars/Schema.hs | 14 ++++++------ 6 files changed, 63 insertions(+), 59 deletions(-) diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 8ed29cf..74052d9 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -1,8 +1,7 @@ -- | This module provides the functions to parse and execute @GraphQL@ queries. module Language.GraphQL where -import Control.Monad (MonadPlus) - +import Control.Monad.IO.Class (MonadIO) import qualified Data.Text as T import qualified Data.Aeson as Aeson @@ -21,7 +20,7 @@ import Language.GraphQL.Error -- executed according to the given 'Schema'. -- -- Returns the response as an @Aeson.@'Aeson.Value'. -graphql :: MonadPlus m => Schema m -> T.Text -> m Aeson.Value +graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value graphql = flip graphqlSubs $ const Nothing -- | Takes a 'Schema', a variable substitution function and text @@ -30,7 +29,7 @@ graphql = flip graphqlSubs $ const Nothing -- query and the query is then executed according to the given 'Schema'. -- -- Returns the response as an @Aeson.@'Aeson.Value'. -graphqlSubs :: MonadPlus m => Schema m -> Subs -> T.Text -> m Aeson.Value +graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value graphqlSubs schema f = either (parseError . errorBundlePretty) (execute schema f) . parse document "" diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index eb53bba..7416167 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} + -- | This module provides the function to execute a @GraphQL@ request -- -- according to a 'Schema'. module Language.GraphQL.Execute (execute) where -import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.Aeson as Aeson @@ -21,17 +22,22 @@ import qualified Language.GraphQL.Schema as Schema -- Returns the result of the query against the 'Schema' wrapped in a /data/ field, or -- errors wrapped in an /errors/ field. execute - :: (MonadPlus m) - => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value -execute schema subs doc = do - coreDocument <- maybe mzero pure (Transform.document subs doc) - document schema coreDocument + :: MonadIO m + => Schema m -> Schema.Subs -> AST.Document -> m Aeson.Value +execute schema subs doc = + maybe transformError (document schema) $ Transform.document subs doc + where + transformError = return $ Aeson.object + [("errors", Aeson.toJSON + [ Aeson.object [("message", "Schema transformation error.")] + ] + )] -document :: MonadPlus m => Schema m -> AST.Core.Document -> m Aeson.Value +document :: MonadIO m => Schema m -> AST.Core.Document -> m Aeson.Value document schema (op :| []) = operation schema op document _ _ = error "Multiple operations not supported yet" -operation :: MonadPlus m => Schema m -> AST.Core.Operation -> m Aeson.Value +operation :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value operation schema (AST.Core.Query flds) = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds)) operation schema (AST.Core.Mutation flds) diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 5569155..1efdf0d 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -25,7 +25,7 @@ module Language.GraphQL.Schema , Value(..) ) where -import Control.Monad (MonadPlus(..)) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Data.Foldable ( find @@ -44,11 +44,11 @@ import Language.GraphQL.Type import Language.GraphQL.AST.Core -- | A GraphQL schema. --- @f@ is usually expected to be an instance of 'Alternative'. +-- @m@ is usually expected to be an instance of 'MonadIO'. type Schema m = NonEmpty (Resolver m) -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information --- (or 'empty'). @m@ is usually expected to be an instance of 'MonadPlus'. +-- (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO. data Resolver m = Resolver Text -- ^ Name (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver @@ -61,18 +61,18 @@ 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 -> ActionT m [Resolver m] -> Resolver m +object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m object name = objectA name . const -- | Like 'object' but also taking 'Argument's. -objectA :: MonadPlus m +objectA :: MonadIO m => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m objectA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld -- | Like 'object' but also taking 'Argument's and can be null or a list of objects. -wrappedObjectA :: MonadPlus m +wrappedObjectA :: MonadIO m => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight where @@ -80,23 +80,23 @@ wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight = withField (traverse (`resolve` sels) resolver) fld -- | Like 'object' but can be null or a list of objects. -wrappedObject :: MonadPlus m +wrappedObject :: MonadIO m => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m wrappedObject name = wrappedObjectA name . const -- | A scalar represents a primitive value, like a string or an integer. -scalar :: (MonadPlus m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m +scalar :: (MonadIO 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) +scalarA :: (MonadIO m, Aeson.ToJSON a) => Name -> (Arguments -> ActionT m a) -> Resolver m scalarA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld result = withField (return result) fld -- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars. -wrappedScalarA :: (MonadPlus m, Aeson.ToJSON a) +wrappedScalarA :: (MonadIO m, Aeson.ToJSON a) => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight where @@ -106,23 +106,23 @@ wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight resolveRight fld (List result) = withField (return result) fld -- | Like 'scalar' but can be null or a list of scalars. -wrappedScalar :: (MonadPlus m, Aeson.ToJSON a) +wrappedScalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m (Wrapping a) -> Resolver m wrappedScalar name = wrappedScalarA name . const -- | 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 -> ActionT m [Text] -> Resolver m +enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m enum name = enumA name . const -- | Like 'enum' but also taking 'Argument's. -enumA :: MonadPlus m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m +enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m enumA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld resolver = withField (return resolver) fld -- | Like 'enum' but also taking 'Argument's and can be null or a list of enums. -wrappedEnumA :: MonadPlus m +wrappedEnumA :: MonadIO m => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight where @@ -132,10 +132,10 @@ wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight resolveRight fld (List resolver) = withField (return resolver) fld -- | Like 'enum' but can be null or a list of enums. -wrappedEnum :: MonadPlus m => Name -> ActionT m (Wrapping [Text]) -> Resolver m +wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m wrappedEnum name = wrappedEnumA name . const -resolveFieldValue :: MonadPlus m +resolveFieldValue :: MonadIO m => ([Argument] -> ActionT m a) -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) -> Field @@ -149,7 +149,7 @@ resolveFieldValue f resolveRight fld@(Field _ _ args _) = do return $ HashMap.singleton (aliasOrName fld) Aeson.Null -- | Helper function to facilitate 'Argument' handling. -withField :: (MonadPlus m, Aeson.ToJSON a) +withField :: (MonadIO m, Aeson.ToJSON a) => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value) withField v fld = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v @@ -157,11 +157,11 @@ withField v fld -- | Takes a list of 'Resolver's and a list of 'Field's and applies each -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. -resolve :: MonadPlus m +resolve :: MonadIO m => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where - tryResolvers fld = mplus (maybe mzero (tryResolver fld) $ find (compareResolvers fld) resolvers) $ errmsg fld + tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers compareResolvers (Field _ name _ _) (Resolver name' _) = name == name' tryResolver fld (Resolver _ resolver) = resolver fld errmsg fld@(Field _ name _ _) = do diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 1305de3..5ceeb82 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -2,8 +2,10 @@ module Test.StarWars.Data where import Data.Monoid (mempty) -import Control.Applicative (liftA2) -import Control.Monad (MonadPlus(..)) +import Control.Applicative ( Alternative(..) + , liftA2 + ) +import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Except (throwE) import Data.Maybe (catMaybes) import Data.Text (Text) @@ -52,7 +54,7 @@ appearsIn :: Character -> [Int] appearsIn (Left x) = _appearsIn . _droidChar $ x appearsIn (Right x) = _appearsIn . _humanChar $ x -secretBackstory :: MonadPlus m => Character -> ActionT m Text +secretBackstory :: MonadIO m => Character -> ActionT m Text secretBackstory = const $ ActionT $ throwE "secretBackstory is secret." typeName :: Character -> Text @@ -150,30 +152,30 @@ getHero _ = artoo getHeroIO :: Int -> IO Character getHeroIO = pure . getHero -getHuman :: MonadPlus m => ID -> m Character +getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman' -getHuman' :: MonadPlus m => ID -> m Human +getHuman' :: Alternative f => ID -> f Human getHuman' "1000" = pure luke' getHuman' "1001" = pure vader getHuman' "1002" = pure han getHuman' "1003" = pure leia getHuman' "1004" = pure tarkin -getHuman' _ = mzero +getHuman' _ = empty -getDroid :: MonadPlus m => ID -> m Character +getDroid :: Alternative f => ID -> f Character getDroid = fmap Left . getDroid' -getDroid' :: MonadPlus m => ID -> m Droid +getDroid' :: Alternative f => ID -> f Droid getDroid' "2000" = pure threepio getDroid' "2001" = pure artoo' -getDroid' _ = mzero +getDroid' _ = empty getFriends :: Character -> [Character] -getFriends char = catMaybes $ liftA2 mplus getDroid getHuman <$> friends char +getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char -getEpisode :: MonadPlus m => Int -> m Text +getEpisode :: Alternative f => Int -> f Text getEpisode 4 = pure "NEWHOPE" getEpisode 5 = pure "EMPIRE" getEpisode 6 = pure "JEDI" -getEpisode _ = mzero +getEpisode _ = empty diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs index 27e66ea..3a6ca75 100644 --- a/tests/Test/StarWars/QueryTests.hs +++ b/tests/Test/StarWars/QueryTests.hs @@ -11,7 +11,10 @@ import Language.GraphQL import Language.GraphQL.Schema (Subs) import Text.RawString.QQ (r) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, testCase, (@?=)) +import Test.Tasty.HUnit ( Assertion + , testCase + , (@?=) + ) import Test.StarWars.Schema -- * Test @@ -344,13 +347,7 @@ test = testGroup "Star Wars Query Tests" alderaan = "homePlanet" .= ("Alderaan" :: Text) testQuery :: Text -> Aeson.Value -> Assertion -testQuery q expected = graphql schema q @?= Just expected - --- testFail :: Text -> Assertion --- testFail q = graphql schema q @?= Nothing +testQuery q expected = graphql schema q >>= (@?= expected) 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 +testQueryParams f q expected = graphqlSubs schema f q >>= (@?= expected) diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 6615d09..3cc34fd 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -2,9 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Schema where -import Control.Monad (MonadPlus(..)) import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (MonadIO(..)) import Data.List.NonEmpty (NonEmpty((:|))) import Language.GraphQL.Schema ( Schema , Resolver @@ -19,10 +19,10 @@ import Test.StarWars.Data -- * Schema -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: MonadPlus m => Schema m +schema :: MonadIO m => Schema m schema = hero :| [human, droid] -hero :: MonadPlus m => Resolver m +hero :: MonadIO m => Resolver m hero = Schema.objectA "hero" $ \case [] -> character artoo [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4 @@ -30,7 +30,7 @@ hero = Schema.objectA "hero" $ \case [Argument "episode" (ValueEnum "JEDI" )] -> character $ getHero 6 _ -> ActionT $ throwE "Invalid arguments." -human :: MonadPlus m => Resolver m +human :: MonadIO m => Resolver m human = Schema.wrappedObjectA "human" $ \case [Argument "id" (ValueString i)] -> do humanCharacter <- lift $ return $ getHuman i >>= Just @@ -39,12 +39,12 @@ human = Schema.wrappedObjectA "human" $ \case Just e -> Named <$> character e _ -> ActionT $ throwE "Invalid arguments." -droid :: MonadPlus m => Resolver m +droid :: MonadIO m => Resolver m droid = Schema.objectA "droid" $ \case - [Argument "id" (ValueString i)] -> character =<< lift (getDroid i) + [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i) _ -> ActionT $ throwE "Invalid arguments." -character :: MonadPlus m => Character -> ActionT m [Resolver m] +character :: MonadIO m => Character -> ActionT m [Resolver m] character char = return [ Schema.scalar "id" $ return $ id_ char , Schema.scalar "name" $ return $ name char