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()` reuses the slot's remote `PACKAGES.db`, and
### cranlike's `update_db()` only reparses files whose md5 changed, so entries
### already in the database keep the stamp they were written with. Dropping
### `PACKAGES.db` to force a full reparse does work, but for an S3 repo cranlike
### reads each package's metadata from the CRAN *source* mirror on GitHub, so a
### 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
### `upload_package_index()` re-emit `PACKAGES*` from it. `update_db()` always
### rewrites the index files even when nothing was reparsed, so no tarball is
### re-read and nothing is fetched from GitHub.
###
### The replacement comes from `bincraft::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.
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 absent or literally "NA".
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(base_dir, file.path(base_dir, r_minors))

repair_slot <- function(slot) {
  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)
}

invisible(lapply(slots, repair_slot))

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
# is reparsed, because no tarball's md5 changed.
message("Re-emitting index files from the corrected database...")
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
))