From 036473ab81fa4a75db8ee5c15113966c7fb5b7bb Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Thu, 17 Sep 2026 11:05:27 +0300
Subject: [PATCH] Don't catch async exceptions

---
 src/HomeAssistant/Runtime.hs            | 14 +++++++-------
 src/HomeAssistant/Runtime/Supervisor.hs |  4 ++--
 test/RuntimeSpec.hs                     | 25 ++++++++++++++++++++++++-
 3 files changed, 33 insertions(+), 10 deletions(-)

diff --git a/src/HomeAssistant/Runtime.hs b/src/HomeAssistant/Runtime.hs
index 9a1c89b..174f0b2 100644
--- a/src/HomeAssistant/Runtime.hs
+++ b/src/HomeAssistant/Runtime.hs
@@ -54,13 +54,13 @@ data Controller = forall b. Controller T.Text (HASS (Event Value) b) Bool
 
 controllers :: [Controller]
 controllers =
-  [ Controller "bedroom-presence" bedroomPresenceController False
-  , Controller "bedroom-button" bedroomButtonController False
-  , Controller "bedroom-drawer" bedroomDrawerController False
-  , Controller "bedroom-humidifier" humidifierController False
-  , Controller "school-light-controller" schoolLightController False
-  , Controller "kitchen-motion-controller" kitchenMotionController False
-  , Controller "livingroom-presence" livingroomPresenceController False
+  [ Controller "bedroom-presence" bedroomPresenceController True
+  , Controller "bedroom-button" bedroomButtonController True
+  , Controller "bedroom-drawer" bedroomDrawerController True
+  , Controller "bedroom-humidifier" humidifierController True
+  , Controller "school-light-controller" schoolLightController True
+  , Controller "kitchen-motion-controller" kitchenMotionController True
+  , Controller "livingroom-presence" livingroomPresenceController True
   , Controller "hallway-motion-controller" hallwayLightsController True
   ]
 
diff --git a/src/HomeAssistant/Runtime/Supervisor.hs b/src/HomeAssistant/Runtime/Supervisor.hs
index 13184a5..eef0f77 100644
--- a/src/HomeAssistant/Runtime/Supervisor.hs
+++ b/src/HomeAssistant/Runtime/Supervisor.hs
@@ -16,7 +16,7 @@ import Data.Void (Void)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Catch (MonadCatch, MonadMask)
 import Katip (KatipContext, logFM, ls)
-import Control.Retry (RetryStatus(..), recovering, fullJitterBackoff, capDelay)
+import Control.Retry (RetryStatus(..), recovering, fullJitterBackoff, capDelay, skipAsyncExceptions)
 import Control.Monad (when)
 import Katip.Core (Severity(..))
 
@@ -41,7 +41,7 @@ instance Exception SupervisorException
 -- restarted instead of escalated.
 supervised :: (MonadIO m, MonadCatch m, KatipContext m, MonadMask m) => Text -> m Void -> m Void
 supervised name action = checkpoint (Annotation name) $ do
-  recovering retryPolicy handlers $ \RetryStatus{rsIterNumber} -> do
+  recovering retryPolicy (skipAsyncExceptions ++ handlers) $ \RetryStatus{rsIterNumber} -> do
     when (rsIterNumber > 0) $ logFM WarningS $ ls $ "Child crashed, retry no " <> show rsIterNumber
     action
   where
diff --git a/test/RuntimeSpec.hs b/test/RuntimeSpec.hs
index 53dcdbc..1841639 100644
--- a/test/RuntimeSpec.hs
+++ b/test/RuntimeSpec.hs
@@ -1,9 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module RuntimeSpec (spec) where
 
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async, cancel, race, waitCatch)
+import Control.Exception (bracket)
+import Control.Monad (forever)
+import Control.Monad.IO.Class (liftIO)
+import HomeAssistant.Runtime.Supervisor (supervised)
+import Katip (LogEnv, closeScribes, initLogEnv, runKatipContextT)
 import Test.Hspec
 
 spec :: Spec
-spec = pure ()
+spec = describe "supervised" $ do
+  it "propagates ThreadKilled instead of retrying" $
+    withTestLogEnv $ \le -> do
+      worker <- async $ runKatipContextT le () mempty $
+        supervised "test" (liftIO (forever (threadDelay 100000)))
+      threadDelay 200000
+      cancel worker
+      result <- race (threadDelay 5000000) (waitCatch worker)
+      case result of
+        Left () -> expectationFailure
+          "supervised retried on ThreadKilled (process would hang)"
+        Right _ -> pure ()
+
+withTestLogEnv :: (LogEnv -> IO a) -> IO a
+withTestLogEnv = bracket (initLogEnv "test" "test") closeScribes
 
 -- I'm commenting out the test as that specific controller
 -- was just a dummy for seeing how the data flows (dead code)