Merge pull request #170 from fizruk/rethrow-exceptions

fizruk · Feb 6, 2024 · 67baad1 · 67baad1
2 parents 319846f + f1ab9d4
commit 67baad1
Show file tree

Hide file tree

Showing 4 changed files with 22 additions and 8 deletions.
diff --git a/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp.hs b/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp.hs
@@ -16,7 +16,6 @@ module Telegram.Bot.Simple.BotApp (
   getEnvToken,
 ) where
 
-import           Control.Concurrent                  (forkIO)
 import           Control.Monad                       (void)
 import           Data.String                         (fromString)
 import           Servant.Client
@@ -42,7 +41,7 @@ startBotAsync bot env = do
   fork_ $ startBotPolling bot botEnv
   return (issueAction botEnv Nothing . Just)
   where
-    fork_ = void . forkIO . void . flip runClientM env
+    fork_ = void . asyncLink . void . flip runClientM env
 
 -- | Like 'startBotAsync', but ignores result.
 startBotAsync_ :: BotApp model action -> ClientEnv -> IO ()

diff --git a/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp/Internal.hs b/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp/Internal.hs
@@ -3,7 +3,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Telegram.Bot.Simple.BotApp.Internal where
 
-import           Control.Concurrent      (ThreadId, forkIO, threadDelay)
+import           Control.Concurrent       (ThreadId, threadDelay)
+import           Control.Concurrent.Async (Async, async, asyncThreadId, link)
 import           Control.Concurrent.STM
 import           Control.Monad           (forever, void, (<=<))
 import           Control.Monad.Except    (catchError)
@@ -117,14 +118,16 @@ processActionJob botApp botEnv@BotEnv{..} = do
 -- | Process incoming actions indefinitely.
 processActionsIndefinitely
   :: BotApp model action -> BotEnv model action -> IO ThreadId
-processActionsIndefinitely botApp botEnv = forkIO . forever $ do
-  runClientM (processActionJob botApp botEnv) (botClientEnv botEnv)
+processActionsIndefinitely botApp botEnv = do
+  a <- asyncLink $ forever $ do
+    runClientM (processActionJob botApp botEnv) (botClientEnv botEnv)
+  return (asyncThreadId a)
 
 -- | Start 'Telegram.Update' polling for a bot.
 startBotPolling :: BotApp model action -> BotEnv model action -> ClientM ()
 startBotPolling BotApp{..} botEnv@BotEnv{..} = startPolling handleUpdate
   where
-    handleUpdate update = liftIO . void . forkIO $ do
+    handleUpdate update = liftIO . void . asyncLink $ do
       maction <- botAction update <$> readTVarIO botModelVar
       case maction of
         Nothing     -> return ()
@@ -154,3 +157,15 @@ startPolling handleUpdate = go Nothing
           pure maxUpdateId
       liftIO $ threadDelay 1000000
       go nextUpdateId
+
+-- ** Helpers
+
+-- | Instead of 'forkIO' which hides exceptions,
+-- allow users to handle those exceptions separately.
+-- 
+-- See <https://github.com/fizruk/telegram-bot-simple/issues/159>.
+asyncLink :: IO a -> IO (Async a)
+asyncLink action = do
+  a <- async action
+  link a
+  return a
diff --git a/telegram-bot-simple/src/Telegram/Bot/Simple/Webhook.hs b/telegram-bot-simple/src/Telegram/Bot/Simple/Webhook.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE TypeOperators         #-}
 module Telegram.Bot.Simple.Webhook (webhookApp) where
 
-import           Control.Concurrent                  (forkIO)
 import           Control.Concurrent.STM
 import           Control.Monad.IO.Class              (MonadIO (liftIO))
 import           Data.Functor                        (void)
@@ -20,7 +19,7 @@ server BotApp {..} botEnv@BotEnv {..} =
   where
     updateHandler :: Update -> Handler ()
     updateHandler update = liftIO $ handleUpdate update
-    handleUpdate update = liftIO . void . forkIO $ do
+    handleUpdate update = liftIO . void . asyncLink $ do
       maction <- botAction update <$> readTVarIO botModelVar
       case maction of
         Nothing     -> return ()

diff --git a/telegram-bot-simple/telegram-bot-simple.cabal b/telegram-bot-simple/telegram-bot-simple.cabal
@@ -49,6 +49,7 @@ library
   build-depends:
       aeson
     , aeson-pretty
+    , async
     , base >=4.9 && <5
     , bytestring
     , cron >=0.7.0