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

{- | Textual extraction of the @host[:port]@ authority an outbound request dials.

These are comparison extractors, not an RFC 3986 parser: a value with no recognisable
authority yields the empty string or 'Nothing', which every guard treats as not-allowed. The
SSRF gates in "Ecluse.Core.Security.Host" consume the extracted 'HostPort', so the parsing
here carries no policy of its own.
-}
module Ecluse.Core.Security.Authority (
    -- * The dialled authority
    HostPort (..),

    -- * Authority extraction
    hostAddress,
    hostPortAddress,
    hostPortAddressWithDefault,
    splitHostPort,

    -- * Configured-URL refusal
    refuseCredentialMaterial,

    -- * Log-safe rendering
    authorityLabel,
    dialledAuthorityLabel,
    credentialFreeUrl,
) where

import Data.Text qualified as T

import Ecluse.Core.Text (afterFirst, httpPrefix, isPrefixOfLowered, readDecimalText)

{- | The authority an outbound fetch dials: a bare host with its effective port. The gate
authorises the pair, so an allowlisted host at an attacker-chosen port is not authorised.
-}
data HostPort = HostPort
    { HostPort -> Text
hpHost :: Text
    -- ^ The bare host: no brackets, no port, lower-cased by both extractors.
    , HostPort -> Word16
hpPort :: Word16
    -- ^ The effective port: the explicit @:port@, or the caller's portless default.
    }
    deriving stock (HostPort -> HostPort -> Bool
(HostPort -> HostPort -> Bool)
-> (HostPort -> HostPort -> Bool) -> Eq HostPort
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HostPort -> HostPort -> Bool
== :: HostPort -> HostPort -> Bool
$c/= :: HostPort -> HostPort -> Bool
/= :: HostPort -> HostPort -> Bool
Eq, Eq HostPort
Eq HostPort =>
(HostPort -> HostPort -> Ordering)
-> (HostPort -> HostPort -> Bool)
-> (HostPort -> HostPort -> Bool)
-> (HostPort -> HostPort -> Bool)
-> (HostPort -> HostPort -> Bool)
-> (HostPort -> HostPort -> HostPort)
-> (HostPort -> HostPort -> HostPort)
-> Ord HostPort
HostPort -> HostPort -> Bool
HostPort -> HostPort -> Ordering
HostPort -> HostPort -> HostPort
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 :: HostPort -> HostPort -> Ordering
compare :: HostPort -> HostPort -> Ordering
$c< :: HostPort -> HostPort -> Bool
< :: HostPort -> HostPort -> Bool
$c<= :: HostPort -> HostPort -> Bool
<= :: HostPort -> HostPort -> Bool
$c> :: HostPort -> HostPort -> Bool
> :: HostPort -> HostPort -> Bool
$c>= :: HostPort -> HostPort -> Bool
>= :: HostPort -> HostPort -> Bool
$cmax :: HostPort -> HostPort -> HostPort
max :: HostPort -> HostPort -> HostPort
$cmin :: HostPort -> HostPort -> HostPort
min :: HostPort -> HostPort -> HostPort
Ord, Int -> HostPort -> ShowS
[HostPort] -> ShowS
HostPort -> String
(Int -> HostPort -> ShowS)
-> (HostPort -> String) -> ([HostPort] -> ShowS) -> Show HostPort
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HostPort -> ShowS
showsPrec :: Int -> HostPort -> ShowS
$cshow :: HostPort -> String
show :: HostPort -> String
$cshowList :: [HostPort] -> ShowS
showList :: [HostPort] -> ShowS
Show)

{- | The bare host of a URI or @host[:port]@ authority, lower-cased and unbracketed. A value with no
recognisable host yields the empty string, which the guards treat as not-allowed.
-}
hostAddress :: Text -> Text
hostAddress :: Text -> Text
hostAddress Text
raw = Text -> Text
T.toLower (Text -> ((Text, Text) -> Text) -> Maybe (Text, Text) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (Text, Text) -> Text
forall a b. (a, b) -> a
fst (Text -> Maybe (Text, Text)
splitHostPort (Text -> Text
authorityOf Text
raw)))

{- | The host and the effective port a URI or @host[:port]@ authority dials, or 'Nothing' when it
holds none. A portless URL dials 443, and an out-of-grammar or written-but-empty port is refused.

>>> hostPortAddress "https://[2606:4700::1111]:8443/thing"
Just (HostPort {hpHost = "2606:4700::1111", hpPort = 8443})
-}
hostPortAddress :: Text -> Maybe HostPort
hostPortAddress :: Text -> Maybe HostPort
hostPortAddress = Word16 -> Text -> Maybe HostPort
hostPortAddressWithDefault Word16
443

{- | 'hostPortAddress' with the caller's own port for a URL that writes none, for a scheme whose
portless default is not the gate's 443. The authority split and the port grammar do not change.
-}
hostPortAddressWithDefault :: Word16 -> Text -> Maybe HostPort
hostPortAddressWithDefault :: Word16 -> Text -> Maybe HostPort
hostPortAddressWithDefault Word16
portless Text
raw = do
    let authority :: Text
authority = Text -> Text
authorityOf Text
raw
    (host, rest) <- Text -> Maybe (Text, Text)
splitHostPort Text
authority
    guard (not (T.null host))
    port <- effectivePort portless authority rest
    pure (HostPort (T.toLower host) port)

{- | The log-safe label for a URL: its validated host and effective port, or @\<unresolved\>@. An
attacker-influenced or credential-bearing URL must never reach a log line or a span as written.

>>> authorityLabel "https://deploy:hunter2@registry.npmjs.org/thing/-/thing-1.0.0.tgz?sig=abc"
"registry.npmjs.org:443"
-}
authorityLabel :: Text -> Text
authorityLabel :: Text -> Text
authorityLabel = Word16 -> Text -> Text
authorityLabelWithDefault Word16
443

{- | 'authorityLabel' for a URL a client dials as written, so a portless @http://@ URL names port 80.

>>> dialledAuthorityLabel "HTTP://mirror.example.test/epss.csv.gz"
"mirror.example.test:80"
-}
dialledAuthorityLabel :: Text -> Text
dialledAuthorityLabel :: Text -> Text
dialledAuthorityLabel Text
raw = Word16 -> Text -> Text
authorityLabelWithDefault Word16
portless Text
raw
  where
    portless :: Word16
portless = if LowerPrefix -> Text -> Bool
isPrefixOfLowered LowerPrefix
httpPrefix Text
raw then Word16
80 else Word16
443

authorityLabelWithDefault :: Word16 -> Text -> Text
authorityLabelWithDefault :: Word16 -> Text -> Text
authorityLabelWithDefault Word16
portless = Text -> (HostPort -> Text) -> Maybe HostPort -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
unresolvedAuthority HostPort -> Text
renderHostPort (Maybe HostPort -> Text)
-> (Text -> Maybe HostPort) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Text -> Maybe HostPort
hostPortAddressWithDefault Word16
portless

{- | A fetched URL with every credential carrier removed: userinfo, query, and fragment, the
last two whole, because either can hold a signed-URL credential.

>>> credentialFreeUrl "https://deploy:hunter2@osv.example.test/npm/all.zip?sig=abc#frag"
"https://osv.example.test/npm/all.zip"
-}
credentialFreeUrl :: Text -> Text
credentialFreeUrl :: Text -> Text
credentialFreeUrl Text
raw = Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
authorityOf Text
raw Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
  where
    (Text
written, Text
separator) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"://" Text
raw
    (Text
scheme, Text
afterScheme) = case Text -> Text -> Maybe Text
T.stripPrefix Text
"://" Text
separator of
        Just Text
rest -> (Text
written Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"://", Text
rest)
        Maybe Text
Nothing -> (Text
"", Text
raw)
    path :: Text
path = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Char
'?', Char
'#']) ((Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') Text
afterScheme)

-- The angle brackets match what the resolved-configuration provenance lines use for a
-- withheld value.
unresolvedAuthority :: Text
unresolvedAuthority :: Text
unresolvedAuthority = Text
"<unresolved>"

{- Render a 'HostPort' back to a @host:port@ authority. An IPv6 host must be re-bracketed, since
@2606:4700::1111:8443@ is neither the host nor a parseable authority. -}
renderHostPort :: HostPort -> Text
renderHostPort :: HostPort -> Text
renderHostPort (HostPort Text
host Word16
port)
    | Text
":" Text -> Text -> Bool
`T.isInfixOf` Text
host = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
host Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall b a. (Show a, IsString b) => a -> b
show Word16
port
    | Bool
otherwise = Text
host Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall b a. (Show a, IsString b) => a -> b
show Word16
port

{- The port an authority dials: an explicit @":port"@, or @portless@ when it writes none. A
written-but-empty port is malformed, and the authority's trailing colon is what catches it. -}
effectivePort :: Word16 -> Text -> Text -> Maybe Word16
effectivePort :: Word16 -> Text -> Text -> Maybe Word16
effectivePort Word16
portless Text
authority Text
rest = case Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
rest of
    Just Text
written -> Text -> Maybe Word16
parsePort Text
written
    Maybe Text
Nothing
        | Bool -> Bool
not (Text -> Bool
T.null Text
rest) -> Maybe Word16
forall a. Maybe a
Nothing
        | Text
":" Text -> Text -> Bool
`T.isSuffixOf` Text
authority -> Maybe Word16
forall a. Maybe a
Nothing
        | Bool
otherwise -> Word16 -> Maybe Word16
forall a. a -> Maybe a
Just Word16
portless

{- A dialled port in the one spelling the gate accepts: decimal digits, no leading zero, 1..65535.
No crafted spelling may alias a canonical port, so 'readDecimalText' bars the other spellings. -}
parsePort :: Text -> Maybe Word16
parsePort :: Text -> Maybe Word16
parsePort Text
t = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> Text -> Text
T.take Int
1 Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"0")
    n <- Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimalText Text
t :: Maybe Integer
    guard (n >= 1 && n <= 65535)
    pure (fromInteger n)

-- Returns the answer alone, never the credential-bearing span it read.
carriesUserinfo :: Text -> Bool
carriesUserinfo :: Text -> Bool
carriesUserinfo = Text -> Text -> Bool
T.isInfixOf Text
"@" (Text -> Bool) -> (Text -> Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
authoritySpan

{- | Refuse an operator-configured URL that carries credential material: userinfo, a query string,
or a fragment. Run it before any check that quotes the value, and the reason it returns never does.

>>> refuseCredentialMaterial "server.publicUrl" "https://deploy:hunter2@ecluse.example.test"
Left "server.publicUrl must not carry userinfo (a credential belongs in its own configuration key)"

>>> refuseCredentialMaterial "registry.url" "https://registry.npmjs.org/@acme/thing"
Right ()
-}
refuseCredentialMaterial :: Text -> Text -> Either Text ()
refuseCredentialMaterial :: Text -> Text -> Either Text ()
refuseCredentialMaterial Text
subject Text
url
    | Text -> Bool
carriesUserinfo Text
url =
        Text -> Either Text ()
forall a b. a -> Either a b
Left (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must not carry userinfo (a credential belongs in its own configuration key)")
    | Text
"?" Text -> Text -> Bool
`T.isInfixOf` Text
url = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must not carry a query string")
    | Text
"#" Text -> Text -> Bool
`T.isInfixOf` Text
url = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text
subject Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" must not carry a fragment")
    | Bool
otherwise = () -> Either Text ()
forall a b. b -> Either a b
Right ()

{- The authority component, userinfo intact, truncated at the first path, query, or fragment
delimiter. Kept private: a caller holding the credential-bearing span is the exposure to prevent. -}
authoritySpan :: Text -> Text
authoritySpan :: Text -> Text
authoritySpan Text
raw = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Char
'/', Char
'?', Char
'#']) (Text -> Text -> Text
afterFirst Text
"://" Text
raw)

{- The authority of a URI or bare @host[:port]@ value, with any userinfo dropped. 'hostAddress' and
'hostPortAddress' share it, so the two extractions cannot drift on an authority edge case. -}
authorityOf :: Text -> Text
authorityOf :: Text -> Text
authorityOf = Text -> Text -> Text
afterLast Text
"@" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
authoritySpan

-- The text after @needle@'s last occurrence, or all of @hay@ if absent. The last "@" is the
-- userinfo boundary, matching what URL parsers do.
afterLast :: Text -> Text -> Text
afterLast :: Text -> Text -> Text
afterLast Text
needle Text
hay =
    let (Text
pre, Text
post) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
needle Text
hay
     in if Text -> Bool
T.null Text
pre then Text
hay else Text
post

{- | Split a @host[:port]@ authority into its bare host and the raw @":port"@ remainder, empty when
no port is present. The split is bracket-aware, and an unclosed opening bracket yields 'Nothing'.
-}
splitHostPort :: Text -> Maybe (Text, Text)
splitHostPort :: Text -> Maybe (Text, Text)
splitHostPort Text
authority
    | Text -> Bool
T.null Text
authority = Maybe (Text, Text)
forall a. Maybe a
Nothing
    | Bool
otherwise = case Text -> Text -> Maybe Text
T.stripPrefix Text
"[" Text
authority of
        Just Text
rest -> case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"]" Text
rest of
            (Text
_, Text
"") -> Maybe (Text, Text)
forall a. Maybe a
Nothing -- an opening bracket with no close: malformed
            (Text
inner, Text
afterBracket) -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
inner, Int -> Text -> Text
T.drop Int
1 Text
afterBracket)
        Maybe Text
Nothing -> case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
":" Text
authority of
            (Text
"", Text
_) -> Maybe (Text, Text)
forall a. Maybe a
Nothing
            (Text
h, Text
"") -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"")
            (Text
h, Text
p) -> if Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
":" then (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
"") else (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
h, Text
p)