From 00cb2255618d64e1286709f9270ef68914067827 Mon Sep 17 00:00:00 2001
From: wlandau <will.landau.oss@gmail.com>
Date: Thu, 29 Feb 2024 10:54:08 -0500
Subject: [PATCH] Restrict JSON fields

---
 R/assert_package.R          |  9 +++++++--
 R/build_universe.R          | 16 +++++++++++++---
 man/assert_package.Rd       |  5 ++++-
 tests/test-build_universe.R |  2 +-
 4 files changed, 25 insertions(+), 7 deletions(-)

diff --git a/R/assert_package.R b/R/assert_package.R
index 1928e01..454ca65 100644
--- a/R/assert_package.R
+++ b/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) {
diff --git a/R/build_universe.R b/R/build_universe.R
index 2744d09..6a2e402 100644
--- a/R/build_universe.R
+++ b/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
     )
   }
diff --git a/man/assert_package.Rd b/man/assert_package.Rd
index d499c61..9551cca 100644
--- a/man/assert_package.Rd
+++ b/man/assert_package.Rd
@@ -4,7 +4,7 @@
 \alias{assert_package}
 \title{Validate a Package Entry}
 \usage{
-assert_package(name, url)
+assert_package(name, url, assert_cran_url = TRUE)
 }
 \arguments{
 \item{name}{Character of length 1, package name.}
@@ -12,6 +12,9 @@ assert_package(name, url)
 \item{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.}
+
+\item{assert_cran_url}{Logical of length 1, whether to check
+the alignment between the specified URL and the CRAN URL.}
 }
 \value{
 A character string if there is a problem with the package entry,
diff --git a/tests/test-build_universe.R b/tests/test-build_universe.R
index acb4ec6..5dbc721 100644
--- a/tests/test-build_universe.R
+++ b/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
   )