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

{- | The core transport-fault vocabulary. A client-library adapter classifies its own
exceptions at its edge, so no consumer layer ever sees the library's exception type.
-}
module Ecluse.Core.Fault (
    -- * Transport faults
    TransportFault (..),
    transportFault,
    TransportCause (..),
    renderTransportCause,
    transportRetryable,

    -- * Retry delays
    RetryAfter (..),

    -- * The shared detail budget
    boundedDetail,
) where

import Data.Text qualified as T

{- | One classified transport failure. Build it with 'transportFault' so the detail stays
bounded.
-}
data TransportFault = TransportFault
    { TransportFault -> TransportCause
tfCause :: TransportCause
    -- ^ The closed classification a consumer or an operator reads.
    , TransportFault -> Text
tfDetail :: Text
    {- ^ The client library's rendered detail, bounded to a log-line-sized budget.
    Diagnostic text only: it is never parsed, and no decision may branch on it.
    -}
    }
    deriving stock (TransportFault -> TransportFault -> Bool
(TransportFault -> TransportFault -> Bool)
-> (TransportFault -> TransportFault -> Bool) -> Eq TransportFault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportFault -> TransportFault -> Bool
== :: TransportFault -> TransportFault -> Bool
$c/= :: TransportFault -> TransportFault -> Bool
/= :: TransportFault -> TransportFault -> Bool
Eq, Int -> TransportFault -> ShowS
[TransportFault] -> ShowS
TransportFault -> String
(Int -> TransportFault -> ShowS)
-> (TransportFault -> String)
-> ([TransportFault] -> ShowS)
-> Show TransportFault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportFault -> ShowS
showsPrec :: Int -> TransportFault -> ShowS
$cshow :: TransportFault -> String
show :: TransportFault -> String
$cshowList :: [TransportFault] -> ShowS
showList :: [TransportFault] -> ShowS
Show)

{- | Build a 'TransportFault' with the detail truncated to the log-line budget, so a
pathological rendered exception cannot bloat a log line or a held error value.
-}
transportFault :: TransportCause -> Text -> TransportFault
transportFault :: TransportCause -> Text -> TransportFault
transportFault TransportCause
cause Text
detail = TransportCause -> Text -> TransportFault
TransportFault TransportCause
cause (Text -> Text
boundedDetail Text
detail)

{- | Why the transport could not deliver. Coarse on purpose: each constructor is a
distinction an operator reads differently, and anything finer belongs in 'tfDetail'.
-}
data TransportCause
    = -- | The peer did not answer in time (a connect or response timeout).
      TransportTimeout
    | {- | The peer could not be reached at all: a refused or reset connection, or a
      name that did not resolve.
      -}
      TransportUnreachable
    | -- | The TLS layer refused the peer (a handshake or certificate failure).
      TransportTls
    | {- | Any other client-reported fault (a malformed response, an unparseable
      URL, an internal client error): the closed catch-all, so the sum stays total
      over whatever a client library reports.
      -}
      TransportProtocol
    deriving stock (TransportCause -> TransportCause -> Bool
(TransportCause -> TransportCause -> Bool)
-> (TransportCause -> TransportCause -> Bool) -> Eq TransportCause
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransportCause -> TransportCause -> Bool
== :: TransportCause -> TransportCause -> Bool
$c/= :: TransportCause -> TransportCause -> Bool
/= :: TransportCause -> TransportCause -> Bool
Eq, Int -> TransportCause -> ShowS
[TransportCause] -> ShowS
TransportCause -> String
(Int -> TransportCause -> ShowS)
-> (TransportCause -> String)
-> ([TransportCause] -> ShowS)
-> Show TransportCause
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransportCause -> ShowS
showsPrec :: Int -> TransportCause -> ShowS
$cshow :: TransportCause -> String
show :: TransportCause -> String
$cshowList :: [TransportCause] -> ShowS
showList :: [TransportCause] -> ShowS
Show)

-- | What a transport cause says happened, for a line an operator reads.
renderTransportCause :: TransportCause -> Text
renderTransportCause :: TransportCause -> Text
renderTransportCause = \case
    TransportCause
TransportTimeout -> Text
"the peer did not answer in time"
    TransportCause
TransportUnreachable -> Text
"the peer could not be reached"
    TransportCause
TransportTls -> Text
"the TLS layer refused the peer"
    TransportCause
TransportProtocol -> Text
"the peer's answer could not be used"

{- | Is a fault with this cause worth another attempt? A timeout and an unreachable peer
can clear on their own. A TLS refusal and a protocol fault need an operator or a fix.
-}
transportRetryable :: TransportCause -> Bool
transportRetryable :: TransportCause -> Bool
transportRetryable = \case
    TransportCause
TransportTimeout -> Bool
True
    TransportCause
TransportUnreachable -> Bool
True
    TransportCause
TransportTls -> Bool
False
    TransportCause
TransportProtocol -> Bool
False

{- | A @Retry-After@ delay, in whole seconds. A 'newtype' so a raw count of seconds is
never confused with some other integer when it reaches a response header or a sweep's wait.
-}
newtype RetryAfter = RetryAfter Int
    deriving stock (RetryAfter -> RetryAfter -> Bool
(RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> Bool) -> Eq RetryAfter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RetryAfter -> RetryAfter -> Bool
== :: RetryAfter -> RetryAfter -> Bool
$c/= :: RetryAfter -> RetryAfter -> Bool
/= :: RetryAfter -> RetryAfter -> Bool
Eq, Eq RetryAfter
Eq RetryAfter =>
(RetryAfter -> RetryAfter -> Ordering)
-> (RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> Bool)
-> (RetryAfter -> RetryAfter -> RetryAfter)
-> (RetryAfter -> RetryAfter -> RetryAfter)
-> Ord RetryAfter
RetryAfter -> RetryAfter -> Bool
RetryAfter -> RetryAfter -> Ordering
RetryAfter -> RetryAfter -> RetryAfter
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RetryAfter -> RetryAfter -> Ordering
compare :: RetryAfter -> RetryAfter -> Ordering
$c< :: RetryAfter -> RetryAfter -> Bool
< :: RetryAfter -> RetryAfter -> Bool
$c<= :: RetryAfter -> RetryAfter -> Bool
<= :: RetryAfter -> RetryAfter -> Bool
$c> :: RetryAfter -> RetryAfter -> Bool
> :: RetryAfter -> RetryAfter -> Bool
$c>= :: RetryAfter -> RetryAfter -> Bool
>= :: RetryAfter -> RetryAfter -> Bool
$cmax :: RetryAfter -> RetryAfter -> RetryAfter
max :: RetryAfter -> RetryAfter -> RetryAfter
$cmin :: RetryAfter -> RetryAfter -> RetryAfter
min :: RetryAfter -> RetryAfter -> RetryAfter
Ord, Int -> RetryAfter -> ShowS
[RetryAfter] -> ShowS
RetryAfter -> String
(Int -> RetryAfter -> ShowS)
-> (RetryAfter -> String)
-> ([RetryAfter] -> ShowS)
-> Show RetryAfter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RetryAfter -> ShowS
showsPrec :: Int -> RetryAfter -> ShowS
$cshow :: RetryAfter -> String
show :: RetryAfter -> String
$cshowList :: [RetryAfter] -> ShowS
showList :: [RetryAfter] -> ShowS
Show)

{- | Truncate a rendered detail to the shared log-line budget. Every fault vocabulary that
carries diagnostic text bounds it identically.
-}
boundedDetail :: Text -> Text
boundedDetail :: Text -> Text
boundedDetail = Text -> Text
T.copy (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.take Int
maxDetailChars

-- The rendered-detail budget: generous enough for any realistic client-library
-- message, small enough that a held fault value stays log-line sized.
maxDetailChars :: Int
maxDetailChars :: Int
maxDetailChars = Int
512