-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | The one supervision combinator every background loop runs under, so no loop carries a
private copy of the catch-log-backoff machinery.

Typed fault channels stay in the steps: a step receiving an @Either fault a@ from a handle
makes its own domain decision and sets its own pacing. What reaches this combinator's catch
is residue, an exception escaping some dependency's typed contract, plus whatever a step's
policy classifies 'Permanent'.
-}
module Ecluse.Core.Supervision (
    -- * The combinator
    superviseLoop,
    SupervisionPolicy (..),
    transientPolicy,
    FaultDisposition (..),

    -- * Bounded exponential backoff
    BackoffSchedule (..),
    backoffMicros,
    backgroundLoopBackoff,

    -- * Bounded retry pacing
    delayListPolicy,
) where

import Control.Retry (RetryPolicyM, RetryStatus (rsIterNumber), retryPolicy)
import Katip (KatipContext, Severity (ErrorS, WarningS), logFM, ls)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Concurrent (threadDelay)
import UnliftIO.Exception (throwIO, tryAny)

import Ecluse.Core.Text (displayExceptionT)

{- | What the supervisor does with a synchronous fault the step let escape. An asynchronous
exception is never classified, so cancellation propagates and the shutdown race always wins.
-}
data FaultDisposition
    = -- | Log at 'WarningS', back off (bounded exponential), rerun the step.
      Transient
    | -- | Rethrow: fail up to the process supervisor, taking the process down.
      Permanent
    deriving stock (FaultDisposition -> FaultDisposition -> Bool
(FaultDisposition -> FaultDisposition -> Bool)
-> (FaultDisposition -> FaultDisposition -> Bool)
-> Eq FaultDisposition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FaultDisposition -> FaultDisposition -> Bool
== :: FaultDisposition -> FaultDisposition -> Bool
$c/= :: FaultDisposition -> FaultDisposition -> Bool
/= :: FaultDisposition -> FaultDisposition -> Bool
Eq, Int -> FaultDisposition -> ShowS
[FaultDisposition] -> ShowS
FaultDisposition -> String
(Int -> FaultDisposition -> ShowS)
-> (FaultDisposition -> String)
-> ([FaultDisposition] -> ShowS)
-> Show FaultDisposition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FaultDisposition -> ShowS
showsPrec :: Int -> FaultDisposition -> ShowS
$cshow :: FaultDisposition -> String
show :: FaultDisposition -> String
$cshowList :: [FaultDisposition] -> ShowS
showList :: [FaultDisposition] -> ShowS
Show)

{- | A bounded exponential backoff, doubling from the base towards the cap as consecutive
failures mount, so a persistently-failing dependency retries at most once per cap interval.
-}
data BackoffSchedule = BackoffSchedule
    { BackoffSchedule -> Int
bsBaseMicros :: Int
    -- ^ The delay after the first failure, in microseconds.
    , BackoffSchedule -> Int
bsCapMicros :: Int
    -- ^ The ceiling the doubling saturates at, in microseconds.
    }
    deriving stock (BackoffSchedule -> BackoffSchedule -> Bool
(BackoffSchedule -> BackoffSchedule -> Bool)
-> (BackoffSchedule -> BackoffSchedule -> Bool)
-> Eq BackoffSchedule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BackoffSchedule -> BackoffSchedule -> Bool
== :: BackoffSchedule -> BackoffSchedule -> Bool
$c/= :: BackoffSchedule -> BackoffSchedule -> Bool
/= :: BackoffSchedule -> BackoffSchedule -> Bool
Eq, Int -> BackoffSchedule -> ShowS
[BackoffSchedule] -> ShowS
BackoffSchedule -> String
(Int -> BackoffSchedule -> ShowS)
-> (BackoffSchedule -> String)
-> ([BackoffSchedule] -> ShowS)
-> Show BackoffSchedule
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BackoffSchedule -> ShowS
showsPrec :: Int -> BackoffSchedule -> ShowS
$cshow :: BackoffSchedule -> String
show :: BackoffSchedule -> String
$cshowList :: [BackoffSchedule] -> ShowS
showList :: [BackoffSchedule] -> ShowS
Show)

{- | The delay before the next retry, given how many failures ran consecutively:
@base * 2^failures@, saturated at the cap.
-}
backoffMicros :: BackoffSchedule -> Int -> Int
backoffMicros :: BackoffSchedule -> Int -> Int
backoffMicros BackoffSchedule
schedule Int
consecutiveFailures =
    Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (BackoffSchedule -> Int
bsCapMicros BackoffSchedule
schedule) (BackoffSchedule -> Int
bsBaseMicros BackoffSchedule
schedule Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
consecutiveFailures Int
backoffShiftClamp))

-- The exponent clamp that keeps the doubling from overflowing before the
-- ceiling applies.
backoffShiftClamp :: Int
backoffShiftClamp :: Int
backoffShiftClamp = Int
12

{- | One loop's supervision policy. A loop classifies a fault that no retry can fix, such as
an unconfigured handle reached at runtime, as 'Permanent', and everything else as 'Transient'.
-}
data SupervisionPolicy = SupervisionPolicy
    { SupervisionPolicy -> Text
spLabel :: Text
    -- ^ Names the loop in its supervision log lines.
    , SupervisionPolicy -> SomeException -> FaultDisposition
spClassify :: SomeException -> FaultDisposition
    -- ^ Classify a synchronous fault the step let escape.
    , SupervisionPolicy -> BackoffSchedule
spBackoff :: BackoffSchedule
    -- ^ The pace for retrying transient faults. A completed step resets it.
    }

{- | The policy for a loop with no wiring fault to fail up on: every synchronous escape is
residue, logged and retried at @schedule@'s pace.
-}
transientPolicy :: Text -> BackoffSchedule -> SupervisionPolicy
transientPolicy :: Text -> BackoffSchedule -> SupervisionPolicy
transientPolicy Text
label BackoffSchedule
schedule =
    SupervisionPolicy
        { spLabel :: Text
spLabel = Text
label
        , spClassify :: SomeException -> FaultDisposition
spClassify = FaultDisposition -> SomeException -> FaultDisposition
forall a b. a -> b -> a
const FaultDisposition
Transient
        , spBackoff :: BackoffSchedule
spBackoff = BackoffSchedule
schedule
        }

{- | Run the step forever under the policy: a completed step resets the backoff and reruns at once,
since the step owns its own pacing. 'tryAny' leaves asynchronous exceptions alone, so cancellation
tears the loop down.
-}
superviseLoop :: (MonadUnliftIO m, KatipContext m) => SupervisionPolicy -> m () -> m Void
superviseLoop :: forall (m :: * -> *).
(MonadUnliftIO m, KatipContext m) =>
SupervisionPolicy -> m () -> m Void
superviseLoop SupervisionPolicy
policy m ()
step = Int -> m Void
forall {b}. Int -> m b
go Int
0
  where
    go :: Int -> m b
go Int
consecutiveFaults =
        m () -> m (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny m ()
step m (Either SomeException ())
-> (Either SomeException () -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Right () -> Int -> m b
go Int
0
            Left SomeException
fault -> case SupervisionPolicy -> SomeException -> FaultDisposition
spClassify SupervisionPolicy
policy SomeException
fault of
                FaultDisposition
Permanent -> do
                    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
ErrorS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (SupervisionPolicy -> Text
spLabel SupervisionPolicy
policy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": permanent fault, failing up: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
fault))
                    SomeException -> m b
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
fault
                FaultDisposition
Transient -> SupervisionPolicy -> Int -> SomeException -> m ()
forall (m :: * -> *).
KatipContext m =>
SupervisionPolicy -> Int -> SomeException -> m ()
warnAndBackOff SupervisionPolicy
policy Int
consecutiveFaults SomeException
fault m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> m b
go (Int
consecutiveFaults Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- A retry the loop makes for itself, so it warns. The 'Permanent' arm of 'superviseLoop' is this
-- combinator's only error, and it fails the process up.
warnAndBackOff :: (KatipContext m) => SupervisionPolicy -> Int -> SomeException -> m ()
warnAndBackOff :: forall (m :: * -> *).
KatipContext m =>
SupervisionPolicy -> Int -> SomeException -> m ()
warnAndBackOff SupervisionPolicy
policy Int
consecutiveFaults SomeException
fault = do
    let delay :: Int
delay = BackoffSchedule -> Int -> Int
backoffMicros (SupervisionPolicy -> BackoffSchedule
spBackoff SupervisionPolicy
policy) Int
consecutiveFaults
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (SupervisionPolicy -> Text
spLabel SupervisionPolicy
policy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": iteration faulted (retrying in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
delay Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"µs): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
fault))
    Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
delay

{- | The pace a background loop retries a transient fault at: one second after the first
failure, doubling to a thirty-second ceiling.
-}
backgroundLoopBackoff :: BackoffSchedule
backgroundLoopBackoff :: BackoffSchedule
backgroundLoopBackoff = BackoffSchedule{bsBaseMicros :: Int
bsBaseMicros = Int
1_000_000, bsCapMicros :: Int
bsCapMicros = Int
30_000_000}

{- | A delay list as a "Control.Retry" policy: retry @n@ waits the @n@-th delay in microseconds,
so the list's length is the retry budget. It paces a bounded run, not an endless loop.
-}
delayListPolicy :: (Monad m) => [Int] -> RetryPolicyM m
delayListPolicy :: forall (m :: * -> *). Monad m => [Int] -> RetryPolicyM m
delayListPolicy [Int]
delays = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy (\RetryStatus
rs -> [Int]
delays [Int] -> Int -> Maybe Int
forall a. [a] -> Int -> Maybe a
!!? RetryStatus -> Int
rsIterNumber RetryStatus
rs)