diff --git a/DESCRIPTION b/DESCRIPTION index 7d24be224..38ade75f1 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NEWS.md b/NEWS.md index d26cb782d..7c85702e2 100644 --- a/NEWS.md +++ b/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). diff --git a/R/check-win.R b/R/check-win.R index 11bd586d2..8ee41b867 100644 --- a/R/check-win.R +++ b/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

heading for the requested version, then grab the file + # input and submit button from the
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) +} diff --git a/man/check_win.Rd b/man/check_win.Rd index 1212d6f53..768a1e798 100644 --- a/man/check_win.Rd +++ b/man/check_win.Rd @@ -13,6 +13,7 @@ check_win_devel( manual = TRUE, email = NULL, quiet = FALSE, + webform = FALSE, ... ) @@ -22,6 +23,7 @@ check_win_release( manual = TRUE, email = NULL, quiet = FALSE, + webform = FALSE, ... ) @@ -31,6 +33,7 @@ check_win_oldrelease( manual = TRUE, email = NULL, quiet = FALSE, + webform = FALSE, ... ) } @@ -49,6 +52,8 @@ to use the package maintainer's email.} \item{quiet}{If \code{TRUE}, suppresses output.} +\item{webform}{If \code{TRUE}, uses web form instead of passive FTP upload.} + \item{...}{Additional arguments passed to \code{\link[pkgbuild:build]{pkgbuild::build()}}.} } \description{ diff --git a/tests/testthat/test-check-win.R b/tests/testthat/test-check-win.R index b918c3755..8fa1c0db3 100644 --- a/tests/testthat/test-check-win.R +++ b/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()