[#51] Revise exceptions handling (#55)

Problem: Currently we use `ExceptT BotException IO` which is
inconvenient because both BotException, other sync exceptions and async
exceptions should be handled separately.

Solution: Remove ExceptT, use UnliftIO for exceptions handling, also use
UnliftIO for asyncs instead of monad-control.

package.yaml

@@ -43,12 +43,8 @@ library:
   - katip
   - lens
   - lens-aeson
-  - lifted-async
-  - lifted-base
   - managed
   - megaparsec
-  - monad-control
-  - mtl
   - nyan-interpolation
   - o-clock
   - random
@@ -65,9 +61,9 @@ library:
   - time
   - time-compat
   - transformers
-  - transformers-base
   - tz
   - tztime
+  - unliftio
   - unordered-containers
   - utf8-string
   - validation

src/TzBot/Cache.hs

@@ -23,7 +23,6 @@ module TzBot.Cache
 
 import Universum
 
-import Control.Concurrent.Async.Lifted (withAsync)
 import Data.Cache (Cache)
 import Data.Cache qualified as Cache
 import Data.Cache.Internal qualified as CacheI
@@ -32,6 +31,7 @@ import Formatting (Buildable)
 import System.Clock (TimeSpec)
 import Text.Interpolation.Nyan (int, rmode')
 import Time (Hour, KnownDivRat, Nanosecond, Time(..), hour, threadDelay, toUnit)
+import UnliftIO.Async (withAsync)
 
 import TzBot.Logger (KatipContext, katipAddNamespace, logDebug)
 import TzBot.Util (multTimeSpec, randomTimeSpec, timeToTimespec, (+-))

src/TzBot/Feedback/Save.hs

@@ -9,14 +9,14 @@ module TzBot.Feedback.Save
 
 import Universum
 
-import Control.Monad.Error.Class (MonadError(catchError))
 import Data.Aeson (ToJSON, encode)
 import Data.List.NonEmpty qualified as NE
 import Data.String.Conversions (cs)
 import Data.Time (UTCTime)
 import Data.Time.TZInfo (TZLabel)
 import Data.Time.Zones.All (toTZName)
 import Text.Interpolation.Nyan (int, rmode')
+import UnliftIO.Exception qualified as UnliftIO
 
 import TzBot.Logger
 import TzBot.Render (TranslationPairs, asForOthersS, renderSlackBlocks)
@@ -34,14 +34,14 @@ data FeedbackEntry = FeedbackEntry
   } deriving stock (Show, Generic)
     deriving ToJSON via RecordWrapper FeedbackEntry
 
-logFeedbackError :: (KatipContext m) => BotException -> m ()
+logFeedbackError :: (KatipContext m) => SomeException -> m ()
 logFeedbackError (displayException -> err) = do
   logError [int||Error occured while saving user feedback: #{err}|]
 
 -- | Save user feedback to the Slack channel if configured
 --   and record to the file if configured.
 saveFeedback :: FeedbackEntry -> BotM ()
-saveFeedback entry = flip catchError logFeedbackError $ do
+saveFeedback entry = UnliftIO.handleAny logFeedbackError $ do
   FeedbackConfig {..} <- asks bsFeedbackConfig
   whenJust fcFeedbackChannel $ saveFeedbackSlack entry
   whenJust fcFeedbackFile $ saveFeedbackFile entry

src/TzBot/ProcessEvents.hs

@@ -18,6 +18,7 @@ import Slacker
   pattern Interactive)
 import Slacker.SocketMode (InteractiveEnvelope(..))
 import Text.Interpolation.Nyan (int, rmode', rmode's)
+import UnliftIO.Exception qualified as UnliftIO
 
 import TzBot.Logger
 import TzBot.ProcessEvents.BlockAction qualified as B
@@ -28,7 +29,7 @@ import TzBot.ProcessEvents.Message (processMessageEvent)
 import TzBot.RunMonad (BotM, BotState(..), runBotM)
 import TzBot.Slack.API.Block (ActionId(..))
 import TzBot.Slack.Fixtures qualified as Fixtures
-import TzBot.Util (catchAllErrors, encodeText)
+import TzBot.Util (encodeText)
 
 {- |
 After the message event came, the bot sends some ephemerals
@@ -85,14 +86,11 @@ handler shutdownRef bState _cfg e = run $ do
   where
     run :: BotM a -> IO ()
     run action = void $ runBotM bState $ do
-      eithRes <- catchAllErrors action
-      whenLeft eithRes $ \eithErr -> do
-        case eithErr of
-          Left someExc
-            | Just UserInterrupt <- fromException someExc ->
-                liftIO $ join $ readIORef shutdownRef
-            | otherwise -> logException someExc
-          Right botExc -> logException botExc
+      eithRes <- UnliftIO.trySyncOrAsync action
+      whenLeft eithRes $ \e -> do
+        case fromException e of
+          Just UserInterrupt -> liftIO $ join $ readIORef shutdownRef
+          _ -> logError [int||Error occured: #{displayException e}|]
 
     envelopeIdentifier :: Text
     envelopeIdentifier = case e of

src/TzBot/ProcessEvents/Message.hs

@@ -8,13 +8,13 @@ module TzBot.ProcessEvents.Message
 
 import Universum hiding (try)
 
-import Control.Concurrent.Async.Lifted (forConcurrently)
 import Data.List (singleton)
 import Data.List.NonEmpty qualified as NE
 import Data.Set qualified as S
 import Data.Text.Lazy.Builder (Builder)
 import System.Random (randomRIO)
-import Text.Interpolation.Nyan (int, rmode', rmode's)
+import Text.Interpolation.Nyan (int, rmode')
+import UnliftIO qualified
 
 import TzBot.Cache qualified as Cache
 import TzBot.Config (Config(..))
@@ -26,7 +26,7 @@ import TzBot.Slack.API
 import TzBot.Slack.Events
 import TzBot.Slack.Fixtures qualified as Fixtures
 import TzBot.TimeReference (TimeReference(..))
-import TzBot.Util (catchAllErrors, isDevEnvironment, whenT, withMaybe)
+import TzBot.Util (isDevEnvironment, whenT, withMaybe)
 
 data MessageEventType = METMessage | METMessageEdited
   deriving stock (Eq)
@@ -223,15 +223,14 @@ ephemeralsMailing channelId sendAction = do
   usersInChannelIds <- getChannelMembersCached channelId
   let setSize = S.size usersInChannelIds
   logInfo [int||#{setSize} users in the channel #{channelId}, sending ephemerals|]
-  eithRes <- forConcurrently (toList usersInChannelIds) $ catchAllErrors . sendAction
+  eithRes <- UnliftIO.forConcurrently (toList usersInChannelIds) $ UnliftIO.trySyncOrAsync . sendAction
   let failedMsg = "Ephemeral sending failed" :: Builder
-      logAll :: Either SomeException BotException -> BotM ()
-      logAll (Left se) = logError [int||#{failedMsg}, unknown error occured: #s{se}|]
-      logAll (Right ke) = logError [int||#{failedMsg}, #{displayException ke}|]
+      logAll :: SomeException -> BotM ()
+      logAll se = logError [int||#{failedMsg}, #{displayException se}|]
 
       processResult
         :: (Int, Int)
-        -> Either (Either SomeException BotException) Bool
+        -> Either SomeException Bool
         -> BotM (Int, Int)
       processResult (oks_, errs_) eithRes_ = case eithRes_ of
         Left err_ -> logAll err_ >> pure (oks_, errs_ + 1)

src/TzBot/RunMonad.hs

@@ -7,14 +7,11 @@ module TzBot.RunMonad where
 import Universum
 
 import Control.Lens (makeLensesWith)
-import Control.Monad.Base (MonadBase)
-import Control.Monad.Except (MonadError)
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Set qualified as S
 import Katip qualified as K
 import Network.HTTP.Client (Manager)
-import Servant.Client (ClientError)
 import Text.Interpolation.Nyan (int, rmode')
+import UnliftIO (MonadUnliftIO)
 
 import TzBot.Cache (TzCache)
 import TzBot.Config.Types (BotConfig)
@@ -44,24 +41,19 @@ data BotState = BotState
 makeLensesWith postfixFields ''BotState
 
 newtype BotM a = BotM
-  { unBotM :: ReaderT BotState (ExceptT BotException IO) a
+  { unBotM :: ReaderT BotState IO a
   }
   deriving newtype
     ( Functor, Applicative, Monad
-    , MonadReader BotState, MonadError BotException
-    , MonadIO, MonadBaseControl IO, MonadBase IO
+    , MonadReader BotState
+    , MonadIO, MonadUnliftIO
     )
 
-runBotM :: BotState -> BotM a -> IO (Either BotException a)
+runBotM :: BotState -> BotM a -> IO a
 runBotM state action =
   action
     & unBotM
     & flip runReaderT state
-    & runExceptT
-
-runOrThrowBotM :: BotState -> BotM a -> IO a
-runOrThrowBotM state action =
-  runBotM state action >>= either throwM pure
 
 instance K.Katip BotM where
   localLogEnv f = local (over bsLogEnvL f)
@@ -74,7 +66,8 @@ instance K.KatipContext BotM where
   getKatipNamespace = view bsLogNamespaceL
 
 runKatipWithBotState :: BotState -> K.KatipContextT m a -> m a
-runKatipWithBotState BotState {..} action = K.runKatipContextT bsLogEnv bsLogContext bsLogNamespace action
+runKatipWithBotState BotState {..} action =
+  K.runKatipContextT bsLogEnv bsLogContext bsLogNamespace action
 ----------------------------------------------------------------------------
 -- Exceptions
 ----------------------------------------------------------------------------
@@ -86,7 +79,6 @@ type ErrorDescription = Text
 data BotException
   = EndpointFailed EndpointName ErrorDescription
   | UnexpectedResult EndpointName FunctionName ErrorDescription
-  | ServantError ClientError
   deriving stock (Show, Generic)
 
 instance Exception BotException where
@@ -100,5 +92,3 @@ instance Exception BotException where
       [int|s|
         '#{funcName}', unexpected result from endpoint '#{endpoint}': #{err}
       |]
-    ServantError clientError ->
-      displayException clientError

src/TzBot/Slack.hs

@@ -5,7 +5,6 @@
 module TzBot.Slack
   ( BotM(..)
   , runBotM
-  , runOrThrowBotM
   , AppLevelToken(..)
   , BotToken(..)
   , BotState(..)
@@ -24,7 +23,6 @@ module TzBot.Slack
 
 import Universum hiding (toString)
 
-import Control.Monad.Except (throwError)
 import Data.Aeson (Value)
 import Data.ByteString.UTF8 (toString)
 import Data.DList qualified as DList
@@ -40,13 +38,13 @@ import Servant.Client.Core
   (ClientError(FailureResponse), ResponseF(responseHeaders, responseStatusCode))
 import Text.Interpolation.Nyan (int, rmode', rmode's)
 import Time.Units (sec, threadDelay)
+import UnliftIO.Exception qualified as UnliftIO
 
 import TzBot.Cache qualified as Cache
 import TzBot.Config
 import TzBot.Logger
 import TzBot.RunMonad
-  (BotException(..), BotM(..), BotState(..), ErrorDescription, runBotM, runKatipWithBotState,
-  runOrThrowBotM)
+  (BotException(..), BotM(..), BotState(..), ErrorDescription, runBotM, runKatipWithBotState)
 import TzBot.Slack.API
   (ChannelId, Cursor, Limit(..), Message(..), MessageId(..), OpenViewReq(..), PostEphemeralReq(..),
   PostMessageReq(..), SlackContents(..), SlackResponse(..), ThreadId, UpdateViewReq(..), User,
@@ -107,7 +105,7 @@ retrieveOneMessage channelId messageId = do
   case safeHead msgs of
     Just msg -> pure msg
     Nothing ->
-      throwError $
+      UnliftIO.throwIO $
         UnexpectedResult endpointName functionName
           $ mkErrorMessage messageId Nothing
 
@@ -133,7 +131,7 @@ retrieveOneMessageFromThread channelId threadId messageId = do
   case find (\m -> mMessageId m == messageId) msgs of
     Just msg -> pure msg
     Nothing ->
-      throwError $
+      UnliftIO.throwIO $
         UnexpectedResult endpointName functionName
           $ mkErrorMessage messageId $ Just threadId
 
@@ -175,7 +173,7 @@ handleSlackError endpoint = \case
   SRSuccess a -> pure a
   SRError err_ metadata -> do
     logError [int||#{endpoint} error: #{err_}; metadata: #s{metadata}|]
-    throwError $ EndpointFailed endpoint err_
+    UnliftIO.throwIO $ EndpointFailed endpoint err_
 
 handleSlackErrorSingle :: Text -> SlackResponse $ SlackContents key a -> BotM a
 handleSlackErrorSingle endpoint = fmap scContents . handleSlackError endpoint
@@ -261,8 +259,8 @@ usersInfo
           handleTooManyRequests (runClientM act clientEnv)) (cMaxRetries config)) >>= \case
         Right a -> pure a
         Left clientError -> do
-          logError [int||Client call failed: ${show @Text clientError}|]
-          throwError $ ServantError clientError
+          logError [int||Client call failed: #s{clientError}|]
+          UnliftIO.throwIO clientError
 
 -- | Handles slack API response with status code 429 @Too many requests@.
 -- If action result is success, then return result. If action result is error

src/TzBot/Util.hs

@@ -6,10 +6,7 @@ module TzBot.Util where
 
 import Universum hiding (last, try)
 
-import Control.Exception.Lifted
 import Control.Lens (LensRules, lensField, lensRules, mappingNamer)
-import Control.Monad.Except (MonadError(catchError))
-import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Aeson
 import Data.Aeson qualified as AeKey
 import Data.Aeson qualified as Aeson
@@ -176,22 +173,5 @@ lookup key ciStorage = H.lookup (CI.mk key) $ unCIStorage ciStorage
 postfixFields :: LensRules
 postfixFields = lensRules & lensField .~ mappingNamer (\n -> [n ++ "L"])
 
-----
--- not present in mtl-2.2.2
-tryError :: MonadError e m => m a -> m (Either e a)
-tryError action = (Right <$> action) `catchError` (pure . Left)
-
--- | This catches all the exceptions (including asynchronous ones).
-catchAllErrors
-  :: (MonadError e m, MonadBaseControl IO m)
-  => m a
-  -> m (Either (Either SomeException e) a)
-catchAllErrors action = fmap reorder $ try $ tryError action
-  where
-  reorder :: Either e1 (Either e2 a) -> Either (Either e1 e2) a
-  reorder (Left e) = Left (Left e)
-  reorder (Right (Left e)) = Left (Right e)
-  reorder (Right (Right r)) = Right r
-
 whenT :: (Applicative m) => Bool -> m Bool -> m Bool
 whenT cond_ action_ = if cond_ then action_ else pure False

tzbot.cabal

@@ -135,12 +135,8 @@ library
     , katip
     , lens
     , lens-aeson
-    , lifted-async
-    , lifted-base
     , managed
     , megaparsec
-    , monad-control
-    , mtl
     , nyan-interpolation
     , o-clock
     , optparse-applicative
@@ -157,10 +153,10 @@ library
     , time
     , time-compat
     , transformers
-    , transformers-base
     , tz
     , tztime
     , universum
+    , unliftio
     , unordered-containers
     , utf8-string
     , validation