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

{- | Shared HTTP fault classification for registry, queue, and advisory adapters.
Client exceptions become "Ecluse.Core.Fault" values at the adapter boundary.
-}
module Ecluse.Core.Fault.Http (
    classifyTransport,
    isRetryableStatusCode,
) where

import Network.HTTP.Client (
    HttpException (HttpExceptionRequest, InvalidUrlException),
    HttpExceptionContent (
        ConnectionClosed,
        ConnectionFailure,
        ConnectionTimeout,
        InternalException,
        NoResponseDataReceived,
        ResponseTimeout
    ),
 )
import Network.TLS qualified as TLS

import Ecluse.Core.Fault (
    TransportCause (TransportProtocol, TransportTimeout, TransportTls, TransportUnreachable),
    TransportFault,
    transportFault,
 )
import Ecluse.Core.Text (displayExceptionT)

-- | Classify a client exception, recognising TLS failures by type rather than rendered text.
classifyTransport :: HttpException -> TransportFault
classifyTransport :: HttpException -> TransportFault
classifyTransport HttpException
err = TransportCause -> Text -> TransportFault
transportFault (HttpException -> TransportCause
causeOf HttpException
err) (HttpException -> Text
forall e. Exception e => e -> Text
displayExceptionT HttpException
err)
  where
    causeOf :: HttpException -> TransportCause
causeOf = \case
        HttpExceptionRequest Request
_ HttpExceptionContent
content -> case HttpExceptionContent
content of
            HttpExceptionContent
ConnectionTimeout -> TransportCause
TransportTimeout
            HttpExceptionContent
ResponseTimeout -> TransportCause
TransportTimeout
            ConnectionFailure SomeException
_ -> TransportCause
TransportUnreachable
            HttpExceptionContent
ConnectionClosed -> TransportCause
TransportUnreachable
            -- The peer hung up before the first response byte, so the request never
            -- reached a protocol exchange.
            HttpExceptionContent
NoResponseDataReceived -> TransportCause
TransportUnreachable
            InternalException SomeException
inner
                | Just (TLSException
_ :: TLS.TLSException) <- SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
inner -> TransportCause
TransportTls
                | Bool
otherwise -> TransportCause
TransportProtocol
            HttpExceptionContent
_ -> TransportCause
TransportProtocol
        InvalidUrlException String
_ String
_ -> TransportCause
TransportProtocol

-- | Whether an HTTP status signals a temporary failure: server errors, timeout, or throttling.
isRetryableStatusCode :: Int -> Bool
isRetryableStatusCode :: Int -> Bool
isRetryableStatusCode Int
code = Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
408 Bool -> Bool -> Bool
|| Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
429