Add supervisor with backoff restarts

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