81 lines
2.8 KiB
Haskell
81 lines
2.8 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module HomeAssistant.Runtime.Supervisor
|
|
( supervised
|
|
, Backoff(..)
|
|
, defaultBackoff
|
|
, backoffDelay
|
|
, nextAttempt
|
|
, Fatal(..)
|
|
) where
|
|
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Exception.Annotated
|
|
( Exception
|
|
, Handler (..)
|
|
, SomeException
|
|
, catches
|
|
, displayException
|
|
, throw
|
|
)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)
|
|
import Data.Void (Void)
|
|
|
|
-- | A failure that cannot be fixed by restarting; propagates out of
|
|
-- 'supervised' and terminates the process.
|
|
newtype Fatal = Fatal Text
|
|
deriving (Show)
|
|
|
|
instance Exception Fatal
|
|
|
|
data Backoff = Backoff
|
|
{ backoffBase :: NominalDiffTime -- ^ Delay before the first restart
|
|
, backoffCap :: NominalDiffTime -- ^ Maximum delay between restarts
|
|
, backoffQuiet :: NominalDiffTime -- ^ Uptime after which the delay resets
|
|
}
|
|
deriving (Eq, Show)
|
|
|
|
defaultBackoff :: Backoff
|
|
defaultBackoff = Backoff 0.1 30 30
|
|
|
|
-- | Delay before the @attempt@-th restart: doubles from base, clamped at cap.
|
|
backoffDelay :: Backoff -> Int -> NominalDiffTime
|
|
backoffDelay (Backoff base cap _) attempt = go (max 0 (attempt - 1)) base
|
|
where
|
|
go 0 d = d
|
|
go n d = go (n - 1) (min cap (d * 2))
|
|
|
|
-- | Attempt number to use after a crash that ran for the given uptime.
|
|
nextAttempt :: Backoff -> NominalDiffTime -> Int -> Int
|
|
nextAttempt (Backoff _ _ quiet) uptime attempt
|
|
| uptime >= quiet = 1
|
|
| otherwise = attempt + 1
|
|
|
|
-- | Runs the action forever, restarting it with backoff after synchronous
|
|
-- exceptions; async exceptions propagate. 'Fatal' is rethrown (crashing the
|
|
-- caller) rather than restarted. The action must never return normally and
|
|
-- must not be wrapped in checkpoints around 'Fatal'-throwing code: a
|
|
-- doubly-wrapped 'Fatal' is indistinguishable from a crash and would be
|
|
-- restarted instead of escalated.
|
|
supervised :: Text -> Backoff -> IO Void -> IO Void
|
|
supervised name backoff action = go 1
|
|
where
|
|
go attempt = do
|
|
start <- getCurrentTime
|
|
outcome <- (action >> pure (Nothing :: Maybe (Either Fatal SomeException))) `catches`
|
|
[ Handler $ \(f :: Fatal) -> pure (Just (Left f))
|
|
, Handler $ \(e :: SomeException) -> pure (Just (Right e))
|
|
]
|
|
end <- getCurrentTime
|
|
case outcome of
|
|
Nothing -> error "unreachable: supervised action returned"
|
|
Just (Left f) -> throw f
|
|
Just (Right e) -> do
|
|
putStrLn $ "[" <> T.unpack name <> "] attempt " <> show attempt <> " crashed: " <> displayException e
|
|
let delay = backoffDelay backoff attempt
|
|
putStrLn $ "[" <> T.unpack name <> "] restarting in " <> show delay
|
|
threadDelay (round (realToFrac delay * 1000000 :: Double))
|
|
go (nextAttempt backoff (diffUTCTime end start) attempt)
|