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

{- | Ecosystem-agnostic request mechanics: the outbound finaliser, the credential presentation,
and URL parsing into a typed 'UrlFormationError'. An adapter supplies only its own protocol facts.

'parseRequestEither' seals what it parses, so an adapter cannot obtain an unsealed 'Request'
from this module at all.
-}
module Ecluse.Core.Registry.Request (
    -- * Request finalisation
    sealRequest,
    finaliseRequest,

    -- * Credential presentation
    CredentialMapping,
    credentialMapping,
    credentialRecover,
    attachCredential,
    authorizationUnder,

    -- * Request building
    artifactRequestByUrl,
    joinPath,
    parseRequestEither,
) where

import Data.Text qualified as T
import Network.HTTP.Client (Request (decompress, redirectCount, requestHeaders), parseRequest)
import Network.HTTP.Types.Header (
    HeaderName,
    RequestHeaders,
    hAuthorization,
    hUserAgent,
 )

import Ecluse.Core.BuildIdentity (userAgent)
import Ecluse.Core.Credential (ClientCredential)
import Ecluse.Core.Registry (UrlFormationError (EmptyBaseUrl, UnparseableUrl))
import Ecluse.Core.Text (joinUrlPath)

{- | Seal the outbound invariants onto a request, idempotently. A followed redirect could
re-send a credential cross-host or steer an anonymous fetch past the host allowlist.
-}
sealRequest :: Request -> Request
sealRequest :: Request -> Request
sealRequest Request
request =
    Request
request
        { redirectCount = 0
        , requestHeaders = identify (requestHeaders request)
        }
  where
    identify :: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
identify [(HeaderName, ByteString)]
headers
        | ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hUserAgent) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, ByteString)]
headers = [(HeaderName, ByteString)]
headers
        | Bool
otherwise = (HeaderName
hUserAgent, ByteString
userAgent) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
headers

{- | Apply the ecosystem's injected credential attach, then seal the result through
'sealRequest'. The attach runs first, so it cannot reopen redirect following.
-}
finaliseRequest :: (Request -> Request) -> Request -> Request
finaliseRequest :: (Request -> Request) -> Request -> Request
finaliseRequest Request -> Request
attach = Request -> Request
sealRequest (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
attach

{- | One ecosystem's credential presentation, recovered as a value so an attach re-encodes rather
than replaying a header. The constructor is hidden, so no adapter spells its own attach point.
-}
data CredentialMapping = CredentialMapping
    { CredentialMapping
-> [(HeaderName, ByteString)] -> Maybe ClientCredential
credentialRecover :: RequestHeaders -> Maybe ClientCredential
    {- ^ 'Nothing' for a request carrying none in this ecosystem's form, which the edge gate
    denies rather than half-reading. The compare is over the secret half alone.
    -}
    , -- The header that carries an outbound credential: named per ecosystem, never assumed.
      CredentialMapping -> HeaderName
credentialHeader :: HeaderName
    , -- How a credential renders into that header's value (the ecosystem's own scheme).
      CredentialMapping -> ClientCredential -> ByteString
credentialRender :: ClientCredential -> ByteString
    }

{- | Declare an ecosystem's credential presentation. The constructor is hidden, so this is the
only way to build a 'CredentialMapping'.
-}
credentialMapping ::
    (RequestHeaders -> Maybe ClientCredential) ->
    HeaderName ->
    (ClientCredential -> ByteString) ->
    CredentialMapping
credentialMapping :: ([(HeaderName, ByteString)] -> Maybe ClientCredential)
-> HeaderName
-> (ClientCredential -> ByteString)
-> CredentialMapping
credentialMapping [(HeaderName, ByteString)] -> Maybe ClientCredential
recover HeaderName
header ClientCredential -> ByteString
render =
    CredentialMapping
        { credentialRecover :: [(HeaderName, ByteString)] -> Maybe ClientCredential
credentialRecover = [(HeaderName, ByteString)] -> Maybe ClientCredential
recover
        , credentialHeader :: HeaderName
credentialHeader = HeaderName
header
        , credentialRender :: ClientCredential -> ByteString
credentialRender = ClientCredential -> ByteString
render
        }

{- | Attach a credential to an outbound request under the mapping's own header, then finalise it
through 'finaliseRequest'. A 'Nothing' attaches no header, and the seal still applies.
-}
attachCredential :: CredentialMapping -> Maybe ClientCredential -> Request -> Request
attachCredential :: CredentialMapping -> Maybe ClientCredential -> Request -> Request
attachCredential CredentialMapping
mapping Maybe ClientCredential
credential = (Request -> Request) -> Request -> Request
finaliseRequest ((Request -> Request) -> Request -> Request)
-> (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ case Maybe ClientCredential
credential of
    Maybe ClientCredential
Nothing -> Request -> Request
forall a. a -> a
id
    Just ClientCredential
presented -> \Request
request ->
        Request
request
            { requestHeaders =
                (credentialHeader mapping, credentialRender mapping presented) : requestHeaders request
            }

{- | The first @Authorization@ header's remainder when it carries @scheme@ (compared without
case), with the separating spaces dropped. Another scheme or no header yields 'Nothing'.
-}
authorizationUnder :: Text -> RequestHeaders -> Maybe Text
authorizationUnder :: Text -> [(HeaderName, ByteString)] -> Maybe Text
authorizationUnder Text
scheme [(HeaderName, ByteString)]
headers = do
    (_, raw) <- ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAuthorization) (HeaderName -> Bool)
-> ((HeaderName, ByteString) -> HeaderName)
-> (HeaderName, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst) [(HeaderName, ByteString)]
headers
    let (presented, rest) = T.break (== ' ') (decodeUtf8 raw)
    guard (T.toLower presented == T.toLower scheme)
    pure (T.dropWhile (== ' ') rest)

{- | Build the artifact @GET@ at the URL a projection preserved from upstream. Non-decompressing,
so the bytes the served integrity digest is paired with are never gunzipped.
-}
artifactRequestByUrl :: CredentialMapping -> Maybe ClientCredential -> Text -> Either UrlFormationError Request
artifactRequestByUrl :: CredentialMapping
-> Maybe ClientCredential
-> Text
-> Either UrlFormationError Request
artifactRequestByUrl CredentialMapping
mapping Maybe ClientCredential
credential Text
url = do
    base <- Text -> Either UrlFormationError Request
parseRequestEither Text
url
    pure . attachCredential mapping credential $ base{decompress = const False}

{- Join a base URL and an already-encoded path with exactly one slash, whatever trailing
slashes the configured base writes.
-}
joinPath :: Text -> Text -> Either UrlFormationError Text
joinPath :: Text -> Text -> Either UrlFormationError Text
joinPath Text
baseUrl Text
path
    | Text -> Bool
T.null Text
baseUrl = UrlFormationError -> Either UrlFormationError Text
forall a b. a -> Either a b
Left UrlFormationError
EmptyBaseUrl
    | Bool
otherwise = Text -> Either UrlFormationError Text
forall a b. b -> Either a b
Right (Text -> Text -> Text
joinUrlPath Text
baseUrl Text
path)

{- | Parse a URL into the sealed request every adapter builds from ('sealRequest'). The URL comes
from configuration and an already-safe name, so a parse failure here is a configuration fault.
-}
parseRequestEither :: Text -> Either UrlFormationError Request
parseRequestEither :: Text -> Either UrlFormationError Request
parseRequestEither Text
url =
    case String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (Text -> String
forall a. ToString a => a -> String
toString Text
url) of
        Just Request
request -> Request -> Either UrlFormationError Request
forall a b. b -> Either a b
Right (Request -> Request
sealRequest Request
request)
        Maybe Request
Nothing -> UrlFormationError -> Either UrlFormationError Request
forall a b. a -> Either a b
Left (Text -> UrlFormationError
UnparseableUrl Text
url)