Add supervisor with backoff restarts

src/HomeAssistant/Runtime/Supervisor.hs

@@ -0,0 +1,80 @@
+{-# 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 (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))
+        ]
+      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 <> "s"
+          threadDelay (round (realToFrac delay * 1000000 :: Double))
+          end <- getCurrentTime
+          go (nextAttempt backoff (diffUTCTime end start) attempt)