From 1a80975caad97471ef1287c28caedc6d42318143 Mon Sep 17 00:00:00 2001 From: Tristan Cacqueray Date: Wed, 27 Oct 2021 11:13:31 +0000 Subject: [PATCH] [backend] Replace MonadError with MonadThrow The goal of this change is to remove the ExceptT context as it is not compatible with unliftio, see: https://github.com/fpco/unliftio/issues/68 Thus this change uses the MonadThrow instead as demonstrated in https://github.com/haskell-servant/servant/issues/950 The upshot is that the LentilleError are no longer part of then types and they need to be catched implicitely using the MonadCatch. --- haskell/src/Lentille.hs | 16 ++++++++-------- haskell/src/Lentille/Bugzilla.hs | 2 +- haskell/src/Lentille/Bugzilla/Spec.hs | 2 +- haskell/src/Lentille/Gerrit.hs | 2 +- haskell/src/Lentille/GraphQL.hs | 2 +- haskell/src/Macroscope/Main.hs | 5 +---- haskell/src/Macroscope/Worker.hs | 5 +++-- haskell/src/Monocle/Prelude.hs | 6 +++--- 8 files changed, 19 insertions(+), 21 deletions(-) diff --git a/haskell/src/Lentille.hs b/haskell/src/Lentille.hs index c52641cf1..dbecbfe67 100644 --- a/haskell/src/Lentille.hs +++ b/haskell/src/Lentille.hs @@ -38,21 +38,22 @@ import Say (say) ------------------------------------------------------------------------------- -- The Lentille context -newtype LentilleM a = LentilleM {unLentille :: ExceptT LentilleError IO a} +newtype LentilleM a = LentilleM {unLentille :: IdentityT IO a} deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) - deriving newtype (MonadError LentilleError) -runLentilleM :: MonadIO m => LentilleM a -> m (Either LentilleError a) -runLentilleM = liftIO . runExceptT . unLentille +runLentilleM :: MonadIO m => LentilleM a -> m a +runLentilleM = liftIO . runIdentityT . unLentille -stopLentille :: MonadError LentilleError m => LentilleError -> LentilleStream m a -stopLentille = throwError +stopLentille :: MonadThrow m => LentilleError -> LentilleStream m a +stopLentille = lift . throwM data LentilleError = DecodeError [Text] | HttpError (Text, HTTP.Request, HTTP.Response LByteString) deriving (Show) +instance Exception LentilleError + -- | Here we create the different class instance by using the LentilleM inner IO instance MonadTime LentilleM where mGetCurrentTime = liftIO $ mGetCurrentTime @@ -73,7 +74,7 @@ instance MonadGraphQL LentilleM where httpRequest req = liftIO . HTTP.httpLbs req newManager = liftIO mkManager -type MonadGraphQLE m = (MonadGraphQL m, MonadError LentilleError m) +type MonadGraphQLE m = (MonadGraphQL m, MonadThrow m) instance MonadConfig LentilleM where mReloadConfig fp = do @@ -90,7 +91,6 @@ type LentilleStream m a = Stream (Of a) m () class ( MonadTime m, MonadLog m, -- log is the monocle log facility - MonadError LentilleError m, -- error enable stream to produce error MonadGraphQL m, -- for http worker MonadCrawler m, -- for monocle crawler http api MonadConfig m diff --git a/haskell/src/Lentille/Bugzilla.hs b/haskell/src/Lentille/Bugzilla.hs index 6c0cf5b2e..b030fb126 100644 --- a/haskell/src/Lentille/Bugzilla.hs +++ b/haskell/src/Lentille/Bugzilla.hs @@ -33,7 +33,7 @@ import qualified Web.Bugzilla.RedHat as BZ import Web.Bugzilla.RedHat.Search ((.&&.), (.==.)) import qualified Web.Bugzilla.RedHat.Search as BZS -class (MonadLog m, MonadRetry m, MonadError LentilleError m) => MonadBZ m where +class (MonadLog m, MonadRetry m) => MonadBZ m where bzRequest :: FromJSON bugs => BugzillaSession -> BZ.Request -> m bugs newContext :: BZ.BugzillaServer -> m BZ.BugzillaContext diff --git a/haskell/src/Lentille/Bugzilla/Spec.hs b/haskell/src/Lentille/Bugzilla/Spec.hs index 10e6b1b06..0fe798c4b 100644 --- a/haskell/src/Lentille/Bugzilla/Spec.hs +++ b/haskell/src/Lentille/Bugzilla/Spec.hs @@ -30,7 +30,7 @@ testBugToTaskData = testCase "bugToTaskData" go where go = do bzSession <- bugzillaMockClient - Right bz <- runLentilleM $ getBugWithScore bzSession 1791815 + bz <- runLentilleM $ getBugWithScore bzSession 1791815 case toTaskData bz of (td : _tds) -> sequence_ diff --git a/haskell/src/Lentille/Gerrit.hs b/haskell/src/Lentille/Gerrit.hs index 6539f0e17..354539abe 100644 --- a/haskell/src/Lentille/Gerrit.hs +++ b/haskell/src/Lentille/Gerrit.hs @@ -46,7 +46,7 @@ import Prelude (init, last) -- Gerrit context ------------------------------------------------------------------------------- -class (MonadRetry m, MonadLog m, MonadError LentilleError m) => MonadGerrit m where +class (MonadRetry m, MonadLog m) => MonadGerrit m where getGerritClient :: Text -> Maybe (Text, Text) -> m G.GerritClient getProjects :: GerritEnv -> Int -> G.GerritProjectQuery -> Maybe Int -> m GerritProjectsMessage queryChanges :: GerritEnv -> Int -> [GerritQuery] -> Maybe Int -> m [GerritChange] diff --git a/haskell/src/Lentille/GraphQL.hs b/haskell/src/Lentille/GraphQL.hs index 151fbf29a..54cbe8142 100644 --- a/haskell/src/Lentille/GraphQL.hs +++ b/haskell/src/Lentille/GraphQL.hs @@ -114,7 +114,7 @@ streamFetch client mkArgs transformResponse = go Nothing (pageInfo, rateLimit, decodingErrors, xs) <- case respE of Left err -> case reqLog of - [(req, resp)] -> throwError $ HttpError (from err, req, resp) + [(req, resp)] -> lift $ throwM $ HttpError (from err, req, resp) [] -> error $ "No request log found, error is: " <> from err xs -> error $ "Multiple log found for error: " <> from err <> ", " <> show xs Right resp -> pure $ transformResponse resp diff --git a/haskell/src/Macroscope/Main.hs b/haskell/src/Macroscope/Main.hs index 83a62567d..b98801f95 100644 --- a/haskell/src/Macroscope/Main.hs +++ b/haskell/src/Macroscope/Main.hs @@ -31,10 +31,7 @@ crawlerName Config.Crawler {..} = name -- withClient "http://localhost:8080" Nothing $ \client -> runMacroscope True "/home/user/git/github.com/change-metrics/monocle/etc/config.yaml" 30 client runMacroscope :: Bool -> FilePath -> Word32 -> MonocleClient -> IO () runMacroscope verbose confPath interval client = do - res <- runLentilleM $ runMacroscope' verbose confPath interval client - case res of - Left e -> error $ "Macroscope failed: " <> show e - Right x -> pure x + runLentilleM $ runMacroscope' verbose confPath interval client runMacroscope' :: (MonadCatch m, MonadGerrit m, MonadBZ m, LentilleMonad m) => Bool -> FilePath -> Word32 -> MonocleClient -> m () runMacroscope' verbose confPath interval client = do diff --git a/haskell/src/Macroscope/Worker.hs b/haskell/src/Macroscope/Worker.hs index c5cafb164..c96df7253 100644 --- a/haskell/src/Macroscope/Worker.hs +++ b/haskell/src/Macroscope/Worker.hs @@ -128,7 +128,7 @@ process logFunc postFunc = -- | Run is the main function used by macroscope runStream :: - (MonadError LentilleError m, MonadLog m, MonadRetry m, MonadCrawler m) => + (MonadCatch m, MonadLog m, MonadRetry m, MonadCrawler m) => MonocleClient -> MonocleTime -> ApiKey -> @@ -141,7 +141,8 @@ runStream monocleClient startDate apiKey indexName crawlerName documentStream = lc = LogCrawlerContext (toText indexName) (toText crawlerName) wLog event = mLog $ Log Macroscope event drainEntities offset = - safeDrainEntities offset `catchError` handleStreamError offset + safeDrainEntities offset `catch` handleStreamError offset + safeDrainEntities offset = do -- It is important to get the commit date before starting the process to not miss -- document updated when we start diff --git a/haskell/src/Monocle/Prelude.hs b/haskell/src/Monocle/Prelude.hs index 22a2f9439..7d86ab22b 100644 --- a/haskell/src/Monocle/Prelude.hs +++ b/haskell/src/Monocle/Prelude.hs @@ -37,9 +37,9 @@ module Monocle.Prelude runWriterT, -- * exceptions - MonadThrow, + MonadThrow (..), MonadMask, - MonadCatch, + MonadCatch (..), Handler (Handler), -- * tests @@ -116,7 +116,7 @@ where import qualified Control.Foldl as L import Control.Lens (Lens', lens, mapMOf, over, view) -import Control.Monad.Catch (Handler (Handler), MonadCatch, MonadMask, MonadThrow) +import Control.Monad.Catch (Handler (Handler), MonadCatch (catch), MonadMask, MonadThrow (throwM)) import Control.Monad.Except (MonadError, catchError, throwError) import Control.Monad.Morph (hoist) import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)