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

{- | The resilience harness around the advisory package read: a per-attempt timeout, bounded retry
with backoff, and a per-rule circuit breaker, attached by 'Ecluse.Core.Rules.prepare'.

Any value the read returns resets the breaker unretried, so only a harness-observed fault advances
the breaker and returns a 'ReadFault'. 'runResilient' never throws.
-}
module Ecluse.Core.Rules.Effectful (
    -- * The resilience policy
    Resilience (..),
    EffectfulConfig (..),
    defaultEffectfulConfig,
    newBreaker,

    -- * Running a read through it
    runResilient,
    ReadFault (..),
) where

import Control.Retry (retrying)
import Data.Time (NominalDiffTime, UTCTime)
import UnliftIO (timeout, tryAny)

import Ecluse.Core.Breaker (
    Breaker,
    BreakerReporter,
    admit,
    initialBreaker,
    recordFailure,
    recordSuccess,
    reportBreakerChange,
 )
import Ecluse.Core.Rules.Types
import Ecluse.Core.Supervision (delayListPolicy)
import Ecluse.Core.Text (displayExceptionT)

-- | The resilience policy around one advisory rule's reads. Each rule holds its own breaker state.
data Resilience = Resilience
    { Resilience -> EffectfulConfig
resConfig :: EffectfulConfig
    -- ^ The per-attempt timeout, retry budget\/backoff, and breaker threshold\/cooldown.
    , Resilience -> TVar Breaker
resBreaker :: TVar Breaker
    -- ^ This rule's circuit-breaker state, shared across requests.
    , Resilience -> BreakerReporter
resBreakerReporter :: BreakerReporter
    {- ^ The observer this rule's breaker reports state transitions to
    (@ecluse.rule.breaker.state@). Inert ('Ecluse.Core.Breaker.noBreakerReporter') when unobserved.
    -}
    , Resilience -> IO UTCTime
resClock :: IO UTCTime
    {- ^ The wall clock the breaker reads for admission and cooldown, separate from the request
    snapshot 'ctxNow'. A fresh read at failure commit starts the cooldown at the failure.
    -}
    }

-- | Why the harness gave a read up. Each rule relying on it resolves this under its own alignment.
data ReadFault = ReadFault
    { ReadFault -> Transience
rfTransience :: Transience
    -- ^ Whether a retry may succeed, with the configured @Retry-After@ hint.
    , ReadFault -> Text
rfReason :: Text
    -- ^ The client-facing cause a decision carries.
    , ReadFault -> Text
rfDetail :: Text
    -- ^ The fault detail an operator reads in the outage report, never in a client message.
    }
    deriving stock (ReadFault -> ReadFault -> Bool
(ReadFault -> ReadFault -> Bool)
-> (ReadFault -> ReadFault -> Bool) -> Eq ReadFault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadFault -> ReadFault -> Bool
== :: ReadFault -> ReadFault -> Bool
$c/= :: ReadFault -> ReadFault -> Bool
/= :: ReadFault -> ReadFault -> Bool
Eq, Int -> ReadFault -> ShowS
[ReadFault] -> ShowS
ReadFault -> String
(Int -> ReadFault -> ShowS)
-> (ReadFault -> String)
-> ([ReadFault] -> ShowS)
-> Show ReadFault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadFault -> ShowS
showsPrec :: Int -> ReadFault -> ShowS
$cshow :: ReadFault -> String
show :: ReadFault -> String
$cshowList :: [ReadFault] -> ShowS
showList :: [ReadFault] -> ShowS
Show)

-- | Run one read under its 'Resilience' policy: the read's value, or why the harness gave it up.
runResilient :: Resilience -> IO a -> IO (Either ReadFault a)
runResilient :: forall a. Resilience -> IO a -> IO (Either ReadFault a)
runResilient Resilience
res IO a
act = do
    admitted <- Resilience -> UTCTime -> IO Bool
admitProbe Resilience
res (UTCTime -> IO Bool) -> IO UTCTime -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Resilience -> IO UTCTime
resClock Resilience
res
    if not admitted
        then
            -- Breaker open and still cooling down: fast-fail without running the read, the cheap
            -- path a sustained outage stays on.
            pure (Left (ReadFault (transientCause (resConfig res)) breakerOpen breakerOpen))
        else do
            result <- attemptWithRetry res act
            -- Read the clock again after the retry run. An exhausted result then starts its
            -- cooldown at the failure commit, not at the start of the run.
            settledNow <- resClock res
            settleOutcome res settledNow result
  where
    breakerOpen :: Text
breakerOpen = Text
"the rule source circuit breaker is open"

-- Settle a finished retry run against the breaker. A value resets it, an exhausted run trips it.
settleOutcome :: Resilience -> UTCTime -> Either (Transience, Text) a -> IO (Either ReadFault a)
settleOutcome :: forall a.
Resilience
-> UTCTime
-> Either (Transience, Text) a
-> IO (Either ReadFault a)
settleOutcome Resilience
res UTCTime
now = \case
    Right a
value -> do
        Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res Breaker -> Breaker
recordSuccess
        Either ReadFault a -> IO (Either ReadFault a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either ReadFault a
forall a b. b -> Either a b
Right a
value)
    Left (Transience
transience, Text
detail) -> do
        Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res (EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure (Resilience -> EffectfulConfig
resConfig Resilience
res) UTCTime
now)
        Either ReadFault a -> IO (Either ReadFault a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadFault -> Either ReadFault a
forall a b. a -> Either a b
Left (Transience -> Text -> Text -> ReadFault
ReadFault Transience
transience Text
"the rule could not be evaluated" Text
detail))

-- Attempt the read under the per-attempt timeout until the retry budget is spent. Only a fault retries.
attemptWithRetry :: Resilience -> IO a -> IO (Either (Transience, Text) a)
attemptWithRetry :: forall a. Resilience -> IO a -> IO (Either (Transience, Text) a)
attemptWithRetry Resilience
res IO a
act =
    RetryPolicyM IO
-> (RetryStatus -> Either (Transience, Text) a -> IO Bool)
-> (RetryStatus -> IO (Either (Transience, Text) a))
-> IO (Either (Transience, Text) a)
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying ([Int] -> RetryPolicyM IO
forall (m :: * -> *). Monad m => [Int] -> RetryPolicyM m
delayListPolicy (EffectfulConfig -> [Int]
ecBackoff (Resilience -> EffectfulConfig
resConfig Resilience
res))) RetryStatus -> Either (Transience, Text) a -> IO Bool
forall {f :: * -> *} {p} {a} {b}.
Applicative f =>
p -> Either a b -> f Bool
shouldRetry (\RetryStatus
_ -> Resilience -> IO a -> IO (Either (Transience, Text) a)
forall a. Resilience -> IO a -> IO (Either (Transience, Text) a)
attemptOnce Resilience
res IO a
act)
  where
    shouldRetry :: p -> Either a b -> f Bool
shouldRetry p
_ = Bool -> f Bool
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> f Bool) -> (Either a b -> Bool) -> Either a b -> f Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either a b -> Bool
forall a b. Either a b -> Bool
isLeft

-- One attempt under the timeout. Only a throw or a timeout retries and feeds the breaker.
attemptOnce :: Resilience -> IO a -> IO (Either (Transience, Text) a)
attemptOnce :: forall a. Resilience -> IO a -> IO (Either (Transience, Text) a)
attemptOnce Resilience
res IO a
act = do
    result <- IO (Maybe a) -> IO (Either SomeException (Maybe a))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (Int -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout (EffectfulConfig -> Int
ecTimeout (Resilience -> EffectfulConfig
resConfig Resilience
res)) IO a
act)
    pure $ case result of
        Left SomeException
e -> (Transience, Text) -> Either (Transience, Text) a
forall a b. a -> Either a b
Left (Transience
transient, Text
"the rule threw: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptionT SomeException
e)
        Right Maybe a
Nothing -> (Transience, Text) -> Either (Transience, Text) a
forall a b. a -> Either a b
Left (Transience
transient, Text
"the attempt timed out")
        Right (Just a
value) -> a -> Either (Transience, Text) a
forall a b. b -> Either a b
Right a
value
  where
    transient :: Transience
transient = EffectfulConfig -> Transience
transientCause (Resilience -> EffectfulConfig
resConfig Resilience
res)

transientCause :: EffectfulConfig -> Transience
transientCause :: EffectfulConfig -> Transience
transientCause EffectfulConfig
cfg = Maybe RetryAfter -> Transience
WillResolve (EffectfulConfig -> Maybe RetryAfter
ecRetryAfter EffectfulConfig
cfg)

-- Commits what 'Ecluse.Core.Breaker.admit' decided, so the move out of 'Open' takes effect.
admitProbe :: Resilience -> UTCTime -> IO Bool
admitProbe :: Resilience -> UTCTime -> IO Bool
admitProbe Resilience
res UTCTime
now = do
    (permitted, old, new) <- STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker))
-> STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker)
forall a b. (a -> b) -> a -> b
$ do
        st <- TVar Breaker -> STM Breaker
forall a. TVar a -> STM a
readTVar (Resilience -> TVar Breaker
resBreaker Resilience
res)
        let (p, st') = admit now st
        writeTVar (resBreaker res) st'
        pure (p, st, st')
    reportBreakerChange (resBreakerReporter res) old new
    pure permitted

-- Reads the breaker before and after in one transaction, so the report reflects exactly the
-- transition that committed.
commitBreaker :: Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker :: Resilience -> (Breaker -> Breaker) -> IO ()
commitBreaker Resilience
res Breaker -> Breaker
step = do
    (old, new) <- STM (Breaker, Breaker) -> IO (Breaker, Breaker)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Breaker, Breaker) -> IO (Breaker, Breaker))
-> STM (Breaker, Breaker) -> IO (Breaker, Breaker)
forall a b. (a -> b) -> a -> b
$ do
        st <- TVar Breaker -> STM Breaker
forall a. TVar a -> STM a
readTVar (Resilience -> TVar Breaker
resBreaker Resilience
res)
        let st' = Breaker -> Breaker
step Breaker
st
        writeTVar (resBreaker res) st'
        pure (st, st')
    reportBreakerChange (resBreakerReporter res) old new

tripOnFailure :: EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure :: EffectfulConfig -> UTCTime -> Breaker -> Breaker
tripOnFailure EffectfulConfig
cfg = Int -> NominalDiffTime -> UTCTime -> Breaker -> Breaker
recordFailure (EffectfulConfig -> Int
ecBreakerThreshold EffectfulConfig
cfg) (EffectfulConfig -> NominalDiffTime
ecBreakerCooldown EffectfulConfig
cfg)

{- | The resilience knobs around an advisory rule's package read. The breaker's timing reads
'resClock' fresh at failure commit, not the request snapshot 'ctxNow'.
-}
data EffectfulConfig = EffectfulConfig
    { EffectfulConfig -> Int
ecTimeout :: Int
    {- ^ The per-attempt timeout in microseconds. The harness treats an attempt that
    does not return within it as a failure, a transient and retryable cause.
    -}
    , EffectfulConfig -> [Int]
ecBackoff :: [Int]
    {- ^ The delay in microseconds before each retry, one entry per retry. Its length is
    the retry budget, so @[]@ admits no retry at all.
    -}
    , EffectfulConfig -> Int
ecBreakerThreshold :: Int
    -- ^ Consecutive exhausted reads that trip the breaker, one read per request.
    , EffectfulConfig -> NominalDiffTime
ecBreakerCooldown :: NominalDiffTime
    {- ^ How long the breaker stays open (fast-failing the rule) before it allows a
    single half-open probe to test recovery.
    -}
    , EffectfulConfig -> Maybe RetryAfter
ecRetryAfter :: Maybe RetryAfter
    {- ^ The @Retry-After@ hint a faulted evaluation carries back to the client.
    'Nothing' sends no hint.
    -}
    }

{- | A 2-second per-attempt timeout and two retries, at 100ms then 250ms. The breaker trips after
5 consecutive failures and cools for 30 seconds.
-}
defaultEffectfulConfig :: EffectfulConfig
defaultEffectfulConfig :: EffectfulConfig
defaultEffectfulConfig =
    EffectfulConfig
        { ecTimeout :: Int
ecTimeout = Int
2_000_000
        , ecBackoff :: [Int]
ecBackoff = [Int
100_000, Int
250_000]
        , ecBreakerThreshold :: Int
ecBreakerThreshold = Int
5
        , ecBreakerCooldown :: NominalDiffTime
ecBreakerCooldown = NominalDiffTime
30
        , ecRetryAfter :: Maybe RetryAfter
ecRetryAfter = Maybe RetryAfter
forall a. Maybe a
Nothing
        }

-- | A fresh, healthy breaker (no failures recorded) in a new 'TVar'.
newBreaker :: IO (TVar Breaker)
newBreaker :: IO (TVar Breaker)
newBreaker = Breaker -> IO (TVar Breaker)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Breaker
initialBreaker