feat: check_win: add webform argument as alternative to FTP upload

DESCRIPTION

@@ -54,7 +54,8 @@ Suggests:
     remotes (>= 2.5.0),
     rmarkdown (>= 2.14),
     rstudioapi (>= 0.13),
-    spelling (>= 2.2)
+    spelling (>= 2.2),
+    xml2
 VignetteBuilder: knitr, quarto
 Config/Needs/website: tidyverse/tidytemplate
 Config/testthat/edition: 3

NEWS.md

@@ -18,6 +18,7 @@ Other improvements
 * `build_site()` now just calls `pkgdown::build_site()`, meaning that you will get more (informative) output by default (#2578).
 * `check_doc_fields()` is a new function that checks for missing `\value` and `\examples` fields in Rd files, which are commonly flagged by CRAN (#2525).
 * `check_mac_devel()` is a new function to check a package using the macOS builder at https://mac.r-project.org/macbuilder/submit.html (@nfrerebeau, #2507)
+* `check_win()` and friends gain a `webform` argument that uses a webform instead of passive FTP upload (@brownag, #2619).
 * `dev_sitrep()` now works correctly inside Positron (#2618), uses pak instead of remotes to check for dependencies that are missing/behind/ahead (#2663), and uses cli for user-facing messages.
 * `is_loading()` is now re-exported from pkgload (#2556).
 * `load_all()` now errors if called recursively, i.e. if you accidentally include a `load_all()` call in one of your R source files (#2617).

R/check-win.R

@@ -13,6 +13,7 @@
 #' @param email An alternative email address to use. If `NULL`, the default is
 #'   to use the package maintainer's email.
 #' @param quiet If `TRUE`, suppresses output.
+#' @param webform If `TRUE`, uses web form instead of passive FTP upload.
 #' @param ... Additional arguments passed to [pkgbuild::build()].
 #' @family build functions
 #' @name check_win
@@ -26,6 +27,7 @@ check_win_devel <- function(
   manual = TRUE,
   email = NULL,
   quiet = FALSE,
+  webform = FALSE,
   ...
 ) {
   check_dots_used(action = getOption("devtools.ellipsis_action", warn))
@@ -37,6 +39,7 @@ check_win_devel <- function(
     manual = manual,
     email = email,
     quiet = quiet,
+    webform = webform,
     ...
   )
 }
@@ -49,6 +52,7 @@ check_win_release <- function(
   manual = TRUE,
   email = NULL,
   quiet = FALSE,
+  webform = FALSE,
   ...
 ) {
   check_dots_used(action = getOption("devtools.ellipsis_action", warn))
@@ -60,6 +64,7 @@ check_win_release <- function(
     manual = manual,
     email = email,
     quiet = quiet,
+    webform = webform,
     ...
   )
 }
@@ -72,6 +77,7 @@ check_win_oldrelease <- function(
   manual = TRUE,
   email = NULL,
   quiet = FALSE,
+  webform = FALSE,
   ...
 ) {
   check_dots_used(action = getOption("devtools.ellipsis_action", warn))
@@ -83,6 +89,7 @@ check_win_oldrelease <- function(
     manual = manual,
     email = email,
     quiet = quiet,
+    webform = webform,
     ...
   )
 }
@@ -94,6 +101,7 @@ check_win <- function(
   manual = TRUE,
   email = NULL,
   quiet = FALSE,
+  webform = FALSE,
   ...
 ) {
   pkg <- as.package(pkg)
@@ -131,13 +139,11 @@ check_win <- function(
   )
   on.exit(file_delete(built_path), add = TRUE)
 
-  url <- paste0(
-    "ftp://win-builder.r-project.org/",
-    version,
-    "/",
-    path_file(built_path)
-  )
-  walk(url, upload_ftp, file = built_path)
+  if (webform) {
+    submit_winbuilder_webform(built_path, version)
+  } else {
+    submit_winbuilder_ftp(built_path, version)
+  }
 
   if (!quiet) {
     time <- strftime(Sys.time() + 30 * 60, "%I:%M %p")
@@ -152,6 +158,20 @@ check_win <- function(
   invisible()
 }
 
+submit_winbuilder_ftp <- function(path, version) {
+  url <- paste0(
+    "ftp://win-builder.r-project.org/",
+    version,
+    "/",
+    path_file(path)
+  )
+  walk(url, upload_ftp, file = path)
+}
+
+submit_winbuilder_webform <- function(path, version) {
+  walk(version, upload_webform, file = path)
+}
+
 confirm_maintainer_email <- function(email, call = parent.frame()) {
   if (!rlang::is_interactive()) {
     return(FALSE)
@@ -216,3 +236,52 @@ upload_ftp <- function(file, url, verbose = FALSE) {
   )
   curl::curl_fetch_memory(url, handle = h)
 }
+
+parse_winbuilder_form <- function(url, version) {
+  req <- httr2::request(url)
+  resp <- httr2::req_perform(req)
+  html <- xml2::read_html(httr2::resp_body_string(resp))
+
+  # Extract hidden fields shared by the whole form
+  hidden_nodes <- xml2::xml_find_all(html, ".//input[@type='hidden']")
+  hidden <- as.list(xml2::xml_attr(hidden_nodes, "value"))
+  names(hidden) <- xml2::xml_attr(hidden_nodes, "name")
+
+  # Find the <h2> heading for the requested version, then grab the file
+  # input and submit button from the <div> that follows it
+  headings <- xml2::xml_find_all(html, ".//h2")
+  heading_texts <- xml2::xml_text(headings)
+  idx <- match(version, heading_texts)
+  if (is.na(idx)) {
+    cli::cli_abort(
+      "Could not find {.val {version}} section in the WinBuilder form."
+    )
+  }
+
+  section <- xml2::xml_find_first(headings[[idx]], "following-sibling::div")
+  file_field <- xml2::xml_attr(
+    xml2::xml_find_first(section, ".//input[@type='file']"),
+    "name"
+  )
+  button_field <- xml2::xml_attr(
+    xml2::xml_find_first(section, ".//input[@type='submit']"),
+    "name"
+  )
+
+  list(hidden = hidden, file_field = file_field, button_field = button_field)
+}
+
+upload_webform <- function(file, version) {
+  check_installed(c("httr2", "xml2"))
+
+  upload_url <- "https://win-builder.r-project.org/upload.aspx"
+  form <- parse_winbuilder_form(upload_url, version)
+
+  body <- form$hidden
+  body[[form$file_field]] <- curl::form_file(file)
+  body[[form$button_field]] <- "Upload File"
+
+  req <- httr2::request(upload_url)
+  req <- httr2::req_body_multipart(req, !!!body)
+  httr2::req_perform(req)
+}

tests/testthat/test-check-win.R

@@ -1,3 +1,22 @@
+test_that("parse_winbuilder_form() can extract form fields from live page", {
+  skip_on_cran()
+  skip_if_not_installed("httr2")
+  skip_if_not_installed("xml2")
+
+  url <- "https://win-builder.r-project.org/upload.aspx"
+
+  for (version in c("R-devel", "R-release", "R-oldrelease")) {
+    form <- parse_winbuilder_form(url, version)
+
+    expect_named(form, c("hidden", "file_field", "button_field"))
+    expect_true("__VIEWSTATE" %in% names(form$hidden))
+    expect_true("__VIEWSTATEGENERATOR" %in% names(form$hidden))
+    expect_true("__EVENTVALIDATION" %in% names(form$hidden))
+    expect_type(form$file_field, "character")
+    expect_type(form$button_field, "character")
+  }
+})
+
 test_that("change_maintainer_email checks fields", {
   path <- withr::local_tempfile()