build-cran-binaries/local/seed-helpers.R

# Pure helpers for local/seed-pure-r.R, kept separate so local/tests can source
# them without touching S3 or the metadata DB.

# "alpine" for alpine324, "rhel" for rhel9. Seeding only ever crosses versions
# within one family: a pure-R binary has no compiled code, but install-time R
# code can still capture the build system's paths and tools.
codename_family <- function(codename) {
  sub("[0-9]+$", "", codename)
}

per_minor_key <- function(keys) {
  grepl("^[0-9]+\\.[0-9]+/", keys)
}

# Split `<pkg>_<ver>.tar.gz` file names; NA where a name does not parse.
split_tarball_name <- function(files) {
  m <- regmatches(files, regexec("^([A-Za-z0-9.]+)_([^_]+)\\.tar\\.gz$", files))
  part <- function(i) {
    vapply(m, function(x) if (length(x) == 3L) x[[i]] else NA_character_, "")
  }
  list(package = part(2L), version = part(3L))
}

# Donor objects worth downloading and verifying for the target slot.
#
# `donor_keys`/`donor_etags` describe the donor slot, keys relative to its
#   contrib dir (`curl_5.0.tar.gz`, `Archive/curl/curl_4.3.tar.gz`).
# `target_keys` are the target slot's keys, same form.
# `release_pkgs`  packages on CRAN now; the build scope.
# `compiled_pkgs` packages whose current CRAN release needs compilation. Their
#   archive versions are skipped as well: a seed only saves time, so guessing
#   wrong in this direction costs a build, never a broken binary.
# `cran_md5`  CRAN's MD5 per `<pkg>_<ver>`. An ETag equal to it is CRAN's source
#   tarball served as a fallback, never a binary worth copying.
#
# Anything already present in the target, under any non-per-minor key, is left
# alone: that is either a build or an earlier seed.
seed_candidates <- function(
  donor_keys,
  donor_etags,
  target_keys,
  release_pkgs,
  compiled_pkgs,
  cran_md5,
  exclude = character()
) {
  files <- basename(donor_keys)
  parsed <- split_tarball_name(files)
  md5 <- if (length(cran_md5) == 0L) {
    rep(NA_character_, length(files))
  } else {
    unname(cran_md5[paste(parsed$package, parsed$version, sep = "_")])
  }
  is_source <- !is.na(md5) & !is.na(donor_etags) & donor_etags == md5
  present <- basename(target_keys[!per_minor_key(target_keys)])

  keep <- !is.na(parsed$package) &
    !per_minor_key(donor_keys) &
    parsed$package %in% release_pkgs &
    !parsed$package %in% compiled_pkgs &
    !parsed$package %in% exclude &
    !files %in% present &
    !is_source
  out <- data.frame(
    key = donor_keys,
    package = parsed$package,
    version = parsed$version,
    stringsAsFactors = FALSE
  )[keep, , drop = FALSE]
  # The same version can sit both flat and under Archive/ while the donor waits
  # for process_unarchived_pkgs(); copy it once, flat first.
  out <- out[order(grepl("^Archive/", out$key)), , drop = FALSE]
  out <- out[!duplicated(basename(out$key)), , drop = FALSE]
  rownames(out) <- NULL
  out
}

# `Built: R 4.5.3; ; 2026-09-01 10:00:00 UTC; unix` -> R version and platform.
# The platform is empty exactly when the package has no compiled code.
parse_built <- function(built) {
  parts <- trimws(strsplit(built, ";", fixed = TRUE)[[1L]])
  list(
    r_version = sub("^R\\s+", "", parts[1L]),
    platform = if (length(parts) >= 2L) parts[2L] else NA_character_
  )
}

# Whether one downloaded donor tarball may be published in the target slot.
#
# Every check has to pass; anything unreadable is a refusal, never a guess,
# because a refusal only means the package gets built the normal way.
#   * it is a binary: DESCRIPTION carries a `Built` field (a CRAN source
#     fallback does not);
#   * it has no compiled code: empty `Built` platform and no libs/ directory;
#   * it was built by the target's primary R minor, the one whose binaries the
#     flat slot holds;
#   * `abi_verdict` (bincraft's upload-time symbol inspection) calls it portable
#     across every installed minor, exactly the decision a fresh upload would
#     make before writing to the flat slot.
seed_verdict <- function(tarball, package, version, target_minor, abi_verdict) {
  reject <- function(reason) {
    list(seed = FALSE, reason = reason, unsupported = character())
  }
  read_members <- function() {
    tryCatch(
      utils::untar(tarball, list = TRUE),
      error = function(e) NULL,
      warning = function(w) NULL
    )
  }
  members <- read_members()
  if (is.null(members)) {
    return(reject("unreadable"))
  }
  desc <- paste0(package, "/DESCRIPTION")
  if (!desc %in% members) {
    return(reject("unreadable"))
  }
  if (any(startsWith(members, paste0(package, "/libs/")))) {
    return(reject("compiled"))
  }

  dir <- tempfile("seed_desc_")
  on.exit(unlink(dir, recursive = TRUE, force = TRUE), add = TRUE)
  fields <- tryCatch(
    {
      utils::untar(tarball, files = desc, exdir = dir)
      read.dcf(
        file.path(dir, desc),
        fields = c("Package", "Version", "Built")
      )
    },
    error = function(e) NULL,
    warning = function(w) NULL
  )
  if (is.null(fields) || nrow(fields) != 1L) {
    return(reject("unreadable"))
  }
  if (
    !identical(unname(fields[1L, "Package"]), package) ||
      !identical(unname(fields[1L, "Version"]), version)
  ) {
    return(reject("mismatch"))
  }
  if (is.na(fields[1L, "Built"])) {
    return(reject("source"))
  }
  built <- parse_built(fields[1L, "Built"])
  if (is.na(built$platform) || nzchar(built$platform)) {
    return(reject("compiled"))
  }
  built_minor <- sub("^(\\d+\\.\\d+).*$", "\\1", built$r_version)
  if (!identical(built_minor, target_minor)) {
    return(reject("r-minor"))
  }

  verdict <- abi_verdict(tarball)
  if (!isTRUE(verdict$inspected) || !identical(verdict$sensitive, FALSE)) {
    return(reject("abi"))
  }
  list(seed = TRUE, reason = "seeded", unsupported = verdict$unsupported)
}