build-cran-binaries/local/repair-built-stamp.R

#!/usr/bin/env Rscript

### Rewrite a broken `Built` stamp across one arch/codename slot.
###
### A slot's index can end up advertising a stamp whose platform triple is
### unusable, e.g. `Built: R 4.5.0; NA; ...`. uvr picks binary vs source by
### matching that triple plus the R minor, so no client matches it and the whole
### slot silently reverts to source-only, which makes uvr compile everything and
### fail wherever a system `-dev` library is missing.
###
### Rewriting it is not a matter of re-running the normal index update.
### `upload_package_index()` uses the slot's published `PACKAGES.rds` as its
### cache: a record whose tarball is still listed with the same ETag is reused,
### stamp included, and only new or replaced tarballs are read and stamped. A
### full re-read would mean 25k requests to raw.githubusercontent.com per slot
### 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 the published `PACKAGES.rds`, put it back, and let
### `upload_package_index()` re-emit `PACKAGES*` from it. No tarball is re-read
### and nothing is fetched from GitHub.
###
### 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.
###
### Usage, inside the platform's build image:
###   Rscript local/repair-built-stamp.R <arch> [--apply]
###
### Without `--apply` it reports what it would change and touches nothing.

suppressPackageStartupMessages({
  library(bincraft)
})

args <- commandArgs(trailingOnly = TRUE)
arch <- args[1L]
apply_changes <- "--apply" %in% args

if (is.na(arch) || !nzchar(arch)) {
  stop(
    "Usage: Rscript local/repair-built-stamp.R <arch> [--apply]",
    call. = FALSE
  )
}

bucket <- "devxy-rpkgs-binaries"
endpoint <- "https://s3.eu-central-003.backblazeb2.com"
region <- "eu-central-003"

codename <- bincraft::set_codename(NULL)
if (is.null(codename) || is.na(codename) || !nzchar(codename)) {
  stop(
    "Could not detect a codename from /etc/os-release; run this in a build image.",
    call. = FALSE
  )
}

# built_stamp() refuses an unusable platform, so a broken build image fails here
# rather than writing a second bad stamp over the first one. It is internal to
# bincraft, hence `:::`.
stamp <- bincraft:::built_stamp()
message(sprintf("Slot:        %s/%s", arch, codename))
message(sprintf("New stamp:   %s", stamp))

s3fs::s3_file_system(
  aws_access_key_id = Sys.getenv("B2_S3_ACCESS_KEY"),
  aws_secret_access_key = Sys.getenv("B2_S3_SECRET_KEY"),
  endpoint = endpoint,
  region_name = region,
  refresh = TRUE
)

base_dir <- file.path(bucket, arch, codename, "latest", "src", "contrib")

# 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;%'",
  "OR Built LIKE '%;  ;%'"
)

# The generic slot plus every per-minor sub-slot, which carry the same stamp and
# are poisoned by the same run.
r_minors <- sub(
  "^.*/R/([0-9]+\\.[0-9]+)\\.[0-9]+$",
  "\\1",
  list.dirs("/opt/R", recursive = FALSE)
)
r_minors <- unique(grep("^[0-9]+\\.[0-9]+$", r_minors, value = TRUE))
slots <- c(
  stats::setNames(base_dir, NA_character_),
  stats::setNames(file.path(base_dir, r_minors), r_minors)
)

# 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))
    return(invisible(NULL))
  }

  db_local <- tempfile(fileext = ".db")
  s3fs::s3_file_download(db_remote, db_local, overwrite = TRUE)

  con <- DBI::dbConnect(RSQLite::SQLite(), db_local)
  on.exit(DBI::dbDisconnect(con), add = TRUE)

  total <- DBI::dbGetQuery(con, "SELECT COUNT(*) AS n FROM packages")$n
  broken <- DBI::dbGetQuery(
    con,
    sprintf("SELECT COUNT(*) AS n FROM packages WHERE %s", broken_stamp_where)
  )$n

  message(sprintf("  %s: %s entries, %s broken", slot, total, broken))
  if (broken == 0L) {
    return(invisible(NULL))
  }
  if (!apply_changes) {
    message("    (dry run, pass --apply to rewrite)")
    return(invisible(NULL))
  }

  DBI::dbExecute(
    con,
    sprintf("UPDATE packages SET Built = ? WHERE %s", broken_stamp_where),
    params = list(stamp)
  )
  DBI::dbDisconnect(con)
  on.exit()

  s3fs::s3_file_upload(db_local, db_remote, overwrite = TRUE)
  message(sprintf("    rewrote %s entries and uploaded PACKAGES.db", broken))
  invisible(NULL)
}

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 records. Nothing
# is reparsed, because no tarball changed.
message("Re-emitting index files from the corrected records...")
bincraft::upload_package_index(
  codename = codename,
  s3_endpoint = endpoint,
  s3_region = region,
  s3_bucket = bucket,
  s3_access_key_id = Sys.getenv("B2_S3_ACCESS_KEY"),
  s3_secret_access_key = Sys.getenv("B2_S3_SECRET_KEY")
)
for (minor in r_minors) {
  try(
    bincraft::upload_package_index(
      codename = codename,
      r_minor = minor,
      s3_endpoint = endpoint,
      s3_region = region,
      s3_bucket = bucket,
      s3_access_key_id = Sys.getenv("B2_S3_ACCESS_KEY"),
      s3_secret_access_key = Sys.getenv("B2_S3_SECRET_KEY")
    ),
    silent = FALSE
  )
}

message("Done. Verify with:")
message(sprintf(
  "  curl -sS https://cran.devxy.io/%s/%s/latest/src/contrib/PACKAGES | grep '^Built:' | sort | uniq -c",
  arch,
  codename
))