Don't catch async exceptions

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-presence" bedroomPresenceController True
-  , Controller "bedroom-button" bedroomButtonController False
+  , Controller "bedroom-button" bedroomButtonController True
-  , Controller "bedroom-drawer" bedroomDrawerController False
+  , Controller "bedroom-drawer" bedroomDrawerController True
-  , Controller "bedroom-humidifier" humidifierController False
+  , Controller "bedroom-humidifier" humidifierController True
-  , Controller "school-light-controller" schoolLightController False
+  , Controller "school-light-controller" schoolLightController True
-  , Controller "kitchen-motion-controller" kitchenMotionController False
+  , Controller "kitchen-motion-controller" kitchenMotionController True
-  , Controller "livingroom-presence" livingroomPresenceController False
+  , Controller "livingroom-presence" livingroomPresenceController True
   , Controller "hallway-motion-controller" hallwayLightsController True
   ]
 

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

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)