perf(build-newer-r): skip packages that already have a binary in bulk

Decide the already-built candidates from one listing per slot and one ABI-verdict query instead of a DB connection and several S3 requests per package; anything undecidable still goes through bincraft.

local/build-newer-r.R

@@ -27,6 +27,94 @@ message(sprintf(
 if ("--dry-run" %in% args) {
   print(pkgs, row.names = FALSE)
 } else {
+  # Most candidates were built on an earlier run. Asking bincraft about each one
+  # costs a DB connection plus several S3 requests, about 4s a package, so the
+  # loop spent well over an hour per run re-confirming existing binaries.
+  # Decide those in bulk first; bincraft still checks whatever is left.
+  local_machine <- Sys.info()[["machine"]]
+  arch <- if (grepl("arm64|aarch64", local_machine)) "arm64" else "amd64"
+  slot_dir <- sprintf(
+    "devxy-rpkgs-binaries/%s/%s/latest/src/contrib",
+    arch,
+    bincraft::set_codename(NULL)
+  )
+  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
+  )
+  # NULL when the listing fails, so that route falls back to bincraft.
+  list_etags <- function(dir) {
+    info <- tryCatch(s3fs::s3_dir_info(dir), error = function(e) {
+      message(sprintf("Could not list %s: %s", dir, conditionMessage(e)))
+      NULL
+    })
+    if (is.null(info)) {
+      return(NULL)
+    }
+    stats::setNames(
+      gsub('^"|"$', "", as.character(info$etag)),
+      basename(as.character(info$uri))
+    )
+  }
+  # The verdicts bincraft::classify_r_minor_sensitive() would read from its
+  # cache, fetched in one query rather than one connection per package.
+  read_verdicts <- function(packages) {
+    tryCatch(
+      {
+        con <- DBI::dbConnect(
+          RPostgres::Postgres(),
+          dbname = "build_metadata",
+          host = "r-binaries.devxy.io",
+          port = 15432,
+          user = "rpkgs",
+          password = Sys.getenv("PGPASS"),
+          sslmode = "verify-full"
+        )
+        on.exit(DBI::dbDisconnect(con), add = TRUE)
+        rows <- DBI::dbGetQuery(
+          con,
+          paste(
+            "SELECT package, version, r_minor_sensitive FROM abi_classification",
+            "WHERE classifier_sig = $1 AND package = ANY($2::text[])"
+          ),
+          params = list(
+            bincraft:::abi_classifier_signature(),
+            paste0("{", paste(packages, collapse = ","), "}")
+          )
+        )
+        stats::setNames(
+          as.logical(rows$r_minor_sensitive),
+          paste(rows$package, rows$version, sep = "_")
+        )
+      },
+      error = function(e) {
+        message(sprintf("Could not read ABI verdicts: %s", conditionMessage(e)))
+        logical()
+      }
+    )
+  }
+  sensitive <- read_verdicts(pkgs$Package)
+  before <- nrow(pkgs)
+  pkgs <- newer_r_outstanding(
+    pkgs,
+    sensitive,
+    list_etags(slot_dir),
+    list_etags(file.path(
+      slot_dir,
+      sub("^(\\d+\\.\\d+).*", "\\1", target_r)
+    )),
+    bincraft:::cran_source_md5()
+  )
+  message(sprintf(
+    "%d of %d already carry a binary at their routed path; %d left for bincraft",
+    before - nrow(pkgs),
+    before,
+    nrow(pkgs)
+  ))
+
   options(crayon.enabled = TRUE, Ncpus = 4, future.globals.onReference = NULL)
   for (i in seq_len(nrow(pkgs))) {
     message(sprintf(

local/newer-r-helpers.R

@@ -73,3 +73,42 @@ newer_r_candidates <- function(db, primary_r, target_r) {
   result <- db[selected, c("Package", "Version"), drop = FALSE]
   result[order(result$Package), , drop = FALSE]
 }
+
+# Candidates that still need a build, decided from one bucket listing per slot
+# instead of a metadata-DB connection and several S3 requests per package.
+#
+# Mirrors bincraft's own skip decision: a package is done when a binary sits at
+# the path its cached ABI verdict routes it to, `<slot>/<minor>/` when
+# r-minor-sensitive and the flat `<slot>/` otherwise. A CRAN source sitting at
+# that key is a fallback, not a binary (see outstanding_packages()). Whatever
+# this cannot decide, no cached verdict or a slot that could not be listed,
+# stays in the list, so bincraft makes that call exactly as before.
+#
+# `sensitive`    cached verdicts for the current classifier, named `<pkg>_<ver>`
+# `flat_etags`   listing of the flat slot as for outstanding_packages(), or
+#                NULL when it could not be listed
+# `minor_etags`  the same for this interpreter's per-minor slot
+newer_r_outstanding <- function(
+  pkgs,
+  sensitive,
+  flat_etags,
+  minor_etags,
+  cran_md5
+) {
+  verdict <- unname(sensitive[paste(pkgs$Package, pkgs$Version, sep = "_")])
+  version <- stats::setNames(pkgs$Version, pkgs$Package)
+  keep <- rep(TRUE, nrow(pkgs))
+  routes <- list(
+    list(sensitive = FALSE, etags = flat_etags),
+    list(sensitive = TRUE, etags = minor_etags)
+  )
+  for (route in routes) {
+    idx <- which(verdict %in% route$sensitive)
+    if (length(idx) == 0L || is.null(route$etags)) {
+      next
+    }
+    keep[idx] <- pkgs$Package[idx] %in%
+      outstanding_packages(pkgs$Package[idx], route$etags, version, cran_md5)
+  }
+  pkgs[keep, , drop = FALSE]
+}

local/tests/test-newer-r-helpers.R

@@ -1,4 +1,5 @@
 source(file.path("..", "newer-r-helpers.R"))
+source(file.path("..", "rebuild-missing-helpers.R"))
 
 test_that("R constraints respect patch versions, bounds, and missing fields", {
   expect_true(r_requirement_satisfied(NA_character_, "4.4.3"))
@@ -79,3 +80,70 @@ test_that("R-devel Recommended copies cannot block ordinary CRAN dependencies",
     c("arules", "arulesSequences", "indirect")
   )
 })
+
+candidates <- function() {
+  data.frame(
+    Package = c(
+      "flat_done",
+      "flat_todo",
+      "minor_done",
+      "minor_flat_only",
+      "unclassified",
+      "fallback"
+    ),
+    Version = c("1.0", "1.0", "2.0", "2.0", "3.0", "4.0")
+  )
+}
+
+verdicts <- c(
+  flat_done_1.0 = FALSE,
+  flat_todo_1.0 = FALSE,
+  minor_done_2.0 = TRUE,
+  minor_flat_only_2.0 = TRUE,
+  fallback_4.0 = FALSE
+)
+
+flat <- c(
+  flat_done_1.0.tar.gz = "aaa",
+  minor_flat_only_2.0.tar.gz = "bbb",
+  unclassified_3.0.tar.gz = "ccc",
+  fallback_4.0.tar.gz = "c0ffee"
+)
+minor <- c(minor_done_2.0.tar.gz = "ddd")
+md5 <- c(fallback_4.0 = "c0ffee")
+
+test_that("newer_r_outstanding skips only binaries at the routed path", {
+  expect_identical(
+    newer_r_outstanding(candidates(), verdicts, flat, minor, md5)$Package,
+    # flat_todo: absent; minor_flat_only: sensitive, so a flat copy does not
+    # count; unclassified: no verdict, left to bincraft; fallback: CRAN source
+    c("flat_todo", "minor_flat_only", "unclassified", "fallback")
+  )
+})
+
+test_that("newer_r_outstanding keeps a route whose slot could not be listed", {
+  expect_identical(
+    newer_r_outstanding(candidates(), verdicts, NULL, minor, md5)$Package,
+    c("flat_done", "flat_todo", "minor_flat_only", "unclassified", "fallback")
+  )
+  expect_identical(
+    newer_r_outstanding(candidates(), verdicts, flat, NULL, md5)$Package,
+    c("flat_todo", "minor_done", "minor_flat_only", "unclassified", "fallback")
+  )
+})
+
+test_that("newer_r_outstanding without verdicts or listings changes nothing", {
+  expect_identical(
+    newer_r_outstanding(candidates(), logical(), flat, minor, md5),
+    candidates()
+  )
+  empty <- stats::setNames(character(), character())
+  expect_identical(
+    nrow(newer_r_outstanding(candidates(), verdicts, empty, empty, md5)),
+    nrow(candidates())
+  )
+  expect_identical(
+    nrow(newer_r_outstanding(candidates()[0L, ], verdicts, flat, minor, md5)),
+    0L
+  )
+})