fix(repair-built-stamp): patch the published PACKAGES.rds once bincraft drops cranlike

bincraft#33 replaces the cranlike fork: upload_package_index() no longer
keeps a PACKAGES.db and reuses the records of the published PACKAGES.rds
instead, so patching the database stops having any effect.

- patch Built in each slot's PACKAGES.rds, limited to the slot's own rows,
  when the installed bincraft no longer loads cranlike
- keep patching PACKAGES.db for releases that still do
- call the internal built_stamp() with `:::`, it was never exported

.crow/repair-built-stamp.yaml

@@ -3,8 +3,8 @@
 #
 # uvr matches the stamp's platform triple plus R minor to decide binary vs
 # source, so an unusable triple turns a whole slot source-only. See
-# local/repair-built-stamp.R for why this patches PACKAGES.db in place instead
+# local/repair-built-stamp.R for why this patches the published PACKAGES.rds in
-# of forcing a full reparse.
+# place instead of forcing a full reparse.
 #
 # Run with `dry_run: true` first: it reports how many entries are broken per
 # slot and changes nothing. Pick the R version the slot should advertise, which

local/repair-built-stamp.R

@@ -9,21 +9,22 @@
 ### fail wherever a system `-dev` library is missing.
 ###
 ### Rewriting it is not a matter of re-running the normal index update.
-### `upload_package_index()` reuses the slot's remote `PACKAGES.db`, and
+### `upload_package_index()` uses the slot's published `PACKAGES.rds` as its
-### cranlike's `update_db()` only reparses files whose md5 changed, so entries
+### cache: a record whose tarball is still listed with the same ETag is reused,
-### already in the database keep the stamp they were written with. Dropping
+### stamp included, and only new or replaced tarballs are read and stamped. A
-### `PACKAGES.db` to force a full reparse does work, but for an S3 repo cranlike
+### full re-read would mean 25k requests to raw.githubusercontent.com per slot
-### reads each package's metadata from the CRAN *source* mirror on GitHub, so a
+### and a real risk of being rate-limited part-way through.
-### 25k-entry slot means 25k requests to raw.githubusercontent.com and a real
-### risk of being rate-limited part-way through.
 ###
 ### Only the `Built` column is wrong, so correct it in place instead: patch the
-### column in `PACKAGES.db`, put the database back, and let
+### column in the published `PACKAGES.rds`, put it back, and let
-### `upload_package_index()` re-emit `PACKAGES*` from it. `update_db()` always
+### `upload_package_index()` re-emit `PACKAGES*` from it. No tarball is re-read
-### rewrites the index files even when nothing was reparsed, so no tarball is
+### and nothing is fetched from GitHub.
-### re-read and nothing is fetched from GitHub.
 ###
-### The replacement comes from `bincraft::built_stamp()` under the R running
+### bincraft releases before the switch away from cranlike (bincraft#33) read
+### the slot's `PACKAGES.db` instead, so with one of those installed the script
+### patches that database, as it always did.
+###
+### The replacement comes from bincraft's `built_stamp()` under the R running
 ### this script, so run it under the R version the slot should advertise (the
 ### `R_VERSION` its entry in `.crow/process-updates.yaml` uses). That is what a
 ### healthy `upload_package_index()` run would have written.
@@ -61,8 +62,9 @@ if (is.null(codename) || is.na(codename) || !nzchar(codename)) {
 }
 
 # built_stamp() refuses an unusable platform, so a broken build image fails here
-# rather than writing a second bad stamp over the first one.
+# rather than writing a second bad stamp over the first one. It is internal to
-stamp <- bincraft::built_stamp()
+# bincraft, hence `:::`.
+stamp <- bincraft:::built_stamp()
 message(sprintf("Slot:        %s/%s", arch, codename))
 message(sprintf("New stamp:   %s", stamp))
 
@@ -76,7 +78,12 @@ s3fs::s3_file_system(
 
 base_dir <- file.path(bucket, arch, codename, "latest", "src", "contrib")
 
-# A stamp is broken when its platform component is absent or literally "NA".
+# A stamp is broken when its platform component is literally "NA" or empty.
+broken_stamp <- function(built) {
+  !is.na(built) & grepl("; NA;|;  ;", built)
+}
+# The same test for PACKAGES.db, which also counts a missing stamp as broken:
+# the database never holds a deliberately cleared one.
 broken_stamp_where <- paste(
   "Built IS NULL",
   "OR Built LIKE '%; NA;%'",
@@ -91,9 +98,70 @@ r_minors <- sub(
   list.dirs("/opt/R", recursive = FALSE)
 )
 r_minors <- unique(grep("^[0-9]+\\.[0-9]+$", r_minors, value = TRUE))
-slots <- c(base_dir, file.path(base_dir, r_minors))
+slots <- c(
+  stats::setNames(base_dir, NA_character_),
+  stats::setNames(file.path(base_dir, r_minors), r_minors)
+)
 
-repair_slot <- function(slot) {
+# bincraft imports cranlike for as long as it keeps the index in PACKAGES.db.
+uses_packages_db <- "cranlike" %in% loadedNamespaces()
+
+repair_packages_rds <- function(slot, r_minor) {
+  rds_remote <- file.path(slot, "PACKAGES.rds")
+  if (!s3fs::s3_file_exists(rds_remote)) {
+    message(sprintf("  %s: no PACKAGES.rds, skipping", slot))
+    return(invisible(NULL))
+  }
+
+  rds_local <- tempfile(fileext = ".rds")
+  on.exit(unlink(rds_local), add = TRUE)
+  s3fs::s3_file_download(rds_remote, rds_local, overwrite = TRUE)
+  records <- readRDS(rds_local)
+
+  # A per-minor index is published as a union with the generic slot, and only
+  # the rows carrying the slot's own `Path` are reused from it; the generic ones
+  # are re-read from the generic slot's index, which is repaired on its own.
+  own <- if (!("Path" %in% colnames(records))) {
+    rep(TRUE, nrow(records))
+  } else if (is.na(r_minor)) {
+    is.na(records[, "Path"])
+  } else {
+    records[, "Path"] %in% r_minor
+  }
+  # A missing stamp is not broken here: bincraft clears it on purpose for a
+  # package whose build failed and that is served as its CRAN source.
+  broken <- own & broken_stamp(records[, "Built"])
+
+  message(sprintf(
+    "  %s: %s entries, %s broken",
+    slot,
+    sum(own),
+    sum(broken)
+  ))
+  if (!any(broken)) {
+    return(invisible(NULL))
+  }
+  if (!apply_changes) {
+    message("    (dry run, pass --apply to rewrite)")
+    return(invisible(NULL))
+  }
+
+  records[broken, "Built"] <- stamp
+  saveRDS(records, rds_local, compress = "xz")
+  s3fs::s3_file_upload(
+    rds_local,
+    rds_remote,
+    overwrite = TRUE,
+    CacheControl = "no-store"
+  )
+  message(sprintf(
+    "    rewrote %s entries and uploaded PACKAGES.rds",
+    sum(broken)
+  ))
+  invisible(NULL)
+}
+
+repair_packages_db <- function(slot, r_minor) {
   db_remote <- file.path(slot, "PACKAGES.db")
   if (!s3fs::s3_file_exists(db_remote)) {
     message(sprintf("  %s: no PACKAGES.db, skipping", slot))
@@ -134,16 +202,21 @@ repair_slot <- function(slot) {
   invisible(NULL)
 }
 
-invisible(lapply(slots, repair_slot))
+repair_slot <- if (uses_packages_db) repair_packages_db else repair_packages_rds
+message(sprintf(
+  "Patching:    %s",
+  if (uses_packages_db) "PACKAGES.db" else "PACKAGES.rds"
+))
+invisible(Map(repair_slot, slots, names(slots)))
 
 if (!apply_changes) {
   message("Dry run complete; nothing was changed.")
   quit(save = "no")
 }
 
-# Re-emit PACKAGES/PACKAGES.gz/PACKAGES.rds from the corrected database. Nothing
+# Re-emit PACKAGES/PACKAGES.gz/PACKAGES.rds from the corrected records. Nothing
-# is reparsed, because no tarball's md5 changed.
+# is reparsed, because no tarball changed.
-message("Re-emitting index files from the corrected database...")
+message("Re-emitting index files from the corrected records...")
 bincraft::upload_package_index(
   codename = codename,
   s3_endpoint = endpoint,