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

{- | The ecosystem-agnostic filtering /decision/ for a single public-upstream
packument: which versions survive a rule set, which version @dist-tags.latest@
resolves to, and the per-version decisions a no-survivors outcome must report.

This mirrors "Ecluse.Core.Package.Merge" -- the pure fold above the registry handle that
emits a __plan__ rather than a finished document. It reasons over the typed
'Ecluse.Core.Package.PackageInfo' domain model only; it never touches a registry's wire
format. The per-ecosystem adapter __replays__ this plan onto the raw upstream
document, so unmodeled wire keys survive (the typed model is lossy, so re-encoding
it would drop them). See @docs\/architecture\/registry-model.md@ → "Decision
surface vs served surface".

__Decision, not served surface.__ A 'FilterPlan' carries exactly the decisions the
filter owns:

* __Survivors.__ A version key survives iff the rules engine 'Admitted' it; every
  other verdict -- a denial, deny-by-default, or an undecidable outcome -- drops it.
  Presence in the served packument /is/ availability (see
  @docs\/research\/reverse-engineering\/npm.md@ §8), so a non-approved version is
  removed rather than flagged.

* __Resolved @latest@.__ The surviving @dist-tags.latest@ under the shared
  __keep-unless-denied, stable-preferring__ rule ('Ecluse.Core.Version.selectLatest'):
  the upstream @latest@ is kept untouched while it survives, and only repointed --
  to the highest /stable/ survivor -- when it was itself denied. This is the
  @latest@ /within the public set/, which the cross-upstream merge then re-resolves
  over the union; it is not the final served @latest@.

* __Decisions.__ Every version's 'Decision', in version-key order, so a
  no-survivors outcome can render each denial and choose a status.

What the plan deliberately omits is any "dropped tags" list: a stale tag -- one
whose target did not survive -- is droppable __structurally__ from the survivor set
alone (a tag is kept iff its target is in 'fpSurvivors'), so the replay needs no
extra field to find them. The plan stays minimal: the decisions the filter owns,
nothing the replay can recompute.

This filters a __single public packument__ (the gated set). Combining it with the
trusted /private/ set is the cross-upstream merge ("Ecluse.Core.Package.Merge").

== Egress-scheme enforcement

The module also owns the other ecosystem-agnostic reduction a fetched packument needs
before serve: normalising every served artifact URL against the https-only egress policy
('Ecluse.Core.Security.Egress.resolveTarballUrl'), parameterised by the upstream base URL
the packument was served from. Like the filter above, it reasons over the domain model and
the agnostic egress policy alone (no wire format in sight), so it is the projection
post-step every ecosystem shares rather than copies: a divergent copy of an egress-policy
application is exactly the drift the policy's correct-by-construction design exists to
prevent, and the foreign-host artifact locations of PyPI and RubyGems make it matter there
even more than for npm. An https artifact URL is kept, a same-host @http@ URL is upgraded to
https, and a version whose artifact is @http@ on a foreign host (or any non-http(s) URL) is
dropped from the served set and recorded as an 'Ecluse.Core.Package.InvalidVersionManifest'.
-}
module Ecluse.Core.Package.Filter (
    -- * Rule-filter plan
    FilterPlan (..),
    filterPlanFromDecisions,
    restrictToSurvivors,

    -- * Egress-scheme enforcement
    enforceArtifactScheme,
    enforceArtifactSchemeDetails,
) where

import Data.Aeson (Value (String))
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T

import Ecluse.Core.Package (
    Artifact (artUrl),
    InvalidEntry (..),
    InvalidEntryKind (InvalidVersionManifest),
    PackageDetails (pkgArtifacts),
    PackageInfo (infoDistTags, infoInvalidEntries, infoVersions),
    pkgVersion,
 )
import Ecluse.Core.Rules.Types (Decision (Admitted))
import Ecluse.Core.Security (hostAddress)
import Ecluse.Core.Security.Egress (registryUrlText, resolveTarballUrl)
import Ecluse.Core.Version (Version, renderVersion, selectLatest, unVersion)

{- | The decisions filtering a single public packument owns, for the adapter to
replay onto the raw upstream @Value@. Carries only what the filter decides over the
typed model -- never a finished, re-serialisable document (see this module's
header). The replay derives everything else (which stale tags to drop, which
@time@ entries to prune) from these fields.
-}
data FilterPlan = FilterPlan
    { FilterPlan -> Set Text
fpSurvivors :: Set Text
    {- ^ The surviving version keys (the raw 'Ecluse.Core.Package.infoVersions' keys):
    exactly those the rules engine approved. Empty when no version survived.
    -}
    , FilterPlan -> Maybe Version
fpLatest :: Maybe Version
    {- ^ @dist-tags.latest@ resolved over the survivors by the shared selector --
    kept as published while it survives, else repointed (stable-preferring) to the
    highest survivor. 'Nothing' when nothing survives. When present it is always one
    of 'fpSurvivors', so the replay can point @latest@ at a key that is served.
    -}
    , FilterPlan -> [Decision]
fpDecisions :: [Decision]
    {- ^ Every version's 'Decision', in version-key order, for the no-survivors
    status and denial body. Carried for every version (not only the denied ones) so
    the adapter can zip them back onto the same-ordered versions.
    -}
    }
    deriving stock (FilterPlan -> FilterPlan -> Bool
(FilterPlan -> FilterPlan -> Bool)
-> (FilterPlan -> FilterPlan -> Bool) -> Eq FilterPlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilterPlan -> FilterPlan -> Bool
== :: FilterPlan -> FilterPlan -> Bool
$c/= :: FilterPlan -> FilterPlan -> Bool
/= :: FilterPlan -> FilterPlan -> Bool
Eq, Int -> FilterPlan -> ShowS
[FilterPlan] -> ShowS
FilterPlan -> String
(Int -> FilterPlan -> ShowS)
-> (FilterPlan -> String)
-> ([FilterPlan] -> ShowS)
-> Show FilterPlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilterPlan -> ShowS
showsPrec :: Int -> FilterPlan -> ShowS
$cshow :: FilterPlan -> String
show :: FilterPlan -> String
$cshowList :: [FilterPlan] -> ShowS
showList :: [FilterPlan] -> ShowS
Show)

{- | Build a 'FilterPlan' from per-version 'Decision's already taken. This is the
path the __effectful__ tier feeds: it decides each version in IO (see
"Ecluse.Core.Rules"), then hands the decisions here for the pure
survivor\/@latest@ resolution. @latest@ is resolved by
'Ecluse.Core.Version.selectLatest' from the upstream-tagged @latest@ (looked up
among the versions, so a tag aimed at an absent version contributes nothing) and
the surviving versions -- kept while it survives, else repointed downward to the
highest stable survivor. The decision map is keyed by raw version string and
__must__ cover exactly the packument's versions; a version with no decision is
treated as not surviving.

A version survives iff its decision is an 'Admitted'; every other
verdict -- denial, deny-by-default, or 'Ecluse.Core.Rules.Types.Undecidable' -- drops it,
so a fail-closed undecidable version is filtered out exactly like a denial, while its
decision is still carried in 'fpDecisions' for the no-survivors status.
-}
filterPlanFromDecisions :: Map Text Decision -> PackageInfo -> FilterPlan
filterPlanFromDecisions :: Map Text Decision -> PackageInfo -> FilterPlan
filterPlanFromDecisions Map Text Decision
decisions PackageInfo
info =
    FilterPlan
        { fpSurvivors :: Set Text
fpSurvivors = Set Text
survivors
        , fpLatest :: Maybe Version
fpLatest = Maybe Version -> [Version] -> Maybe Version
selectLatest Maybe Version
chosen [Version]
survivingVersions
        , fpDecisions :: [Decision]
fpDecisions = Map Text Decision -> [Decision]
forall k a. Map k a -> [a]
Map.elems Map Text Decision
decisions
        }
  where
    -- A version survives only on an explicit approval; every other outcome (deny,
    -- deny-by-default, undecidable) drops it.
    survivors :: Set Text
    survivors :: Set Text
survivors = Map Text Decision -> Set Text
forall k a. Map k a -> Set k
Map.keysSet ((Decision -> Bool) -> Map Text Decision -> Map Text Decision
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Decision -> Bool
isApproved Map Text Decision
decisions)

    isApproved :: Decision -> Bool
    isApproved :: Decision -> Bool
isApproved = \case
        Admitted{} -> Bool
True
        Decision
_ -> Bool
False

    -- The parsed 'Version' a raw key projects to, if present in the packument.
    -- Used both to map surviving keys to 'Version's and to resolve @latest@.
    versionOf :: Text -> Maybe Version
    versionOf :: Text -> Maybe Version
versionOf Text
raw = PackageDetails -> Version
pkgVersion (PackageDetails -> Version)
-> Maybe PackageDetails -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text PackageDetails -> Maybe PackageDetails
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
raw (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)

    -- 'selectLatest'\'s @chosen@: the upstream @latest@ tag's target as a 'Version'
    -- (the tag's raw string looked up among the versions). It decides /survival/
    -- itself, so the version need only be present, not surviving.
    chosen :: Maybe Version
    chosen :: Maybe Version
chosen = Text -> Map Text Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"latest" (PackageInfo -> Map Text Version
infoDistTags PackageInfo
info) Maybe Version -> (Version -> Maybe Version) -> Maybe Version
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Version
versionOf (Text -> Maybe Version)
-> (Version -> Text) -> Version -> Maybe Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
unVersion

    -- 'selectLatest'\'s @survivors@: the surviving versions' parsed 'Version's.
    survivingVersions :: [Version]
    survivingVersions :: [Version]
survivingVersions = (Text -> Maybe Version) -> [Text] -> [Version]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe Version
versionOf (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList Set Text
survivors)

{- | Restrict a 'PackageInfo' to the version keys that survived filtering -- the
'FilterPlan'\'s own 'fpSurvivors' -- so the typed view handed to the cross-upstream
merge carries exactly the gated set ('Ecluse.Core.Package.Merge.mergePackuments'
treats a gated source as already filtered and never re-filters). @dist-tags@ is
pruned to the surviving keys likewise (the merge reconciles tags over the union);
@dist-tags@ targets absent from the survivors are dropped. Each surviving version
carries its own publish time, so restricting the versions carries the times with it
(the merge reconstructs the served @time@ from the survivors).
-}
restrictToSurvivors :: Set Text -> PackageInfo -> PackageInfo
restrictToSurvivors :: Set Text -> PackageInfo -> PackageInfo
restrictToSurvivors Set Text
survivors PackageInfo
info =
    PackageInfo
info
        { infoVersions = Map.restrictKeys (infoVersions info) survivors
        , infoDistTags = Map.filter ((`Set.member` survivors) . renderVersion) (infoDistTags info)
        }

{- | Normalise every served version's artifact URL scheme against the https-only egress
policy ('Ecluse.Core.Security.Egress.resolveTarballUrl'), given the @upstreamBaseUrl@ the
packument was served from. An https artifact URL is kept, a same-host @http@ URL is
__upgraded__ to https, and a version whose artifact is @http@ on a foreign host (or any
non-http(s) URL) is __dropped__ from the served set and recorded as an
'Ecluse.Core.Package.InvalidVersionManifest' carrying the offending URL (the #486
drop-and-record contract), so the version is never dialled in plaintext and the drop is
observable.

The enforcement applies only when the upstream is __https__ (in production every configured
upstream is https by construction). A non-https upstream is the test\/dev loopback opt-in,
whose artifact URLs are left untouched. Applied as a projection post-step at the fetch
boundary, where the upstream URL is known, so each ecosystem's projection stays context-free
and shares this one fold rather than copying it.
-}
enforceArtifactScheme :: Text -> PackageInfo -> PackageInfo
enforceArtifactScheme :: Text -> PackageInfo -> PackageInfo
enforceArtifactScheme Text
upstreamBaseUrl PackageInfo
info =
    case Text -> Maybe Text
httpsUpstreamHost Text
upstreamBaseUrl of
        Maybe Text
Nothing -> PackageInfo
info
        Just Text
upstreamHost ->
            let (Map Text PackageDetails
kept, [InvalidEntry]
drops) = (Text
 -> PackageDetails
 -> (Map Text PackageDetails, [InvalidEntry])
 -> (Map Text PackageDetails, [InvalidEntry]))
-> (Map Text PackageDetails, [InvalidEntry])
-> Map Text PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (Text
-> Text
-> PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
-> (Map Text PackageDetails, [InvalidEntry])
step Text
upstreamHost) (Map Text PackageDetails
forall k a. Map k a
Map.empty, []) (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)
             in PackageInfo
info{infoVersions = kept, infoInvalidEntries = infoInvalidEntries info <> drops}
  where
    step :: Text
-> Text
-> PackageDetails
-> (Map Text PackageDetails, [InvalidEntry])
-> (Map Text PackageDetails, [InvalidEntry])
step Text
upstreamHost Text
rawVersion PackageDetails
details (Map Text PackageDetails
keptAcc, [InvalidEntry]
dropAcc) =
        case Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details of
            Right PackageDetails
ok -> (Text
-> PackageDetails
-> Map Text PackageDetails
-> Map Text PackageDetails
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
rawVersion PackageDetails
ok Map Text PackageDetails
keptAcc, [InvalidEntry]
dropAcc)
            Left (Text
reason, Text
badUrl) ->
                (Map Text PackageDetails
keptAcc, InvalidEntryKind -> Text -> Value -> Text -> InvalidEntry
InvalidEntry InvalidEntryKind
InvalidVersionManifest Text
rawVersion (Text -> Value
String Text
badUrl) Text
reason InvalidEntry -> [InvalidEntry] -> [InvalidEntry]
forall a. a -> [a] -> [a]
: [InvalidEntry]
dropAcc)

{- | The single-version form of 'enforceArtifactScheme' for the selective decode path:
'Nothing' drops the version (its artifact URL is non-https and not upgradeable), a 'Just'
carries the version with each artifact's URL normalised to https. A non-https (test\/dev
loopback) upstream leaves the version untouched.
-}
enforceArtifactSchemeDetails :: Text -> PackageDetails -> Maybe PackageDetails
enforceArtifactSchemeDetails :: Text -> PackageDetails -> Maybe PackageDetails
enforceArtifactSchemeDetails Text
upstreamBaseUrl PackageDetails
details =
    case Text -> Maybe Text
httpsUpstreamHost Text
upstreamBaseUrl of
        Maybe Text
Nothing -> PackageDetails -> Maybe PackageDetails
forall a. a -> Maybe a
Just PackageDetails
details
        Just Text
upstreamHost -> Either (Text, Text) PackageDetails -> Maybe PackageDetails
forall l r. Either l r -> Maybe r
rightToMaybe (Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details)

-- The bare host of an @https@ upstream base URL, or 'Nothing' for a non-https (test/dev
-- loopback) upstream whose artifact URLs the scheme enforcement leaves untouched.
httpsUpstreamHost :: Text -> Maybe Text
httpsUpstreamHost :: Text -> Maybe Text
httpsUpstreamHost Text
baseUrl
    | Text
"https://" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.toLower Text
baseUrl = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
hostAddress Text
baseUrl)
    | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing

-- Resolve every artifact of a version against the egress policy: 'Right' the version
-- with each @artUrl@ normalised to https, or 'Left' the drop reason and the first
-- offending URL.
resolveDetails :: Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails :: Text -> PackageDetails -> Either (Text, Text) PackageDetails
resolveDetails Text
upstreamHost PackageDetails
details =
    (\NonEmpty Artifact
arts -> PackageDetails
details{pkgArtifacts = arts}) (NonEmpty Artifact -> PackageDetails)
-> Either (Text, Text) (NonEmpty Artifact)
-> Either (Text, Text) PackageDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Artifact -> Either (Text, Text) Artifact)
-> NonEmpty Artifact -> Either (Text, Text) (NonEmpty Artifact)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact Text
upstreamHost) (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)

-- Normalise one artifact's URL: keep https, upgrade a same-host http, drop otherwise.
resolveArtifact :: Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact :: Text -> Artifact -> Either (Text, Text) Artifact
resolveArtifact Text
upstreamHost Artifact
art =
    case Text -> Text -> Either Text RegistryUrl
resolveTarballUrl Text
upstreamHost (Artifact -> Text
artUrl Artifact
art) of
        Right RegistryUrl
resolved -> Artifact -> Either (Text, Text) Artifact
forall a b. b -> Either a b
Right Artifact
art{artUrl = registryUrlText resolved}
        Left Text
reason -> (Text, Text) -> Either (Text, Text) Artifact
forall a b. a -> Either a b
Left (Text
reason, Artifact -> Text
artUrl Artifact
art)