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

{- | The floor every ecosystem's projection of an untrusted registry document sits on: per-entry
lenient degradation, the shared name checks, and the upstream name-agreement test.

The three name checks travel together because skipping any one of them reaches an interpolated
upstream URL. An ecosystem's grammar layers its own rules on top and never replaces them.
-}
module Ecluse.Core.Registry.WireSupport (
    -- * Per-entry lenient degradation
    partitionLenientList,

    -- * Name agreement
    Projection (..),
    checkNameAgreement,

    -- * The name floor
    NameRefusal (..),
    parseNameComponent,
    nameComponentWith,
    withinNameLimit,
) where

import Data.Aeson (Value)
import Data.Text qualified as T

import Ecluse.Core.Package (
    InvalidEntry,
    InvalidEntryKind,
    PackageName,
    isAsciiNameComponent,
    mkInvalidEntry,
    renderPackageName,
 )
import Ecluse.Core.Registry (ParseError (ParseError))
import Ecluse.Core.Server.Path (isSafeComponent)

{- | Partition a list of keyed raw entries into the ones that decode and the ones that do not,
in input order. An array-shaped format pairs each element with its own key first.
-}
partitionLenientList :: InvalidEntryKind -> (Value -> Either String a) -> [(Text, Value)] -> ([(Text, a)], [InvalidEntry])
partitionLenientList :: forall a.
InvalidEntryKind
-> (Value -> Either String a)
-> [(Text, Value)]
-> ([(Text, a)], [InvalidEntry])
partitionLenientList InvalidEntryKind
kind Value -> Either String a
decode =
    ((Text, Value)
 -> ([(Text, a)], [InvalidEntry]) -> ([(Text, a)], [InvalidEntry]))
-> ([(Text, a)], [InvalidEntry])
-> [(Text, Value)]
-> ([(Text, a)], [InvalidEntry])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Value)
-> ([(Text, a)], [InvalidEntry]) -> ([(Text, a)], [InvalidEntry])
step ([], [])
  where
    step :: (Text, Value)
-> ([(Text, a)], [InvalidEntry]) -> ([(Text, a)], [InvalidEntry])
step (Text
key, Value
value) ([(Text, a)]
kept, [InvalidEntry]
dropped) = case Value -> Either String a
decode Value
value of
        Right a
a -> ((Text
key, a
a) (Text, a) -> [(Text, a)] -> [(Text, a)]
forall a. a -> [a] -> [a]
: [(Text, a)]
kept, [InvalidEntry]
dropped)
        Left String
err -> ([(Text, a)]
kept, InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
mkInvalidEntry InvalidEntryKind
kind Text
key Value
value (String -> Text
forall a. ToText a => a -> Text
toText String
err) InvalidEntry -> [InvalidEntry] -> [InvalidEntry]
forall a. a -> [a] -> [a]
: [InvalidEntry]
dropped)

{- | What an upstream document projected into, once its self-reported name has been checked.
A mismatch carries no payload, so a disagreeing origin's contribution is unrepresentable.
-}
data Projection a
    = -- | The self-reported name agreed with the request, carrying what was projected.
      Projected a
    | -- | The document self-reported this /different/ name (carried verbatim for the audit log).
      NameMismatch Text
    deriving stock (Projection a -> Projection a -> Bool
(Projection a -> Projection a -> Bool)
-> (Projection a -> Projection a -> Bool) -> Eq (Projection a)
forall a. Eq a => Projection a -> Projection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Projection a -> Projection a -> Bool
== :: Projection a -> Projection a -> Bool
$c/= :: forall a. Eq a => Projection a -> Projection a -> Bool
/= :: Projection a -> Projection a -> Bool
Eq, Int -> Projection a -> ShowS
[Projection a] -> ShowS
Projection a -> String
(Int -> Projection a -> ShowS)
-> (Projection a -> String)
-> ([Projection a] -> ShowS)
-> Show (Projection a)
forall a. Show a => Int -> Projection a -> ShowS
forall a. Show a => [Projection a] -> ShowS
forall a. Show a => Projection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Projection a -> ShowS
showsPrec :: Int -> Projection a -> ShowS
$cshow :: forall a. Show a => Projection a -> String
show :: Projection a -> String
$cshowList :: forall a. Show a => [Projection a] -> ShowS
showList :: [Projection a] -> ShowS
Show)

{- | Compare through ecosystem-aware 'PackageName' equality, never a byte compare an encoding
variant could slip past. The proxy never substitutes the reported name for the requested one.
-}
checkNameAgreement :: PackageName -> PackageName -> a -> Projection a
checkNameAgreement :: forall a. PackageName -> PackageName -> a -> Projection a
checkNameAgreement PackageName
requestedName PackageName
reportedName a
projected
    | PackageName
reportedName PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
requestedName = a -> Projection a
forall a. a -> Projection a
Projected a
projected
    | Bool
otherwise = Text -> Projection a
forall a. Text -> Projection a
NameMismatch (PackageName -> Text
renderPackageName PackageName
reportedName)

-- | Why a name component did not clear the floor every ecosystem's grammar sits on.
data NameRefusal
    = -- | The component was empty, so it names nothing.
      NameEmpty
    | -- | The component carried a non-ASCII or control codepoint, which renders two names as one.
      NameNotAscii
    | -- | The component was not a safe path component (a separator, a dot-dot, a control byte).
      NameUnsafeComponent
    deriving stock (NameRefusal -> NameRefusal -> Bool
(NameRefusal -> NameRefusal -> Bool)
-> (NameRefusal -> NameRefusal -> Bool) -> Eq NameRefusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameRefusal -> NameRefusal -> Bool
== :: NameRefusal -> NameRefusal -> Bool
$c/= :: NameRefusal -> NameRefusal -> Bool
/= :: NameRefusal -> NameRefusal -> Bool
Eq, Int -> NameRefusal -> ShowS
[NameRefusal] -> ShowS
NameRefusal -> String
(Int -> NameRefusal -> ShowS)
-> (NameRefusal -> String)
-> ([NameRefusal] -> ShowS)
-> Show NameRefusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NameRefusal -> ShowS
showsPrec :: Int -> NameRefusal -> ShowS
$cshow :: NameRefusal -> String
show :: NameRefusal -> String
$cshowList :: [NameRefusal] -> ShowS
showList :: [NameRefusal] -> ShowS
Show)

{- | Parse one component of a package name against the floor every ecosystem shares: non-empty,
ASCII, and safe to interpolate into an upstream URL. The three travel together because one skip reaches that URL.
-}
parseNameComponent :: Text -> Either NameRefusal Text
parseNameComponent :: Text -> Either NameRefusal Text
parseNameComponent Text
component
    | Text -> Bool
T.null Text
component = NameRefusal -> Either NameRefusal Text
forall a b. a -> Either a b
Left NameRefusal
NameEmpty
    | Bool -> Bool
not (Text -> Bool
isAsciiNameComponent Text
component) = NameRefusal -> Either NameRefusal Text
forall a b. a -> Either a b
Left NameRefusal
NameNotAscii
    | Bool -> Bool
not (Text -> Bool
isSafeComponent Text
component) = NameRefusal -> Either NameRefusal Text
forall a b. a -> Either a b
Left NameRefusal
NameUnsafeComponent
    | Bool
otherwise = Text -> Either NameRefusal Text
forall a b. b -> Either a b
Right Text
component

{- | Clear the shared floor and then an ecosystem's own grammar. The noun names the component
in every refusal, so each ecosystem keeps its own wording ("npm name component").
-}
nameComponentWith :: Text -> (Text -> Bool) -> Text -> Either ParseError Text
nameComponentWith :: Text -> (Text -> Bool) -> Text -> Either ParseError Text
nameComponentWith Text
noun Text -> Bool
usable Text
component = do
    onFloor <- (NameRefusal -> ParseError)
-> Either NameRefusal Text -> Either ParseError Text
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first NameRefusal -> ParseError
floorRefusal (Text -> Either NameRefusal Text
parseNameComponent Text
component)
    if usable onFloor
        then Right onFloor
        else Left unusable
  where
    floorRefusal :: NameRefusal -> ParseError
    floorRefusal :: NameRefusal -> ParseError
floorRefusal = \case
        NameRefusal
NameEmpty -> Text -> ParseError
ParseError (Text
"empty " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noun)
        NameRefusal
NameNotAscii -> Text -> ParseError
ParseError (Text
"non-ASCII " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noun Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
component)
        NameRefusal
NameUnsafeComponent -> ParseError
unusable

    unusable :: ParseError
    unusable :: ParseError
unusable = Text -> ParseError
ParseError (Text
"unusable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
noun Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
component)

{- | Refuse a name over an ecosystem's own cap, which the noun names in the refusal text.
'T.compareLength' stops at the cap without measuring the whole input.
-}
withinNameLimit :: Text -> Int -> Text -> Either ParseError ()
withinNameLimit :: Text -> Int -> Text -> Either ParseError ()
withinNameLimit Text
noun Int
limit Text
raw
    | Text -> Int -> Ordering
T.compareLength Text
raw Int
limit Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT = ParseError -> Either ParseError ()
forall a b. a -> Either a b
Left (Text -> ParseError
ParseError Text
overLong)
    | Bool
otherwise = () -> Either ParseError ()
forall a b. b -> Either a b
Right ()
  where
    overLong :: Text
    overLong :: Text
overLong = Text
noun Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" over " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
limit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" characters, starting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show (Int -> Text -> Text
T.take Int
24 Text
raw)