-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT
{-# LANGUAGE MagicHash #-}

{- | Shared text parsing, rendering and storage without dependencies on other core modules.
Inbound routes and outbound artifact filenames share the same path-component gate.
-}
module Ecluse.Core.Text (
    nonBlank,
    stripTrailingSlash,
    joinUrlPath,
    urlFilename,
    urlFilenameComponent,
    isSafeComponent,
    afterFirst,
    LowerPrefix,
    httpsPrefix,
    httpPrefix,
    lowerPrefixChars,
    isPrefixOfLowered,
    registryPath,
    readDecimalText,
    readHexText,
    renderIso8601Utc,
    displayExceptionT,
    textStorageBytes,
) where

import Data.Array.Byte (ByteArray (..))
import Data.Char (isControl)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Text.Internal qualified as TI
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TB
import Data.Text.Lazy.Builder.Int qualified as TBI
import Data.Text.Read qualified as TR
import Data.Time (UTCTime (UTCTime), diffTimeToPicoseconds, toGregorian)
import Data.Time.Format.ISO8601 (iso8601Show)
import GHC.Exts (Int (I#), sizeofByteArray#)
import Network.HTTP.Types.URI (urlDecode)

{- | The text trimmed of surrounding whitespace, or 'Nothing' when nothing remains.
An empty or all-whitespace value therefore counts as absent.
-}
nonBlank :: Text -> Maybe Text
nonBlank :: Text -> Maybe Text
nonBlank Text
t =
    let trimmed :: Text
trimmed = Text -> Text
T.strip Text
t
     in if Text -> Bool
T.null Text
trimmed then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
trimmed

-- | Drop every trailing slash from a URL base, so @https:\/\/host\/\/@ and @https:\/\/host@ agree.
stripTrailingSlash :: Text -> Text
stripTrailingSlash :: Text -> Text
stripTrailingSlash = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

{- | Join a URL base and an already-encoded path with exactly one slash, whatever trailing
slashes the base writes. It appends the path verbatim, and neither encodes nor validates it.
-}
joinUrlPath :: Text -> Text -> Text
joinUrlPath :: Text -> Text -> Text
joinUrlPath Text
b Text
path = Text -> Text
stripTrailingSlash Text
b Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path

{- | The final URL path component, preserving its encoded spelling without query or fragment.
Both the raw and once-decoded component must pass 'isSafeComponent', with valid decoded UTF-8.
-}
urlFilename :: Text -> Maybe Text
urlFilename :: Text -> Maybe Text
urlFilename Text
url = do
    let filename :: Text
filename = Text -> Text
urlFilenameComponent Text
url
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Bool
isSafeComponent Text
filename)
    -- A component with no percent sign decodes to itself.
    Bool -> Maybe () -> Maybe ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'%') Text
filename) (Maybe () -> Maybe ()) -> Maybe () -> Maybe ()
forall a b. (a -> b) -> a -> b
$ do
        decoded <- Either UnicodeException Text -> Maybe Text
forall l r. Either l r -> Maybe r
rightToMaybe (ByteString -> Either UnicodeException Text
TE.decodeUtf8' (Bool -> ByteString -> ByteString
urlDecode Bool
False (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
filename)))
        guard (isSafeComponent decoded)
    Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
filename

{- | The raw final URL path component without query or fragment, possibly empty.
No decoding or validation occurs. Callers must validate and encode it before URL construction.
-}
urlFilenameComponent :: Text -> Text
urlFilenameComponent :: Text -> Text
urlFilenameComponent = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
inPath
  where
    inPath :: Char -> Bool
inPath Char
ch = Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#'

-- | Refuse empty components, traversal, separators, and controls. Callers must still percent-encode on URL construction.
isSafeComponent :: Text -> Bool
isSafeComponent :: Text -> Bool
isSafeComponent Text
c =
    Bool -> Bool
not (Text -> Bool
T.null Text
c)
        Bool -> Bool -> Bool
&& Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"."
        Bool -> Bool -> Bool
&& Text
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
".."
        Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
safeChar Text
c
  where
    safeChar :: Char -> Bool
safeChar Char
ch = Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/' Bool -> Bool -> Bool
&& Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isControl Char
ch)

{- | The text after @needle@'s first occurrence, or all of @hay@ if absent. The scheme separator
matches first, so a crafted "https://169.254.169.254/x?u=https://ok" gates on the host dialled.
-}
afterFirst :: Text -> Text -> Text
afterFirst :: Text -> Text -> Text
afterFirst Text
needle Text
hay = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
hay (Text -> Text -> Maybe Text
T.stripPrefix Text
needle ((Text, Text) -> Text
forall a b. (a, b) -> b
snd (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
needle Text
hay)))

{- | A lower-case prefix with its length in characters, so checking for it never measures a text.
The constructor stays private, so each count sits beside its prefix in this module.
-}
data LowerPrefix = LowerPrefix Int Text
    deriving stock (MonthOfYear -> LowerPrefix -> ShowS
[LowerPrefix] -> ShowS
LowerPrefix -> String
(MonthOfYear -> LowerPrefix -> ShowS)
-> (LowerPrefix -> String)
-> ([LowerPrefix] -> ShowS)
-> Show LowerPrefix
forall a.
(MonthOfYear -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: MonthOfYear -> LowerPrefix -> ShowS
showsPrec :: MonthOfYear -> LowerPrefix -> ShowS
$cshow :: LowerPrefix -> String
show :: LowerPrefix -> String
$cshowList :: [LowerPrefix] -> ShowS
showList :: [LowerPrefix] -> ShowS
Show)

-- | The @https://@ scheme prefix.
httpsPrefix :: LowerPrefix
httpsPrefix :: LowerPrefix
httpsPrefix = MonthOfYear -> Text -> LowerPrefix
LowerPrefix MonthOfYear
8 Text
"https://"

-- | The @http://@ scheme prefix.
httpPrefix :: LowerPrefix
httpPrefix :: LowerPrefix
httpPrefix = MonthOfYear -> Text -> LowerPrefix
LowerPrefix MonthOfYear
7 Text
"http://"

-- | The prefix's length in characters.
lowerPrefixChars :: LowerPrefix -> Int
lowerPrefixChars :: LowerPrefix -> MonthOfYear
lowerPrefixChars (LowerPrefix MonthOfYear
chars Text
_) = MonthOfYear
chars

{- | Whether the prefix begins the lower-cased text. It lowers only the prefix's length of the text,
which suffices because 'T.toLower' maps each character on its own to at least one.
-}
isPrefixOfLowered :: LowerPrefix -> Text -> Bool
isPrefixOfLowered :: LowerPrefix -> Text -> Bool
isPrefixOfLowered (LowerPrefix MonthOfYear
chars Text
prefix) Text
t = Text
lowered Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
prefix
  where
    -- Equality, not 'T.isPrefixOf', which streams both texts and allocates for each character.
    lowered :: Text
lowered = MonthOfYear -> Text -> Text
T.take MonthOfYear
chars (Text -> Text
T.toLower (MonthOfYear -> Text -> Text
T.take MonthOfYear
chars Text
t))

{- | The path half of an absolute URL, from the first slash after the authority. It splits on the
first scheme separator, so a later one inside the URL cannot move where the path starts.
-}
registryPath :: Text -> Text
registryPath :: Text -> Text
registryPath Text
raw = (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') (Text -> Text -> Text
afterFirst Text
"://" Text
raw)

{- | The non-negative integer a bare decimal digit run spells, 'Nothing' for anything else.
Stricter than 'readMaybe', which also takes a sign, @0x10@, @0o10@, @  5@, and @(5)@.
-}
readDecimalText :: (Integral a) => Text -> Maybe a
readDecimalText :: forall a. Integral a => Text -> Maybe a
readDecimalText = Reader a -> Text -> Maybe a
forall a. Reader a -> Text -> Maybe a
readWholly Reader a
forall a. Integral a => Reader a
TR.decimal

{- | The non-negative integer a bare hexadecimal digit run spells. The @0x@ prefix that
@Data.Text.Read.hexadecimal@ takes is refused, so a caller strips and judges the prefix itself.
-}
readHexText :: (Integral a) => Text -> Maybe a
readHexText :: forall a. Integral a => Text -> Maybe a
readHexText Text
t
    | LowerPrefix -> Text -> Bool
isPrefixOfLowered LowerPrefix
hexPrefix Text
t = Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = Reader a -> Text -> Maybe a
forall a. Reader a -> Text -> Maybe a
readWholly Reader a
forall a. Integral a => Reader a
TR.hexadecimal Text
t

hexPrefix :: LowerPrefix
hexPrefix :: LowerPrefix
hexPrefix = MonthOfYear -> Text -> LowerPrefix
LowerPrefix MonthOfYear
2 Text
"0x"

-- The value a reader produced, only when it consumed the whole input. Trailing text is a
-- refusal rather than a silent prefix parse.
readWholly :: TR.Reader a -> Text -> Maybe a
readWholly :: forall a. Reader a -> Text -> Maybe a
readWholly Reader a
textReader Text
t = case Reader a
textReader Text
t of
    Right (a
n, Text
rest) | Text -> Bool
T.null Text
rest -> a -> Maybe a
forall a. a -> Maybe a
Just a
n
    Either String (a, Text)
_ -> Maybe a
forall a. Maybe a
Nothing

{- | Match 'iso8601Show', using a builder for years 0-9999 below 86 400 seconds.
Other instants delegate to 'iso8601Show' to preserve its representation.
-}
renderIso8601Utc :: UTCTime -> Text
renderIso8601Utc :: UTCTime -> Text
renderIso8601Utc t :: UTCTime
t@(UTCTime Day
day DiffTime
dt)
    | Integer
year Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 Bool -> Bool -> Bool
|| Integer
year Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
9999 Bool -> Bool -> Bool
|| Integer
picos Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
86_400_000_000_000_000 = String -> Text
forall a. ToText a => a -> Text
toText (UTCTime -> String
forall t. ISO8601 t => t -> String
iso8601Show UTCTime
t)
    | Bool
otherwise =
        LazyText -> Text
TL.toStrict (LazyText -> Text) -> (Builder -> LazyText) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
TB.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$
            MonthOfYear -> Integer -> Builder
digits MonthOfYear
4 Integer
year
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MonthOfYear -> Integer -> Builder
digits MonthOfYear
2 (MonthOfYear -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
month)
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"-"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MonthOfYear -> Integer -> Builder
digits MonthOfYear
2 (MonthOfYear -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral MonthOfYear
dayOfMonth)
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"T"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MonthOfYear -> Integer -> Builder
digits MonthOfYear
2 Integer
hh
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MonthOfYear -> Integer -> Builder
digits MonthOfYear
2 Integer
mm
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
":"
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> MonthOfYear -> Integer -> Builder
digits MonthOfYear
2 Integer
ss
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
fraction
                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"Z"
  where
    (Integer
year, MonthOfYear
month, MonthOfYear
dayOfMonth) = Day -> (Integer, MonthOfYear, MonthOfYear)
toGregorian Day
day
    picos :: Integer
picos = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
dt
    (Integer
secondsOfDay, Integer
frac) = Integer
picos Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
1_000_000_000_000
    (Integer
hh, Integer
rem') = Integer
secondsOfDay Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
3600
    (Integer
mm, Integer
ss) = Integer
rem' Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`divMod` Integer
60

    -- The fractional second as @iso8601Show@ renders it: nothing when zero,
    -- else a dot and the 12 picosecond digits with trailing zeros trimmed.
    fraction :: TB.Builder
    fraction :: Builder
fraction
        | Integer
frac Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = Builder
forall a. Monoid a => a
mempty
        | Bool
otherwise =
            Text -> Builder
TB.fromText (Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0') (MonthOfYear -> Char -> Text -> Text
T.justifyRight MonthOfYear
12 Char
'0' (Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
frac)))

-- A non-negative integer, zero-padded to at least the given width (the inputs here never
-- exceed it).
digits :: Int -> Integer -> TB.Builder
digits :: MonthOfYear -> Integer -> Builder
digits MonthOfYear
width Integer
n =
    let body :: String
body = Integer -> String
forall b a. (Show a, IsString b) => a -> b
show Integer
n :: String
        pad :: MonthOfYear
pad = MonthOfYear
width MonthOfYear -> MonthOfYear -> MonthOfYear
forall a. Num a => a -> a -> a
- String -> MonthOfYear
forall a. [a] -> MonthOfYear
forall (t :: * -> *) a. Foldable t => t a -> MonthOfYear
length String
body
     in String -> Builder
TB.fromString (MonthOfYear -> Char -> String
forall a. MonthOfYear -> a -> [a]
replicate MonthOfYear
pad Char
'0') Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. Integral a => a -> Builder
TBI.decimal Integer
n

-- | Render an exception as 'Text' for a log line or error value.
displayExceptionT :: (Exception e) => e -> Text
displayExceptionT :: forall e. Exception e => e -> Text
displayExceptionT = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (e -> String) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
forall e. Exception e => e -> String
displayException

-- | The byte size of the array behind a text. A slice keeps the whole array of the text it came from.
textStorageBytes :: Text -> Int
textStorageBytes :: Text -> MonthOfYear
textStorageBytes (TI.Text (ByteArray ByteArray#
array) MonthOfYear
_ MonthOfYear
_) = Int# -> MonthOfYear
I# (ByteArray# -> Int#
sizeofByteArray# ByteArray#
array)