[backend] Replace MonadError with MonadThrow

The goal of this change is to remove the ExceptT context as it is
not compatible with unliftio, see:
  fpco/unliftio#68

Thus this change uses the MonadThrow instead as demonstrated in
  haskell-servant/servant#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

@@ -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

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
 

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_

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]

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

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

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

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)