-- 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 into an 'IpAddr' or 'Nothing' for a DNS name. Its dotted-quad is
lenient by design, coercing each octet exactly as @inet_aton@ and hence a libc resolver does,
so the policy layer tests the address the proxy would actually dial rather than a decimal
misreading. Delegating the recognition to a library would move that boundary, so only range
membership goes to @iproute@, in "Ecluse.Core.Security.Host".
-}
module Ecluse.Core.Security.IpLiteral (
    -- * IP literals
    IpAddr (..),
    parseIpLiteral,
) where

import Data.Text qualified as T

import Ecluse.Core.Text (readDecimalText, readHexText)

{- | An IP literal recognised from a host. The constructors are exported so
"Ecluse.Core.Security.Host" can convert one to an @iproute@ @IP@ value.
-}
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 the host allowlist still
constrains: a short @inet_aton@ form (@2130706433@, @127.1@), a bad octet, or a zone id.
-}
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

{- The host literal passes the @inet_aton@-faithful 'octetInetAton' and the embedded
IPv4-in-IPv6 form the strict-decimal 'octetDecimal'. Only the four-part form counts. -}
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 octet under @inet_aton@'s per-part base rules: @0x@ is hexadecimal, a leading @0@ octal,
anything else decimal. A digit outside the chosen base (the @8@ in @08@) fails, as glibc does. -}
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" -> Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readHexText (Int -> Text -> Text
T.drop Int
1 Text
rest)
            | 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)
_ -> Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimalText Text
tok

{- An IPv4 octet as a strict decimal run in @0..255@: the spelling inside an IPv4-in-IPv6
literal, where @inet_aton@'s base coercion does not apply, so the value is >= 0.
-}
octetDecimal :: Text -> Maybe Word8
octetDecimal :: Text -> Maybe Word8
octetDecimal Text
t = do
    n <- Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readDecimalText Text
t :: Maybe Integer
    if n <= 255 then Just (fromInteger n) else Nothing

{- The full eight-group form, or a @::@-compressed one optionally ending in an embedded
dotted-quad IPv4. Enough for the addresses the internal-range block covers. -}
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

{- One side of the @::@. Its final token may be a dotted-quad IPv4 (RFC 4291), which expands to
two groups, so @::ffff:169.254.169.254@ decodes rather than passing for a name. -}
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. 'readHexText' takes no sign and
no @0x@ prefix, so a parsed value is >= 0 and @0x1@ is not a group.
-}
parseV6Group :: Text -> Maybe Word16
parseV6Group :: Text -> Maybe Word16
parseV6Group Text
t = do
    n <- Text -> Maybe Integer
forall a. Integral a => Text -> Maybe a
readHexText Text
t :: 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 must total at most 7. -}
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 octal digits (0..7). @Data.Text.Read@ ships no octal
-- reader, so the leading-zero @inet_aton@ octal octet keeps its own gate.
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