local/backfill-flat-safety.R

@@ -48,29 +48,56 @@ cat(sprintf(
   length(bincraft:::cross_minor_volatile_symbols(sets))
 ))
 
-read_index <- function(index_url) {
+# The flat slot is listed from S3, not from PACKAGES.gz over HTTPS. Reading the
-  con <- gzcon(url(index_url, open = "rb"))
+# index from inside R sends an R User-Agent, which the edge routes to a
-  on.exit(close(con), add = TRUE)
+# per-minor index; that enumerates union records carrying `Path: <minor>`, whose
-  read.dcf(con, fields = c("Package", "Version", "Built", "NeedsCompilation"))
+# 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(
-flat <- read_index(sprintf(
+  aws_access_key_id = Sys.getenv("B2_S3_ACCESS_KEY"),
-  "https://cran.rpkgs.com/%s/%s/latest/src/contrib/PACKAGES.gz",
+  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
-))
+)
-# Source fallbacks carry no binary, so there is nothing to inspect.
+objects <- s3fs::s3_dir_ls(contrib, recurse = TRUE)
-flat <- flat[!is.na(flat[, "Built"]), , drop = FALSE]
+relative <- sub(sprintf("^(s3://)?%s/", contrib), "", objects)
-compiled <- flat[
+# Flat objects only: no `<minor>/` prefix and nothing under Archive/.
-  !is.na(flat[, "NeedsCompilation"]) & flat[, "NeedsCompilation"] == "yes",
+flat_files <- relative[
-  ,
+  grepl("\\.tar\\.gz$", relative) & !grepl("/", relative, fixed = TRUE)
-  drop = FALSE
 ]
+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 binaries, %d compiled and worth inspecting\n",
+  "%s/%s: %d flat objects, %d compiled and worth inspecting\n",
   arch,
   codename,
-  nrow(flat),
+  length(flat_files),
   nrow(compiled)
 ))
 if (!is.na(limit) && limit > 0L && limit < nrow(compiled)) {
@@ -78,11 +105,8 @@ if (!is.na(limit) && limit > 0L && limit < nrow(compiled)) {
   cat(sprintf("Limited to the first %d\n", limit))
 }
 
-base <- sprintf(
+# Fetch from the bucket as well: the edge does not rewrite tarball requests,
-  "https://cran.rpkgs.com/%s/%s/latest/src/contrib",
+# but it does cache them, and the object is what the verdict is about.
-  arch,
-  codename
-)
 safe <- 0L
 unsafe <- 0L
 skipped <- 0L
@@ -92,13 +116,12 @@ for (i in seq_len(nrow(compiled))) {
   tarball <- file.path(tempdir(), sprintf("%s_%s.tar.gz", pkg, ver))
   ok <- tryCatch(
     {
-      utils::download.file(
+      s3fs::s3_file_download(
-        sprintf("%s/%s_%s.tar.gz", base, pkg, ver),
+        sprintf("%s/%s_%s.tar.gz", contrib, pkg, ver),
         tarball,
-        quiet = TRUE,
+        overwrite = TRUE
-        mode = "wb"
       )
-      TRUE
+      file.exists(tarball)
     },
     error = function(e) FALSE,
     warning = function(w) FALSE