{-# 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)