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

{- | Outbound-request guards for the data plane: where the proxy is allowed to fetch.

An outbound target comes from the client's request path or an upstream's @dist.tarball@, and
must pass both halves of the SSRF gate: 'isAllowedUpstreamHost' restricts a fetch to the
configured upstream @host:port@ pairs, and 'isBlockedTarget' rejects internal address
literals. They compare different projections on purpose. Authorisation compares the full
authority, because the fetch dials the port too, while the block classifies the bare host,
because an address is internal at any port.
-}
module Ecluse.Core.Security.Host (
    -- * Outbound host:port allowlist
    AllowedHostPorts,
    allowedHostPorts,
    isAllowedUpstreamHost,

    -- * Internal-range block
    isBlockedTarget,
    isBlockedIP,
    parseBlockedRange,

    -- * Artifact-host gate
    Origin (..),
    tarballHostAllowed,
    artifactAuthorityHonoured,
    ecosystemArtifactAuthorities,
    TarballHostGate (..),
    tarballHostGate,
) where

import Data.IP (
    IP (IPv4, IPv6),
    IPRange (IPv4Range, IPv6Range),
    fromIPv6b,
    isMatchedTo,
    toIPv4,
    toIPv6,
 )
import Data.Set qualified as Set
import Data.Text qualified as T

import Ecluse.Core.Security.Authority (HostPort (..), hostPortAddress)
import Ecluse.Core.Security.IpLiteral (IpAddr (IpV4, IpV6), parseIpLiteral)

{- | The @host:port@ pairs the host guards authorise, canonicalised by 'allowedHostPorts', its
only constructor. An entry authorises exactly its own pair, port 443 when none was written.
-}
newtype AllowedHostPorts = AllowedHostPorts (Set HostPort)
    deriving stock (AllowedHostPorts -> AllowedHostPorts -> Bool
(AllowedHostPorts -> AllowedHostPorts -> Bool)
-> (AllowedHostPorts -> AllowedHostPorts -> Bool)
-> Eq AllowedHostPorts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AllowedHostPorts -> AllowedHostPorts -> Bool
== :: AllowedHostPorts -> AllowedHostPorts -> Bool
$c/= :: AllowedHostPorts -> AllowedHostPorts -> Bool
/= :: AllowedHostPorts -> AllowedHostPorts -> Bool
Eq, Int -> AllowedHostPorts -> ShowS
[AllowedHostPorts] -> ShowS
AllowedHostPorts -> String
(Int -> AllowedHostPorts -> ShowS)
-> (AllowedHostPorts -> String)
-> ([AllowedHostPorts] -> ShowS)
-> Show AllowedHostPorts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AllowedHostPorts -> ShowS
showsPrec :: Int -> AllowedHostPorts -> ShowS
$cshow :: AllowedHostPorts -> String
show :: AllowedHostPorts -> String
$cshowList :: [AllowedHostPorts] -> ShowS
showList :: [AllowedHostPorts] -> ShowS
Show)

{- | Normalise configured upstream authorities to the key form the guards match on. Equivalent
spellings of one IP literal collapse, so an operator's @0:0:0:0:0:0:0:1@ matches an incoming @::1@.
-}
allowedHostPorts :: Set HostPort -> AllowedHostPorts
allowedHostPorts :: Set HostPort -> AllowedHostPorts
allowedHostPorts = Set HostPort -> AllowedHostPorts
AllowedHostPorts (Set HostPort -> AllowedHostPorts)
-> (Set HostPort -> Set HostPort)
-> Set HostPort
-> AllowedHostPorts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HostPort -> HostPort) -> Set HostPort -> Set HostPort
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map HostPort -> HostPort
canonicalEntry
  where
    canonicalEntry :: HostPort -> HostPort
canonicalEntry (HostPort Text
host Word16
port) = Text -> Word16 -> HostPort
HostPort (Text -> Text
canonicalHostKey Text
host) Word16
port

{- | The allowlist half of the SSRF gate. Matching the pair is load-bearing: an allowlisted
host on an attacker-chosen port (@registry.npmjs.org:9443@) is an unauthorised target.
-}
isAllowedUpstreamHost :: AllowedHostPorts -> HostPort -> Bool
isAllowedUpstreamHost :: AllowedHostPorts -> HostPort -> Bool
isAllowedUpstreamHost (AllowedHostPorts Set HostPort
allowed) (HostPort Text
host Word16
port) =
    Bool -> Bool
not (Text -> Bool
T.null Text
host) Bool -> Bool -> Bool
&& Text -> Word16 -> HostPort
HostPort (Text -> Text
canonicalHostKey Text
host) Word16
port HostPort -> Set HostPort -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set HostPort
allowed

{- | Whether @host@ is an internal-address literal the proxy must not fetch. A DNS name is
not blocked here: the allowlist and the validating-TLS manager close that class.
-}
isBlockedTarget :: [IPRange] -> Text -> Bool
isBlockedTarget :: [IPRange] -> Text -> Bool
isBlockedTarget [IPRange]
additionalRanges Text
host =
    Bool -> (IpAddr -> Bool) -> Maybe IpAddr -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([IPRange] -> IP -> Bool
isBlockedIP [IPRange]
additionalRanges (IP -> Bool) -> (IpAddr -> IP) -> IpAddr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IpAddr -> IP
ipAddrToIP) (Text -> Maybe IpAddr
parseIpLiteral Text
host)

{- | Whether an 'IP' falls in a blocked internal range. An IPv6 address embedding an IPv4 one
decodes first (see 'decodeEmbeddedV4'), so an embedding literal cannot slip the IPv4 ranges.
-}
isBlockedIP :: [IPRange] -> IP -> Bool
isBlockedIP :: [IPRange] -> IP -> Bool
isBlockedIP [IPRange]
additionalRanges IP
ip = (IPRange -> Bool) -> [IPRange] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any IPRange -> Bool
matches ([IPRange]
blockedRanges [IPRange] -> [IPRange] -> [IPRange]
forall a. Semigroup a => a -> a -> a
<> [IPRange]
additionalRanges)
  where
    decoded :: IP
decoded = IP -> IP
decodeEmbeddedV4 IP
ip
    matches :: IPRange -> Bool
matches = \case
        IPv4Range AddrRange IPv4
r -> case IP
decoded of
            IPv4 IPv4
a -> IPv4
a IPv4 -> AddrRange IPv4 -> Bool
forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo` AddrRange IPv4
r
            IPv6 IPv6
_ -> Bool
False
        IPv6Range AddrRange IPv6
r -> case IP
decoded of
            IPv6 IPv6
a -> IPv6
a IPv6 -> AddrRange IPv6 -> Bool
forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo` AddrRange IPv6
r
            IPv4 IPv4
_ -> Bool
False

-- An operator cannot narrow this fixed set, only extend it through the @additionalRanges@
-- 'isBlockedIP' also consults.
blockedRanges :: [IPRange]
blockedRanges :: [IPRange]
blockedRanges =
    [ IPRange
"0.0.0.0/8" -- unspecified / this-host (reaches loopback on Linux)
    , IPRange
"10.0.0.0/8" -- RFC1918 private
    , IPRange
"100.64.0.0/10" -- CGNAT shared (RFC 6598)
    , IPRange
"127.0.0.0/8" -- loopback
    , IPRange
"169.254.0.0/16" -- link-local (incl. 169.254.169.254 metadata)
    , IPRange
"172.16.0.0/12" -- RFC1918 private
    , IPRange
"192.168.0.0/16" -- RFC1918 private
    , IPRange
"::/128" -- IPv6 unspecified
    , IPRange
"::1/128" -- IPv6 loopback
    , IPRange
"fe80::/10" -- IPv6 link-local
    , IPRange
"fc00::/7" -- IPv6 unique-local (incl. AWS IMDSv6 fd00:ec2::254)
    ]

{- | Parse one operator-configured CIDR entry (@"203.0.113.0\/24"@) into an 'IPRange'. It goes
through @iproute@'s total 'Read', not its partial 'IsString', so a malformed entry fails closed.
-}
parseBlockedRange :: Text -> Maybe IPRange
parseBlockedRange :: Text -> Maybe IPRange
parseBlockedRange = String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe IPRange)
-> (Text -> String) -> Text -> Maybe IPRange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString

-- The embedded-IPv4 decode stays with 'isBlockedIP', so an embedding literal rides through
-- here as the IPv6 it textually is.
ipAddrToIP :: IpAddr -> IP
ipAddrToIP :: IpAddr -> IP
ipAddrToIP = \case
    IpV4 Word8
a Word8
b Word8
c Word8
d -> IPv4 -> IP
IPv4 ([Int] -> IPv4
toIPv4 ((Word8 -> Int) -> [Word8] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word8
a, Word8
b, Word8
c, Word8
d]))
    IpV6 [Word16]
groups -> IPv6 -> IP
IPv6 ([Int] -> IPv6
toIPv6 ((Word16 -> Int) -> [Word16] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word16]
groups))

-- An IP literal renders through @iproute@'s 'show', so equivalent spellings collapse, and a
-- DNS name is only case-folded. Both guards fold through here, so neither can drift.
canonicalHostKey :: Text -> Text
canonicalHostKey :: Text -> Text
canonicalHostKey Text
host = case Text -> Maybe IpAddr
parseIpLiteral Text
host of
    Just IpAddr
addr -> IP -> Text
forall b a. (Show a, IsString b) => a -> b
show (IpAddr -> IP
ipAddrToIP IpAddr
addr)
    Maybe IpAddr
Nothing -> Text -> Text
T.toLower Text
host

{- Decode the IPv4-mapped, IPv4-compatible, and NAT64 embeddings. No embedding prefix falls in
a blocked IPv6 range, so without this @::169.254.169.254@ would pass the SSRF block. -}
decodeEmbeddedV4 :: IP -> IP
decodeEmbeddedV4 :: IP -> IP
decodeEmbeddedV4 = \case
    IPv6 IPv6
v6 -> case IPv6 -> [Int]
fromIPv6b IPv6
v6 of
        [Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0xFF, Int
0xFF, Int
a, Int
b, Int
c, Int
d] ->
            IPv4 -> IP
IPv4 ([Int] -> IPv4
toIPv4 [Int
a, Int
b, Int
c, Int
d])
        [Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
a, Int
b, Int
c, Int
d] ->
            IPv4 -> IP
IPv4 ([Int] -> IPv4
toIPv4 [Int
a, Int
b, Int
c, Int
d])
        [Int
0x00, Int
0x64, Int
0xFF, Int
0x9B, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
0, Int
a, Int
b, Int
c, Int
d] ->
            IPv4 -> IP
IPv4 ([Int] -> IPv4
toIPv4 [Int
a, Int
b, Int
c, Int
d])
        [Int
0x00, Int
0x64, Int
0xFF, Int
0x9B, Int
0x00, Int
0x01, Int
_, Int
_, Int
_, Int
_, Int
_, Int
_, Int
a, Int
b, Int
c, Int
d] ->
            IPv4 -> IP
IPv4 ([Int] -> IPv4
toIPv4 [Int
a, Int
b, Int
c, Int
d])
        [Int]
_ -> IPv6 -> IP
IPv6 IPv6
v6
    IP
ip -> IP
ip

{- | The trust of the origin a @dist.tarball@ comes from. It governs the literal internal-range
block alone, since a private registry may live on an internal address.
-}
data Origin
    = -- | The operator-configured private upstream: exempt from the literal internal-range block.
      TrustedOrigin
    | -- | The public upstream, and any attacker-influenceable target: subject to the literal internal-range block.
      UntrustedOrigin
    deriving stock (Origin -> Origin -> Bool
(Origin -> Origin -> Bool)
-> (Origin -> Origin -> Bool) -> Eq Origin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Origin -> Origin -> Bool
== :: Origin -> Origin -> Bool
$c/= :: Origin -> Origin -> Bool
/= :: Origin -> Origin -> Bool
Eq, Int -> Origin -> ShowS
[Origin] -> ShowS
Origin -> String
(Int -> Origin -> ShowS)
-> (Origin -> String) -> ([Origin] -> ShowS) -> Show Origin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Origin -> ShowS
showsPrec :: Int -> Origin -> ShowS
$cshow :: Origin -> String
show :: Origin -> String
$cshowList :: [Origin] -> ShowS
showList :: [Origin] -> ShowS
Show)

{- | Whether a @dist.tarball@ authority may be fetched. An upstream's @dist.tarball@ is
server-chosen data, so the target must equal the packument authority, @ecosystemHosts@ aside.
-}
tarballHostAllowed ::
    -- | The ecosystem's canonical artifact authorities, same-host-equivalent.
    AllowedHostPorts ->
    Origin ->
    -- | The @host:port@ allowlist (the same one every outbound fetch is gated by).
    AllowedHostPorts ->
    {- | The operator-configured ranges extending the fixed internal-range block
    (untrusted origin).
    -}
    [IPRange] ->
    -- | The authority that served the packument, when one could be extracted.
    Maybe HostPort ->
    -- | The authority of the candidate @dist.tarball@, when one could be extracted.
    Maybe HostPort ->
    Bool
tarballHostAllowed :: AllowedHostPorts
-> Origin
-> AllowedHostPorts
-> [IPRange]
-> Maybe HostPort
-> Maybe HostPort
-> Bool
tarballHostAllowed AllowedHostPorts
ecosystemHosts Origin
origin AllowedHostPorts
allowed [IPRange]
additionalBlockedRanges Maybe HostPort
packumentOrigin Maybe HostPort
tarballTarget =
    AllowedHostPorts -> Maybe HostPort -> Maybe HostPort -> Bool
artifactAuthorityHonoured AllowedHostPorts
ecosystemHosts Maybe HostPort
packumentOrigin Maybe HostPort
tarballTarget
        -- A target no authority extracts from is unfetchable, so it authorises nothing.
        Bool -> Bool -> Bool
&& Bool -> (HostPort -> Bool) -> Maybe HostPort -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False HostPort -> Bool
fetchable Maybe HostPort
tarballTarget
  where
    fetchable :: HostPort -> Bool
fetchable HostPort
target =
        AllowedHostPorts -> HostPort -> Bool
isAllowedUpstreamHost AllowedHostPorts
allowed HostPort
target Bool -> Bool -> Bool
&& Origin -> [IPRange] -> HostPort -> Bool
internalRangeOk Origin
origin [IPRange]
additionalBlockedRanges HostPort
target

-- The block classifies the bare host, since an address is internal whatever port it is
-- dialled on. The trusted private origin is exempt (see 'Origin').
internalRangeOk :: Origin -> [IPRange] -> HostPort -> Bool
internalRangeOk :: Origin -> [IPRange] -> HostPort -> Bool
internalRangeOk Origin
origin [IPRange]
additionalBlockedRanges HostPort
target = case Origin
origin of
    Origin
TrustedOrigin -> Bool
True
    Origin
UntrustedOrigin -> Bool -> Bool
not ([IPRange] -> Text -> Bool
isBlockedTarget [IPRange]
additionalBlockedRanges (HostPort -> Text
hpHost HostPort
target))

{- | Whether an artifact's authority is honoured for a document the given authority served: the
same dial target, or one the ecosystem serves artifact bytes from by design.
-}
artifactAuthorityHonoured :: AllowedHostPorts -> Maybe HostPort -> Maybe HostPort -> Bool
artifactAuthorityHonoured :: AllowedHostPorts -> Maybe HostPort -> Maybe HostPort -> Bool
artifactAuthorityHonoured AllowedHostPorts
ecosystemHosts Maybe HostPort
packumentOrigin Maybe HostPort
artifactTarget =
    case (Maybe HostPort
packumentOrigin, Maybe HostPort
artifactTarget) of
        (Just HostPort
packument, Just HostPort
target) ->
            HostPort -> HostPort -> Bool
sameAuthority HostPort
target HostPort
packument Bool -> Bool -> Bool
|| AllowedHostPorts -> HostPort -> Bool
isAllowedUpstreamHost AllowedHostPorts
ecosystemHosts HostPort
target
        (Maybe HostPort, Maybe HostPort)
_ -> Bool
False

{- | The authority set of an ecosystem's declared artifact hosts, which the gate and each
adapter's projection both derive 'artifactAuthorityHonoured''s first argument through.
-}
ecosystemArtifactAuthorities :: [Text] -> AllowedHostPorts
ecosystemArtifactAuthorities :: [Text] -> AllowedHostPorts
ecosystemArtifactAuthorities = Set HostPort -> AllowedHostPorts
allowedHostPorts (Set HostPort -> AllowedHostPorts)
-> ([Text] -> Set HostPort) -> [Text] -> AllowedHostPorts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HostPort] -> Set HostPort
forall a. Ord a => [a] -> Set a
Set.fromList ([HostPort] -> Set HostPort)
-> ([Text] -> [HostPort]) -> [Text] -> Set HostPort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Maybe HostPort) -> [Text] -> [HostPort]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe HostPort
hostPortAddress

-- Whether two authorities are one dial target: equal canonical host keys and equal
-- effective ports.
sameAuthority :: HostPort -> HostPort -> Bool
sameAuthority :: HostPort -> HostPort -> Bool
sameAuthority (HostPort Text
host Word16
port) (HostPort Text
host' Word16
port') =
    Text -> Text
canonicalHostKey Text
host Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text
canonicalHostKey Text
host' Bool -> Bool -> Bool
&& Word16
port Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
port'

{- | The mount-constant inputs to the per-request 'tarballHostAllowed' gate. The gate runs on
the hot artifact path, so only the dynamic public @dist.tarball@ authority is parsed per request.
-}
data TarballHostGate = TarballHostGate
    { TarballHostGate -> AllowedHostPorts
thgAllowlist :: AllowedHostPorts
    {- ^ The mount's configured upstreams plus the ecosystem's artifact hosts, the same set
    every outbound fetch is gated against. A URL that writes no port contributes its host at 443.
    -}
    , TarballHostGate -> AllowedHostPorts
thgEcosystemHosts :: AllowedHostPorts
    {- ^ The adapter's artifact authorities (npm has none, PyPI's is @files.pythonhosted.org@):
    the one same-host equivalence, still internal-range-gated like any target.
    -}
    , TarballHostGate -> Maybe HostPort
thgPrivateHostPort :: Maybe HostPort
    -- ^ The private upstream's authority. 'Nothing' authorises nothing (fail closed).
    , TarballHostGate -> Maybe HostPort
thgPublicHostPort :: Maybe HostPort
    -- ^ The public upstream's authority, with the same fail-closed reading.
    }
    deriving stock (TarballHostGate -> TarballHostGate -> Bool
(TarballHostGate -> TarballHostGate -> Bool)
-> (TarballHostGate -> TarballHostGate -> Bool)
-> Eq TarballHostGate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TarballHostGate -> TarballHostGate -> Bool
== :: TarballHostGate -> TarballHostGate -> Bool
$c/= :: TarballHostGate -> TarballHostGate -> Bool
/= :: TarballHostGate -> TarballHostGate -> Bool
Eq, Int -> TarballHostGate -> ShowS
[TarballHostGate] -> ShowS
TarballHostGate -> String
(Int -> TarballHostGate -> ShowS)
-> (TarballHostGate -> String)
-> ([TarballHostGate] -> ShowS)
-> Show TarballHostGate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TarballHostGate -> ShowS
showsPrec :: Int -> TarballHostGate -> ShowS
$cshow :: TarballHostGate -> String
show :: TarballHostGate -> String
$cshowList :: [TarballHostGate] -> ShowS
showList :: [TarballHostGate] -> ShowS
Show)

{- | Build the gate from the ecosystem's artifact hosts and a mount's private, public, and
mirror-target URLs. A URL no authority extracts from authorises nothing (fail closed).
-}
tarballHostGate :: [Text] -> Maybe Text -> Text -> Maybe Text -> TarballHostGate
tarballHostGate :: [Text] -> Maybe Text -> Text -> Maybe Text -> TarballHostGate
tarballHostGate [Text]
ecosystemHostUrls Maybe Text
privateUrl Text
publicUrl Maybe Text
mirrorUrl =
    TarballHostGate
        { thgAllowlist :: AllowedHostPorts
thgAllowlist =
            Set HostPort -> AllowedHostPorts
allowedHostPorts
                ( [HostPort] -> Set HostPort
forall a. Ord a => [a] -> Set a
Set.fromList
                    ([Maybe HostPort] -> [HostPort]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe HostPort
privateHostPort, Maybe HostPort
publicHostPort, Text -> Maybe HostPort
hostPortAddress (Text -> Maybe HostPort) -> Maybe Text -> Maybe HostPort
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
mirrorUrl] [Maybe HostPort] -> [Maybe HostPort] -> [Maybe HostPort]
forall a. Semigroup a => a -> a -> a
<> (Text -> Maybe HostPort) -> [Text] -> [Maybe HostPort]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe HostPort
hostPortAddress [Text]
ecosystemHostUrls))
                )
        , thgEcosystemHosts :: AllowedHostPorts
thgEcosystemHosts = [Text] -> AllowedHostPorts
ecosystemArtifactAuthorities [Text]
ecosystemHostUrls
        , thgPrivateHostPort :: Maybe HostPort
thgPrivateHostPort = Maybe HostPort
privateHostPort
        , thgPublicHostPort :: Maybe HostPort
thgPublicHostPort = Maybe HostPort
publicHostPort
        }
  where
    privateHostPort :: Maybe HostPort
privateHostPort = Text -> Maybe HostPort
hostPortAddress (Text -> Maybe HostPort) -> Maybe Text -> Maybe HostPort
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Text
privateUrl
    publicHostPort :: Maybe HostPort
publicHostPort = Text -> Maybe HostPort
hostPortAddress Text
publicUrl