Use MonadBaseControl IO

Author: Raveline

log-base/src/Log/Monad.hs

@@ -6,7 +6,6 @@ module Log.Monad (
   , InnerLogT
   , LogT(..)
   , runLogT
-  , runLogTAttentionOnFailure
   , mapLogT
   , logMessageIO
   , getLoggerIO
@@ -47,19 +46,25 @@ instance MonadReader r m => MonadReader r (LogT m) where
     ask   = lift ask
     local = mapLogT . local
 
--- | Run a 'LogT' computation
+-- | Run a 'LogT' computation and log any uncaught exceptions.
 --
 -- Note that in the case of asynchronous/bulk loggers 'runLogT'
 -- doesn't guarantee that all messages are actually written to the log
 -- once it finishes. Use 'withPGLogger' or 'withElasticSearchLogger'
 -- for that.
-runLogT :: Text     -- ^ Application component name to use.
+runLogT :: (MonadBaseControl IO m)
+        => Text     -- ^ Application component name to use.
         -> Logger   -- ^ The logging back-end to use.
         -> LogLevel -- ^ The maximum log level allowed to be logged.
                     --   Only messages less or equal than this level with be logged.
         -> LogT m a -- ^ The 'LogT' computation to run.
         -> m a
-runLogT component logger maxLogLevel m = runReaderT (unLogT m) LoggerEnv {
+runLogT component logger maxLogLevel m = runReaderT
+  (unLogT $ liftedCatch m (\(SomeException e) -> do
+      logAttention "Uncaught exception" $ object ["error" .= show e]
+      E.throw e)
+  )
+  LoggerEnv {
   leLogger = logger
 , leComponent = component
 , leDomain = []
@@ -68,42 +73,16 @@ runLogT component logger maxLogLevel m = runReaderT (unLogT m) LoggerEnv {
 } -- We can't do synchronisation here, since 'runLogT' can be invoked
   -- quite often from the application (e.g. on every request).
 
+-- Generalized version of catch taken from `lifted-base`
+liftedCatch :: (MonadBaseControl IO m, Exception e)
+      => m a       -- ^ The computation to run
+      -> (e -> m a) -- ^ Handler to invoke if an exception is raised
+      -> m a
+liftedCatch a handler = control $ \runInIO ->
+  E.catch
+    (runInIO a)
+    (\e -> runInIO $ handler e)
 
--- | Run a 'LogT' computation and log any uncaught exception
--- 
--- Note that in the case of asynchronous/bulk loggers 'runLogT'
--- doesn't guarantee that all messages are actually written to the log
--- once it finishes. Use 'withPGLogger' or 'withElasticSearchLogger'
--- for that.
-runLogTAttentionOnFailure :: (MonadBase IO m, MonadMask m)
-        => Text     -- ^ Application component name to use.
-        -> Logger   -- ^ The logging back-end to use.
-        -> LogLevel -- ^ The maximum log level allowed to be logged.
-                    --   Only messages less or equal than this level with be logged.
-        -> LogT m a -- ^ The 'LogT' computation to run.
-        -> m a
-runLogTAttentionOnFailure component logger maxLogLevel m =
-    fst <$> runReaderT
-    (unLogT $
-    generalBracket
-      (pure ())
-      (\_ -> \case
-        ExitCaseSuccess _ -> pure ()
-        ExitCaseException (SomeException e) -> do
-          logAttention "Uncaught exception raised" $ object ["error" .= show e]
-          error "In a catch"
-        ExitCaseAbort ->
-          logAttention_ "Process was aborted"
-      )
-      (const m))
-    LoggerEnv
-        { leLogger = logger
-        , leComponent = component
-        , leDomain = []
-        , leData = []
-        , leMaxLogLevel = maxLogLevel
-        } -- We can't do synchronisation here, since 'runLogT' can be invoked
-        -- quite often from the application (e.g. on every request).
 
 -- | Transform the computation inside a 'LogT'.
 mapLogT :: (m a -> n b) -> LogT m a -> LogT n b