1#' Release package to CRAN.
2#'
3#' Run automated and manual tests, then post package to CRAN.
4#'
5#' The package release process will:
6#'
7#' \itemize{
8#'   \item Confirm that the package passes `R CMD check` on relevant platforms
9#'   \item Confirm that important files are up-to-date
10#'   \item Build the package
11#'   \item Submit the package to CRAN, using comments in "cran-comments.md"
12#' }
13#'
14#' You can add arbitrary extra questions by defining an (un-exported) function
15#' called `release_questions()` that returns a character vector
16#' of additional questions to ask.
17#'
18#' You also need to read the CRAN repository policy at
19#' 'https://cran.r-project.org/web/packages/policies.html' and make
20#' sure you're in line with the policies. `release` tries to automate as
21#' many of polices as possible, but it's impossible to be completely
22#' comprehensive, and they do change in between releases of devtools.
23#'
24#' @template devtools
25#' @param check if `TRUE`, run checking, otherwise omit it.  This
26#'   is useful if you've just checked your package and you're ready to
27#'   release it.
28#' @param args An optional character vector of additional command
29#'   line arguments to be passed to `R CMD build`.
30#' @seealso [usethis::use_release_issue()] to create a checklist of release
31#'   tasks that you can use in addition to or in place of `release`.
32#' @export
33release <- function(pkg = ".", check = FALSE, args = NULL) {
34  pkg <- as.package(pkg)
35  # Figure out if this is a new package
36  cran_version <- cran_pkg_version(pkg$package)
37  new_pkg <- is.null(cran_version)
38
39  if (yesno("Have you checked for spelling errors (with `spell_check()`)?")) {
40    return(invisible())
41  }
42
43  if (check) {
44    cat_rule(
45      left = "Building and checking",
46      right = pkg$package,
47      line = 2
48    )
49    check(pkg,
50      cran = TRUE, remote = TRUE, manual = TRUE,
51      build_args = args, run_dont_test = TRUE
52    )
53  }
54  if (yesno("Have you run `R CMD check` locally?")) {
55    return(invisible())
56  }
57
58  release_checks(pkg)
59  if (yesno("Were devtool's checks successful?")) {
60    return(invisible())
61  }
62
63  if (!new_pkg) {
64    show_cran_check <- TRUE
65    cran_details <- NULL
66    end_sentence <- " ?"
67    if (requireNamespace("foghorn", quietly = TRUE)) {
68      show_cran_check <- has_cran_results(pkg$package)
69      cran_details <- foghorn::cran_details(pkg = pkg$package)
70    }
71    if (show_cran_check) {
72      if (!is.null(cran_details)) {
73        end_sentence <- "\n shown above?"
74        cat_rule(paste0("Details of the CRAN check results for ", pkg$package))
75        summary(cran_details)
76        cat_rule()
77      }
78      cran_url <- paste0(
79        cran_mirror(), "/web/checks/check_results_",
80        pkg$package, ".html"
81      )
82      if (yesno(
83        "Have you fixed all existing problems at \n", cran_url,
84        end_sentence
85      )) {
86        return(invisible())
87      }
88    }
89  }
90
91  if (yesno("Have you checked on R-hub (with `check_rhub()`)?")) {
92    return(invisible())
93  }
94
95  if (yesno("Have you checked on win-builder (with `check_win_devel()`)?")) {
96    return(invisible())
97  }
98
99  deps <- if (new_pkg) 0 else length(revdep(pkg$package))
100  if (deps > 0) {
101    msg <- paste0(
102      "Have you checked the ", deps, " reverse dependencies ",
103      "(with the revdepcheck package)?"
104    )
105    if (yesno(msg)) {
106      return(invisible())
107    }
108  }
109
110  questions <- c(
111    "Have you updated `NEWS.md` file?",
112    "Have you updated `DESCRIPTION`?",
113    "Have you updated `cran-comments.md?`",
114    if (dir_exists("docs/")) "Have you updated website in `docs/`?",
115    if (file_exists("codemeta.json")) "Have you updated codemeta.json with codemetar::write_codemeta()?",
116    find_release_questions(pkg)
117  )
118  for (question in questions) {
119    if (yesno(question)) return(invisible())
120  }
121
122  if (uses_git(pkg$path)) {
123    git_checks(pkg)
124    if (yesno("Were Git checks successful?")) {
125      return(invisible())
126    }
127  }
128
129  submit_cran(pkg, args = args)
130
131  invisible(TRUE)
132}
133
134has_cran_results <- function(pkg) {
135  cran_res <- foghorn::cran_results(
136    pkg = pkg,
137    show = c("error", "fail", "warn", "note")
138  )
139  sum(cran_res[, -1]) > 0
140}
141
142find_release_questions <- function(pkg = ".") {
143  pkg <- as.package(pkg)
144
145  q_fun <- pkgload::ns_env(pkg$package)$release_questions
146  if (is.null(q_fun)) {
147    character()
148  } else {
149    q_fun()
150  }
151}
152
153yesno <- function(...) {
154  yeses <- c("Yes", "Definitely", "For sure", "Yup", "Yeah", "Of course", "Absolutely")
155  nos <- c("No way", "Not yet", "I forget", "No", "Nope", "Uhhhh... Maybe?")
156
157  cat(paste0(..., collapse = ""))
158  qs <- c(sample(yeses, 1), sample(nos, 2))
159  rand <- sample(length(qs))
160
161  utils::menu(qs[rand]) != which(rand == 1)
162}
163
164# https://tools.ietf.org/html/rfc2368
165email <- function(address, subject, body) {
166  url <- paste(
167    "mailto:",
168    utils::URLencode(address),
169    "?subject=", utils::URLencode(subject),
170    "&body=", utils::URLencode(body),
171    sep = ""
172  )
173
174  tryCatch({
175    utils::browseURL(url, browser = email_browser())
176  },
177  error = function(e) {
178    cli::cli_alert_danger("Sending failed with error: {e$message}")
179    cat("To: ", address, "\n", sep = "")
180    cat("Subject: ", subject, "\n", sep = "")
181    cat("\n")
182    cat(body, "\n", sep = "")
183  }
184  )
185
186  invisible(TRUE)
187}
188
189email_browser <- function() {
190  if (!identical(.Platform$GUI, "RStudio")) {
191    return(getOption("browser"))
192  }
193
194  # Use default browser, even if RStudio running
195  if (.Platform$OS.type == "windows") {
196    return(NULL)
197  }
198
199  browser <- Sys.which(c("xdg-open", "open"))
200  browser[nchar(browser) > 0][[1]]
201}
202
203
204maintainer <- function(pkg = ".") {
205  pkg <- as.package(pkg)
206
207  authors <- pkg$`authors@r`
208  if (!is.null(authors)) {
209    people <- eval(parse(text = authors))
210    if (is.character(people)) {
211      maintainer <- utils::as.person(people)
212    } else {
213      maintainer <- Find(function(x) "cre" %in% x$role, people)
214    }
215  } else {
216    maintainer <- pkg$maintainer
217    if (is.null(maintainer)) {
218      stop("No maintainer defined in package.", call. = FALSE)
219    }
220    maintainer <- utils::as.person(maintainer)
221  }
222
223  list(
224    name = paste(maintainer$given, maintainer$family),
225    email = maintainer$email
226  )
227}
228
229cran_comments <- function(pkg = ".") {
230  pkg <- as.package(pkg)
231
232  path <- path(pkg$path, "cran-comments.md")
233  if (!file_exists(path)) {
234    warning("Can't find cran-comments.md.\n",
235      "This file gives CRAN volunteers comments about the submission,\n",
236      "Create it with use_cran_comments().\n",
237      call. = FALSE
238    )
239    return(character())
240  }
241
242  paste0(readLines(path, warn = FALSE), collapse = "\n")
243}
244
245cran_submission_url <- "https://xmpalantir.wu.ac.at/cransubmit/index2.php"
246
247#' Submit a package to CRAN.
248#'
249#' This uses the new CRAN web-form submission process. After submission, you
250#' will receive an email asking you to confirm submission - this is used
251#' to check that the package is submitted by the maintainer.
252#'
253#' It's recommended that you use [release()] rather than this
254#' function as it performs more checks prior to submission.
255#'
256#' @template devtools
257#' @inheritParams release
258#' @export
259#' @keywords internal
260submit_cran <- function(pkg = ".", args = NULL) {
261  if (yesno("Is your email address ", maintainer(pkg)$email, "?")) {
262    return(invisible())
263  }
264
265  pkg <- as.package(pkg)
266  built_path <- build_cran(pkg, args = args)
267
268  if (yesno("Ready to submit ", pkg$package, " (", pkg$version, ") to CRAN?")) {
269    return(invisible())
270  }
271
272  upload_cran(pkg, built_path)
273
274  usethis::with_project(pkg$path,
275    flag_release(pkg)
276  )
277}
278
279build_cran <- function(pkg, args) {
280  cli::cli_alert_info("Building")
281  built_path <- pkgbuild::build(pkg$path, tempdir(), manual = TRUE, args = args)
282  cli::cli_alert_info("Submitting file: {built_path}")
283  size <- format(as.object_size(file_info(built_path)$size), units = "auto")
284  cli::cli_alert_info("File size: {size}")
285  built_path
286}
287
288extract_cran_msg <- function(msg) {
289  # Remove "CRAN package Submission" and "Submit package to CRAN"
290  msg <- gsub("CRAN package Submission|Submit package to CRAN", "", msg)
291
292  # remove all html tags
293  msg <- gsub("<[^>]+>", "", msg)
294
295  # remove tabs
296  msg <- gsub("\t+", "", msg)
297
298  # Remove extra newlines
299  msg <- gsub("\n+", "\n", msg)
300
301  msg
302}
303
304upload_cran <- function(pkg, built_path) {
305  pkg <- as.package(pkg)
306  maint <- maintainer(pkg)
307  comments <- cran_comments(pkg)
308
309  # Initial upload ---------
310  cli::cli_alert_info("Uploading package & comments")
311  body <- list(
312    pkg_id = "",
313    name = maint$name,
314    email = maint$email,
315    uploaded_file = httr::upload_file(built_path, "application/x-gzip"),
316    comment = comments,
317    upload = "Upload package"
318  )
319  r <- httr::POST(cran_submission_url, body = body)
320
321  # If a 404 likely CRAN is closed for maintenance, try to get the message
322  if (httr::status_code(r) == 404) {
323    msg <- ""
324    try({
325      r2 <- httr::GET(sub("index2", "index", cran_submission_url))
326      msg <- extract_cran_msg(httr::content(r2, "text"))
327    })
328    stop("Submission failed:", msg, call. = FALSE)
329  }
330
331  httr::stop_for_status(r)
332  new_url <- httr::parse_url(r$url)
333
334  # Confirmation -----------
335  cli::cli_alert_info("Confirming submission")
336  body <- list(
337    pkg_id = new_url$query$pkg_id,
338    name = maint$name,
339    email = maint$email,
340    policy_check = "1/",
341    submit = "Submit package"
342  )
343  r <- httr::POST(cran_submission_url, body = body)
344  httr::stop_for_status(r)
345  new_url <- httr::parse_url(r$url)
346  if (new_url$query$submit == "1") {
347    cli::cli_alert_success("Package submission successful")
348    cli::cli_alert_info("Check your email for confirmation link.")
349  } else {
350    stop("Package failed to upload.", call. = FALSE)
351  }
352
353  invisible(TRUE)
354}
355
356as.object_size <- function(x) structure(x, class = "object_size")
357
358flag_release <- function(pkg = ".") {
359  pkg <- as.package(pkg)
360  if (!uses_git(pkg$path)) {
361    return(invisible())
362  }
363
364  cli::cli_alert_warning("Don't forget to tag this release once accepted by CRAN")
365
366  date <- Sys.Date()
367  withr::with_dir(pkg$path, {
368    sha <- system2("git", c("rev-parse", "--short", "HEAD"), stdout = TRUE)
369  })
370
371  msg <- paste0(
372    "This package was submitted to CRAN on ", date, ".\n",
373    "Once it is accepted, delete this file and tag the release (commit ", sha, ")."
374  )
375  writeLines(msg, path(pkg$path, "CRAN-RELEASE"))
376  usethis::use_build_ignore("CRAN-RELEASE")
377}
378
379cran_mirror <- function(repos = getOption("repos")) {
380  repos[repos == "@CRAN@"] <- "https://cloud.r-project.org"
381
382  if (is.null(names(repos))) {
383    names(repos) <- "CRAN"
384  }
385
386  repos[["CRAN"]]
387}
388
389# Return the version of a package on CRAN (or other repository)
390# @param package The name of the package.
391# @param available A matrix of information about packages.
392cran_pkg_version <- function(package, available = available.packages()) {
393  idx <- available[, "Package"] == package
394  if (any(idx)) {
395    as.package_version(available[package, "Version"])
396  } else {
397    NULL
398  }
399}
400