Merge pull request #37 from wlandau/80

Check the R advisory database

DESCRIPTION

@@ -2,7 +2,7 @@ Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
 Description: R-multiverse requires this internal infrastructure package to
   automate contribution reviews and populate universes.
-Version: 0.2.12
+Version: 0.2.13
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues
@@ -33,8 +33,10 @@ Imports:
   jsonlite,
   nanonext,
   pkgsearch,
+  stats,
   utils,
-  vctrs
+  vctrs,
+  yaml
 Suggests:
   gert,
   testthat (>= 3.0.0)

NAMESPACE

@@ -32,7 +32,10 @@ importFrom(nanonext,ncurl)
 importFrom(nanonext,parse_url)
 importFrom(nanonext,status_code)
 importFrom(pkgsearch,cran_package)
+importFrom(stats,aggregate)
 importFrom(utils,available.packages)
 importFrom(utils,compareVersion)
+importFrom(utils,unzip)
 importFrom(vctrs,vec_rbind)
 importFrom(vctrs,vec_slice)
+importFrom(yaml,read_yaml)

NEWS.md

@@ -1,3 +1,7 @@
+# multiverse.internals 0.2.13
+
+* Record issues for vulnerabilities in <https://github.com/RConsortium/r-advisory-database>.
+
 # multiverse.internals 0.2.12
 
 * Amend argument defaults in `propose_snapshot()` to include source files.

R/issues_descriptions.R

@@ -3,9 +3,12 @@
 #' @family issues
 #' @description Report issues with the `DESCRIPTION` files of packages.
 #' @details [issues_descriptions()] scans downloaded metadata from the
-#'   `PACKAGES.json` file of an R universe and reports issues with a
-#'   package's description file, such as the presence of a
-#'   `"Remotes"` field.
+#'   `PACKAGES.json` file of an R universe and scans for specific issues in a
+#'   package's description file:
+#'   1. The presence of a `"Remotes"` field.
+#'   2. There is a security advisory at
+#'     <https://github.com/RConsortium/r-advisory-database>
+#'     for the given package version.
 #' @inheritSection record_issues Package issues
 #' @return A named list of information about packages which do not comply
 #'   with `DESCRPTION` checks. Each name is a package name,
@@ -18,14 +21,80 @@
 #'   issues <- issues_descriptions(meta = meta)
 #'   str(issues)
 issues_descriptions <- function(meta = meta_packages()) {
+  meta$issue <- FALSE
+  meta <- issues_descriptions_advisories(meta)
   meta <- issues_descriptions_remotes(meta)
-  fields <- "remotes"
-  meta <- meta[, c("package", fields)]
-  issues_list(meta)
+  meta <- meta[meta$issue,, drop = FALSE] # nolint
+  issues_list(meta[, c("package", "advisories", "remotes")])
+}
+
+issues_descriptions_advisories <- function(meta) {
+  advisories <- read_advisories(timeout = 60000L, retries = 3L)
+  meta <- merge(
+    x = meta,
+    y = advisories,
+    by = c("package", "version"),
+    all.x = TRUE,
+    all.y = FALSE
+  )
+  meta$issue <- meta$issue | !vapply(meta$advisories, anyNA, logical(1L))
+  meta
 }
 
 issues_descriptions_remotes <- function(meta) {
   meta[["remotes"]] <- meta[["remotes"]] %||% replicate(nrow(meta), NULL)
   meta$remotes <- lapply(meta$remotes, function(x) x[nzchar(x)])
-  meta[vapply(meta$remotes, length, integer(1L)) > 0L, ]
+  meta$issue <- meta$issue | vapply(meta$remotes, length, integer(1L)) > 0L
+  meta
+}
+
+read_advisories <- function(timeout, retries) {
+  path <- tempfile()
+  dir.create(path)
+  on.exit(unlink(path, recursive = TRUE, force = TRUE))
+  zipfile <- file.path(path, "file.zip")
+  for (try in seq_len(retries)) {
+    response <- nanonext::ncurl(
+      "https://github.com/RConsortium/r-advisory-database/zipball/main",
+      convert = FALSE,
+      follow = TRUE,
+      timeout = timeout
+    )
+    if (all(response[["status"]] == 200L)) {
+      break
+    }
+    if (all(try == retries)) {
+      stop(
+        "Failed to download R Consortium advisories database. Status: ",
+        status_code(response[["status"]]),
+        call. = FALSE
+      )
+    }
+  }
+  writeBin(response[["data"]], zipfile)
+  unzip(zipfile, exdir = path, junkpaths = TRUE)
+  advisories <- Sys.glob(file.path(path, "RSEC*.yaml"))
+  out <- do.call(vctrs::vec_rbind, lapply(advisories, read_advisory))
+  stats::aggregate(x = advisories ~ package + version, data = out, FUN = list)
+}
+
+read_advisory <- function(path) {
+  out <- lapply(
+    yaml::read_yaml(file = path)$affected,
+    advisory_entry,
+    path = path
+  )
+  do.call(vctrs::vec_rbind, out)
+}
+
+advisory_entry <- function(entry, path) {
+  data.frame(
+    package = entry$package$name,
+    version = entry$versions,
+    advisories = file.path(
+      "https://github.com/RConsortium/r-advisory-database/blob/main/vulns",
+      entry$package$name,
+      basename(path)
+    )
+  )
 }

R/package.R

@@ -3,6 +3,8 @@
 #' @importFrom jsonlite parse_json read_json stream_in write_json
 #' @importFrom nanonext ncurl parse_url status_code
 #' @importFrom pkgsearch cran_package
-#' @importFrom utils available.packages compareVersion
+#' @importFrom stats aggregate
+#' @importFrom utils available.packages compareVersion unzip
 #' @importFrom vctrs vec_rbind vec_slice
+#' @importFrom yaml read_yaml
 NULL

R/utils_issues.R

@@ -3,7 +3,9 @@ issues_list <- function(x) {
   out <- list()
   for (index in seq_len(nrow(x))) {
     for (field in setdiff(colnames(x), "package")) {
-      out[[x$package[index]]][[field]] <- x[[field]][[index]]
+      if (!all(is.na(x[[field]][[index]]))) {
+        out[[x$package[index]]][[field]] <- x[[field]][[index]]
+      }
     }
   }
   out[order(as.character(names(out)))]

tests/testthat/test-issues_descriptions.R

@@ -15,3 +15,34 @@ test_that("issues_descriptions() on a small repo", {
   issues <- issues_descriptions(meta = meta)
   expect_true(is.list(issues))
 })
+
+test_that("issues_descriptions() with security advisories", {
+  example <- mock_meta_packages$package == "nanonext"
+  commonmark <- mock_meta_packages[example,, drop = FALSE] # nolint
+  commonmark$package <- "commonmark"
+  commonmark$version <- "0.2"
+  readxl <- mock_meta_packages[example,, drop = FALSE] # nolint
+  readxl$package <- "readxl"
+  readxl$version <- "1.4.1"
+  meta <- rbind(mock_meta_packages, commonmark, readxl)
+  out <- issues_descriptions(meta)
+  exp <- list(
+    audio.whisper = list(remotes = "bnosac/audio.vadwebrtc"),
+    commonmark = list(
+      advisories = file.path(
+        "https://github.com/RConsortium/r-advisory-database",
+        "blob/main/vulns/commonmark",
+        c("RSEC-2023-6.yaml", "RSEC-2023-7.yaml", "RSEC-2023-8.yaml")
+      )
+    ),
+    readxl = list(
+      advisories = file.path(
+        "https://github.com/RConsortium/r-advisory-database",
+        "blob/main/vulns/readxl/RSEC-2023-2.yaml"
+      )
+    ),
+    stantargets = list(remotes = c("hyunjimoon/SBC", "stan-dev/cmdstanr")),
+    tidypolars = list(remotes = "markvanderloo/tinytest/pkg")
+  )
+  expect_equal(out, exp)
+})

tests/testthat/test-utils_issues.R

@@ -0,0 +1,25 @@
+test_that("issues_list() handles missing and empty values correctly", {
+  meta <- data.frame(
+    package = c("audio.whisper", "readxl", "stantargets", "tidypolars"),
+    advisory = c(
+      NA_character_,
+      "url",
+      NA_character_,
+      NA_character_
+    )
+  )
+  meta$remotes <- list(
+    "bnosac/audio.vadwebrtc",
+    NULL,
+    c("hyunjimoon/SBC", "stan-dev/cmdstanr"),
+    "markvanderloo/tinytest/pkg"
+  )
+  out <- issues_list(meta)
+  exp <- list(
+    audio.whisper = list(remotes = "bnosac/audio.vadwebrtc"),
+    readxl = list(advisory = "url"),
+    stantargets = list(remotes = c("hyunjimoon/SBC", "stan-dev/cmdstanr")),
+    tidypolars = list(remotes = "markvanderloo/tinytest/pkg")
+  )
+  expect_equal(out, exp)
+})