74 lines
2.6 KiB
Haskell
74 lines
2.6 KiB
Haskell
{-# 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
|