build-cran-binaries/local/packages-to-build.R

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

library(bincraft, quietly = TRUE)
suppressPackageStartupMessages(library(dplyr))
library(DBI, quietly = TRUE)
library(purrr, quietly = TRUE)
library(progressr, quietly = TRUE)
suppressPackageStartupMessages(library(data.table))

# Sys.setenv("OS" = "alpine")
# Sys.setenv("OS_VERSION" = "3.22")
# Sys.setenv("ARCH" = "arm64")

arch <- Sys.getenv("ARCH")
# target: alpine-322, ubuntu-2404, redhat-9, etc.
platform <- paste(
  Sys.getenv("OS"),
  gsub("[.]", "", Sys.getenv("OS_VERSION")),
  sep = "-"
)
# Use bincraft's codename detection for S3 paths (e.g. "rhel10" not "redhat10")
codename <- bincraft::set_codename(NULL)

con <- DBI::dbConnect(
  RPostgres::Postgres(),
  dbname = "build_metadata",
  host = "r-binaries.devxy.io",
  port = 15432,
  user = "rpkgs",
  password = Sys.getenv("PGPASS"),
  sslmode = "require"
)

cran_archive <- tools::CRAN_archive_db()
cran_release <- tools::CRAN_package_db()
# Subset cran_archive to only those packages
cran_archive_in_release <- cran_archive[
  names(cran_archive) %in% cran_release$Package
]

archive_versions <- rbindlist(
  lapply(names(cran_archive), function(pkg) {
    df <- as.data.table(cran_archive_in_release[[pkg]])
    file_names <- rownames(cran_archive_in_release[[pkg]]) # Get row names from the original data.frame!
    versions <- sub(".*_(.*)\\.tar\\.gz$", "\\1", file_names)
    data.table(
      Package = pkg,
      Version = versions,
      mtime = df$mtime
    )
  }),
  fill = TRUE
)

# Select the 4 most recent archive versions by mtime for each package
# Combined with the 1 release version = 5 versions per package
archive_versions <- archive_versions[
  order(Package, -as.numeric(mtime))
][,
  head(.SD, 4),
  by = Package
][,
  .(Package, Version)
]

# Now get release versions (assuming cran_release has Package and Version columns)
#
# Packages published in the last few days are held back. `check_for_binary()`
# reads the published version from the `cran` GitHub mirror
# (`GET /repos/cran/<pkg>/commits`), and that mirror lags CRAN: a package that
# has just appeared has no repository there yet. The call then 404s, which is
# permanent, but it is wrapped in `purrr::insistently` and retried ten times
# with a backoff capped at 60s - so one unmirrored package burns about five
# minutes and then aborts the whole shard.
#
# Holding them back costs nothing: the daily update pipeline builds new and
# updated packages anyway, and they arrive here on the next run once the mirror
# has caught up.
mirror_lag_days <- as.numeric(
  Sys.getenv("CRAN_MIRROR_LAG_DAYS", unset = "3")
)
published <- as.POSIXct(cran_release$Published, tz = "UTC")
too_recent <- !is.na(published) &
  published > (Sys.time() - mirror_lag_days * 86400)
if (any(too_recent)) {
  message(sprintf(
    "Holding back %d package(s) published in the last %g day(s); the cran GitHub mirror will not have them yet: %s",
    sum(too_recent),
    mirror_lag_days,
    paste(utils::head(cran_release$Package[too_recent], 10L), collapse = ", ")
  ))
}

release_versions <- data.table(
  Package = cran_release$Package[!too_recent],
  Version = as.character(cran_release$Version[!too_recent])
)

pkgs_to_build <- unique(rbind(archive_versions, release_versions, fill = TRUE))
setorder(pkgs_to_build, Package, Version)

### Get all packages in S3
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
)
s3_pkgs <- s3fs::s3_dir_ls(
  sprintf("devxy-rpkgs-binaries/%s/%s/latest/src/contrib", arch, codename),
  recurse = TRUE
)

# `recurse = TRUE` walks the per-minor slots as well, and `basename()` throws
# the directory away - so `4.5/curl_1.0.tar.gz` and `curl_1.0.tar.gz` collapse
# to one name and a package present under *any* R minor counts as built for
# *all* of them. The candidate list then prunes exactly the packages a
# per-minor pass exists to build: arm64/alpine324 reported "0 remaining" for
# both 4.4 and 4.6 while its indexes were dropping 2400+ packages as missing.
#
# Per-minor objects are therefore excluded here. Presence in a specific minor
# is decided downstream, where the running R version is known: build-all.R
# filters on it, and `build_binary_package()` checks the per-minor path per
# package and skips what is already there.
#
# Archive/ is kept. Those are versions that were built and then superseded;
# dropping them would make every archived version look unbuilt.
per_minor_object <- grepl("/[0-9]+\\.[0-9]+/[^/]+$", s3_pkgs)
if (any(per_minor_object)) {
  cat(sprintf(
    "Excluding %d per-minor object(s) from the presence check; those are decided per pass\n",
    sum(per_minor_object)
  ))
}
file_names <- basename(s3_pkgs[!per_minor_object])

# An object occupying a key is not proof a binary was built: a package whose
# build failed has its CRAN source published under exactly that name. Left in
# the cache, `build_binary_package()` reads it as "already built" and skips the
# package forever, which is how alpine324 accumulated ~13.5k source tarballs.
#
# bincraft stamps `Built` only on records it actually built, so the slot's own
# index distinguishes them. A slot last indexed by a bincraft that predates that
# fix stamps `Built` on everything, so the cache is then unchanged from before.
# Archived objects have no index record and are kept: unknown means binary,
# never "rebuild it".
index_url <- sprintf(
  "https://cran.rpkgs.com/%s/%s/latest/src/contrib/PACKAGES.gz",
  arch,
  codename
)
source_served <- tryCatch(
  {
    con_idx <- gzcon(url(index_url, open = "rb"))
    on.exit(close(con_idx), add = TRUE)
    idx <- read.dcf(con_idx, fields = c("Package", "Version", "Built"))
    sprintf(
      "%s_%s.tar.gz",
      idx[is.na(idx[, "Built"]), "Package"],
      idx[is.na(idx[, "Built"]), "Version"]
    )
  },
  error = function(e) {
    cat(sprintf(
      "WARNING: could not read %s (%s); keeping the full S3 cache\n",
      index_url,
      conditionMessage(e)
    ))
    character(0)
  }
)

binary_cache <- setdiff(file_names, source_served)

# The existence cache and the candidate list need different views of the same
# listing, and conflating them is what made this wrong in both directions.
#
# The candidate list must ignore per-minor objects, or a package present under
# one minor prunes itself from every other minor's work (#189). The existence
# cache must NOT ignore them, or `build_binary_package()` is told nothing is
# present under any minor and recompiles the lot: amd64/resolute recompiled
# 8683 packages it had already built, reporting "already exists in S3" three
# times.
#
# So the cache keeps the path relative to the slot, and `build-all.R` selects
# the part that matches the pass it is running: the flat slot for the primary,
# `<minor>/` for a per-minor pass.
#
# `s3_dir_ls()` returns keys with the `s3://` scheme attached, so stripping the
# prefix as a fixed substring takes it out of the middle and leaves
# `s3://4.4/curl_1.0.tar.gz`. That leading scheme defeats the `^<minor>/` test
# downstream, so every per-minor object is read as a flat-slot object: the
# sensitive passes see an empty cache and recompile everything they already
# have. Anchor the pattern and swallow the scheme with it.
contrib_prefix <- sprintf(
  "^(s3://)?devxy-rpkgs-binaries/%s/%s/latest/src/contrib/",
  arch,
  codename
)
relative_paths <- sub(contrib_prefix, "", s3_pkgs)

# The strip is load-bearing and fails silently, so assert it. Both counts are
# derived from the same listing and use the same shape of pattern, so they must
# agree exactly; a mismatch means the prefix no longer describes the keys.
stripped_per_minor <- grepl("^[0-9]+\\.[0-9]+/[^/]+$", relative_paths)
if (sum(stripped_per_minor) != sum(per_minor_object)) {
  stop(sprintf(
    paste0(
      "S3 prefix strip failed: %d per-minor objects in the listing, %d after ",
      "stripping /%s/. Example key: %s"
    ),
    sum(per_minor_object),
    sum(stripped_per_minor),
    contrib_prefix,
    if (any(per_minor_object)) {
      s3_pkgs[which(per_minor_object)[1L]]
    } else {
      "<none>"
    }
  ))
}
source_basenames <- source_served
existence_cache <- relative_paths[
  !basename(relative_paths) %in% source_basenames
]
cat(sprintf(
  "S3 cache: %d objects, %d served as CRAN source, %d usable binaries\n",
  length(file_names),
  length(file_names) - length(binary_cache),
  length(binary_cache)
))

# Save the S3 file listing for the build step to use as s3_package_cache.
# This avoids loading s3fs/reticulate in the build container, saving memory for
# the dependency-installer subprocesses
# Mark the format explicitly. `build-all.R` has to tell a slot-relative cache
# from a pre-#191 basename one, and sniffing for a "/" cannot: a new-format
# cache for a slot with no per-minor or Archive objects holds bare names too,
# and would be read as legacy and used unfiltered, which makes a per-minor pass
# believe the flat slot's binaries are its own and build nothing.
attr(existence_cache, "slot_relative") <- TRUE
saveRDS(existence_cache, "/mnt/cache/packages/s3_cache.rds")
# Built from the filtered listing, not the raw one: `s3_dt` is subtracted from
# the build list below, so a source fallback left in here would exclude the very
# package that needs building.
matches <- regexec("^([A-Za-z0-9.]+)_([0-9][^/]*)\\.tar\\.gz$", binary_cache)
parts <- regmatches(binary_cache, matches)
parts <- parts[sapply(parts, length) == 3]
s3_dt <- data.table(
  Package = sapply(parts, `[`, 2),
  Version = sapply(parts, `[`, 3)
)

### Get all packages with build errors

# Scoped to the R minor this snapshot is computed under. A failure is a fact
# about one interpreter: without the scope a package that failed under the
# primary minor is dropped from the candidate list for every other minor too,
# which is the same omission fixed in local/build-all.R and in bincraft's
# check_package_error().
snapshot_r_minor <- paste(
  R.version$major,
  strsplit(R.version$minor, ".", fixed = TRUE)[[1L]][1L],
  sep = "."
)
sql_query <- paste0(
  # nolint
  "SELECT error_occurred FROM ",
  "single_builds",
  " WHERE name = $1 AND tag = $2 AND platform = $3 AND arch = $4",
  " AND substring(r_version from '^[0-9]+[.][0-9]+') = $5"
)
# Function to query for a single package-version
query_error <- function(pkg, ver) {
  purrr::insistently(
    ~ DBI::dbGetQuery(
      con,
      sql_query,
      params = list(pkg, ver, platform, arch, snapshot_r_minor)
    ),
    rate = purrr::rate_backoff(
      pause_base = 1L,
      pause_cap = 60L,
      pause_min = 1L,
      max_times = 10L,
      jitter = FALSE
    ),
    quiet = FALSE
  )()
}

# Fetch all relevant columns from the database
errored_pkgs <- DBI::dbGetQuery(
  con,
  sprintf(
    "SELECT name, tag FROM single_builds WHERE error_occurred = TRUE and platform='%s' and arch='%s'",
    platform,
    arch
  )
)
errored_pkgs <- as.data.table(errored_pkgs)
setkey(pkgs_to_build, Package, Version)
setnames(errored_pkgs, c("Package", "Version"))
setkey(errored_pkgs, Package, Version)

### Final subsetting
pkgs_no_error <- pkgs_to_build[!errored_pkgs]
# Return the full (Package, Version) pairs that need building
pkgs <- pkgs_no_error[!s3_dt]
# Deduplicate
pkgs <- unique(pkgs)
setorder(pkgs, Package, Version)

### R-minor sensitivity (classify once per package, applied to all versions)
source(file.path("local", "r-minor-helpers.R"))
risky_deps <- bincraft::abi_risky_linking_deps()

release_meta <- data.table(
  Package = cran_release$Package,
  NeedsCompilation = cran_release$NeedsCompilation,
  LinkingTo = cran_release$LinkingTo
)

meta <- release_meta[Package %in% unique(pkgs$Package)]
meta[,
  triage := mapply(
    classify_from_metadata,
    NeedsCompilation,
    LinkingTo,
    MoreArgs = list(risky_deps = risky_deps)
  )
]

# Only the "ambiguous" compiled packages need a source grep.
ambiguous <- meta[triage == "ambiguous", Package]
sensitive_ambiguous <- character()
if (length(ambiguous) > 0L) {
  tmp_src <- file.path(tempdir(), "abi_src")
  dir.create(tmp_src, showWarnings = FALSE, recursive = TRUE)
  sens <- vapply(
    ambiguous,
    function(pkg) {
      out <- tryCatch(
        {
          dl <- utils::download.packages(
            pkg,
            destdir = tmp_src,
            repos = "https://cloud.r-project.org",
            quiet = TRUE
          )
          isTRUE(as.logical(bincraft::needs_per_minor_recompile(dl[1L, 2L])))
        },
        error = function(e) TRUE
      ) # fail safe: treat as sensitive
      out
    },
    logical(1L)
  )
  sensitive_ambiguous <- ambiguous[sens]
}

sensitive_pkgs <- unique(c(
  meta[triage == "sensitive", Package],
  sensitive_ambiguous
))
pkgs[, r_minor_sensitive := Package %in% sensitive_pkgs]
sprintf(
  "R-minor-sensitive packages: %s of %s",
  length(sensitive_pkgs),
  uniqueN(pkgs$Package)
)