{- | The implementation behind 'Ecluse.Core.Credential.Refresh'. This module exposes
the provider's innards -- including the 'refreshingProviderWith' test hook -- that
the curated public module deliberately keeps hidden. Importing it opts out of the
module's stability promises (the same convention @text@ and @bytestring@ use for
their @.Internal@ modules); production code imports 'Ecluse.Core.Credential.Refresh'
instead. The policy itself is documented on the public module's header.
-}
module Ecluse.Core.Credential.Refresh.Internal (
    -- * Configuration
    RefreshConfig (..),
    defaultRefreshConfig,

    -- * The refreshing provider
    refreshingProvider,
    refreshingProviderWith,

    -- * Telemetry reporters
    RefreshReporter (..),
    noRefreshReporter,
    CredentialReporters (..),
    noCredentialReporters,

    -- * Failure
    CredentialError (..),

    -- * State and pure\/transition helpers (exposed for direct testing)
    CacheState (..),
    ServeAction (..),
    decide,
    refreshDueAt,
    onMintSuccess,
    onMintFailure,
    admitMint,
    releaseSingleFlight,
) where

import Control.Concurrent.STM (retry)
import Data.Time (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)
import UnliftIO (asyncWithUnmask, throwIO, try)
import UnliftIO.Exception (mask)

import Ecluse.Core.Breaker (
    Breaker,
    BreakerReporter,
    admit,
    initialBreaker,
    noBreakerReporter,
    recordFailure,
    recordSuccess,
    reportBreakerChange,
 )
import Ecluse.Core.Credential (AuthToken (..), CredentialProvider (..))
import Ecluse.Core.InFlight (guardInFlight)

{- | A failure surfaced from the credential-refresh layer.

The runtime case is 'BreakerOpen': there is no valid token to serve and a fresh
mint is unavailable. A still-valid token is always served instead (the refresh
fails silently in the background), so this is reached only on the expired-token
path. Whether reaching it can affect a client serve depends on what the credential
backs: never under the default @passthrough@ strategy (mirror-write only), but it
can where a provider sits on the private-upstream read (see the module header).

The degenerate case is 'Unconfigured': a 'RefreshConfig' from
'defaultRefreshConfig' was used without supplying an effectful leaf, a wiring
fault the default raises loudly rather than silently serving nothing.
-}
data CredentialError
    = {- | The token has expired and the mint circuit breaker is open, so no mint
      is attempted; the caller must back off and retry later.
      -}
      BreakerOpen
    | {- | A 'RefreshConfig' built from 'defaultRefreshConfig' was used without
      supplying the named effectful leaf ('rcMint' or 'rcClock'). A wiring fault,
      not a runtime token condition.
      -}
      Unconfigured Text
    | {- | The minted token is already expired. This usually indicates severe
      clock skew between the local machine and the cloud provider, or a
      misconfigured backend. It is treated as a mint failure.
      -}
      MintedTokenAlreadyExpired
    deriving stock (CredentialError -> CredentialError -> Bool
(CredentialError -> CredentialError -> Bool)
-> (CredentialError -> CredentialError -> Bool)
-> Eq CredentialError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CredentialError -> CredentialError -> Bool
== :: CredentialError -> CredentialError -> Bool
$c/= :: CredentialError -> CredentialError -> Bool
/= :: CredentialError -> CredentialError -> Bool
Eq, Int -> CredentialError -> ShowS
[CredentialError] -> ShowS
CredentialError -> String
(Int -> CredentialError -> ShowS)
-> (CredentialError -> String)
-> ([CredentialError] -> ShowS)
-> Show CredentialError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CredentialError -> ShowS
showsPrec :: Int -> CredentialError -> ShowS
$cshow :: CredentialError -> String
show :: CredentialError -> String
$cshowList :: [CredentialError] -> ShowS
showList :: [CredentialError] -> ShowS
Show)

instance Exception CredentialError

{- | An observer of a refresh attempt's outcome, so the composition root can record
the @ecluse.credential.*@ signals without the refresh policy depending on telemetry. A
successful mint reports the freshly minted token's remaining lifetime; a failed mint
reports the still-cached token's remaining lifetime (so a sustained outage shows the
gauge decaying as repeated failures resample the ageing token). The seconds are
'Nothing' for a token with no expiry. 'noRefreshReporter' is the inert default.
-}
data RefreshReporter = RefreshReporter
    { RefreshReporter -> Maybe Int -> IO ()
onRefreshSucceeded :: Maybe Int -> IO ()
    -- ^ A mint succeeded; the new token's remaining lifetime in whole seconds.
    , RefreshReporter -> Maybe Int -> IO ()
onRefreshFailed :: Maybe Int -> IO ()
    -- ^ A mint failed; the still-cached token's remaining lifetime in whole seconds.
    }

-- | The inert refresh reporter: records nothing on either outcome.
noRefreshReporter :: RefreshReporter
noRefreshReporter :: RefreshReporter
noRefreshReporter = (Maybe Int -> IO ()) -> (Maybe Int -> IO ()) -> RefreshReporter
RefreshReporter (IO () -> Maybe Int -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass) (IO () -> Maybe Int -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass)

{- | The telemetry observers a refreshing provider records through: the mint circuit
breaker's state changes and each refresh attempt's outcome. Bundled so the composition
root passes one value to the provider constructors; 'noCredentialReporters' is the inert
default the provider carries when telemetry is off (or before the substrate exists).
-}
data CredentialReporters = CredentialReporters
    { CredentialReporters -> BreakerReporter
crBreakerReporter :: BreakerReporter
    -- ^ Observes the mint breaker's state transitions (@ecluse.rule.breaker.state@).
    , CredentialReporters -> RefreshReporter
crRefreshReporter :: RefreshReporter
    -- ^ Observes each refresh outcome (@ecluse.credential.refresh@ \/ @.token.ttl@).
    }

-- | Inert observers for both signals: the provider records nothing.
noCredentialReporters :: CredentialReporters
noCredentialReporters :: CredentialReporters
noCredentialReporters = BreakerReporter -> RefreshReporter -> CredentialReporters
CredentialReporters BreakerReporter
noBreakerReporter RefreshReporter
noRefreshReporter

{- | How a 'refreshingProvider' mints, times, and protects its token. The two
effectful leaves ('rcMint', 'rcClock') and the jitter source ('rcJitter') are
injected so the whole policy is deterministic under test; the rest are policy
knobs with sensible defaults in 'defaultRefreshConfig'.
-}
data RefreshConfig = RefreshConfig
    { RefreshConfig -> IO AuthToken
rcMint :: IO AuthToken
    {- ^ The per-cloud token mint -- the __only__ part that touches a network. A
    backend supplies just this leaf; everything else is cloud-agnostic.
    -}
    , RefreshConfig -> IO UTCTime
rcClock :: IO UTCTime
    {- ^ The clock the policy reads. Injected so refresh timing is testable
    without real time passing.
    -}
    , RefreshConfig -> IO Double
rcJitter :: IO Double
    {- ^ A jitter fraction in @[0, 1)@, sampled once per token, that pulls the
    refresh instant /earlier/ to desynchronise a cohort of instances so they
    do not all refresh at the same moment.
    -}
    , RefreshConfig -> Double
rcRefreshAt :: Double
    {- ^ The fraction of a token's lifetime at which to refresh, before jitter
    (the ~80% point). Clamped into @[0, 1]@.
    -}
    , RefreshConfig -> NominalDiffTime
rcRefreshFloor :: NominalDiffTime
    {- ^ A hard floor: never schedule the refresh later than this many seconds
    before expiry, so a token with a very short lifetime is still refreshed
    ahead of its deadline rather than served right up to it.
    -}
    , RefreshConfig -> Int
rcBreakerThreshold :: Int
    -- ^ Consecutive mint failures that trip the circuit breaker.
    , RefreshConfig -> NominalDiffTime
rcBreakerCooldown :: NominalDiffTime
    {- ^ How long the breaker stays open (fast-failing mints) before a single
    half-open probe is allowed to test recovery.
    -}
    , RefreshConfig -> BreakerReporter
rcBreakerReporter :: BreakerReporter
    {- ^ The observer the mint breaker reports its state transitions to. Inert by
    default ('noBreakerReporter'); the composition root installs the live one.
    -}
    , RefreshConfig -> RefreshReporter
rcRefreshReporter :: RefreshReporter
    {- ^ The observer each refresh attempt's outcome is reported to. Inert by default
    ('noRefreshReporter'); the composition root installs the live one.
    -}
    }

{- | Sensible defaults for the policy knobs. The caller must still supply the
effectful leaves -- 'rcMint' and 'rcClock' default to a mint\/clock that always
fails, so a provider built without wiring them up fails loudly rather than
silently serving nothing.

* refresh at 80% of lifetime (no jitter by default; 'rcJitter' may pull it earlier);
* a 30-second floor before expiry;
* breaker trips after 5 consecutive failures, cooling down for 60 seconds.
-}
defaultRefreshConfig :: RefreshConfig
defaultRefreshConfig :: RefreshConfig
defaultRefreshConfig =
    RefreshConfig
        { rcMint :: IO AuthToken
rcMint = Text -> IO AuthToken
forall a. Text -> IO a
unconfigured Text
"rcMint"
        , rcClock :: IO UTCTime
rcClock = Text -> IO UTCTime
forall a. Text -> IO a
unconfigured Text
"rcClock"
        , rcJitter :: IO Double
rcJitter = Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0
        , rcRefreshAt :: Double
rcRefreshAt = Double
0.8
        , rcRefreshFloor :: NominalDiffTime
rcRefreshFloor = NominalDiffTime
30
        , rcBreakerThreshold :: Int
rcBreakerThreshold = Int
5
        , rcBreakerCooldown :: NominalDiffTime
rcBreakerCooldown = NominalDiffTime
60
        , rcBreakerReporter :: BreakerReporter
rcBreakerReporter = BreakerReporter
noBreakerReporter
        , rcRefreshReporter :: RefreshReporter
rcRefreshReporter = RefreshReporter
noRefreshReporter
        }
  where
    unconfigured :: Text -> IO a
    unconfigured :: forall a. Text -> IO a
unconfigured Text
field = CredentialError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text -> CredentialError
Unconfigured Text
field)

{- | The mutable state of a refreshing provider: the cached token, when its
proactive refresh is due, the single-flight flag, and the breaker.
-}
data CacheState = CacheState
    { CacheState -> AuthToken
csToken :: AuthToken
    -- ^ The token currently served.
    , CacheState -> Maybe UTCTime
csRefreshDue :: Maybe UTCTime
    {- ^ When a proactive background refresh should fire; 'Nothing' for a token
    with no expiry (it never refreshes).
    -}
    , CacheState -> Bool
csRefreshing :: Bool
    -- ^ Whether a mint is in flight (the single-flight flag).
    , CacheState -> Breaker
csBreaker :: Breaker
    -- ^ The circuit-breaker state.
    }

{- | Build a 'CredentialProvider' that caches a token and refreshes it per the
'RefreshConfig' policy (see the module header). Mints once eagerly to seed the
cache, so a provider that cannot mint at all fails here at construction rather
than on the first request; thereafter 'currentToken' serves the cache and
refreshes behind it.
-}
refreshingProvider :: RefreshConfig -> IO CredentialProvider
refreshingProvider :: RefreshConfig -> IO CredentialProvider
refreshingProvider = IO () -> RefreshConfig -> IO CredentialProvider
refreshingProviderWith (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{- | As 'refreshingProvider', but with a hook run on the serving thread at the
single-flight claim → mint-runner handoff: the interruptible window between the
STM transaction committing the claim and the mint runner installing the scope
that releases it. It exists only so a test can deterministically park a serving
thread in that window and cancel it there; production always passes @pure ()@ via
'refreshingProvider'.
-}
refreshingProviderWith :: IO () -> RefreshConfig -> IO CredentialProvider
refreshingProviderWith :: IO () -> RefreshConfig -> IO CredentialProvider
refreshingProviderWith IO ()
afterClaim RefreshConfig
cfg = do
    now <- RefreshConfig -> IO UTCTime
rcClock RefreshConfig
cfg
    token <- rcMint cfg
    due <- refreshDueAt cfg now token
    stateVar <- newTVarIO (CacheState token due False initialBreaker)
    pure CredentialProvider{currentToken = serve afterClaim cfg stateVar}

{- Serve the current token, scheduling a background refresh or -- only when the
token has expired -- minting synchronously. The decision is made in one STM
transaction so single-flight holds across a concurrent cohort.

The claim of the single-flight flag (inside 'decide') and the run that releases it
are kept in __one masked scope__: 'mask' holds async exceptions off the pure handoff
between the STM commit and 'guardInFlight' (which owns the release), so a cancellation
\/ timeout cannot land in the gap and orphan the flag (which would wedge every later
expired caller on the 'decide' 'retry'). The mint work runs under @restore@ (and a
proactive refresh under the forked child's unmask), so it stays interruptible -- the
flag is simply guaranteed to have an owner first. The refresher's waiters re-decide
against the freed flag, not on a result promise, so 'guardInFlight's orphan hand-off
is a no-op here -- the release is the whole signal. The @afterClaim@ hook marks exactly
this window for a test (see 'refreshingProviderWith'); it is @pure ()@ in production.
-}
serve :: IO () -> RefreshConfig -> TVar CacheState -> IO AuthToken
serve :: IO () -> RefreshConfig -> TVar CacheState -> IO AuthToken
serve IO ()
afterClaim RefreshConfig
cfg TVar CacheState
stateVar = ((forall a. IO a -> IO a) -> IO AuthToken) -> IO AuthToken
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. IO a -> IO a) -> IO AuthToken) -> IO AuthToken)
-> ((forall a. IO a -> IO a) -> IO AuthToken) -> IO AuthToken
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    now <- RefreshConfig -> IO UTCTime
rcClock RefreshConfig
cfg
    action <- atomically (decide stateVar now)
    case action of
        ServeCached AuthToken
token -> AuthToken -> IO AuthToken
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthToken
token
        ServeAndRefresh AuthToken
token -> do
            -- Fire-and-forget: the refresh runs in the background and the caller
            -- gets the still-valid cached token immediately. The refresh catches its
            -- own failures, so the discarded 'Async' can never surface one. The flag
            -- was claimed under 'mask'; forking is not interruptible, so the releasing
            -- child is installed before this thread can be interrupted again. The child
            -- runs unmasked, so the background mint stays cancellable, and 'guardInFlight'
            -- releases the flag on the child's every exit.
            _ <-
                ((forall a. IO a -> IO a) -> IO ()) -> IO (Async ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
((forall b. m b -> m b) -> m a) -> m (Async a)
asyncWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO (Async ()))
-> ((forall a. IO a -> IO a) -> IO ()) -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
                    (IO () -> IO ())
-> (SomeException -> IO ()) -> IO () -> IO () -> IO ()
forall a.
(IO a -> IO a) -> (SomeException -> IO ()) -> IO () -> IO a -> IO a
guardInFlight IO () -> IO ()
forall a. IO a -> IO a
unmask SomeException -> IO ()
noWaiter (TVar CacheState -> IO ()
releaseSingleFlight TVar CacheState
stateVar) (IO ()
afterClaim IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefreshConfig -> TVar CacheState -> IO ()
backgroundRefresh RefreshConfig
cfg TVar CacheState
stateVar)
            pure token
        ServeAction
MintNow ->
            -- The flag was claimed under 'mask'; 'guardInFlight' releases it on every
            -- exit and runs the synchronous mint under @restore@ so it stays cancellable.
            (IO AuthToken -> IO AuthToken)
-> (SomeException -> IO ())
-> IO ()
-> IO AuthToken
-> IO AuthToken
forall a.
(IO a -> IO a) -> (SomeException -> IO ()) -> IO () -> IO a -> IO a
guardInFlight IO AuthToken -> IO AuthToken
forall a. IO a -> IO a
restore SomeException -> IO ()
noWaiter (TVar CacheState -> IO ()
releaseSingleFlight TVar CacheState
stateVar) (IO ()
afterClaim IO () -> IO AuthToken -> IO AuthToken
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RefreshConfig -> TVar CacheState -> IO AuthToken
mintSynchronously RefreshConfig
cfg TVar CacheState
stateVar)
  where
    -- The refresher's waiters re-decide against the freed flag (the 'decide' STM
    -- retry), not on a result promise, so there is nothing for the orphan hand-off to
    -- unblock -- releasing the flag is the whole signal.
    noWaiter :: SomeException -> IO ()
    noWaiter :: SomeException -> IO ()
noWaiter = IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- | The single-flight decision over the current cache state, made atomically so it
holds across a concurrent cohort: serve the still-valid token, claim the flag and
route to a background refresh when one is due, or -- when the token has expired --
either claim the flag and mint synchronously or, if a mint is already in flight,
'retry' (block) until it lands rather than launching a second. The flag claim
happens here, in the transaction, so at most one mint is ever launched; the
claiming caller is responsible for releasing it (see 'serve' \/ 'releaseSingleFlight').
-}
decide :: TVar CacheState -> UTCTime -> STM ServeAction
decide :: TVar CacheState -> UTCTime -> STM ServeAction
decide TVar CacheState
stateVar UTCTime
now = do
    st <- TVar CacheState -> STM CacheState
forall a. TVar a -> STM a
readTVar TVar CacheState
stateVar
    if tokenValid now (csToken st)
        then
            if refreshNeeded now st && not (csRefreshing st)
                then do
                    writeTVar stateVar st{csRefreshing = True}
                    pure (ServeAndRefresh (csToken st))
                else pure (ServeCached (csToken st))
        else -- Expired. If a refresh is already in flight, wait for it (STM
        -- retry) rather than launching a second mint, then re-decide.
            if csRefreshing st
                then retry
                else do
                    writeTVar stateVar st{csRefreshing = True}
                    pure MintNow

-- | What a 'serve'\/'decide' decision resolves to.
data ServeAction
    = -- | The cached token is valid and no refresh is due: serve it.
      ServeCached AuthToken
    | -- | Valid but past the refresh threshold: serve it, refresh in background.
      ServeAndRefresh AuthToken
    | -- | Expired: the caller must mint synchronously (the slow path).
      MintNow
    deriving stock (ServeAction -> ServeAction -> Bool
(ServeAction -> ServeAction -> Bool)
-> (ServeAction -> ServeAction -> Bool) -> Eq ServeAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServeAction -> ServeAction -> Bool
== :: ServeAction -> ServeAction -> Bool
$c/= :: ServeAction -> ServeAction -> Bool
/= :: ServeAction -> ServeAction -> Bool
Eq, Int -> ServeAction -> ShowS
[ServeAction] -> ShowS
ServeAction -> String
(Int -> ServeAction -> ShowS)
-> (ServeAction -> String)
-> ([ServeAction] -> ShowS)
-> Show ServeAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServeAction -> ShowS
showsPrec :: Int -> ServeAction -> ShowS
$cshow :: ServeAction -> String
show :: ServeAction -> String
$cshowList :: [ServeAction] -> ShowS
showList :: [ServeAction] -> ShowS
Show)

{- The background refresh: if the breaker admits a mint, attempt it and fold
the result into the cache; otherwise (breaker open) skip it. Never throws -- a
failure leaves the still-valid token in place and advances the breaker, and a
suppressed refresh just keeps serving the cached token, so the request hot path is
unaffected either way. The single-flight flag is released by the 'guardInFlight' that
wraps this run (see 'serve'), not here, so it clears on every exit including an async
cancel.
-}
backgroundRefresh :: RefreshConfig -> TVar CacheState -> IO ()
backgroundRefresh :: RefreshConfig -> TVar CacheState -> IO ()
backgroundRefresh RefreshConfig
cfg TVar CacheState
stateVar = do
    now <- RefreshConfig -> IO UTCTime
rcClock RefreshConfig
cfg
    permitted <- gatedMint cfg stateVar now
    when permitted $ do
        result <- try (rcMint cfg)
        now' <- rcClock cfg
        case result of
            Right AuthToken
token | UTCTime -> AuthToken -> Bool
tokenValid UTCTime
now' AuthToken
token -> RefreshConfig -> TVar CacheState -> UTCTime -> AuthToken -> IO ()
recordMintSuccess RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now' AuthToken
token
            Right AuthToken
_ -> RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'
            Left (SomeException
_ :: SomeException) -> RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'

{- The synchronous (expired-token) path: the caller blocks on a mint because
there is no valid token to serve. The breaker gates it -- when open and still in
cooldown the call fast-fails with 'BreakerOpen' without minting; otherwise it
mints, and an expired token plus a failing mint is the one case that surfaces to
the caller. The single-flight flag is released by the 'guardInFlight' that 'serve'
wraps around this call (claimed and released in one masked scope), not here.
-}
mintSynchronously :: RefreshConfig -> TVar CacheState -> IO AuthToken
mintSynchronously :: RefreshConfig -> TVar CacheState -> IO AuthToken
mintSynchronously RefreshConfig
cfg TVar CacheState
stateVar = do
    now <- RefreshConfig -> IO UTCTime
rcClock RefreshConfig
cfg
    permitted <- gatedMint cfg stateVar now
    unless permitted (throwIO BreakerOpen)
    result <- try (rcMint cfg)
    now' <- rcClock cfg
    case result of
        Right AuthToken
token | UTCTime -> AuthToken -> Bool
tokenValid UTCTime
now' AuthToken
token -> do
            RefreshConfig -> TVar CacheState -> UTCTime -> AuthToken -> IO ()
recordMintSuccess RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now' AuthToken
token
            AuthToken -> IO AuthToken
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthToken
token
        Right AuthToken
_ -> do
            RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'
            CredentialError -> IO AuthToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CredentialError
MintedTokenAlreadyExpired
        Left (SomeException
e :: SomeException) -> do
            RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'
            SomeException -> IO AuthToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e

{- | Release the single-flight flag. It is run as the release of the 'guardInFlight'
that 'serve' installs in the __same masked scope__ that claimed the flag -- directly
for the synchronous mint, inside the forked child for a proactive refresh -- so the
flag is cleared on __every__ exit: success, a synchronous mint failure, or an
__asynchronous__ exception (cancellation \/ timeout) at any point from the claim
onward, including the handoff between the STM commit and the mint runner. Without
this an orphaned flag would wedge every later expired caller on the STM 'retry'.
The flag is held for the whole operation, so no concurrent mint can re-claim it
mid-flight -- an unconditional release here therefore cannot clobber another
operation's claim.
-}
releaseSingleFlight :: TVar CacheState -> IO ()
releaseSingleFlight :: TVar CacheState -> IO ()
releaseSingleFlight TVar CacheState
stateVar =
    STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar CacheState -> (CacheState -> CacheState) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar CacheState
stateVar (\CacheState
st -> CacheState
st{csRefreshing = False}))

{- | The circuit-breaker admission gate, shared by the background and synchronous
mint paths: defer the decision to 'Ecluse.Core.Breaker.admit' and commit the breaker
state it returns. An open breaker fast-fails the mint without touching the network;
see 'Ecluse.Core.Breaker.admit' for the admission policy.
-}
admitMint :: TVar CacheState -> UTCTime -> STM Bool
admitMint :: TVar CacheState -> UTCTime -> STM Bool
admitMint TVar CacheState
stateVar UTCTime
now = (\(Bool
permitted, Breaker
_, Breaker
_) -> Bool
permitted) ((Bool, Breaker, Breaker) -> Bool)
-> STM (Bool, Breaker, Breaker) -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar CacheState -> UTCTime -> STM (Bool, Breaker, Breaker)
admitMintTxn TVar CacheState
stateVar UTCTime
now

{- The admission gate's transaction, exposing the breaker transition it commits (the
old and new states) so 'gatedMint' can report a half-open recovery probe. 'admitMint'
is the admission-only view used directly in tests. -}
admitMintTxn :: TVar CacheState -> UTCTime -> STM (Bool, Breaker, Breaker)
admitMintTxn :: TVar CacheState -> UTCTime -> STM (Bool, Breaker, Breaker)
admitMintTxn TVar CacheState
stateVar UTCTime
now = do
    st <- TVar CacheState -> STM CacheState
forall a. TVar a -> STM a
readTVar TVar CacheState
stateVar
    let old = CacheState -> Breaker
csBreaker CacheState
st
        (permitted, new) = admit now old
    writeTVar stateVar st{csBreaker = new}
    pure (permitted, old, new)

{- The admission gate plus its breaker-state report: run the transaction and, if it
moved the breaker (an elapsed cooldown admitting a half-open probe), report the new
state. The report is a cheap, total measurement -- it never blocks or throws. -}
gatedMint :: RefreshConfig -> TVar CacheState -> UTCTime -> IO Bool
gatedMint :: RefreshConfig -> TVar CacheState -> UTCTime -> IO Bool
gatedMint RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now = do
    (permitted, old, new) <- STM (Bool, Breaker, Breaker) -> IO (Bool, Breaker, Breaker)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (TVar CacheState -> UTCTime -> STM (Bool, Breaker, Breaker)
admitMintTxn TVar CacheState
stateVar UTCTime
now)
    reportBreakerChange (rcBreakerReporter cfg) old new
    pure permitted

{- Fold a successful mint into the cache, then report it: the breaker reset (a state
change when it had tripped) and the refresh outcome carrying the new token's remaining
lifetime. -}
recordMintSuccess :: RefreshConfig -> TVar CacheState -> UTCTime -> AuthToken -> IO ()
recordMintSuccess :: RefreshConfig -> TVar CacheState -> UTCTime -> AuthToken -> IO ()
recordMintSuccess RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now' AuthToken
token = do
    due <- RefreshConfig -> UTCTime -> AuthToken -> IO (Maybe UTCTime)
refreshDueAt RefreshConfig
cfg UTCTime
now' AuthToken
token
    commitBreakerFold cfg stateVar (onMintSuccess token due)
    onRefreshSucceeded (rcRefreshReporter cfg) (ttlSecondsOf now' token)

{- Fold a failed mint into the cache, then report it: any breaker trip and the refresh
outcome carrying the still-cached token's remaining lifetime (so a sustained outage is
seen as the gauge decaying while repeated failures resample the ageing token). -}
recordMintFailure :: RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure :: RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now' = do
    cached <- CacheState -> AuthToken
csToken (CacheState -> AuthToken) -> IO CacheState -> IO AuthToken
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar CacheState -> IO CacheState
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO TVar CacheState
stateVar
    commitBreakerFold cfg stateVar (onMintFailure cfg now')
    onRefreshFailed (rcRefreshReporter cfg) (ttlSecondsOf now' cached)

{- Commit a mint fold to the cache and report any observable breaker-state change it
made. Keeps the pure 'onMintSuccess' \/ 'onMintFailure' folds (and their direct tests)
untouched, reading the breaker before and after in one transaction so the report
reflects exactly the transition committed. -}
commitBreakerFold :: RefreshConfig -> TVar CacheState -> (CacheState -> CacheState) -> IO ()
commitBreakerFold :: RefreshConfig
-> TVar CacheState -> (CacheState -> CacheState) -> IO ()
commitBreakerFold RefreshConfig
cfg TVar CacheState
stateVar CacheState -> CacheState
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 CacheState -> STM CacheState
forall a. TVar a -> STM a
readTVar TVar CacheState
stateVar
        let st' = CacheState -> CacheState
step CacheState
st
        writeTVar stateVar st'
        pure (csBreaker st, csBreaker st')
    reportBreakerChange (rcBreakerReporter cfg) old new

{- A token's remaining lifetime at the given instant, in whole seconds floored at zero,
or 'Nothing' for a token that never expires (which has no finite lifetime to report). -}
ttlSecondsOf :: UTCTime -> AuthToken -> Maybe Int
ttlSecondsOf :: UTCTime -> AuthToken -> Maybe Int
ttlSecondsOf UTCTime
now AuthToken
token = case AuthToken -> Maybe UTCTime
authExpiresAt AuthToken
token of
    Maybe UTCTime
Nothing -> Maybe Int
forall a. Maybe a
Nothing
    Just UTCTime
expiry -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (NominalDiffTime -> Int
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
expiry UTCTime
now)))

{- | Fold a successful mint into the cache: install the token and reset the
breaker. The single-flight flag is released by 'releaseSingleFlight' as the
'guardInFlight' release around the mint (not here), so it clears even on an async
exception.
-}
onMintSuccess :: AuthToken -> Maybe UTCTime -> CacheState -> CacheState
onMintSuccess :: AuthToken -> Maybe UTCTime -> CacheState -> CacheState
onMintSuccess AuthToken
token Maybe UTCTime
due CacheState
st =
    CacheState
st
        { csToken = token
        , csRefreshDue = due
        , csBreaker = recordSuccess (csBreaker st)
        }

{- | Fold a failed mint into the cache: keep the still-cached token and advance the
breaker per the configured threshold and cooldown ('Ecluse.Core.Breaker.recordFailure').
The single-flight flag is released separately by 'releaseSingleFlight' (see
'onMintSuccess').
-}
onMintFailure :: RefreshConfig -> UTCTime -> CacheState -> CacheState
onMintFailure :: RefreshConfig -> UTCTime -> CacheState -> CacheState
onMintFailure RefreshConfig
cfg UTCTime
now CacheState
st =
    CacheState
st{csBreaker = recordFailure (rcBreakerThreshold cfg) (rcBreakerCooldown cfg) now (csBreaker st)}

{- Whether a token is still usable at the given instant. A token with no
expiry ('Nothing') is always valid.
-}
tokenValid :: UTCTime -> AuthToken -> Bool
tokenValid :: UTCTime -> AuthToken -> Bool
tokenValid UTCTime
now AuthToken
token = case AuthToken -> Maybe UTCTime
authExpiresAt AuthToken
token of
    Maybe UTCTime
Nothing -> Bool
True
    Just UTCTime
expiry -> UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
expiry

{- Whether a proactive refresh is due: the token has a scheduled refresh
instant and the clock has reached it.
-}
refreshNeeded :: UTCTime -> CacheState -> Bool
refreshNeeded :: UTCTime -> CacheState -> Bool
refreshNeeded UTCTime
now CacheState
st = case CacheState -> Maybe UTCTime
csRefreshDue CacheState
st of
    Maybe UTCTime
Nothing -> Bool
False
    Just UTCTime
due -> UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
due

{- | Compute when a freshly minted token's proactive refresh should fire: the
'rcRefreshAt' fraction of its lifetime, pulled earlier by a per-token jitter
sample and capped at 'rcRefreshFloor' before expiry. A token with no expiry never
refreshes ('Nothing').
-}
refreshDueAt :: RefreshConfig -> UTCTime -> AuthToken -> IO (Maybe UTCTime)
refreshDueAt :: RefreshConfig -> UTCTime -> AuthToken -> IO (Maybe UTCTime)
refreshDueAt RefreshConfig
cfg UTCTime
issuedAt AuthToken
token = case AuthToken -> Maybe UTCTime
authExpiresAt AuthToken
token of
    Maybe UTCTime
Nothing -> Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UTCTime
forall a. Maybe a
Nothing
    Just UTCTime
expiry -> do
        jitter <- RefreshConfig -> IO Double
rcJitter RefreshConfig
cfg
        let lifetime = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
expiry UTCTime
issuedAt) :: Double
            frac = Double -> Double
clamp01 (RefreshConfig -> Double
rcRefreshAt RefreshConfig
cfg Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> Double
clamp01 Double
jitter)
            byFraction = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Double -> NominalDiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
frac Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
lifetime)) UTCTime
issuedAt
            floorInstant = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (RefreshConfig -> NominalDiffTime
rcRefreshFloor RefreshConfig
cfg)) UTCTime
expiry
            -- Never later than the floor before expiry, never before issue.
            due = UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
max UTCTime
issuedAt (UTCTime -> UTCTime -> UTCTime
forall a. Ord a => a -> a -> a
min UTCTime
byFraction UTCTime
floorInstant)
        pure (Just due)
  where
    clamp01 :: Double -> Double
    clamp01 :: Double -> Double
clamp01 = Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1