build-cran-binaries/local/prune-stale-flat-binaries.R

### Remove flat-slot binaries recorded as unable to load under some R minor.
#
# Usage:
#   Rscript local/prune-stale-flat-binaries.R <arch> <codename> [--apply] [pkg ...]
#
# The list comes from `abi_flat_safety`, written by the flat-safety backfill
# from the binaries' own symbols, so it names exactly the objects that fail at
# dyn.load() somewhere. It deliberately does *not* use
# `abi_cache_risky_packages()`: that source heuristic calls 93% of compiled
# packages risky where the binaries say 4.3%, and pruning on it would delete
# roughly 3000 working objects per slot to fix about 230 broken ones. Selecting
# per object rather than per package is the same correction #129 made to the
# index writer.
#
# `upload_single_binary()` has written a non-portable package only to the
# per-minor slot since v5.3.0, so this is a one-time cleanup of objects
# uploaded before that, not a recurring sweep. The flat slot is what every
# client that cannot be routed by R minor receives, and such a binary was built
# under whichever R was primary at the time, so it fails at load under any
# minor that dropped a symbol it uses:
#
#   base64enc.so: undefined symbol: SETLENGTH
#
# Deleting the flat object does not create a hole: bincraft's source fallback
# publishes the CRAN source under the same key, so the package stays installable
# everywhere and compiles against the client's own R. Clients that are routed
# keep getting the per-minor binary.
#
# Dry run by default. Nothing is deleted without --apply.

options(error = function() {
  cat("ERROR:", geterrmessage(), "\n", file = stdout())
  traceback(2)
  q(status = 1)
})

library(bincraft, quietly = TRUE)

args <- commandArgs(trailingOnly = TRUE)
apply_changes <- "--apply" %in% args
args <- args[args != "--apply"]
if (length(args) < 2L) {
  stop(
    "usage: prune-stale-flat-binaries.R <arch> <codename> [--apply] [pkg ...]",
    call. = FALSE
  )
}
arch <- args[[1L]]
codename <- args[[2L]]
explicit <- args[-c(1L, 2L)]

bucket <- "devxy-rpkgs-binaries"
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 = "https://s3.eu-central-003.backblazeb2.com",
  region_name = "eu-central-003",
  refresh = TRUE
)

contrib <- sprintf("%s/%s/%s/latest/src/contrib", bucket, arch, codename)
objects <- s3fs::s3_dir_ls(contrib, recurse = TRUE)
relative <- sub(sprintf("^(s3://)?%s/", contrib), "", objects)

is_tarball <- grepl("\\.tar\\.gz$", relative)
# Flat objects only: no `<minor>/` prefix and not under Archive/.
is_flat <- is_tarball & !grepl("/", relative, fixed = TRUE)
flat_files <- relative[is_flat]
flat_pkg <- sub("_.*$", "", flat_files)

if (length(explicit) > 0L) {
  doomed <- flat_files[flat_pkg %in% explicit]
  cat(sprintf(
    "%s/%s: %d flat binaries, %d belong to the %d named package(s)\n",
    arch,
    codename,
    length(flat_files),
    length(doomed),
    length(explicit)
  ))
} else {
  con <- DBI::dbConnect(
    RPostgres::Postgres(),
    dbname = "build_metadata",
    host = "r-binaries.devxy.io",
    port = 15432L,
    user = "rpkgs",
    password = Sys.getenv("PGPASS"),
    sslmode = "require"
  )
  on.exit(try(DBI::dbDisconnect(con), silent = TRUE), add = TRUE)

  # Every recorded-unsafe row, whichever minor it fails under: the flat object
  # is served to clients on all of them, so one failing minor condemns it.
  rows <- DBI::dbGetQuery(
    con,
    paste0(
      "SELECT package, version FROM abi_flat_safety ",
      "WHERE NOT safe AND codename = $1 AND arch = $2"
    ),
    params = list(codename, arch)
  )
  if (nrow(rows) == 0L) {
    stop(
      "No unsafe objects are recorded for this slot. Refusing to proceed: that is indistinguishable from a slot whose flat-safety backfill never ran, and pruning nothing while reporting success would hide it.", # nolint
      call. = FALSE
    )
  }

  # Match the object, not the package. A package can have a safe flat binary at
  # one version and an unsafe one at another, and deleting both would throw
  # away a working binary.
  unsafe_objects <- sprintf("%s_%s", rows$package, rows$version)
  doomed <- flat_files[sub("\\.tar\\.gz$", "", flat_files) %in% unsafe_objects]
  cat(sprintf(
    "%s/%s: %d flat binaries, %d recorded unable to load under some R minor\n",
    arch,
    codename,
    length(flat_files),
    length(doomed)
  ))
}

# Never remove the last artifact of a package. The source fallback republishes
# the CRAN source under this key, but only for packages CRAN still ships, so
# confirm the source exists before deleting the binary.
cran <- tryCatch(
  {
    con <- gzcon(url(
      "https://cloud.r-project.org/src/contrib/PACKAGES.gz",
      open = "rb"
    ))
    on.exit(close(con), add = TRUE)
    read.dcf(con, fields = "Package")[, "Package"]
  },
  error = function(e) character(0)
)
if (length(cran) == 0L) {
  stop("Could not read CRAN's index; refusing to prune blind.", call. = FALSE)
}

orphaned <- doomed[!(sub("_.*$", "", doomed) %in% cran)]
if (length(orphaned) > 0L) {
  cat(sprintf(
    "Keeping %d object(s) whose package is no longer on CRAN, so there is no source to fall back to: %s\n",
    length(orphaned),
    paste(utils::head(orphaned, 5L), collapse = ", ")
  ))
  doomed <- setdiff(doomed, orphaned)
}

if (length(doomed) == 0L) {
  cat("Nothing to prune.\n")
  quit(status = 0)
}

for (f in doomed) {
  cat(sprintf("  %s %s\n", if (apply_changes) "DELETE" else "would delete", f))
}

if (!apply_changes) {
  cat(sprintf(
    "\nDry run: %d object(s) left in place. Re-run with --apply to delete.\n",
    length(doomed)
  ))
  quit(status = 0)
}

for (f in doomed) {
  s3fs::s3_file_delete(file.path(contrib, f))
}
cat(sprintf(
  "Deleted %d flat binary object(s). Re-index the slot so the source fallback republishes them.\n",
  length(doomed)
))