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

{- | A hand-rolled recogniser for IP literals, feeding the internal-range block.

'parseIpLiteral' turns a host string into an 'IpAddr' (dotted-quad IPv4 or the
IPv6 forms a host realistically carries), or 'Nothing' for a DNS name. The
recogniser is deliberately __lenient__ on the IPv4 dotted-quad, coercing each
octet exactly as @inet_aton@ and hence a libc resolver does (leading-zero octal,
@0x@ hex), so the policy layer tests the address that would actually be dialled
rather than a decimal misreading. Range membership is delegated to @iproute@ by
the policy layer ("Ecluse.Core.Security.Host"); recognising the literal stays here
on purpose, because delegating it to a library would change that lenient boundary.
See 'parseIpLiteral' for the exact grammar and the boundaries left unmodelled.
-}
module Ecluse.Core.Security.IpLiteral (
    -- * IP literals
    IpAddr (..),
    parseIpLiteral,

    -- * Lexical predicates (internal for testing)
    isDecimal,
    isHex,
) where

import Data.Text qualified as T

{- | An IP literal recognised from a host, for the internal-range block. The
constructors are exposed so the policy layer ("Ecluse.Core.Security.Host") can
convert it to an @iproute@ @IP@ value for the range-membership test; the type
carries no instances of its own.
-}
data IpAddr
    = -- | An IPv4 address as its four octets.
      IpV4 Word8 Word8 Word8 Word8
    | -- | An IPv6 address, normalised to its eight 16-bit groups.
      IpV6 [Word16]

{- | Parse a host as an IP literal, or 'Nothing' for a DNS name. Handles dotted-
quad IPv4 and the IPv6 forms a host realistically carries -- full eight-group form,
@::@-compressed forms (including @::1@), and a trailing embedded IPv4 (the
@a.b.c.d@ in @::ffff:a.b.c.d@) -- which is enough to recognise the loopback,
link-local, and IPv4-mapped addresses 'Ecluse.Core.Security.Host.isBlockedIP' blocks. It is deliberately
__not__ a complete IPv6 parser (no zone ids); an unrecognised literal is treated
as a name, which the host allowlist still constrains.

Only range __membership__ is delegated to @iproute@ ('Ecluse.Core.Security.Host.isBlockedIP'); recognising
the literal stays hand-rolled __on purpose__. This recogniser is deliberately
__lenient__ on the IPv4 dotted-quad: it accepts the ambiguous octet spellings a
strict IP library rejects and coerces each octet exactly as @inet_aton@ -- and
hence a libc resolver -- does, so the block tests the address that would actually be
dialled. A @0x@\/@0X@-prefixed octet is hexadecimal, a leading-zero octet is
__octal__, and anything else is decimal. A leading-zero octet is therefore /not/
its decimal digits: @0012.0.0.1@ is octal @10.0.0.1@ (RFC1918, blocked), whereas
@010.0.0.1@ is octal @8.0.0.1@ and @0127.0.0.1@ is octal @87.0.0.1@ (both public,
not blocked) -- matching the resolver rather than a decimal misreading. A stricter
parser that rejected these spellings would let an octal\/hex spelling of an
internal address skip the block and reach the resolving fetch as a name, silently
__narrowing__ the SSRF gate.

Two boundaries are deliberately not modelled here; such a host is simply treated as a
name, which the host allowlist constrains. First, the __short__ @inet_aton@ forms with
fewer than four parts (a bare 32-bit number @2130706433@ \/ @0x7f000001@, or a @127.1@)
are not literals here. Second, a malformed octet (an invalid-octal @08@, where 8 is not
an octal digit, or an overflowing @0400@\/@256@\/@0x100@) is not a literal, exactly as a
resolver rejects it. A malformed IPv6 group that overflows 16 bits (@fe80::1ffff@) is
likewise not a literal here. Delegating literal /parsing/ to a library would change this
lenient/strict boundary, so it is kept here.
-}
parseIpLiteral :: Text -> Maybe IpAddr
parseIpLiteral :: Text -> Maybe IpAddr
parseIpLiteral Text
host = case Text -> Maybe (Char, Text)
T.uncons Text
host of
    Maybe (Char, Text)
Nothing -> Maybe IpAddr
forall a. Maybe a
Nothing -- empty host: not a literal
    Just (Char, Text)
_ -> if (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
host then Text -> Maybe IpAddr
parseIPv6 Text
host else (Text -> Maybe Word8) -> Text -> Maybe IpAddr
parseIPv4 Text -> Maybe Word8
octetInetAton Text
host

{- Parse a four-part dotted-quad @a.b.c.d@ into its octets, each coerced to @0..255@
by the supplied octet parser. The top-level host literal passes the
@inet_aton@-faithful 'octetInetAton' (leading-zero octal and @0x@ hex), and the
embedded IPv4-in-IPv6 form passes the strict-decimal 'octetDecimal'; only the
four-part form is recognised (see 'parseIpLiteral' for the short forms treated as names).
-}
parseIPv4 :: (Text -> Maybe Word8) -> Text -> Maybe IpAddr
parseIPv4 :: (Text -> Maybe Word8) -> Text -> Maybe IpAddr
parseIPv4 Text -> Maybe Word8
octet Text
host = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
host of
    [Text
a, Text
b, Text
c, Text
d] -> Word8 -> Word8 -> Word8 -> Word8 -> IpAddr
IpV4 (Word8 -> Word8 -> Word8 -> Word8 -> IpAddr)
-> Maybe Word8 -> Maybe (Word8 -> Word8 -> Word8 -> IpAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Word8
octet Text
a Maybe (Word8 -> Word8 -> Word8 -> IpAddr)
-> Maybe Word8 -> Maybe (Word8 -> Word8 -> IpAddr)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Word8
octet Text
b Maybe (Word8 -> Word8 -> IpAddr)
-> Maybe Word8 -> Maybe (Word8 -> IpAddr)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Word8
octet Text
c Maybe (Word8 -> IpAddr) -> Maybe Word8 -> Maybe IpAddr
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Maybe Word8
octet Text
d
    [Text]
_ -> Maybe IpAddr
forall a. Maybe a
Nothing

{- An IPv4 octet under @inet_aton@'s per-part base rules -- the coercion a libc
resolver ('getAddrInfo') applies, so the internal-range block tests the address a
resolver would actually dial. A @0x@\/@0X@ prefix is hexadecimal, a leading @0@
(with at least one more digit) is octal, and anything else is decimal; the parsed
value must still fit @0..255@, so an overflowing part (@0400@ = 256, @0x100@ = 256)
is rejected exactly as a resolver rejects it. The base-digit check keeps 'readMaybe'
from accepting signs or whitespace and rejects a digit outside the chosen base (the
@8@ in @08@ is not octal), so such a spelling is not a literal -- matching glibc,
which refuses it rather than coercing it.
-}
octetInetAton :: Text -> Maybe Word8
octetInetAton :: Text -> Maybe Word8
octetInetAton Text
tok = do
    n <- Maybe Integer
value
    if n <= 255 then Just (fromInteger n) else Nothing
  where
    value :: Maybe Integer
    value :: Maybe Integer
value = case Text -> Maybe (Char, Text)
T.uncons Text
tok of
        Just (Char
'0', Text
rest)
            | Text -> Text
T.toLower (Int -> Text -> Text
T.take Int
1 Text
rest) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"x" ->
                let hex :: Text
hex = Int -> Text -> Text
T.drop Int
1 Text
rest
                 in if Text -> Bool
isHex Text
hex then String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String
"0x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
hex) else Maybe Integer
forall a. Maybe a
Nothing
            | Bool -> Bool
not (Text -> Bool
T.null Text
rest) ->
                if Text -> Bool
isOctal Text
tok then String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String
"0o" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
tok) else Maybe Integer
forall a. Maybe a
Nothing
        Maybe (Char, Text)
_ -> if Text -> Bool
isDecimal Text
tok then String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
tok) else Maybe Integer
forall a. Maybe a
Nothing

{- An IPv4 octet as a non-empty all-decimal run in @0..255@: the strict spelling
used inside an IPv4-in-IPv6 literal (@::ffff:a.b.c.d@), where the embedded form is
not subject to @inet_aton@'s base coercion. The digit check keeps 'readMaybe' from
accepting signs\/whitespace, so a parsed value is >= 0.
-}
octetDecimal :: Text -> Maybe Word8
octetDecimal :: Text -> Maybe Word8
octetDecimal Text
t = do
    n <- if Text -> Bool
isDecimal Text
t then String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
t) else Maybe Integer
forall a. Maybe a
Nothing :: Maybe Integer
    if n <= 255 then Just (fromInteger n) else Nothing

{- Parse an IPv6 literal -- either the full eight-group form or a @::@-compressed
form (at most one @::@), optionally ending in an embedded dotted-quad IPv4 -- into
its eight 16-bit groups. Enough to recognise the @::1@, @fe80::\/10@, and
@::ffff:0:0\/96@ addresses we block; rejects anything malformed.
-}
parseIPv6 :: Text -> Maybe IpAddr
parseIPv6 :: Text -> Maybe IpAddr
parseIPv6 Text
host = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"::" Text
host of
    [Text
single] -> [Word16] -> Maybe IpAddr
exactlyEightGroups ([Word16] -> Maybe IpAddr) -> Maybe [Word16] -> Maybe IpAddr
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe [Word16]
parseV6Side Text
single
    [Text
before, Text
after] -> do
        hd <- Text -> Maybe [Word16]
parseV6Side Text
before
        tl <- parseV6Side after
        expandCompressedV6 hd tl
    [Text]
_ -> Maybe IpAddr
forall a. Maybe a
Nothing -- more than one "::" is illegal

{- The colon-separated groups of one side of the @::@; "" → no groups. The final
token may be a dotted-quad IPv4 (RFC 4291 §2.2.3, e.g. the @169.254.169.254@ in
@::ffff:169.254.169.254@), which expands to its two 16-bit groups so an
IPv4-mapped literal in its canonical dotted form is decoded rather than
mistaken for a name. Only the last token may be dotted; an interior dotted
token fails 'parseV6Group' (no hex '.') and the whole parse is rejected.
-}
parseV6Side :: Text -> Maybe [Word16]
parseV6Side :: Text -> Maybe [Word16]
parseV6Side Text
t
    | Text -> Bool
T.null Text
t = [Word16] -> Maybe [Word16]
forall a. a -> Maybe a
Just []
    | Bool
otherwise = [Text] -> Maybe [Word16]
parseV6Tokens (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
":" Text
t)

parseV6Tokens :: [Text] -> Maybe [Word16]
parseV6Tokens :: [Text] -> Maybe [Word16]
parseV6Tokens [] = [Word16] -> Maybe [Word16]
forall a. a -> Maybe a
Just []
parseV6Tokens [Text
tok]
    | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
tok = Text -> Maybe [Word16]
parseEmbeddedV4 Text
tok
    | Bool
otherwise = (Word16 -> [Word16] -> [Word16]
forall a. a -> [a] -> [a]
: []) (Word16 -> [Word16]) -> Maybe Word16 -> Maybe [Word16]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Word16
parseV6Group Text
tok
parseV6Tokens (Text
tok : [Text]
rest) = (:) (Word16 -> [Word16] -> [Word16])
-> Maybe Word16 -> Maybe ([Word16] -> [Word16])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Word16
parseV6Group Text
tok Maybe ([Word16] -> [Word16]) -> Maybe [Word16] -> Maybe [Word16]
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Text] -> Maybe [Word16]
parseV6Tokens [Text]
rest

-- A trailing dotted-quad IPv4 as its two 16-bit groups (high pair, low pair).
parseEmbeddedV4 :: Text -> Maybe [Word16]
parseEmbeddedV4 :: Text -> Maybe [Word16]
parseEmbeddedV4 Text
t = case (Text -> Maybe Word8) -> Text -> Maybe IpAddr
parseIPv4 Text -> Maybe Word8
octetDecimal Text
t of
    Just (IpV4 Word8
a Word8
b Word8
c Word8
d) -> [Word16] -> Maybe [Word16]
forall a. a -> Maybe a
Just [Word8 -> Word8 -> Word16
forall {a} {a} {a}. (Integral a, Integral a, Num a) => a -> a -> a
pair Word8
a Word8
b, Word8 -> Word8 -> Word16
forall {a} {a} {a}. (Integral a, Integral a, Num a) => a -> a -> a
pair Word8
c Word8
d]
    Maybe IpAddr
_ -> Maybe [Word16]
forall a. Maybe a
Nothing
  where
    pair :: a -> a -> a
pair a
hi a
lo = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
hi a -> a -> a
forall a. Num a => a -> a -> a
* a
256 a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
lo

{- A group is a non-empty all-hex run that fits in 16 bits. The hex check
keeps 'readMaybe' from accepting signs, so a parsed value is >= 0.
-}
parseV6Group :: Text -> Maybe Word16
parseV6Group :: Text -> Maybe Word16
parseV6Group Text
t = do
    n <- if Text -> Bool
isHex Text
t then String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (String
"0x" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. ToString a => a -> String
toString Text
t) else Maybe Integer
forall a. Maybe a
Nothing :: Maybe Integer
    if n <= 0xFFFF then Just (fromInteger n) else Nothing

{- Fill the compressed form's zero run: "::" stands for at least one all-zero
group, so the explicit groups on either side must total at most 7 (leaving room
to fill to 8).
-}
expandCompressedV6 :: [Word16] -> [Word16] -> Maybe IpAddr
expandCompressedV6 :: [Word16] -> [Word16] -> Maybe IpAddr
expandCompressedV6 [Word16]
hd [Word16]
tl =
    let present :: Int
present = [Word16] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
hd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Word16] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
tl
     in if Int
present Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
7
            then IpAddr -> Maybe IpAddr
forall a. a -> Maybe a
Just ([Word16] -> IpAddr
IpV6 ([Word16]
hd [Word16] -> [Word16] -> [Word16]
forall a. Semigroup a => a -> a -> a
<> Int -> Word16 -> [Word16]
forall a. Int -> a -> [a]
replicate (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
present) Word16
0 [Word16] -> [Word16] -> [Word16]
forall a. Semigroup a => a -> a -> a
<> [Word16]
tl))
            else Maybe IpAddr
forall a. Maybe a
Nothing

-- Exactly the full eight-group form; anything else is malformed.
exactlyEightGroups :: [Word16] -> Maybe IpAddr
exactlyEightGroups :: [Word16] -> Maybe IpAddr
exactlyEightGroups gs :: [Word16]
gs@[Word16
_, Word16
_, Word16
_, Word16
_, Word16
_, Word16
_, Word16
_, Word16
_] = IpAddr -> Maybe IpAddr
forall a. a -> Maybe a
Just ([Word16] -> IpAddr
IpV6 [Word16]
gs)
exactlyEightGroups [Word16]
_ = Maybe IpAddr
forall a. Maybe a
Nothing

-- Whether @t@ is a non-empty run of decimal digits (no sign or whitespace).
isDecimal :: Text -> Bool
isDecimal :: Text -> Bool
isDecimal Text
t = Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Char
'0' .. Char
'9']) Text
t

-- Whether @t@ is a non-empty run of octal digits (0..7).
isOctal :: Text -> Bool
isOctal :: Text -> Bool
isOctal Text
t = Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Char
'0' .. Char
'7']) Text
t

-- Whether @t@ is a non-empty run of hexadecimal digits.
isHex :: Text -> Bool
isHex :: Text -> Bool
isHex Text
t = Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isHexDigit Text
t
  where
    isHexDigit :: Char -> Bool
isHexDigit Char
c = Char
c Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` ([Char
'0' .. Char
'9'] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
'a' .. Char
'f'] String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
'A' .. Char
'F'])