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

{- | The implementation behind "Ecluse.Core.Credential.Refresh", which documents the policy
and re-exports the curated surface. Importing this module opts out of that stability promise,
the convention @text@ and @bytestring@ use, so production code imports the public one.
-}
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,
    releaseSingleFlight,
) where

import Control.Concurrent.STM (retry)
import Data.Ord (clamp)
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 from credential minting or refresh policy.
data CredentialError
    = -- | The token expired with the mint breaker open, so no mint was attempted.
      BreakerOpen
    | -- | An effectful leaf still holds its 'defaultRefreshConfig' placeholder.
      Unconfigured Text
    | -- | An already-expired mint 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

-- | Observe refresh outcomes with the active token's absolute expiry, absent for non-expiring tokens.
data RefreshReporter = RefreshReporter
    { RefreshReporter -> Maybe UTCTime -> IO ()
onRefreshSucceeded :: Maybe UTCTime -> IO ()
    -- ^ A mint succeeded, with the new token's absolute expiry.
    , RefreshReporter -> Maybe UTCTime -> IO ()
onRefreshFailed :: Maybe UTCTime -> IO ()
    -- ^ A mint failed, with the still-cached token's absolute expiry.
    }

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

-- | The telemetry observers a refreshing provider records through, bundled into one value.
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@).
    }

-- | The inert pair: a provider built with it records nothing on either signal.
noCredentialReporters :: CredentialReporters
noCredentialReporters :: CredentialReporters
noCredentialReporters = BreakerReporter -> RefreshReporter -> CredentialReporters
CredentialReporters BreakerReporter
noBreakerReporter RefreshReporter
noRefreshReporter

-- | Refresh policy with injected mint, clock, jitter and observers.
data RefreshConfig = RefreshConfig
    { RefreshConfig -> IO AuthToken
rcMint :: IO AuthToken
    -- ^ The per-cloud token mint, the __only__ part that touches a network.
    , RefreshConfig -> IO UTCTime
rcClock :: IO UTCTime
    -- ^ Injected so a test drives refresh timing without real time passing.
    , RefreshConfig -> IO Double
rcJitter :: IO Double
    {- ^ A fraction in @[0, 1)@, sampled once per token, pulling the refresh instant
    /earlier/. It desynchronises a cohort of instances.
    -}
    , RefreshConfig -> Double
rcRefreshAt :: Double
    -- ^ The fraction of a token's lifetime to refresh at, before jitter. Clamped to @[0, 1]@.
    , RefreshConfig -> NominalDiffTime
rcRefreshFloor :: NominalDiffTime
    {- ^ Seconds before expiry the refresh may never be scheduled past, so a short-lived token
    still refreshes ahead of its deadline.
    -}
    , 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 one half-open probe tests
    recovery.
    -}
    , RefreshConfig -> CredentialReporters
rcReporters :: CredentialReporters
    -- ^ Inert by default. The composition root installs the live pair.
    }

-- | Default policy knobs. Unwired 'rcMint' and 'rcClock' throw 'Unconfigured'.
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
        , rcReporters :: CredentialReporters
rcReporters = CredentialReporters
noCredentialReporters
        }
  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.
data CacheState = CacheState
    { CacheState -> AuthToken
csToken :: AuthToken
    -- ^ The token currently served.
    , CacheState -> Maybe UTCTime
csRefreshDue :: Maybe UTCTime
    -- ^ When the background refresh fires. 'Nothing' for a token with no expiry.
    , CacheState -> Bool
csRefreshing :: Bool
    -- ^ Whether a mint is in flight (the single-flight flag).
    , CacheState -> Breaker
csBreaker :: Breaker
    -- ^ The circuit-breaker state.
    }

-- | Build a cached provider, minting eagerly so an initial mint failure aborts construction.
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 ())

-- | Add a test hook between the single-flight claim and the mint runner.
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}

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

{- An async exception between the single-flight claim and the run that releases it would
wedge every later expired caller on the 'decide' 'retry', so both stay in one masked scope. -}
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
    atomically (decide stateVar now) >>= \case
        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 -> AuthToken
token AuthToken -> IO () -> IO AuthToken
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ IO () -> RefreshConfig -> TVar CacheState -> IO ()
forkRefresh IO ()
afterClaim RefreshConfig
cfg TVar CacheState
stateVar
        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)

{- The masked fork installs the child's flag release before the parent can receive an
interruption, and 'backgroundRefresh' catches the mint's own failures. -}
forkRefresh :: IO () -> RefreshConfig -> TVar CacheState -> IO ()
forkRefresh :: IO () -> RefreshConfig -> TVar CacheState -> IO ()
forkRefresh IO ()
afterClaim RefreshConfig
cfg TVar CacheState
stateVar =
    IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
        ((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)

-- Waiters re-decide against the freed flag (the 'decide' STM 'retry'), not on a result
-- promise, so the orphan hand-off has nothing to unblock.
noWaiter :: SomeException -> IO ()
noWaiter :: SomeException -> IO ()
noWaiter = IO () -> SomeException -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass

{- | Claim a mint atomically when one is due, or block until an in-flight refresh frees the
flag. The caller must release a claim with 'releaseSingleFlight'.
-}
decide :: TVar CacheState -> UTCTime -> STM ServeAction
decide :: TVar CacheState -> UTCTime -> STM ServeAction
decide TVar CacheState
stateVar UTCTime
now = TVar CacheState -> STM CacheState
forall a. TVar a -> STM a
readTVar TVar CacheState
stateVar STM CacheState
-> (CacheState -> STM ServeAction) -> STM ServeAction
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TVar CacheState -> UTCTime -> CacheState -> STM ServeAction
decideFrom TVar CacheState
stateVar UTCTime
now

-- An expired token with a mint already in flight waits for it (the STM 'retry') and
-- re-decides, rather than launching a second one.
decideFrom :: TVar CacheState -> UTCTime -> CacheState -> STM ServeAction
decideFrom :: TVar CacheState -> UTCTime -> CacheState -> STM ServeAction
decideFrom TVar CacheState
stateVar UTCTime
now CacheState
st
    | Bool -> Bool
not (UTCTime -> AuthToken -> Bool
tokenValid UTCTime
now (CacheState -> AuthToken
csToken CacheState
st)) =
        if CacheState -> Bool
csRefreshing CacheState
st then STM ServeAction
forall a. STM a
retry else TVar CacheState -> CacheState -> ServeAction -> STM ServeAction
claimSingleFlight TVar CacheState
stateVar CacheState
st ServeAction
MintNow
    | UTCTime -> CacheState -> Bool
refreshNeeded UTCTime
now CacheState
st Bool -> Bool -> Bool
&& Bool -> Bool
not (CacheState -> Bool
csRefreshing CacheState
st) =
        TVar CacheState -> CacheState -> ServeAction -> STM ServeAction
claimSingleFlight TVar CacheState
stateVar CacheState
st (AuthToken -> ServeAction
ServeAndRefresh (CacheState -> AuthToken
csToken CacheState
st))
    | Bool
otherwise = ServeAction -> STM ServeAction
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthToken -> ServeAction
ServeCached (CacheState -> AuthToken
csToken CacheState
st))

claimSingleFlight :: TVar CacheState -> CacheState -> ServeAction -> STM ServeAction
claimSingleFlight :: TVar CacheState -> CacheState -> ServeAction -> STM ServeAction
claimSingleFlight TVar CacheState
stateVar CacheState
st ServeAction
action = ServeAction
action ServeAction -> STM () -> STM ServeAction
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar CacheState -> CacheState -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar CacheState
stateVar CacheState
st{csRefreshing = True}

-- What one gated mint attempt concluded, after its outcome is folded into the cache.
data MintOutcome
    = BreakerRefused
    | Minted AuthToken
    | MintedExpired
    | MintThrew SomeException

-- It never throws, so each caller decides for itself what an outcome surfaces as.
attemptMint :: RefreshConfig -> TVar CacheState -> IO MintOutcome
attemptMint :: RefreshConfig -> TVar CacheState -> IO MintOutcome
attemptMint RefreshConfig
cfg TVar CacheState
stateVar = do
    now <- RefreshConfig -> IO UTCTime
rcClock RefreshConfig
cfg
    permitted <- gatedMint cfg stateVar now
    if permitted
        then do
            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
                    MintOutcome -> IO MintOutcome
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthToken -> MintOutcome
Minted AuthToken
token)
                Right AuthToken
_ -> do
                    RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'
                    MintOutcome -> IO MintOutcome
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MintOutcome
MintedExpired
                Left (SomeException
e :: SomeException) -> do
                    RefreshConfig -> TVar CacheState -> UTCTime -> IO ()
recordMintFailure RefreshConfig
cfg TVar CacheState
stateVar UTCTime
now'
                    MintOutcome -> IO MintOutcome
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException -> MintOutcome
MintThrew SomeException
e)
        else pure BreakerRefused

-- It discards the outcome, so a failed background mint never reaches a caller.
backgroundRefresh :: RefreshConfig -> TVar CacheState -> IO ()
backgroundRefresh :: RefreshConfig -> TVar CacheState -> IO ()
backgroundRefresh RefreshConfig
cfg TVar CacheState
stateVar = IO MintOutcome -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RefreshConfig -> TVar CacheState -> IO MintOutcome
attemptMint RefreshConfig
cfg TVar CacheState
stateVar)

{- The one path where a mint failure surfaces to the caller. It rethrows the mint's own
exception, so a caller can dispatch on the cause. -}
mintSynchronously :: RefreshConfig -> TVar CacheState -> IO AuthToken
mintSynchronously :: RefreshConfig -> TVar CacheState -> IO AuthToken
mintSynchronously RefreshConfig
cfg TVar CacheState
stateVar =
    RefreshConfig -> TVar CacheState -> IO MintOutcome
attemptMint RefreshConfig
cfg TVar CacheState
stateVar IO MintOutcome -> (MintOutcome -> IO AuthToken) -> IO AuthToken
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Minted AuthToken
token -> AuthToken -> IO AuthToken
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthToken
token
        MintOutcome
BreakerRefused -> CredentialError -> IO AuthToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CredentialError
BreakerOpen
        MintOutcome
MintedExpired -> CredentialError -> IO AuthToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CredentialError
MintedTokenAlreadyExpired
        MintThrew SomeException
e -> SomeException -> IO AuthToken
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e

{- | Release the single-flight flag. 'serve' runs it under 'guardInFlight' inside the masked
scope that claimed it, so the flag clears on every exit, an async cancel included.
-}
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}))

-- Returns the old and new breaker states so 'gatedMint' can report the transition.
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, which 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 (crBreakerReporter (rcReporters cfg)) old new
    pure permitted

-- Report the breaker reset and the new token's expiry, after the cache fold.
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 (crRefreshReporter (rcReporters cfg)) (authExpiresAt token)

-- Report any breaker trip and the still-cached token's expiry, after the cache fold.
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 (crRefreshReporter (rcReporters cfg)) (authExpiresAt cached)

-- One transaction reads the breaker before and after, so the report reflects exactly the
-- transition it 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 (crBreakerReporter (rcReporters cfg)) old new

{- | Fold a successful mint into the cache. 'guardInFlight' releases the single-flight flag
around the mint, not this fold, so the flag 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. The cached token stays in place and the breaker
advances under the configured threshold and cooldown.
-}
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)}

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

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

{- | When a freshly minted token's refresh should fire. Jitter only pulls the 'rcRefreshAt'
fraction of the token's lifetime earlier, never later.
-}
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 -> Double
forall a. Ord a => (a, a) -> a -> a
clamp (Double
0, Double
1)