Fix supervisor and proper rate limiting

test/BackoffProp.hs

@@ -1,21 +0,0 @@
-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/ConnectionSpec.hs

@@ -9,7 +9,7 @@ import Data.Text (Text)
 import Data.Time (UTCTime (..), utc)
 import Data.UUID (fromString)
 import HomeAssistant.Controller (Service (..), Target(..))
-import HomeAssistant.Runtime.Connection (encodeService, dedupeBatch, isTriggerEvent)
+import HomeAssistant.Runtime.Connection (encodeService, isTriggerEvent)
 import Test.Hspec
 
 spec :: Spec
@@ -44,34 +44,6 @@ spec = do
     it "is false when there is no type" $
       isTriggerEvent (object ["id" .= (1 :: Int)]) `shouldBe` False
 
-  describe "dedupeBatch" $ do
-    it "collapses identical calls to one" $
-      let batch = [ (req 1, lightOn [AreaId "x"])
-                  , (req 2, lightOn [AreaId "x"])
-                  , (req 3, lightOn [AreaId "x"])
-                  ]
-      in dedupeBatch batch `shouldBe` [(req 3, lightOn [AreaId "x"])]
-
-    it "keeps same-target different-service calls separate" $
-      let batch = [ (req 1, lightOn  [AreaId "x"])
-                  , (req 2, lightOff [AreaId "x"])
-                  ]
-          result = dedupeBatch batch
-      in length result `shouldBe` 2
-
-    it "newest call wins for the same key" $
-      let batch = [ (req 1, lightOn [AreaId "x"])
-                  , (req 2, lightOn [AreaId "x"])
-                  , (req 3, lightOn [AreaId "x"])
-                  ]
-      in map requestTraceId (map fst (dedupeBatch batch)) `shouldBe`
-           [fromJust (fromString "00000000-0000-0000-0000-000000000003")]
-
-    it "treats target lists in different order as the same key" $
-      let batch = [ (req 1, lightOn [EntityId "a", EntityId "b"])
-                  , (req 2, lightOn [EntityId "b", EntityId "a"])
-                  ]
-      in length (dedupeBatch batch) `shouldBe` 1
 
 req :: Int -> Request
 req n = Request (UTCTime (toEnum 0) (fromIntegral (0 :: Int))) utc

test/Main.hs

@@ -3,14 +3,12 @@ module Main (main) where
 import Test.Hspec (hspec)
 import qualified AFRPLawsSpec
 import qualified AFRPSpec
-import qualified BackoffProp
 import qualified BedroomSpec
 import qualified BusSpec
 import qualified ConnectionSpec
 import qualified GraphingSpec
 import qualified MetricsSpec
 import qualified RuntimeSpec
-import qualified SupervisorSpec
 
 main :: IO ()
 main = hspec $ do
@@ -22,5 +20,3 @@ main = hspec $ do
   GraphingSpec.spec
   MetricsSpec.spec
   RuntimeSpec.spec
-  SupervisorSpec.spec
-  BackoffProp.spec

test/SupervisorSpec.hs

@@ -1,73 +0,0 @@
-{-# 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