Download snapshots from GitHub

Don't see any obvious way to test this, but I tried it out a bunch interactively. Snapshot test deliberately failing so I can double check that the message is useful.

Fixes #1779

Author: hadley

DESCRIPTION

@@ -40,6 +40,7 @@ Suggests:
     curl (>= 0.9.5),
     diffviewer (>= 0.1.0),
     digest (>= 0.6.33),
+    gh,
     knitr,
     rmarkdown,
     rstudioapi,

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* New `snapshot_download_gh()` makes it easy to get snapshots off GitHub and into your local package (#1779).
 * `expect_snapshot_file(name=)` must have a unique file path. If a snapshot file attempts to be saved with a duplicate `name`, an error will be thrown. (#1592)
 * `test_dir()`, `test_file()`, `test_package()`, `test_check()`, `test_local()`, `source_file()` gain a `shuffle` argument uses `sample()` to randomly reorder the top-level expressions in each test file (#1942). This random reordering surfaces dependencies between tests and code outside of any test, as well as dependencies between tests. This helps you find and eliminate unintentional dependencies.
 * `snapshot_accept(test)` now works when the test file name contains `.` (#1669).

R/snapshot-file.R

@@ -180,14 +180,31 @@ snapshot_review_hint <- function(
 
   path <- paste0("tests/testthat/_snaps/", test, "/", new_name(name))
 
+  if (check) {
+    gh_hint <- snap_download_hint()
+    on_gh <- !is.null(gh_hint)
+
+    if (on_gh) {
+      bullets <- gh_hint
+    } else {
+      bullets <- c(
+        if (ci) "* Download and unzip run artifact\n",
+        if (!ci) "* Locate check directory\n",
+        paste0("* Copy '", path, "' to local test directory\n")
+      )
+    }
+  } else {
+    bullets <- NULL
+  }
+
   paste0(
-    if (check && ci) "* Download and unzip run artifact\n",
-    if (check && !ci) "* Locate check directory\n",
-    if (check) paste0("* Copy '", path, "' to local test directory\n"),
-    if (check) "* ",
-    cli::format_inline(
-      "Run {.run testthat::snapshot_review('{test}/')} to review changes"
-    )
+    c(
+      bullets,
+      cli::format_inline(
+        "* Run {.run testthat::snapshot_review('{test}/')} to review changes"
+      )
+    ),
+    collapse = ""
   )
 }
 

R/snapshot-github.R

@@ -0,0 +1,121 @@
+#' Download snapshots from GitHub
+#'
+#' @description
+#' If your snapshots fail on GitHub, it can be a pain to figure out exactly
+#' why, or to incporate them into your local package. This function makes it
+#' easy.
+#'
+#' Note that you should not generally need to fill out this function yourself;
+#' instead copy and paste from the hint emitted on GitHub.
+#'
+#' @param repository Repository name, e.g. `"r-lib/testthat"`.
+#' @param job_id Job ID, e.g. `"47905180716"`. You can find this in the job url.
+#' @param dest_dir Directory to download to. Defaults to the current directory.
+#' @export
+snapshot_download_gh <- function(repository, job_id, dest_dir = ".") {
+  check_installed("gh")
+
+  dest_snaps <- file.path(dest_dir, "tests", "testthat", "_snaps")
+  if (!dir.exists(dest_snaps)) {
+    cli::cli_abort("No snapshot directory found in {.file {dest_dir}}.")
+  }
+
+  artifact_id <- gh_find_artifact(repository, job_id)
+
+  path <- withr::local_tempfile(pattern = "gh-snaps-")
+  gh_download_artifact(repository, artifact_id, path)
+
+  inner_dir <- dir(path, full.names = TRUE)[1]
+  src_snaps <- file.path(inner_dir, "tests", "testthat", "_snaps")
+  dir_copy(src_snaps, dest_snaps)
+}
+
+snap_download_hint <- function() {
+  repository <- Sys.getenv("GITHUB_REPOSITORY")
+  job_id <- Sys.getenv("GITHUB_JOB")
+
+  if (repository == "" || job_id == "") {
+    return()
+  }
+
+  sprintf(
+    "* Call `gh_download_snaps(\"%s\", %s)` to download the snapshots from GitHub.\n",
+    repository,
+    job_id
+  )
+}
+
+
+gh_find_artifact <- function(repository, job_id) {
+  job_logs <- gh::gh(
+    "GET /repos/{repository}/actions/jobs/{job_id}/logs",
+    repository = repository,
+    job_id = job_id,
+    .send_headers = c("Accept" = "application/vnd.github.v3+json")
+  )
+
+  log_lines <- strsplit(job_logs$message, "\r?\n")[[1]]
+  matches <- re_match(log_lines, "Artifact download URL: (?<artifact_url>.*)")
+  matches <- matches[!is.na(matches$artifact_url), ]
+
+  if (!nrow(matches)) {
+    cli::cli_abort("Failed to find artifact")
+  }
+
+  # Take last artifact URL; if the job has failed the previous artifact will
+  # be the R CMD check logs
+  artifact_url <- matches$artifact_url[nrow(matches)]
+  basename(artifact_url)
+}
+
+gh_download_artifact <- function(repository, artifact_id, path) {
+  zip_path <- withr::local_tempfile(pattern = "gh-zip-")
+  gh::gh(
+    "/repos/{repository}/actions/artifacts/{artifact_id}/{archive_format}",
+    repository = repository,
+    artifact_id = artifact_id,
+    archive_format = "zip",
+    .destfile = zip_path
+  )
+  unzip(zip_path, exdir = path)
+  invisible(path)
+}
+
+# Directory helpers ------------------------------------------------------------
+
+dir_create <- function(paths) {
+  for (path in paths) {
+    dir.create(path, recursive = TRUE, showWarnings = FALSE)
+  }
+  invisible(paths)
+}
+
+dir_copy <- function(src_dir, dst_dir) {
+  # First create directories
+  dirs <- list.dirs(src_dir, recursive = TRUE, full.names = FALSE)
+  dir_create(file.path(dst_dir, dirs))
+
+  # Then copy files
+  files <- dir(src_dir, recursive = TRUE)
+  src_files <- file.path(src_dir, files)
+  dst_files <- file.path(dst_dir, files)
+  same <- map_lgl(seq_along(files), \(i) {
+    same_file(src_files[[i]], dst_files[[i]])
+  })
+
+  n_new <- sum(!same)
+  if (n_new == 0) {
+    cli::cli_inform(c(i = "No new snapshots."))
+  } else {
+    cli::cli_inform(c(
+      v = "Copying {n_new} new snapshots: {.file {files[!same]}}."
+    ))
+  }
+
+  file.copy(src_files[!same], dst_files[!same], overwrite = TRUE)
+  invisible()
+}
+
+same_file <- function(x, y) {
+  file.exists(x) && file.exists(y) && hash_file(x) == hash_file(y)
+}

R/snapshot.R

@@ -368,6 +368,7 @@ snapshot_accept_hint <- function(variant, file, reset_output = TRUE) {
   }
 
   paste0(
+    snap_download_hint(),
     cli::format_inline(
       "* Run {.run testthat::snapshot_accept('{name}')} to accept the change."
     ),

R/utils.R

@@ -67,3 +67,28 @@ no_wrap <- function(x) {
 paste_c <- function(...) {
   paste0(c(...), collapse = "")
 }
+
+# from rematch2
+re_match <- function(text, pattern, perl = TRUE, ...) {
+  stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
+  text <- as.character(text)
+  match <- regexpr(pattern, text, perl = perl, ...)
+  start <- as.vector(match)
+  length <- attr(match, "match.length")
+  end <- start + length - 1L
+  matchstr <- substring(text, start, end)
+  matchstr[start == -1] <- NA_character_
+  res <- data.frame(stringsAsFactors = FALSE, .text = text, .match = matchstr)
+  if (!is.null(attr(match, "capture.start"))) {
+    gstart <- attr(match, "capture.start")
+    glength <- attr(match, "capture.length")
+    gend <- gstart + glength - 1L
+    groupstr <- substring(text, gstart, gend)
+    groupstr[gstart == -1] <- NA_character_
+    dim(groupstr) <- dim(gstart)
+    res <- cbind(groupstr, res, stringsAsFactors = FALSE)
+  }
+  names(res) <- c(attr(match, "capture.names"), ".text", ".match")
+  class(res) <- c("tbl_df", "tbl", class(res))
+  res
+}

tests/testthat/_snaps/snapshot-file.md

@@ -27,7 +27,7 @@
     Code
       cat(snapshot_review_hint("lala", "foo.r", check = FALSE, ci = FALSE))
     Output
-      Run `testthat::snapshot_review('lala/')` to review changes
+      * Run `testthat::snapshot_review('lala/')` to review changes
 
 ---
 
@@ -47,6 +47,13 @@
       * Copy 'tests/testthat/_snaps/lala/foo.new.r' to local test directory
       * Run `testthat::snapshot_review('lala/')` to review changes
 
+---
+
+    Code
+      cat(snapshot_review_hint("lala", "foo.r", check = TRUE, ci = TRUE))
+    Output
+      * Run `testthat::snapshot_review('lala/')` to review changes
+
 # expect_snapshot_file validates its inputs
 
     Code

tests/testthat/test-snapshot-file.R

@@ -180,6 +180,14 @@ test_that("snapshot_hint output differs in R CMD check", {
     check = TRUE,
     ci = TRUE
   )))
+
+  withr::local_envvar(GITHUB_REPOSITORY = "r-lib/testthat", GITHUB_JOB = "123")
+  expect_snapshot(cat(snapshot_review_hint(
+    "lala",
+    "foo.r",
+    check = TRUE,
+    ci = TRUE
+  )))
 })
 
 test_that("expect_snapshot_file validates its inputs", {