Add supervisor with backoff restarts

test/BackoffProp.hs

@@ -0,0 +1,21 @@
+module BackoffProp (spec) where
+
+import Data.Maybe (listToMaybe)
+import Data.Time (NominalDiffTime)
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import HomeAssistant.Runtime.Supervisor (Backoff (..), backoffDelay)
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.Hedgehog (hedgehog, forAll, (===))
+
+spec :: Spec
+spec = describe "backoffDelay" $
+  it "doubles from base, clamped at cap" $ hedgehog $ do
+    baseD <- forAll $ Gen.double (Range.constant 0.0001 10)
+    ratio <- forAll $ Gen.double (Range.constant 1 100)
+    let base = realToFrac baseD :: NominalDiffTime
+        cap = realToFrac (baseD * ratio) :: NominalDiffTime
+        backoff = Backoff base cap 1
+        delays = map (backoffDelay backoff) [1 .. 100 :: Int]
+    listToMaybe delays === Just (min cap base)
+    mapM_ (\(a, b) -> b === min cap (a * 2)) (zip delays (drop 1 delays))

test/Main.hs

@@ -1,12 +1,16 @@
 module Main (main) where
 
 import Test.Hspec (hspec)
+import qualified BackoffProp
 import qualified BusSpec
 import qualified ConnectionSpec
 import qualified RuntimeSpec
+import qualified SupervisorSpec
 
 main :: IO ()
 main = hspec $ do
   BusSpec.spec
   ConnectionSpec.spec
   RuntimeSpec.spec
+  SupervisorSpec.spec
+  BackoffProp.spec

test/SupervisorSpec.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module SupervisorSpec (spec) where
+
+import Control.Concurrent (newEmptyMVar, putMVar, readMVar, threadDelay)
+import Control.Concurrent.Async (async, cancel, poll, waitCatch)
+import Control.Exception (fromException)
+import Control.Exception.Annotated (AnnotatedException (..), throw)
+import Control.Monad (forever)
+import Data.IORef (atomicModifyIORef', newIORef, readIORef)
+import Data.Maybe (isJust, isNothing)
+import HomeAssistant.Runtime.Supervisor
+import Test.Hspec
+
+tinyBackoff :: Backoff
+tinyBackoff = Backoff 0.001 0.002 0.001
+
+spec :: Spec
+spec = describe "supervised" $ do
+  it "restarts a crashing action until it stays up" $ do
+    counter <- newIORef (0 :: Int)
+    up <- newEmptyMVar
+    let action = do
+          n <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
+          if n < 3
+            then ioError (userError "boom")
+            else do putMVar up (); forever (threadDelay 1000000)
+    sup <- async (supervised "test" tinyBackoff action)
+    readMVar up
+    threadDelay 50000
+    status <- poll sup
+    isNothing status `shouldBe` True
+    readIORef counter `shouldReturn` 3
+    cancel sup
+
+  it "rethrows Fatal instead of restarting" $ do
+    counter <- newIORef (0 :: Int)
+    let action = do
+          _ <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
+          throw (Fatal "auth_invalid")
+    sup <- async (supervised "test" tinyBackoff action)
+    res <- waitCatch sup
+    case res of
+      Left se -> case fromException se :: Maybe (AnnotatedException Fatal) of
+        Just _  -> pure ()
+        Nothing -> expectationFailure "expected Fatal to propagate"
+      Right _ -> expectationFailure "supervised returned"
+    threadDelay 50000
+    readIORef counter `shouldReturn` 1
+
+  it "does not restart on async exceptions" $ do
+    counter <- newIORef (0 :: Int)
+    let action = do
+          _ <- atomicModifyIORef' counter (\c -> (c + 1, c + 1))
+          forever (threadDelay 1000000)
+    sup <- async (supervised "test" tinyBackoff action)
+    threadDelay 100000
+    cancel sup
+    threadDelay 100000
+    readIORef counter `shouldReturn` 1
+    status <- poll sup
+    isJust status `shouldBe` True
+
+  describe "nextAttempt" $ do
+    it "resets after a quiet period" $
+      nextAttempt tinyBackoff 0.001 5 `shouldBe` 1
+    it "increments otherwise" $
+      nextAttempt tinyBackoff 0.0005 5 `shouldBe` 6
+
+  describe "backoffDelay" $ do
+    it "starts at base" $ backoffDelay tinyBackoff 1 `shouldBe` 0.001
+    it "doubles" $ backoffDelay tinyBackoff 2 `shouldBe` 0.002
+    it "clamps at cap" $ backoffDelay tinyBackoff 3 `shouldBe` 0.002