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

{- | npm listing and unpublish requests for the protocol maintenance backend.
The final version requires whole-package deletion, because an empty Verdaccio
packument truncates subsequent store listings.
-}
module Ecluse.Core.Registry.Npm.Maintenance (
    npmMaintenance,

    -- * The listing
    listingRequestFor,
    packageListingParser,

    -- * The unpublish
    packumentRequestFor,
    versionDeleteRequestsFor,
) where

import Data.Aeson (Object, Value (Object, String), decodeStrict, encode)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.JsonStream.Parser qualified as J
import Data.Map.Strict qualified as Map
import Network.HTTP.Client (Request (method, requestHeaders))
import Network.HTTP.Types.Header (hAccept)

import Ecluse.Core.Ecosystem (Ecosystem (Npm))
import Ecluse.Core.Package (PackageName, unscopedName)
import Ecluse.Core.Registry (
    RegistryResponse (responseBody),
    UrlFormationError,
    renderUrlFormationError,
 )
import Ecluse.Core.Registry.Adapter.Capability (
    AdapterMaintenance (..),
    StoreListing (..),
    VersionDelete (..),
 )
import Ecluse.Core.Registry.Maintenance (StoreRefusal, storeRefusal)
import Ecluse.Core.Registry.Maintenance.NameSpace (mkNameAlphabet)
import Ecluse.Core.Registry.Npm.Document (tarballUrl)
import Ecluse.Core.Registry.Npm.Project (npmNameLeadChars, projectName)
import Ecluse.Core.Registry.Npm.Request (
    MetadataForm (Full),
    artifactFileUrl,
    jsonPutRequest,
    metadataRequest,
    packageUrl,
    withToken,
 )
import Ecluse.Core.Registry.Origin (OriginClient (ocToken), originBaseUrl)
import Ecluse.Core.Registry.Request (joinPath, parseRequestEither)
import Ecluse.Core.Registry.ServedDocument (adjustField)
import Ecluse.Core.Server.Path (encodeComponent, isSafeComponent)
import Ecluse.Core.Text (nonBlank, urlFilenameComponent)
import Ecluse.Core.Version (Version, compareVersions, mkVersion, renderVersion)

-- | npm's maintenance slice. It fills both verbs, so an npm mount is sweepable.
npmMaintenance :: AdapterMaintenance
npmMaintenance :: AdapterMaintenance
npmMaintenance =
    AdapterMaintenance
        { maintenanceListing :: Maybe StoreListing
maintenanceListing =
            StoreListing -> Maybe StoreListing
forall a. a -> Maybe a
Just
                StoreListing
                    { listingRequest :: OriginClient -> Either UrlFormationError Request
listingRequest = OriginClient -> Either UrlFormationError Request
listingRequestFor
                    , listingParser :: Parser [PackageName]
listingParser = Parser [PackageName]
packageListingParser
                    }
        , maintenanceVersionDelete :: Maybe VersionDelete
maintenanceVersionDelete =
            VersionDelete -> Maybe VersionDelete
forall a. a -> Maybe a
Just
                VersionDelete
                    { deleteDocumentRequest :: OriginClient -> PackageName -> Either UrlFormationError Request
deleteDocumentRequest = OriginClient -> PackageName -> Either UrlFormationError Request
packumentRequestFor
                    , deleteRequests :: OriginClient
-> PackageName
-> Version
-> RegistryResponse
-> Either StoreRefusal (NonEmpty Request)
deleteRequests = OriginClient
-> PackageName
-> Version
-> RegistryResponse
-> Either StoreRefusal (NonEmpty Request)
versionDeleteRequestsFor
                    }
        , maintenanceAlphabet :: NameAlphabet
maintenanceAlphabet = String -> NameAlphabet
mkNameAlphabet String
npmNameLeadChars
        }

-- | Read the store listing. The caller classifies any response other than @200@.
listingRequestFor :: OriginClient -> Either UrlFormationError Request
listingRequestFor :: OriginClient -> Either UrlFormationError Request
listingRequestFor OriginClient
origin = do
    url <- Text -> Text -> Either UrlFormationError Text
joinPath (OriginClient -> Text
originBaseUrl OriginClient
origin) Text
"-/all"
    base <- parseRequestEither url
    pure . withToken (ocToken origin) $
        base{requestHeaders = (hAccept, "application/json") : requestHeaders base}

-- | Read only package-name keys. Values are skipped without constructing package objects.
packageListingParser :: J.Parser [PackageName]
packageListingParser :: Parser [PackageName]
packageListingParser = (Maybe (Map Text PackageName) -> Either String [PackageName])
-> Parser (Maybe (Map Text PackageName)) -> Parser [PackageName]
forall a b. (a -> Either String b) -> Parser a -> Parser b
J.mapWithFailure Maybe (Map Text PackageName) -> Either String [PackageName]
forall {a} {k} {a}. IsString a => Maybe (Map k a) -> Either a [a]
finish ((Maybe (Map Text PackageName)
 -> Maybe Text -> Maybe (Map Text PackageName))
-> Maybe (Map Text PackageName)
-> Parser (Maybe Text)
-> Parser (Maybe (Map Text PackageName))
forall b a. (b -> a -> b) -> b -> Parser a -> Parser b
J.foldI Maybe (Map Text PackageName)
-> Maybe Text -> Maybe (Map Text PackageName)
collect Maybe (Map Text PackageName)
forall a. Maybe a
Nothing Parser (Maybe Text)
events)
  where
    events :: Parser (Maybe Text)
events = Maybe Text
-> Maybe Text -> Parser (Maybe Text) -> Parser (Maybe Text)
forall a. a -> a -> Parser a -> Parser a
J.objectFound Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ((Text, ()) -> Text) -> (Text, ()) -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, ()) -> Text
forall a b. (a, b) -> a
fst ((Text, ()) -> Maybe Text)
-> Parser (Text, ()) -> Parser (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser (Text, ())
forall a. Parser a -> Parser (Text, a)
J.objectItems (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()))
    collect :: Maybe (Map Text PackageName)
-> Maybe Text -> Maybe (Map Text PackageName)
collect Maybe (Map Text PackageName)
found Maybe Text
Nothing = Map Text PackageName -> Maybe (Map Text PackageName)
forall a. a -> Maybe a
Just (Map Text PackageName
-> Maybe (Map Text PackageName) -> Map Text PackageName
forall a. a -> Maybe a -> a
fromMaybe Map Text PackageName
forall a. Monoid a => a
mempty Maybe (Map Text PackageName)
found)
    collect Maybe (Map Text PackageName)
found (Just Text
raw) = Map Text PackageName -> Maybe (Map Text PackageName)
forall a. a -> Maybe a
Just (Map Text PackageName -> Maybe (Map Text PackageName))
-> Map Text PackageName -> Maybe (Map Text PackageName)
forall a b. (a -> b) -> a -> b
$ case Text -> Either ParseError PackageName
projectName Text
raw of
        Right PackageName
name | Text
raw Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"_updated" -> Text -> PackageName -> Map Text PackageName -> Map Text PackageName
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
raw PackageName
name (Map Text PackageName
-> Maybe (Map Text PackageName) -> Map Text PackageName
forall a. a -> Maybe a -> a
fromMaybe Map Text PackageName
forall a. Monoid a => a
mempty Maybe (Map Text PackageName)
found)
        Either ParseError PackageName
_ -> Map Text PackageName
-> Maybe (Map Text PackageName) -> Map Text PackageName
forall a. a -> Maybe a -> a
fromMaybe Map Text PackageName
forall a. Monoid a => a
mempty Maybe (Map Text PackageName)
found
    finish :: Maybe (Map k a) -> Either a [a]
finish Maybe (Map k a)
Nothing = a -> Either a [a]
forall a b. a -> Either a b
Left a
"the store's package listing is not a JSON object"
    finish (Just Map k a
names) = [a] -> Either a [a]
forall a b. b -> Either a b
Right (Map k a -> [a]
forall k a. Map k a -> [a]
Map.elems Map k a
names)

-- | Read the full packument, because the install view omits @_rev@ and @time@.
packumentRequestFor :: OriginClient -> PackageName -> Either UrlFormationError Request
packumentRequestFor :: OriginClient -> PackageName -> Either UrlFormationError Request
packumentRequestFor OriginClient
origin =
    Text
-> Maybe ClientCredential
-> MetadataForm
-> PackageName
-> Either UrlFormationError Request
metadataRequest (OriginClient -> Text
originBaseUrl OriginClient
origin) (OriginClient -> Maybe ClientCredential
ocToken OriginClient
origin) MetadataForm
Full

-- | Refuse absent versions and unreadable revisions. Delete the whole package only for its last version.
versionDeleteRequestsFor ::
    OriginClient ->
    PackageName ->
    Version ->
    RegistryResponse ->
    Either StoreRefusal (NonEmpty Request)
versionDeleteRequestsFor :: OriginClient
-> PackageName
-> Version
-> RegistryResponse
-> Either StoreRefusal (NonEmpty Request)
versionDeleteRequestsFor OriginClient
origin PackageName
name Version
version RegistryResponse
response = do
    packument <- Method -> Either StoreRefusal Object
decodePackument (RegistryResponse -> Method
responseBody RegistryResponse
response)
    revision <- revisionOf packument
    versions <- versionsOf packument
    manifest <- manifestOf raw versions
    if KeyMap.size versions == 1
        then deleteWholePackage origin revision name
        else
            deleteOneVersion
                origin
                revision
                name
                (tarballFilename name version manifest)
                (removeVersion raw versions packument)
  where
    raw :: Text
raw = Version -> Text
renderVersion Version
version

deleteWholePackage :: OriginClient -> Text -> PackageName -> Either StoreRefusal (NonEmpty Request)
deleteWholePackage :: OriginClient
-> Text -> PackageName -> Either StoreRefusal (NonEmpty Request)
deleteWholePackage OriginClient
origin Text
revision PackageName
name = do
    request <- Either UrlFormationError Request -> Either StoreRefusal Request
forall a. Either UrlFormationError a -> Either StoreRefusal a
unformable (Text -> PackageName -> Either UrlFormationError Text
packageUrl (OriginClient -> Text
originBaseUrl OriginClient
origin) PackageName
name Either UrlFormationError Text
-> (Text -> Either UrlFormationError Request)
-> Either UrlFormationError Request
forall a b.
Either UrlFormationError a
-> (a -> Either UrlFormationError b) -> Either UrlFormationError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= OriginClient -> Text -> Text -> Either UrlFormationError Request
deleteAtRevision OriginClient
origin Text
revision)
    pure (request :| [])

-- The requests run in order, so the packument edit goes first and a refused tarball delete
-- cannot leave the version still served.
deleteOneVersion :: OriginClient -> Text -> PackageName -> Text -> Object -> Either StoreRefusal (NonEmpty Request)
deleteOneVersion :: OriginClient
-> Text
-> PackageName
-> Text
-> Object
-> Either StoreRefusal (NonEmpty Request)
deleteOneVersion OriginClient
origin Text
revision PackageName
name Text
filename Object
edited = do
    editRequest <- Either UrlFormationError Request -> Either StoreRefusal Request
forall a. Either UrlFormationError a -> Either StoreRefusal a
unformable (OriginClient
-> PackageName
-> Text
-> Object
-> Either UrlFormationError Request
packumentPutRequest OriginClient
origin PackageName
name Text
revision Object
edited)
    tarballRequest <- unformable (artifactFileUrl (originBaseUrl origin) name filename >>= deleteAtRevision origin revision)
    pure (editRequest :| [tarballRequest])

-- A URL that will not form is this one version's refusal, with the URL reduced to its authority.
unformable :: Either UrlFormationError a -> Either StoreRefusal a
unformable :: forall a. Either UrlFormationError a -> Either StoreRefusal a
unformable = (UrlFormationError -> StoreRefusal)
-> Either UrlFormationError a -> Either StoreRefusal a
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 (Text -> Text -> StoreRefusal
storeRefusal Text
"UNFORMABLE_URL" (Text -> StoreRefusal)
-> (UrlFormationError -> Text) -> UrlFormationError -> StoreRefusal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UrlFormationError -> Text
renderUrlFormationError)

decodePackument :: ByteString -> Either StoreRefusal Object
decodePackument :: Method -> Either StoreRefusal Object
decodePackument Method
body =
    StoreRefusal -> Maybe Object -> Either StoreRefusal Object
forall l r. l -> Maybe r -> Either l r
maybeToRight
        (Text -> Text -> StoreRefusal
storeRefusal Text
"UNREADABLE_DOCUMENT" Text
"the store's packument is not a JSON object")
        (Method -> Maybe Object
forall a. FromJSON a => Method -> Maybe a
decodeStrict Method
body)

-- Verdaccio does not enforce revision matching, so concurrent publishes can be lost.
revisionOf :: Object -> Either StoreRefusal Text
revisionOf :: Object -> Either StoreRefusal Text
revisionOf Object
packument = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"_rev" Object
packument of
    Just (String Text
revision) | Text -> Bool
isSafeComponent Text
revision -> Text -> Either StoreRefusal Text
forall a b. b -> Either a b
Right Text
revision
    Maybe Value
_ ->
        StoreRefusal -> Either StoreRefusal Text
forall a b. a -> Either a b
Left (Text -> Text -> StoreRefusal
storeRefusal Text
"NO_REVISION" Text
"the store's packument carries no _rev an edit can address")

versionsOf :: Object -> Either StoreRefusal Object
versionsOf :: Object -> Either StoreRefusal Object
versionsOf Object
packument = case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"versions" Object
packument of
    Just (Object Object
versions) -> Object -> Either StoreRefusal Object
forall a b. b -> Either a b
Right Object
versions
    Maybe Value
_ ->
        StoreRefusal -> Either StoreRefusal Object
forall a b. a -> Either a b
Left (Text -> Text -> StoreRefusal
storeRefusal Text
"UNREADABLE_DOCUMENT" Text
"the store's packument carries no versions object")

manifestOf :: Text -> Object -> Either StoreRefusal Value
manifestOf :: Text -> Object -> Either StoreRefusal Value
manifestOf Text
raw Object
versions =
    StoreRefusal -> Maybe Value -> Either StoreRefusal Value
forall l r. l -> Maybe r -> Either l r
maybeToRight
        (Text -> Text -> StoreRefusal
storeRefusal Text
"VERSION_ABSENT" Text
"the store's packument holds no such version")
        (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
raw) Object
versions)

packumentPutRequest :: OriginClient -> PackageName -> Text -> Object -> Either UrlFormationError Request
packumentPutRequest :: OriginClient
-> PackageName
-> Text
-> Object
-> Either UrlFormationError Request
packumentPutRequest OriginClient
origin PackageName
name Text
revision Object
packument = do
    url <- Text -> Text -> Text
atRevision Text
revision (Text -> Text)
-> Either UrlFormationError Text -> Either UrlFormationError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> PackageName -> Either UrlFormationError Text
packageUrl (OriginClient -> Text
originBaseUrl OriginClient
origin) PackageName
name
    jsonPutRequest (ocToken origin) url (toStrict (encode packument))

deleteAtRevision :: OriginClient -> Text -> Text -> Either UrlFormationError Request
deleteAtRevision :: OriginClient -> Text -> Text -> Either UrlFormationError Request
deleteAtRevision OriginClient
origin Text
revision Text
url = do
    base <- Text -> Either UrlFormationError Request
parseRequestEither (Text -> Text -> Text
atRevision Text
revision Text
url)
    pure
        . withToken (ocToken origin)
        $ base
            { method = "DELETE"
            , requestHeaders = (hAccept, "application/json") : requestHeaders base
            }

atRevision :: Text -> Text -> Text
atRevision :: Text -> Text -> Text
atRevision Text
revision Text
url = Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/-rev/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
encodeComponent Text
revision

{- A @latest@ that pointed at the removed version moves to the greatest survivor, because a
packument without one leaves an unqualified install with no version to resolve. -}
removeVersion :: Text -> Object -> Object -> Object
removeVersion :: Text -> Object -> Object -> Object
removeVersion Text
raw Object
versions Object
packument =
    Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"versions" (Object -> Value
Object Object
remaining) (Key -> (Value -> Value) -> Object -> Object
adjustField Key
"dist-tags" ((Object -> Object) -> Value -> Value
withinObject Object -> Object
retag) Object
prunedTime)
  where
    key :: Key
key = Text -> Key
Key.fromText Text
raw
    remaining :: Object
remaining = Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
key Object
versions
    prunedTime :: Object
prunedTime = Key -> (Value -> Value) -> Object -> Object
adjustField Key
"time" ((Object -> Object) -> Value -> Value
withinObject (Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
key)) Object
packument
    retag :: Object -> Object
retag Object
tags = Object -> (Text -> Object) -> Maybe Text -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
kept (\Text
latest -> Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"latest" (Text -> Value
String Text
latest) Object
kept) Maybe Text
restoredLatest
      where
        kept :: Object
kept = (Value -> Bool) -> Object -> Object
forall v. (v -> Bool) -> KeyMap v -> KeyMap v
KeyMap.filter (Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Value
String Text
raw) Object
tags
        restoredLatest :: Maybe Text
restoredLatest = do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"latest" Object
tags Maybe Value -> Maybe Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Maybe Value
forall a. a -> Maybe a
Just (Text -> Value
String Text
raw))
            [Text] -> Maybe Text
greatestVersion ((Key -> Text) -> [Key] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Text
Key.toText (Object -> [Key]
forall v. KeyMap v -> [Key]
KeyMap.keys Object
remaining))

-- A slot holding anything but an object is left as the store sent it.
withinObject :: (Object -> Object) -> Value -> Value
withinObject :: (Object -> Object) -> Value -> Value
withinObject Object -> Object
edit = \case
    Object Object
inner -> Object -> Value
Object (Object -> Object
edit Object
inner)
    Value
other -> Value
other

greatestVersion :: [Text] -> Maybe Text
greatestVersion :: [Text] -> Maybe Text
greatestVersion = (Maybe Text -> Text -> Maybe Text)
-> Maybe Text -> [Text] -> Maybe Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe Text -> Text -> Maybe Text
keepGreater Maybe Text
forall a. Maybe a
Nothing
  where
    keepGreater :: Maybe Text -> Text -> Maybe Text
keepGreater Maybe Text
held Text
candidate = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
candidate (Text -> Text -> Text
greaterOf Text
candidate) Maybe Text
held)

greaterOf :: Text -> Text -> Text
greaterOf :: Text -> Text -> Text
greaterOf Text
a Text
b = if Text -> Text -> Ordering
npmVersionOrdering Text
a Text
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT then Text
a else Text
b

-- Non-semver pairs fall back to text ordering, so the choice stays deterministic.
npmVersionOrdering :: Text -> Text -> Ordering
npmVersionOrdering :: Text -> Text -> Ordering
npmVersionOrdering Text
a Text
b = Ordering -> Maybe Ordering -> Ordering
forall a. a -> Maybe a -> a
fromMaybe (Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
a Text
b) (Version -> Version -> Maybe Ordering
compareVersions (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
a) (Ecosystem -> Text -> Version
mkVersion Ecosystem
Npm Text
b))

tarballFilename :: PackageName -> Version -> Value -> Text
tarballFilename :: PackageName -> Version -> Value -> Text
tarballFilename PackageName
name Version
version Value
manifest =
    Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
conventional ((Text -> Bool) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter Text -> Bool
isSafeComponent (Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Maybe Text
distTarballSegment Value
manifest))
  where
    conventional :: Text
conventional = PackageName -> Text
unscopedName PackageName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
renderVersion Version
version Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".tgz"

distTarballSegment :: Value -> Maybe Text
distTarballSegment :: Value -> Maybe Text
distTarballSegment Value
manifest = Text -> Text
urlFilenameComponent (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe Text
tarballUrl Value
manifest