Restrict JSON fields

R/assert_package.R

@@ -8,7 +8,9 @@
 #' @param url Usually a character of length 1 with the package URL.
 #'   Can also be a custom JSON string with the package URL and other metadata,
 #'   but this is for rare cases and flags the package for manual review.
-assert_package <- function(name, url) {
+#' @param assert_cran_url Logical of length 1, whether to check
+#'   the alignment between the specified URL and the CRAN URL.
+assert_package <- function(name, url, assert_cran_url = TRUE) {
   if (!is_package_name(name)) {
     return("Invalid package name.")
   }
@@ -71,7 +73,10 @@ assert_package <- function(name, url) {
   if (identical(owner, "cran")) {
     return(paste("URL", shQuote(url), "appears to use a CRAN mirror."))
   }
-  assert_cran_url(name = name, url = url)
+  if (assert_cran_url) {
+    return(assert_cran_url(name = name, url = url))
+  }
+  NULL
 }
 
 is_package_name <- function(name) {

R/build_universe.R

@@ -38,7 +38,11 @@ read_package_entry <- function(package) {
 }
 
 package_entry_url <- function(name, url) {
-  message <- assert_package(name = name, url = url)
+  message <- assert_package(
+    name = name,
+    url = url,
+    assert_cran_url = FALSE # Prevents massive slowdown from 20000+ packages.
+  )
   if (!is.null(message)) {
     stop(message, call. = FALSE)
   }
@@ -50,11 +54,17 @@ package_entry_url <- function(name, url) {
 }
 
 package_entry_json <- function(name, json) {
-  if (!all(c("package", "url", "branch") %in% names(json))) {
+  fields <- names(json)
+  good_fields <- identical(
+    sort(fields),
+    sort(c("package", "url", "branch", "subdir"))
+  )
+  if (!good_fields) {
     stop(
       "Custom JSON entry for package ",
       shQuote(name),
-      " must include fields 'package', 'url', and 'branch'.",
+      " must have fields 'packages', 'url', 'branch', and 'subdir' ",
+      "and no other fields.",
       call. = FALSE
     )
   }

tests/test-build_universe.R

@@ -99,7 +99,7 @@ out <- try(
 stopifnot(inherits(out, "try-error"))
 stopifnot(
   grepl(
-    pattern = "JSON entry for package 'paws.analytics' must include fields",
+    pattern = "JSON entry for package 'paws.analytics' must have fields",
     x = r.releases.utils::try_message(out),
     fixed = TRUE
   )