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

{- | One supervision combinator for every background loop: rerun a step forever,
absorbing transient faults with a bounded exponential backoff and failing
permanent ones up to the process supervisor.

The proxy's background loops (the mirror worker's poll-and-process, the
enqueue-buffer drain, the advisory sync tasks, Pilot's export cycle) all share
one robustness contract: a __transient__ fault (a dependency outage the next
iteration might clear) is logged and retried at a bounded rate, a __permanent__
fault (a wiring error no retry can fix) fails up so the process exits loudly,
and __cancellation__ (the shutdown race tearing the loop down) passes through
untouched. This module is that contract, written once, so each loop's file
carries only its step and its policy rather than a private copy of the
catch-log-backoff machinery.

The typed fault channels stay in the steps: a step that receives an
@Either fault a@ from a handle makes its own domain decision (its own pacing
included), and what reaches this combinator's catch is __residue__ -- an
exception escaping some dependency's typed contract -- plus whichever faults a
step's policy deliberately classifies 'Permanent'.
-}
module Ecluse.Core.Supervision (
    -- * The combinator
    superviseLoop,
    SupervisionPolicy (..),
    FaultDisposition (..),

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

import Katip (KatipContext, Severity (ErrorS), 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.
Asynchronous exceptions are never classified: cancellation propagates untouched,
so the shutdown race can always tear a supervised loop down.
-}
data FaultDisposition
    = -- | Log at 'ErrorS', 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 is retried at
most once per cap interval. A base equal to the cap is a fixed-interval retry.
-}
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 have run
consecutively: @base * 2^failures@, saturated at the cap. The exponent is
clamped so the doubling cannot overflow before the ceiling applies.
-}
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: the label its log lines carry, how a
synchronous fault is classified, and the backoff its transient faults pace at.
Loops with wiring faults that no retry can fix (an unconfigured handle reached
at runtime) classify those 'Permanent'; everything else defaults '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 transient faults are retried at (reset by a completed step).
    }

{- | Run the step forever under the policy: a completed step resets the backoff
and reruns at once (the step owns its own pacing -- poll waits and cycle delays
live inside it); a synchronous fault classifies through the policy ('Transient'
logs and backs off, 'Permanent' rethrows); an asynchronous exception is never
caught ('tryAny'), so cancellation tears the loop down like any other thread.
The 'Void' return makes "this loop never returns" a fact of the type.
-}
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 -> 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
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
": 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
                    Int -> m b
go (Int
consecutiveFaults Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)