Propose snapshot

DESCRIPTION

@@ -2,7 +2,7 @@ Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
 Description: R-multiverse requires this internal infrastructure package to
   automate contribution reviews and populate universes.
-Version: 0.2.10
+Version: 0.2.11
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues

NAMESPACE

@@ -11,6 +11,7 @@ export(issues_descriptions)
 export(issues_versions)
 export(meta_checks)
 export(meta_packages)
+export(propose_snapshot)
 export(record_issues)
 export(record_versions)
 export(review_pull_request)

NEWS.md

@@ -1,3 +1,7 @@
+# multiverse.internals 0.2.11
+
+* Implement `propose_snapshot()`.
+
 # multiverse.internals 0.2.10
 
 * Implement freezing mechanism in `update_staging()`.

R/propose_snapshot.R

@@ -0,0 +1,55 @@
+#' @title Propose snapshot
+#' @export
+#' @family staging
+#' @description Propose a Production snapshot of Staging.
+#' @details [propose_snapshot()] proposes a snapshot of Staging
+#'   to migrate to Production. The recommended snapshot is the list of
+#'   packages for which (1) the build and check results of the current
+#'   release are in Staging, and (2) there are no issues.
+#' @return `NULL` (invisibly)
+#' @inheritParams update_staging
+#' @param repo_staging Character string, URL of the staging universe.
+#' @examples
+#' \dontrun{
+#' url_staging = "https://github.com/r-multiverse/staging"
+#' path_staging <- tempfile()
+#' gert::git_clone(url = url_staging, path = path_staging)
+#' propose_snapshot(
+#'   path_staging = path_staging,
+#'   repo_staging = "https://staging.r-multiverse.org"
+#' )
+#' }
+propose_snapshot <- function(
+  path_staging,
+  repo_staging = "https://staging.r-multiverse.org",
+  mock = NULL
+) {
+  issues <- list.files(
+    file.path(path_staging, "issues"),
+    all.files = TRUE,
+    no.. = TRUE
+  )
+  file_staging <- file.path(path_staging, "packages.json")
+  json_staging <- jsonlite::read_json(file_staging, simplifyVector = TRUE)
+  json_staging <- json_staging[, c("package", "url", "branch")]
+  meta_staging <- mock$staging %||% meta_packages(repo_staging)
+  meta_staging <- meta_staging[, c("package", "remotesha")]
+  staging <- merge(
+    x = json_staging,
+    y = meta_staging,
+    all.x = FALSE,
+    all.y = FALSE
+  )
+  staging <- staging[staging$branch == staging$remotesha,, drop = FALSE] # nolint
+  staging <- staging[!(staging$package %in% issues),, drop = FALSE] # nolint
+  staging$remotesha <- NULL
+  file_snapshot <- file.path(path_staging, "snapshot.json")
+  jsonlite::write_json(staging, file_snapshot, pretty = TRUE)
+  url <- paste0(
+    "https://staging.r-multiverse.org/api/snapshot/zip",
+    "?types=src,win,mac,linux,wasm,docs&packages=",
+    paste(staging$package, collapse = ",")
+  )
+  writeLines(url, file.path(path_staging, "snapshot.url"))
+  invisible()
+}

_pkgdown.yml

@@ -26,4 +26,5 @@ reference:
 - title: Staging
   contents:
   - update_staging
+  - propose_snapshot
   - staging_is_active

tests/testthat/test-propose_snapshot.R

@@ -0,0 +1,54 @@
+test_that("propose_snapshot()", {
+  dir_staging <- tempfile()
+  dir_community <- tempfile()
+  path_staging <- file.path(dir_staging, "staging")
+  dir.create(dir_staging)
+  on.exit(unlink(path_staging, recursive = TRUE))
+  mock <- system.file(
+    "mock",
+    package = "multiverse.internals",
+    mustWork = TRUE
+  )
+  file.copy(
+    from = file.path(mock, "staging"),
+    to = dir_staging,
+    recursive = TRUE
+  )
+  file_staging <- file.path(path_staging, "packages.json")
+  json_staging <- data.frame(
+    package = c("good1", "good2", "unsynced", "issue")
+  )
+  json_staging$url <- file.path(
+    "https://github.com/owner",
+    json_staging$package
+  )
+  json_staging$branch <- "original"
+  jsonlite::write_json(json_staging, file_staging, pretty = TRUE)
+  meta_staging <- data.frame(
+    package = c("good1", "good2", "issue", "removed", "unsynced"),
+    remotesha = c(rep("original", 4), "sha-unsynced")
+  )
+  propose_snapshot(
+    path_staging = path_staging,
+    mock = list(staging = meta_staging)
+  )
+  json_snapshot <- jsonlite::read_json(
+    file.path(path_staging, "snapshot.json"),
+    simplifyVector = TRUE
+  )
+  expect_equal(json_snapshot$package, c("good1", "good2"))
+  expect_equal(
+    json_snapshot$url,
+    file.path("https://github.com/owner", json_snapshot$package)
+  )
+  expect_equal(json_snapshot$branch, rep("original", 2L))
+  expect_equal(ncol(json_snapshot), 3L)
+  url <- readLines(file.path(path_staging, "snapshot.url"))
+  expect_equal(
+    url,
+    paste0(
+      "https://staging.r-multiverse.org/api/snapshot/zip",
+      "?types=src,win,mac,linux,wasm,docs&packages=good1,good2"
+    )
+  )
+})