From f1ab9d4e7d54a2ef658291f95bd8f11749d04234 Mon Sep 17 00:00:00 2001
From: Andrey Prokopenko <persiantiger@yandex.ru>
Date: Mon, 5 Feb 2024 20:56:30 +0100
Subject: [PATCH] Rethrow exceptions via async + link

---
 .../src/Telegram/Bot/Simple/BotApp.hs         |  3 +--
 .../Telegram/Bot/Simple/BotApp/Internal.hs    | 23 +++++++++++++++----
 .../src/Telegram/Bot/Simple/Webhook.hs        |  3 +--
 telegram-bot-simple/telegram-bot-simple.cabal |  1 +
 4 files changed, 22 insertions(+), 8 deletions(-)

diff --git a/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp.hs b/telegram-bot-simple/src/Telegram/Bot/Simple/BotApp.hs
index 0200dfb..aed5d4f 100644
--- 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
index c4ed800..070243c 100644
--- 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
index 018df23..113b494 100644
--- 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
index 0e5be01..0260073 100644
--- 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