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
@@ -28,15 +28,17 @@ Authors@R: c(
 Depends:
   R (>= 3.6)
 Imports:
+  gert,
   gh,
   igraph,
   jsonlite,
   nanonext,
   pkgsearch,
+  stats,
   utils,
-  vctrs
+  vctrs,
+  yaml
 Suggests:
-  gert,
   testthat (>= 3.0.0)
 Encoding: UTF-8
 Language: en-US

NAMESPACE

@@ -19,6 +19,7 @@ export(review_pull_requests)
 export(staging_is_active)
 export(try_message)
 export(update_staging)
+importFrom(gert,git_clone)
 importFrom(gh,gh)
 importFrom(igraph,V)
 importFrom(igraph,graph)
@@ -32,7 +33,9 @@ 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(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,67 @@
 #'   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()
+  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() {
+  path <- tempfile()
+  on.exit(unlink(path, recursive = TRUE, force = TRUE))
+  gert::git_clone(
+    url = "https://github.com/RConsortium/r-advisory-database",
+    path = path,
+    verbose = FALSE
+  )
+  advisories <- list.files(
+    file.path(path, "vulns"),
+    recursive = TRUE,
+    full.names = TRUE
+  )
+  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

@@ -1,8 +1,11 @@
+#' @importFrom gert git_clone
 #' @importFrom gh gh
 #' @importFrom igraph graph neighbors subcomponent V
 #' @importFrom jsonlite parse_json read_json stream_in write_json
 #' @importFrom nanonext ncurl parse_url status_code
 #' @importFrom pkgsearch cran_package
+#' @importFrom stats aggregate
 #' @importFrom utils available.packages compareVersion
 #' @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)
+})