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

{- | A memory-bounded __selective decode__ over a JSON document's token stream: the reusable
engine that materialises only the values a caller picks out and skips every other value's tokens
unallocated, while depth-bounding every value it walks.

A whole-document decode (@aeson@'s @eitherDecodeStrict@) builds a 'Value' for /every/ member of a
large object. When a caller needs only a few members out of a multi-megabyte document, that decode
dominates the cost. This engine walks a document's JSON token stream (@aeson@'s
@Data.Aeson.Decoding@, no new dependency) and materialises a 'Value' only for the picked members,
skipping the rest without allocating them. The win is on the /parse/, not the fetch: the full bytes
are still read, but they are parsed selectively, @O(picked)@ work and residency rather than @O(N)@.

== Faithful to the whole-document decode

Bounded selective decode is a memory-bounding defence on a size-unbounded, attacker-influenced
document, so the walk is faithful to the whole-document decode rather than a shortcut past it:

  * it consumes the __entire__ token stream, so malformed JSON __anywhere__ surfaces as
    'SelectiveUndecodable', matching @eitherDecodeStrict@ failing the whole body;
  * every value is depth-bounded at the caller's budget, so a value nested past it __anywhere__ is
    a 'SelectiveTooDeeplyNested' breach ('Ecluse.Core.Security.withinNestingBudget' is the same
    bound applied to a built 'Value');
  * within one object a key's __first__ occurrence wins: a later duplicate is walked for the
    malformed and over-deep checks but never re-materialised, matching @aeson@'s duplicate-key
    resolution.

The engine names @aeson@'s token types and a depth budget only, no registry or package concept, so
each JSON ecosystem layers its own key-selection walk on top. The npm packument selector is
"Ecluse.Core.Registry.Npm.SelectiveDecode".
-}
module Ecluse.Core.Json.Selective (
    -- * Refusal vocabulary
    SelectiveError (..),

    -- * Bounded token-walk primitives
    findInRecord,
    materialiseWithinBudget,
    withRecord,
    skipValue,
    trailingWhitespace,
) where

import Data.Aeson (Value)
import Data.Aeson.Decoding (toEitherValue)
import Data.Aeson.Decoding.Tokens (TkArray (..), TkRecord (..), Tokens (..))
import Data.Aeson.Key qualified as Key
import Data.ByteString qualified as BS

import Ecluse.Core.Security (withinNestingBudget)

{- | Why a selective decode could not yield a value: the two refusal causes a whole-document
decode would also raise, so a caller maps them onto its own error vocabulary.
-}
data SelectiveError
    = {- | The token stream was not well-formed JSON: malformed bytes anywhere, or trailing
      non-whitespace after the top-level value.
      -}
      SelectiveUndecodable
    | -- | Some value nested deeper than the depth budget allowed.
      SelectiveTooDeeplyNested
    deriving stock (SelectiveError -> SelectiveError -> Bool
(SelectiveError -> SelectiveError -> Bool)
-> (SelectiveError -> SelectiveError -> Bool) -> Eq SelectiveError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SelectiveError -> SelectiveError -> Bool
== :: SelectiveError -> SelectiveError -> Bool
$c/= :: SelectiveError -> SelectiveError -> Bool
/= :: SelectiveError -> SelectiveError -> Bool
Eq, Int -> SelectiveError -> ShowS
[SelectiveError] -> ShowS
SelectiveError -> String
(Int -> SelectiveError -> ShowS)
-> (SelectiveError -> String)
-> ([SelectiveError] -> ShowS)
-> Show SelectiveError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SelectiveError -> ShowS
showsPrec :: Int -> SelectiveError -> ShowS
$cshow :: SelectiveError -> String
show :: SelectiveError -> String
$cshowList :: [SelectiveError] -> ShowS
showList :: [SelectiveError] -> ShowS
Show)

{- | Find one key in a record, materialising __only__ the __first__ occurrence of that key's value
(a 'Value') and skipping every other entry's tokens unallocated. @aeson@'s object decode keeps the
first of duplicate keys, so a later duplicate of the target is walked (for the malformed and
over-deep checks) but not re-materialised. Returns the found value (if any), the __raw__ number of
entries scanned, and the record's continuation. @childBudget@ is the depth budget the record's
values sit at, so a deeply-nested sibling still breaches. The scan runs to the record's end, never
stopping early, so a later duplicate key, a malformed entry, or an over-deep sibling is still seen.
-}
findInRecord :: Int -> Text -> TkRecord k String -> Either SelectiveError (Maybe Value, Int, k)
findInRecord :: forall k.
Int
-> Text
-> TkRecord k String
-> Either SelectiveError (Maybe Value, Int, k)
findInRecord Int
childBudget Text
target = Maybe Value
-> Int
-> TkRecord k String
-> Either SelectiveError (Maybe Value, Int, k)
forall {t} {c}.
Num t =>
Maybe Value
-> t
-> TkRecord c String
-> Either SelectiveError (Maybe Value, t, c)
go Maybe Value
forall a. Maybe a
Nothing Int
0
  where
    go :: Maybe Value
-> t
-> TkRecord c String
-> Either SelectiveError (Maybe Value, t, c)
go Maybe Value
found !t
count = \case
        TkRecordEnd c
cont -> (Maybe Value, t, c) -> Either SelectiveError (Maybe Value, t, c)
forall a b. b -> Either a b
Right (Maybe Value
found, t
count, c
cont)
        TkRecordErr String
_ -> SelectiveError -> Either SelectiveError (Maybe Value, t, c)
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable
        TkPair Key
key Tokens (TkRecord c String) String
valueToks
            | Key -> Text
Key.toText Key
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
target
            , Maybe Value
Nothing <- Maybe Value
found -> do
                (value, cont) <- Int
-> Tokens (TkRecord c String) String
-> Either SelectiveError (Value, TkRecord c String)
forall k.
Int -> Tokens k String -> Either SelectiveError (Value, k)
materialiseWithinBudget Int
childBudget Tokens (TkRecord c String) String
valueToks
                go (Just value) (count + 1) cont
            | Bool
otherwise -> Int
-> Tokens (TkRecord c String) String
-> Either SelectiveError (TkRecord c String)
forall k. Int -> Tokens k String -> Either SelectiveError k
skipValue Int
childBudget Tokens (TkRecord c String) String
valueToks Either SelectiveError (TkRecord c String)
-> (TkRecord c String -> Either SelectiveError (Maybe Value, t, c))
-> Either SelectiveError (Maybe Value, t, c)
forall a b.
Either SelectiveError a
-> (a -> Either SelectiveError b) -> Either SelectiveError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Value
-> t
-> TkRecord c String
-> Either SelectiveError (Maybe Value, t, c)
go Maybe Value
found (t
count t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)

{- | Materialise one value from its tokens, the same 'Value' decode a whole-document path uses,
bounded at @budget@: malformed tokens are 'SelectiveUndecodable', a value past the depth budget is
'SelectiveTooDeeplyNested'. Route every 'Value' a selective walk builds through here, so each
passes the same depth gate.
-}
materialiseWithinBudget :: Int -> Tokens k String -> Either SelectiveError (Value, k)
materialiseWithinBudget :: forall k.
Int -> Tokens k String -> Either SelectiveError (Value, k)
materialiseWithinBudget Int
budget Tokens k String
toks = case Tokens k String -> Either String (Value, k)
forall k e. Tokens k e -> Either e (Value, k)
toEitherValue Tokens k String
toks of
    Left String
_ -> SelectiveError -> Either SelectiveError (Value, k)
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable
    Right (Value
value, k
cont)
        | Int -> Value -> Bool
withinNestingBudget Int
budget Value
value -> (Value, k) -> Either SelectiveError (Value, k)
forall a b. b -> Either a b
Right (Value
value, k
cont)
        | Bool
otherwise -> SelectiveError -> Either SelectiveError (Value, k)
forall a b. a -> Either a b
Left SelectiveError
SelectiveTooDeeplyNested

{- | Run @k@ on a record token, refusing a non-record value and refusing the container outright
when the depth budget is already spent (a record is itself one level).
-}
withRecord :: Int -> Tokens k String -> (TkRecord k String -> Either SelectiveError a) -> Either SelectiveError a
withRecord :: forall k a.
Int
-> Tokens k String
-> (TkRecord k String -> Either SelectiveError a)
-> Either SelectiveError a
withRecord Int
budget Tokens k String
toks TkRecord k String -> Either SelectiveError a
k
    | Int
budget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = SelectiveError -> Either SelectiveError a
forall a b. a -> Either a b
Left SelectiveError
SelectiveTooDeeplyNested
    | Bool
otherwise = case Tokens k String
toks of
        TkRecordOpen TkRecord k String
rec -> TkRecord k String -> Either SelectiveError a
k TkRecord k String
rec
        TkErr String
_ -> SelectiveError -> Either SelectiveError a
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable
        Tokens k String
_ -> SelectiveError -> Either SelectiveError a
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable

{- | Consume one value's tokens without allocating a 'Value', returning the continuation. Bounds
nesting at @budget@ levels exactly as 'Ecluse.Core.Security.withinNestingBudget' does over a built
'Value': a value occupies one level (refused at @budget < 1@) and a container's children are
bounded one level deeper. Malformed tokens are 'SelectiveUndecodable'.
-}
skipValue :: Int -> Tokens k String -> Either SelectiveError k
skipValue :: forall k. Int -> Tokens k String -> Either SelectiveError k
skipValue Int
budget Tokens k String
toks
    | Int
budget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = SelectiveError -> Either SelectiveError k
forall a b. a -> Either a b
Left SelectiveError
SelectiveTooDeeplyNested
    | Bool
otherwise = case Tokens k String
toks of
        TkLit Lit
_ k
cont -> k -> Either SelectiveError k
forall a b. b -> Either a b
Right k
cont
        TkText Text
_ k
cont -> k -> Either SelectiveError k
forall a b. b -> Either a b
Right k
cont
        TkNumber Number
_ k
cont -> k -> Either SelectiveError k
forall a b. b -> Either a b
Right k
cont
        TkArrayOpen TkArray k String
arr -> Int -> TkArray k String -> Either SelectiveError k
forall k. Int -> TkArray k String -> Either SelectiveError k
skipArray (Int
budget Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TkArray k String
arr
        TkRecordOpen TkRecord k String
rec -> Int -> TkRecord k String -> Either SelectiveError k
forall k. Int -> TkRecord k String -> Either SelectiveError k
skipRecord (Int
budget Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) TkRecord k String
rec
        TkErr String
_ -> SelectiveError -> Either SelectiveError k
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable

-- Skip an array's items (each at @budget@), returning the continuation after its end.
skipArray :: Int -> TkArray k String -> Either SelectiveError k
skipArray :: forall k. Int -> TkArray k String -> Either SelectiveError k
skipArray Int
budget = \case
    TkItem Tokens (TkArray k String) String
toks -> Int
-> Tokens (TkArray k String) String
-> Either SelectiveError (TkArray k String)
forall k. Int -> Tokens k String -> Either SelectiveError k
skipValue Int
budget Tokens (TkArray k String) String
toks Either SelectiveError (TkArray k String)
-> (TkArray k String -> Either SelectiveError k)
-> Either SelectiveError k
forall a b.
Either SelectiveError a
-> (a -> Either SelectiveError b) -> Either SelectiveError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> TkArray k String -> Either SelectiveError k
forall k. Int -> TkArray k String -> Either SelectiveError k
skipArray Int
budget
    TkArrayEnd k
cont -> k -> Either SelectiveError k
forall a b. b -> Either a b
Right k
cont
    TkArrayErr String
_ -> SelectiveError -> Either SelectiveError k
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable

-- Skip a record's values (each at @budget@), returning the continuation after its end.
skipRecord :: Int -> TkRecord k String -> Either SelectiveError k
skipRecord :: forall k. Int -> TkRecord k String -> Either SelectiveError k
skipRecord Int
budget = \case
    TkPair Key
_ Tokens (TkRecord k String) String
toks -> Int
-> Tokens (TkRecord k String) String
-> Either SelectiveError (TkRecord k String)
forall k. Int -> Tokens k String -> Either SelectiveError k
skipValue Int
budget Tokens (TkRecord k String) String
toks Either SelectiveError (TkRecord k String)
-> (TkRecord k String -> Either SelectiveError k)
-> Either SelectiveError k
forall a b.
Either SelectiveError a
-> (a -> Either SelectiveError b) -> Either SelectiveError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> TkRecord k String -> Either SelectiveError k
forall k. Int -> TkRecord k String -> Either SelectiveError k
skipRecord Int
budget
    TkRecordEnd k
cont -> k -> Either SelectiveError k
forall a b. b -> Either a b
Right k
cont
    TkRecordErr String
_ -> SelectiveError -> Either SelectiveError k
forall a b. a -> Either a b
Left SelectiveError
SelectiveUndecodable

{- | Whether the bytes after the top-level value are JSON whitespace only: the end-of-input check
@eitherDecodeStrict@ applies, so a body with trailing non-whitespace is refused identically (space,
tab, newline, carriage return are the four JSON whitespace bytes).
-}
trailingWhitespace :: ByteString -> Bool
trailingWhitespace :: ByteString -> Bool
trailingWhitespace = (Word8 -> Bool) -> ByteString -> Bool
BS.all Word8 -> Bool
isJsonSpace
  where
    isJsonSpace :: Word8 -> Bool
    isJsonSpace :: Word8 -> Bool
isJsonSpace Word8
w = Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x20 Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0a Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x0d Bool -> Bool -> Bool
|| Word8
w Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x09