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

{- | Response bounds for the data plane: what an upstream may make the proxy hold, walk, or wait on.

A 'Limits' budget bounds the algorithmic-complexity and stalling DoS a hostile or compromised
upstream can inflict. Every limit fails closed: a breach yields 'Left', never a truncated or partial result.
-}
module Ecluse.Core.Security.Limits (
    -- * Response bounds
    Limits (..),
    defaultLimits,
    BodyLimit (..),
    bodyLimitBytes,
    LimitError (..),
    boundedRead,
    checkVersionCountOf,
    checkArtifactCount,

    -- * Upstream progress
    ProgressFloor,
    ProgressFloorError (..),
    mkProgressFloor,
    floorWindowMicros,
    floorMinBytes,
    floorServeCapMicros,
    requestTimeoutSeconds,
    serveCapMarginSeconds,
    serveCapSeconds,
) where

import Data.ByteString qualified as BS
import Data.ByteString.Builder (byteString, toLazyByteString)
import Data.ByteString.Lazy qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Time (NominalDiffTime)

import Ecluse.Core.Package (PackageInfo, infoVersions, pkgArtifacts)

-- | Byte ceilings by operation, structural metadata backstops, and the upstream progress floor.
data Limits = Limits
    { Limits -> Int
maxMetadataBytes :: Int
    -- ^ Decompressed registry metadata and control-response bytes.
    , Limits -> Int
maxPublishRequestBytes :: Int
    -- ^ Client publish request bytes buffered before relay.
    , Limits -> Int
maxMirrorArtifactBytes :: Int
    -- ^ Artifact bytes buffered for mirror verification and publication.
    , Limits -> Int
maxVersionCount :: Int
    -- ^ npm source versions, PyPI full releases, or PyPI selected source file positions.
    , Limits -> Int
maxArtifactCount :: Int
    -- ^ Valid projected artifacts. Selected PyPI uses its source-file scan count instead.
    , Limits -> Int
maxNestingDepth :: Int
    -- ^ Retained JSON nesting depth. Skipped metadata fields do not use this bound.
    , Limits -> ProgressFloor
progressFloor :: ProgressFloor
    -- ^ The body bytes an upstream exchange must deliver per window, and the serve path's cap.
    }
    deriving stock (Limits -> Limits -> Bool
(Limits -> Limits -> Bool)
-> (Limits -> Limits -> Bool) -> Eq Limits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Limits -> Limits -> Bool
== :: Limits -> Limits -> Bool
$c/= :: Limits -> Limits -> Bool
/= :: Limits -> Limits -> Bool
Eq, Int -> Limits -> ShowS
[Limits] -> ShowS
Limits -> String
(Int -> Limits -> ShowS)
-> (Limits -> String) -> ([Limits] -> ShowS) -> Show Limits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Limits -> ShowS
showsPrec :: Int -> Limits -> ShowS
$cshow :: Limits -> String
show :: Limits -> String
$cshowList :: [Limits] -> ShowS
showList :: [Limits] -> ShowS
Show)

-- | Generous bounded metadata input, with publish and mirror caps resolved separately by composition.
defaultLimits :: Limits
defaultLimits :: Limits
defaultLimits =
    Limits
        { maxMetadataBytes :: Int
maxMetadataBytes = Int
128 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
        , maxPublishRequestBytes :: Int
maxPublishRequestBytes = Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
        , maxMirrorArtifactBytes :: Int
maxMirrorArtifactBytes = Int
12 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
        , maxVersionCount :: Int
maxVersionCount = Int
1_000_000
        , maxArtifactCount :: Int
maxArtifactCount = Int
1_000_000
        , maxNestingDepth :: Int
maxNestingDepth = Int
64
        , progressFloor :: ProgressFloor
progressFloor = Int -> Int -> Int -> ProgressFloor
ProgressFloor (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (NominalDiffTime -> Integer
toMicros NominalDiffTime
10)) (Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024) (Integer -> Int
forall a. Num a => Integer -> a
fromInteger (NominalDiffTime -> Integer
toMicros (Int -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
serveCapSeconds)))
        }

-- | The selected body role and its byte ceiling, shared by reads and failures.
data BodyLimit
    = -- | Metadata and registry control responses.
      MetadataBodyLimit Int
    | -- | Inbound first-party publish requests.
      PublishRequestBodyLimit Int
    | -- | Artifacts buffered by the mirror worker.
      MirrorArtifactBodyLimit Int
    deriving stock (BodyLimit -> BodyLimit -> Bool
(BodyLimit -> BodyLimit -> Bool)
-> (BodyLimit -> BodyLimit -> Bool) -> Eq BodyLimit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BodyLimit -> BodyLimit -> Bool
== :: BodyLimit -> BodyLimit -> Bool
$c/= :: BodyLimit -> BodyLimit -> Bool
/= :: BodyLimit -> BodyLimit -> Bool
Eq, Int -> BodyLimit -> ShowS
[BodyLimit] -> ShowS
BodyLimit -> String
(Int -> BodyLimit -> ShowS)
-> (BodyLimit -> String)
-> ([BodyLimit] -> ShowS)
-> Show BodyLimit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BodyLimit -> ShowS
showsPrec :: Int -> BodyLimit -> ShowS
$cshow :: BodyLimit -> String
show :: BodyLimit -> String
$cshowList :: [BodyLimit] -> ShowS
showList :: [BodyLimit] -> ShowS
Show)

-- | The selected ceiling in bytes, before decoding or projection.
bodyLimitBytes :: BodyLimit -> Int
bodyLimitBytes :: BodyLimit -> Int
bodyLimitBytes = \case
    MetadataBodyLimit Int
cap -> Int
cap
    PublishRequestBodyLimit Int
cap -> Int
cap
    MirrorArtifactBodyLimit Int
cap -> Int
cap

-- | Which 'Limits' ceiling a response exceeded.
data LimitError
    = -- | The selected body role exceeded its configured byte ceiling.
      BodyTooLarge BodyLimit
    | -- | More than 'maxVersionCount' versions. Carries the count seen and the ceiling.
      TooManyVersions Int Int
    | -- | More than 'maxArtifactCount' artifacts across the versions, then the ceiling.
      TooManyArtifacts Int Int
    | -- | JSON nesting exceeded 'maxNestingDepth'. Carries the ceiling.
      TooDeeplyNested Int
    deriving stock (LimitError -> LimitError -> Bool
(LimitError -> LimitError -> Bool)
-> (LimitError -> LimitError -> Bool) -> Eq LimitError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LimitError -> LimitError -> Bool
== :: LimitError -> LimitError -> Bool
$c/= :: LimitError -> LimitError -> Bool
/= :: LimitError -> LimitError -> Bool
Eq, Int -> LimitError -> ShowS
[LimitError] -> ShowS
LimitError -> String
(Int -> LimitError -> ShowS)
-> (LimitError -> String)
-> ([LimitError] -> ShowS)
-> Show LimitError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LimitError -> ShowS
showsPrec :: Int -> LimitError -> ShowS
$cshow :: LimitError -> String
show :: LimitError -> String
$cshowList :: [LimitError] -> ShowS
showList :: [LimitError] -> ShowS
Show)

-- | Return the consumed byte count and body. An empty chunk ends the read, and an overstep refuses it whole.
boundedRead :: (Monad m) => BodyLimit -> m ByteString -> m (Either LimitError (Int, ByteString))
boundedRead :: forall (m :: * -> *).
Monad m =>
BodyLimit
-> m ByteString -> m (Either LimitError (Int, ByteString))
boundedRead BodyLimit
bound m ByteString
readChunk = Int -> Builder -> m (Either LimitError (Int, ByteString))
go Int
0 Builder
forall a. Monoid a => a
mempty
  where
    cap :: Int
cap = BodyLimit -> Int
bodyLimitBytes BodyLimit
bound
    go :: Int -> Builder -> m (Either LimitError (Int, ByteString))
go !Int
seen Builder
acc = do
        chunk <- m ByteString
readChunk
        if BS.null chunk
            then pure (Right (seen, BSL.toStrict (toLazyByteString acc)))
            else
                let seen' = Int
seen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
BS.length ByteString
chunk
                 in if seen' > cap
                        then pure (Left (BodyTooLarge bound))
                        else go seen' (acc <> byteString chunk)

{- | The same ceiling over a bare count, for a caller that knows how many versions a document
carries without projecting it, as the selective decoders do while they skip entries.
-}
checkVersionCountOf :: Limits -> Int -> Either LimitError ()
checkVersionCountOf :: Limits -> Int -> Either LimitError ()
checkVersionCountOf Limits
limits Int
count
    | Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap = LimitError -> Either LimitError ()
forall a b. a -> Either a b
Left (Int -> Int -> LimitError
TooManyVersions Int
count Int
cap)
    | Bool
otherwise = () -> Either LimitError ()
forall a b. b -> Either a b
Right ()
  where
    cap :: Int
cap = Limits -> Int
maxVersionCount Limits
limits

{- | Reject a parsed document carrying more than 'maxArtifactCount' artifacts across all its
versions. Adapters check version counts before applying the artifact ceiling.
-}
checkArtifactCount :: Limits -> PackageInfo -> Either LimitError PackageInfo
checkArtifactCount :: Limits -> PackageInfo -> Either LimitError PackageInfo
checkArtifactCount Limits
limits PackageInfo
info
    | Int
seen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cap = LimitError -> Either LimitError PackageInfo
forall a b. a -> Either a b
Left (Int -> Int -> LimitError
TooManyArtifacts Int
seen Int
cap)
    | Bool
otherwise = PackageInfo -> Either LimitError PackageInfo
forall a b. b -> Either a b
Right PackageInfo
info
  where
    cap :: Int
cap = Limits -> Int
maxArtifactCount Limits
limits
    seen :: Int
seen = (Int -> PackageDetails -> Int)
-> Int -> Map Text PackageDetails -> Int
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' (\Int
acc PackageDetails
details -> Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty Artifact -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)) Int
0 (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)

{- | The front door's per-request timeout, in seconds. Generous enough for a large packument
fetch, bounded so a stuck upstream cannot pin a handler indefinitely.
-}
requestTimeoutSeconds :: Int
requestTimeoutSeconds :: Int
requestTimeoutSeconds = Int
60

-- | Seconds the serve-path cap leaves under the request timeout for admission waits and the work around an exchange.
serveCapMarginSeconds :: Int
serveCapMarginSeconds :: Int
serveCapMarginSeconds = Int
10

-- | How long one serve-path upstream exchange may run, in seconds: the request timeout less its margin.
serveCapSeconds :: Int
serveCapSeconds :: Int
serveCapSeconds = Int
requestTimeoutSeconds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
serveCapMarginSeconds

{- | A progress window, the body bytes a transfer must move within it, and the serve-path cap the
window must stay below. The private constructor keeps the three consistent.
-}
data ProgressFloor = ProgressFloor Int Int Int
    deriving stock (ProgressFloor -> ProgressFloor -> Bool
(ProgressFloor -> ProgressFloor -> Bool)
-> (ProgressFloor -> ProgressFloor -> Bool) -> Eq ProgressFloor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressFloor -> ProgressFloor -> Bool
== :: ProgressFloor -> ProgressFloor -> Bool
$c/= :: ProgressFloor -> ProgressFloor -> Bool
/= :: ProgressFloor -> ProgressFloor -> Bool
Eq, Int -> ProgressFloor -> ShowS
[ProgressFloor] -> ShowS
ProgressFloor -> String
(Int -> ProgressFloor -> ShowS)
-> (ProgressFloor -> String)
-> ([ProgressFloor] -> ShowS)
-> Show ProgressFloor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressFloor -> ShowS
showsPrec :: Int -> ProgressFloor -> ShowS
$cshow :: ProgressFloor -> String
show :: ProgressFloor -> String
$cshowList :: [ProgressFloor] -> ShowS
showList :: [ProgressFloor] -> ShowS
Show)

-- | Why a window and a byte count make no 'ProgressFloor'.
data ProgressFloorError
    = -- | The window is zero or negative.
      WindowNotPositive
    | -- | The window is not below the serve-path cap, so the floor could never fire before the cap.
      WindowNotBelowServeCap
    | -- | The byte count is zero or negative.
      MinBytesNotPositive
    deriving stock (ProgressFloorError -> ProgressFloorError -> Bool
(ProgressFloorError -> ProgressFloorError -> Bool)
-> (ProgressFloorError -> ProgressFloorError -> Bool)
-> Eq ProgressFloorError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressFloorError -> ProgressFloorError -> Bool
== :: ProgressFloorError -> ProgressFloorError -> Bool
$c/= :: ProgressFloorError -> ProgressFloorError -> Bool
/= :: ProgressFloorError -> ProgressFloorError -> Bool
Eq, Int -> ProgressFloorError -> ShowS
[ProgressFloorError] -> ShowS
ProgressFloorError -> String
(Int -> ProgressFloorError -> ShowS)
-> (ProgressFloorError -> String)
-> ([ProgressFloorError] -> ShowS)
-> Show ProgressFloorError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressFloorError -> ShowS
showsPrec :: Int -> ProgressFloorError -> ShowS
$cshow :: ProgressFloorError -> String
show :: ProgressFloorError -> String
$cshowList :: [ProgressFloorError] -> ShowS
showList :: [ProgressFloorError] -> ShowS
Show)

-- | The floor for a serve-path cap, a window, and a byte count, in that order, with every refusal.
mkProgressFloor :: NominalDiffTime -> NominalDiffTime -> Int -> Either (NonEmpty ProgressFloorError) ProgressFloor
mkProgressFloor :: NominalDiffTime
-> NominalDiffTime
-> Int
-> Either (NonEmpty ProgressFloorError) ProgressFloor
mkProgressFloor NominalDiffTime
serveCap NominalDiffTime
window Int
minBytes =
    Either (NonEmpty ProgressFloorError) ProgressFloor
-> (NonEmpty ProgressFloorError
    -> Either (NonEmpty ProgressFloorError) ProgressFloor)
-> Maybe (NonEmpty ProgressFloorError)
-> Either (NonEmpty ProgressFloorError) ProgressFloor
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ProgressFloor -> Either (NonEmpty ProgressFloorError) ProgressFloor
forall a b. b -> Either a b
Right (Int -> Int -> Int -> ProgressFloor
ProgressFloor (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
windowMicros) Int
minBytes (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
capMicros))) NonEmpty ProgressFloorError
-> Either (NonEmpty ProgressFloorError) ProgressFloor
forall a b. a -> Either a b
Left ([ProgressFloorError] -> Maybe (NonEmpty ProgressFloorError)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [ProgressFloorError]
refusals)
  where
    windowMicros :: Integer
windowMicros = NominalDiffTime -> Integer
toMicros NominalDiffTime
window
    capMicros :: Integer
capMicros = NominalDiffTime -> Integer
toMicros NominalDiffTime
serveCap
    refusals :: [ProgressFloorError]
refusals =
        [ProgressFloorError
WindowNotPositive | Integer
windowMicros Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0]
            [ProgressFloorError]
-> [ProgressFloorError] -> [ProgressFloorError]
forall a. Semigroup a => a -> a -> a
<> [ProgressFloorError
WindowNotBelowServeCap | Integer
windowMicros Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0, Integer
windowMicros Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
capMicros]
            [ProgressFloorError]
-> [ProgressFloorError] -> [ProgressFloorError]
forall a. Semigroup a => a -> a -> a
<> [ProgressFloorError
MinBytesNotPositive | Int
minBytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0]

-- | The waiting time, in microseconds, within which a transfer must move 'floorMinBytes'.
floorWindowMicros :: ProgressFloor -> Int
floorWindowMicros :: ProgressFloor -> Int
floorWindowMicros (ProgressFloor Int
window Int
_ Int
_) = Int
window

-- | The body bytes a transfer must move within each window.
floorMinBytes :: ProgressFloor -> Int
floorMinBytes :: ProgressFloor -> Int
floorMinBytes (ProgressFloor Int
_ Int
minBytes Int
_) = Int
minBytes

-- | How long one serve-path exchange may run, in microseconds.
floorServeCapMicros :: ProgressFloor -> Int
floorServeCapMicros :: ProgressFloor -> Int
floorServeCapMicros (ProgressFloor Int
_ Int
_ Int
cap) = Int
cap

toMicros :: NominalDiffTime -> Integer
toMicros :: NominalDiffTime -> Integer
toMicros NominalDiffTime
seconds = NominalDiffTime -> Integer
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime
seconds NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1_000_000)