Refactor url assertions

.lintr

@@ -1,4 +1,5 @@
 linters: linters_with_defaults(
+  cyclocomp_linter = NULL,
   infix_spaces_linter = NULL,
   object_length_linter = NULL,
   object_name_linter = NULL,

NAMESPACE

@@ -1,11 +1,11 @@
 # Generated by roxygen2: do not edit by hand
 
+export(assert_cran_url)
 export(assert_package)
-export(assert_package_url)
 export(build_universe)
 export(review_pull_request)
 export(review_pull_requests)
 importFrom(gh,gh)
 importFrom(jsonlite,read_json)
 importFrom(nanonext,parse_url)
-importFrom(pkgsearch,ps)
+importFrom(pkgsearch,cran_package)

NEWS.md

@@ -1,6 +1,8 @@
 # r.releases.utils 0.0.2.9000 (development)
 
 * Checks URL matches the package description for CRAN packages.
+* `check_package()` checks the URL and name directly, not a file.
+* Add more strict URL assertions.
 
 # r.releases.utils 0.0.2
 

R/assert_cran_url.R

@@ -0,0 +1,49 @@
+#' @title Validate the URL of a package on CRAN.
+#' @export
+#' @keywords internal
+#' @description If the package is on CRAN, validate that the contributed URL
+#'   appears in the CRAN-hosted DESCRIPTION file.
+#' @return A character string if there is a problem with the package entry,
+#'   otherwise `NULL` if there are no issues.
+#' @param name Character of length 1, contributed name of the package.
+#' @param url Character of length 1, contributed URL of the package.
+assert_cran_url <- function(name, url) {
+  result <- try(
+    pkgsearch::cran_package(name = name),
+    silent = TRUE
+  )
+  if (inherits(result, "try-error")) {
+    return(invisible())
+  }
+  package <- result[["Package"]]
+  main_urls <- strsplit(result[["URL"]], ",\n|, |\n", perl = TRUE)[[1L]]
+  bugs_url <- sub(
+    pattern = "/issues/*$",
+    replacement = "",
+    x = result[["BugReports"]],
+    perl = TRUE
+  )
+  cran_urls <- c(main_urls, bugs_url)
+  urls_agree <- lapply(
+    X = cran_urls,
+    FUN = url_agrees_with_cran,
+    reference = url
+  )
+  if (any(unlist(urls_agree))) {
+    return(invisible())
+  }
+  paste(
+    "URL of package",
+    shQuote(name),
+    "is given as",
+    shQuote(url),
+    "but does not appear in its DESCRIPTION file published on CRAN."
+  )
+}
+
+url_agrees_with_cran <- function(cran, reference) {
+  parsed_cran <- url_parse(cran)
+  parsed_reference <- url_parse(reference)
+  (parsed_cran[["host"]] == parsed_reference[["host"]]) &&
+    (parsed_cran[["path"]] == parsed_reference[["path"]])
+}

R/assert_package.R

@@ -4,70 +4,58 @@
 #' @description Validate a package entry.
 #' @return A character string if there is a problem with the package entry,
 #'   otherwise `NULL` if there are no issues.
-assert_package <- function(path) {
-  if (!is_character_scalar(path)) {
-    return("Invalid package file path")
+assert_package <- function(name, url) {
+  if (!is_character_scalar(name)) {
+    return("Invalid package name.")
   }
-  if (!file.exists(path)) {
-    return(paste("file", shQuote(path), "does not exist"))
-  }
-  name <- trimws(basename(path))
-  url <- try(readLines(path, warn = FALSE), silent = TRUE)
-  if (inherits(url, "try-error")) {
-    return(paste("Problem reading file", shQuote(path)))
+  if (!is_character_scalar(url)) {
+    return("Invalid package URL.")
   }
-  assert_package_contents(name = name, url = url)
-}
-
-assert_package_contents <- function(name, url) {
-  good_package_name <- grepl(
+  name <- trimws(name)
+  url <- trimws(trim_trailing_slash(url))
+  valid_package_name <- grepl(
     pattern = "^[a-zA-Z][a-zA-Z0-9.]*[a-zA-Z0-9]$",
     x = name
   )
-  if (!isTRUE(good_package_name)) {
-    return(paste("Found invalid package name: ", shQuote(name)))
-  }
-  if (!is_character_scalar(url)) {
-    return("Invalid package URL")
+  if (!isTRUE(valid_package_name)) {
+    return(paste("Found invalid package name:", shQuote(name)))
   }
-  url <- trimws(url)
-  good_url <- grepl(
-    pattern = "^https?://[a-zA-Z0-9.-]+\\.[a-zA-Z]{2,3}(/\\S*)?$",
-    x = url
-  )
-  if (!isTRUE(good_url)) {
+  parsed_url <- try(url_parse(url), silent = TRUE)
+  if (inherits(parsed_url, "try-error")) {
     return(
       paste("Found malformed URL", shQuote(url), "of package", shQuote(name))
     )
   }
-}
-
-#' @title Validate a Package URL
-#' @export
-#' @keywords internal
-#' @description Validate that the package URL is in the description file if on
-#'   CRAN.
-#' @return A character string if there is a problem with the URL for the given
-#'   package name, otherwise `NULL` if there are no issues.
-assert_package_url <- function(name, url) {
-
-  res <- ps(name, size = 1L)
-  pkg <- res[["package"]]
-  if (length(pkg) && name == pkg) {
-    purl <- parse_url(sub("/$", "", url, perl = TRUE))
-    urls <- strsplit(res[["url"]], ",\n|, |\n", perl = TRUE)[[1L]]
-    for (u in urls) {
-      pu <- parse_url(sub("/$", "", u, perl = TRUE))
-      purl[["host"]] == pu[["host"]] && purl[["path"]] == pu[["path"]] &&
-        return(invisible())
-    }
-    burl <- parse_url(res[["bugreports"]])
-    purl[["host"]] == burl[["host"]] &&
-      purl[["path"]] == sub("/issues/*$", "", burl[["path"]], perl = TRUE) &&
-      return(invisible())
+  if (!identical(name, basename(parsed_url[["path"]]))) {
     return(
-      paste("CRAN package", shQuote(name), "does not have URL", shQuote(url))
+      paste(
+        "Package name",
+        shQuote(name),
+        "appears to disagree with the repository name in the URL",
+        shQuote(url)
+      )
     )
   }
-
+  if (!identical(parsed_url[["scheme"]], "https")) {
+    return(paste("Scheme of URL", shQuote(url), "is not https."))
+  }
+  if (!(parsed_url[["hostname"]] %in% c("github.com", "gitlab.com"))) {
+    return(paste("URL", shQuote(url), "is not a GitHub or GitLab URL."))
+  }
+  splits <- strsplit(parsed_url[["path"]], split = "/", fixed = TRUE)[[1L]]
+  splits <- splits[nzchar(splits)]
+  if (length(splits) < 2L) {
+    return(
+      paste(
+        "URL",
+        shQuote(url),
+        "appears to be an owner, not a repository."
+      )
+    )
+  }
+  owner <- tolower(splits[nzchar(splits)][1L])
+  if (identical(owner, "cran")) {
+    return(paste("URL", shQuote(url), "appears to use a CRAN mirror."))
+  }
+  assert_cran_url(name = name, url = url)
 }

R/build_universe.R

@@ -13,20 +13,10 @@ build_universe <- function(input = getwd(), output = "packages.json") {
   assert_character_scalar(output, "invalid output")
   assert_file(input)
   packages <- list.files(input, all.files = FALSE, full.names = TRUE)
-  for (package in packages) {
-    result <- assert_package(package)
-    is.null(result) || stop(result, call. = FALSE)
-  }
-  urls <- vapply(
-    X = packages,
-    FUN = readLines,
-    FUN.VALUE = character(1L),
-    USE.NAMES = FALSE,
-    warn = FALSE
-  )
+  contents <- lapply(X = packages, FUN = read_package_entry)
   out <- data.frame(
     package = trimws(basename(packages)),
-    url = trimws(urls),
+    url = trimws(unlist(contents, use.names = FALSE)),
     branch = "*release"
   )
   if (!file.exists(dirname(output))) {
@@ -35,3 +25,12 @@ build_universe <- function(input = getwd(), output = "packages.json") {
   jsonlite::write_json(x = out, path = output)
   invisible()
 }
+
+read_package_entry <- function(package) {
+  out <- readLines(con = package, warn = FALSE)
+  message <- assert_package(name = basename(package), url = out)
+  if (!is.null(message)) {
+    stop(message, call. = FALSE)
+  }
+  out
+}

R/package.R

@@ -5,5 +5,5 @@
 #' @importFrom gh gh
 #' @importFrom jsonlite read_json
 #' @importFrom nanonext parse_url
-#' @importFrom pkgsearch ps
+#' @importFrom pkgsearch cran_package
 NULL

R/review_pull_request.R

@@ -77,23 +77,7 @@ review_pull_request <- function(
       return(invisible())
     }
     url <- gsub(pattern = "^.*\\+", replacement = "", x = file$patch)
-    result <- assert_package_contents(name = name, url = url)
-    if (!is.null(result)) {
-      pull_request_defer(
-        owner = owner,
-        repo = repo,
-        number = number,
-        message = paste0(
-          "Pull request ",
-          number,
-          " automated diagnostics failed: ",
-          result,
-          ". Manual review required."
-        )
-      )
-      return(invisible())
-    }
-    result <- assert_package_url(name = name, url = url)
+    result <- assert_package(name = name, url = url)
     if (!is.null(result)) {
       pull_request_defer(
         owner = owner,

R/utils_url.R

@@ -0,0 +1,7 @@
+url_parse <- function(url) {
+  nanonext::parse_url(trim_trailing_slash(url))
+}
+
+trim_trailing_slash <- function(url) {
+  sub(pattern = "/$", replacement = "", x = url, perl = TRUE)
+}