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

{- | Backoff for Pilot's periodic advisory-source fetches.
Bounded exponential waits with full jitter limit repeated load during upstream failures.
"Ecluse.Core.Fault.Http" classifies HTTP failures shared with registry adapters.
-}
module Ecluse.Core.Osv.Retry (
    -- * Policy
    defaultOsvRetryPolicy,

    -- * Classifying a fetch failure
    isRetryableHttpException,
    isRetryableStatusCode,

    -- * Running a fetch under the policy
    withOsvRetry,

    -- * Log lines
    transientMessage,
) where

import Control.Monad.Catch (Handler (Handler), MonadMask)
import Control.Retry (
    RetryPolicyM,
    RetryStatus (rsIterNumber),
    capDelay,
    fullJitterBackoff,
    limitRetries,
    recovering,
 )
import Katip (KatipContext, Severity (WarningS), logFM, ls)
import Network.HTTP.Client (
    HttpException (HttpExceptionRequest),
    HttpExceptionContent (StatusCodeException),
    responseStatus,
 )
import Network.HTTP.Types.Status (statusCode)

import Ecluse.Core.Fault (TransportFault (tfCause), transportRetryable)
import Ecluse.Core.Fault.Http (classifyTransport, isRetryableStatusCode)

-- | Full jitter from a 1s base to a 60s ceiling, with five retries (six attempts).
defaultOsvRetryPolicy :: (MonadIO m) => RetryPolicyM m
defaultOsvRetryPolicy :: forall (m :: * -> *). MonadIO m => RetryPolicyM m
defaultOsvRetryPolicy = Int -> RetryPolicy
limitRetries Int
5 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
60_000_000 (Int -> RetryPolicyM m
forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
1_000_000)

-- | Classify status failures by HTTP code and other exceptions by transport cause.
isRetryableHttpException :: HttpException -> Bool
isRetryableHttpException :: HttpException -> Bool
isRetryableHttpException = \case
    HttpExceptionRequest Request
_ (StatusCodeException Response ()
response ByteString
_) ->
        Int -> Bool
isRetryableStatusCode (Status -> Int
statusCode (Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
response))
    HttpException
other -> TransportCause -> Bool
transportRetryable (TransportFault -> TransportCause
tfCause (HttpException -> TransportFault
classifyTransport HttpException
other))

-- | Retry temporary HTTP failures within the policy budget. Other failures propagate immediately.
withOsvRetry :: (MonadMask m, KatipContext m) => RetryPolicyM m -> m a -> m a
withOsvRetry :: forall (m :: * -> *) a.
(MonadMask m, KatipContext m) =>
RetryPolicyM m -> m a -> m a
withOsvRetry RetryPolicyM m
policy m a
fetch =
    RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering RetryPolicyM m
policy [RetryStatus -> Handler m Bool
forall (m :: * -> *).
KatipContext m =>
RetryStatus -> Handler m Bool
retryHandler] (m a -> RetryStatus -> m a
forall a b. a -> b -> a
const m a
fetch)

-- Declining a permanent 'HttpException' makes 'recovering' re-throw it.
retryHandler :: (KatipContext m) => RetryStatus -> Handler m Bool
retryHandler :: forall (m :: * -> *).
KatipContext m =>
RetryStatus -> Handler m Bool
retryHandler RetryStatus
status = (HttpException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((HttpException -> m Bool) -> Handler m Bool)
-> (HttpException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \HttpException
e ->
    if HttpException -> Bool
isRetryableHttpException HttpException
e
        then Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
WarningS (String -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (RetryStatus -> HttpException -> String
transientMessage RetryStatus
status HttpException
e)) m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

{- | The warning logged before a retry of a transient fetch failure. The attempt number is
1-based, because 'rsIterNumber' counts retries from zero.
-}
transientMessage :: RetryStatus -> HttpException -> String
transientMessage :: RetryStatus -> HttpException -> String
transientMessage RetryStatus
status HttpException
err =
    String
"advisory-source fetch failed transiently on attempt "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ RetryStatus -> Int
rsIterNumber RetryStatus
status)
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; backing off before the next retry. Cause: "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HttpException -> String
forall b a. (Show a, IsString b) => a -> b
show HttpException
err