build-cran-binaries/local/verify-repo-routing.R

# Check that a published slot serves an installable, loadable binary for the R
# running this script, through one of the URL forms a user can configure.
#
#   Rscript local/verify-repo-routing.R <arch> <codename> <form>
#
# One process per form on purpose: `available.packages()` caches its index in
# `tempdir()` keyed by repository URL, and the `arch` and `flat` forms share a
# URL. In a single process the second form would silently read the first form's
# index and the run would prove nothing.
#
# Forms:
#   arch     https://cran.rpkgs.com/<arch>/<codename>/latest with R's own agent
#   generic  https://cran.rpkgs.com/ with an agent naming the distribution
#   flat     the arch URL with a curl agent, so the edge cannot read an R minor
#            from the request and the flat slot answers instead of a per-minor
#            one
#
# `arch` and `generic` are contractual: they are what the website tells people
# to configure, so a failure there fails the run. `flat` measures what a client
# hiding its R minor is exposed to; it is reported and never fatal.

args <- commandArgs(trailingOnly = TRUE)
if (length(args) != 3L) {
  stop("usage: verify-repo-routing.R <arch> <codename> <form>", call. = FALSE)
}
arch <- args[[1L]]
codename <- args[[2L]]
form <- args[[3L]]

# Compiled packages that exercise the R C API broadly, plus one pure-R package
# as a control: if `brew` fails too, the problem is the repository rather than
# the ABI.
PACKAGES <- c(
  "Rcpp",
  "data.table",
  "stringi",
  "xml2",
  "curl",
  "jsonlite",
  "digest",
  "base64enc",
  "yaml",
  "lobstr",
  "brew"
)

arch_url <- sprintf("https://cran.rpkgs.com/%s/%s/latest", arch, codename)

# The agent the website's generic snippet builds, so this exercises the string
# real users send rather than an approximation of it.
generic_agent <- function() {
  os_release <- readLines("/etc/os-release", warn = FALSE)
  field <- function(key) {
    line <- grep(sprintf("^%s=", key), os_release, value = TRUE)
    if (length(line) == 0L) {
      return("")
    }
    gsub('"', "", sub("^[^=]+=", "", line[[1L]]))
  }
  os <- paste(field("NAME"), field("VERSION_ID"))
  codename_id <- field("VERSION_CODENAME")
  if (nzchar(codename_id)) {
    os <- sprintf("%s; codename=%s", os, codename_id)
  }
  sprintf(
    "R/%s (%s) (%s)",
    getRversion(),
    os,
    paste(R.version["platform"], R.version["arch"], R.version["os"])
  )
}

settings <- switch(
  form,
  arch = list(repo = arch_url, agent = getOption("HTTPUserAgent")),
  generic = list(repo = "https://cran.rpkgs.com/", agent = generic_agent()),
  flat = list(repo = arch_url, agent = "curl/8.5.0"),
  stop(sprintf("unknown form '%s'", form), call. = FALSE)
)

# No CRAN in `repos`: a package missing from our index must fail loudly rather
# than be quietly compiled from source, which would hide exactly the gap this
# script exists to find.
options(HTTPUserAgent = settings$agent, repos = c(rpkgs = settings$repo))

r_minor <- paste(getRversion()[1L, 1:2], collapse = ".")
rscript <- file.path(R.home("bin"), "Rscript")

emit <- function(package, status, built = "", secs = NA_real_) {
  cat(
    sprintf(
      "ROW\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n",
      form,
      arch,
      codename,
      r_minor,
      package,
      status,
      # `%.1f` renders NA as the literal "NAs", which reads as a unit rather
      # than as a missing measurement. A package that was never in the index
      # has no timing at all.
      if (is.na(secs)) built else sprintf("%s|%.1fs", built, secs)
    )
  )
}

# `library()` in this process would abort the whole run on a bad `dyn.load()`,
# and the point of the exercise is to survive that and report it.
loads <- function(package, lib) {
  status <- suppressWarnings(system2(
    rscript,
    c("-e", shQuote(sprintf('library("%s")', package))),
    env = sprintf("R_LIBS=%s", lib),
    stdout = FALSE,
    stderr = FALSE
  ))
  identical(as.integer(status), 0L)
}

built_field <- function(package, lib) {
  desc <- file.path(lib, package, "DESCRIPTION")
  if (!file.exists(desc)) {
    return("")
  }
  value <- read.dcf(desc, fields = "Built")[[1L]]
  if (is.na(value)) "" else sub(";.*$", "", value)
}

available <- tryCatch(
  rownames(available.packages()),
  error = function(e) {
    message(sprintf(
      "index unreadable at %s: %s",
      settings$repo,
      conditionMessage(e)
    ))
    character()
  }
)

failures <- 0L
for (package in PACKAGES) {
  if (!package %in% available) {
    emit(package, "MISSING_FROM_INDEX")
    failures <- failures + 1L
    next
  }

  lib <- file.path(tempdir(), sprintf("lib-%s-%s", form, package))
  dir.create(lib, showWarnings = FALSE, recursive = TRUE)
  started <- Sys.time()
  ok <- tryCatch(
    {
      # Hard dependencies come from the same repository and must be present
      # for `R CMD INSTALL` to succeed, so they are installed too; Suggests are
      # not, since a missing one does not stop a package loading.
      install.packages(
        package,
        lib = lib,
        dependencies = c("Depends", "Imports", "LinkingTo"),
        quiet = TRUE
      )
      package %in% rownames(installed.packages(lib.loc = lib))
    },
    error = function(e) FALSE
  )
  secs <- as.numeric(difftime(Sys.time(), started, units = "secs"))

  if (!ok) {
    emit(package, "INSTALL_FAILED", secs = secs)
    failures <- failures + 1L
  } else if (!loads(package, lib)) {
    emit(package, "LOAD_FAILED", built_field(package, lib), secs)
    failures <- failures + 1L
  } else {
    emit(package, "OK", built_field(package, lib), secs)
  }
  unlink(lib, recursive = TRUE, force = TRUE)
}

message(sprintf(
  "%s/%s R %s via %s: %d of %d packages usable",
  arch,
  codename,
  r_minor,
  form,
  length(PACKAGES) - failures,
  length(PACKAGES)
))

if (failures > 0L && !identical(form, "flat")) {
  quit(status = 1L)
}