build-cran-binaries/local/backfill-flat-safety.R

### Record, per flat-slot object, whether it loads under every supported R minor.
#
# Usage: Rscript local/backfill-flat-safety.R <arch> <codename> [limit]
#
# `union_index_records()` keeps a carried flat record when that object is
# recorded safe, and drops it otherwise. Objects uploaded before that record
# existed have no verdict, so they are dropped: a full re-index removed ~2000
# records per per-minor index, all resolving to CRAN source for clients the
# routing serves correctly.
#
# This inspects the objects already in the bucket and writes the verdict, which
# is what restores that coverage. The question is decided by symbols, not
# heuristics: a binary fails at dyn.load() under minor M exactly when it
# references a symbol M does not export, and the volatile set is derived by
# diffing the R builds installed in this image.
#
# Only compiled packages are inspected. A package with no shared object cannot
# fail this way and is never dropped, so proving it would be wasted downloads.
#
# Resumable: objects already recorded are skipped, so a re-run costs one query.

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

library(bincraft, quietly = TRUE)

args <- commandArgs(trailingOnly = TRUE)
if (length(args) < 2L) {
  stop("usage: backfill-flat-safety.R <arch> <codename> [limit]", call. = FALSE)
}
arch <- args[[1L]]
codename <- args[[2L]]
limit <- if (length(args) >= 3L) as.integer(args[[3L]]) else NA_integer_

sets <- bincraft:::installed_r_symbol_sets()
if (is.null(sets)) {
  stop(
    "Fewer than two R minors are installed here, so nothing can be compared. Refusing to record verdicts that would all read 'safe'.", # nolint
    call. = FALSE
  )
}
cat(sprintf(
  "Comparing R minors: %s (%d symbols vary across them)\n",
  paste(names(sets), collapse = ", "),
  length(bincraft:::cross_minor_volatile_symbols(sets))
))

# The flat slot is listed from S3, not from PACKAGES.gz over HTTPS. Reading the
# index from inside R sends an R User-Agent, which the edge routes to a
# per-minor index; that enumerates union records carrying `Path: <minor>`, whose
# objects do not exist at the flat path. Every download then 404s: a first run
# skipped 292 of 300 that way. The bucket cannot be routed and is authoritative.
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(
  "devxy-rpkgs-binaries/%s/%s/latest/src/contrib",
  arch,
  codename
)
objects <- s3fs::s3_dir_ls(contrib, recurse = TRUE)
relative <- sub(sprintf("^(s3://)?%s/", contrib), "", objects)
# Flat objects only: no `<minor>/` prefix and nothing under Archive/.
flat_files <- relative[
  grepl("\\.tar\\.gz$", relative) & !grepl("/", relative, fixed = TRUE)
]
flat_pkg <- sub("_.*$", "", flat_files)
flat_ver <- sub("\\.tar\\.gz$", "", sub("^[^_]*_", "", flat_files))

# Only compiled packages can fail at dyn.load(), so the rest are not worth
# downloading. CRAN's own index says which; it is not behind our edge.
cran <- read.dcf(
  gzcon(url(
    "https://cloud.r-project.org/src/contrib/PACKAGES.gz",
    open = "rb"
  )),
  fields = c("Package", "NeedsCompilation")
)
compiled_names <- cran[
  !is.na(cran[, "NeedsCompilation"]) & cran[, "NeedsCompilation"] == "yes",
  "Package"
]
keep <- flat_pkg %in% compiled_names
compiled <- data.frame(
  Package = flat_pkg[keep],
  Version = flat_ver[keep],
  stringsAsFactors = FALSE
)
cat(sprintf(
  "%s/%s: %d flat objects, %d compiled and worth inspecting\n",
  arch,
  codename,
  length(flat_files),
  nrow(compiled)
))
if (!is.na(limit) && limit > 0L && limit < nrow(compiled)) {
  compiled <- compiled[seq_len(limit), , drop = FALSE]
  cat(sprintf("Limited to the first %d\n", limit))
}

# Fetch from the bucket as well: the edge does not rewrite tarball requests,
# but it does cache them, and the object is what the verdict is about.
safe <- 0L
unsafe <- 0L
skipped <- 0L
for (i in seq_len(nrow(compiled))) {
  pkg <- compiled[i, "Package"]
  ver <- compiled[i, "Version"]
  tarball <- file.path(tempdir(), sprintf("%s_%s.tar.gz", pkg, ver))
  ok <- tryCatch(
    {
      s3fs::s3_file_download(
        sprintf("%s/%s_%s.tar.gz", contrib, pkg, ver),
        tarball,
        overwrite = TRUE
      )
      file.exists(tarball)
    },
    error = function(e) FALSE,
    warning = function(w) FALSE
  )
  if (!ok) {
    skipped <- skipped + 1L
    next
  }
  verdict <- bincraft:::tarball_abi_verdict(tarball, sets)
  unlink(tarball)
  if (!isTRUE(verdict$inspected)) {
    skipped <- skipped + 1L
    next
  }
  bincraft:::flat_safety_store(
    pkg,
    ver,
    codename,
    arch,
    safe = !isTRUE(verdict$sensitive),
    unsupported = verdict$unsupported
  )
  if (isTRUE(verdict$sensitive)) {
    unsafe <- unsafe + 1L
  } else {
    safe <- safe + 1L
  }
  if (i %% 250L == 0L) {
    cat(sprintf(
      "  inspected %d/%d (%d safe, %d unsafe, %d skipped)\n",
      i,
      nrow(compiled),
      safe,
      unsafe,
      skipped
    ))
    utils::flush.console()
  }
}

cat(sprintf(
  "Done: %d inspected, %d safe for every minor, %d unsafe, %d skipped\n",
  nrow(compiled),
  safe,
  unsafe,
  skipped
))