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,8 @@
+# multiverse.internals 0.2.11
+
+* Implement `propose_snapshot()`.
+* Exempt Production from WASM checks.
+
 # multiverse.internals 0.2.10
 
 * Implement freezing mechanism in `update_staging()`.

R/issues_checks.R

@@ -21,7 +21,6 @@ issues_checks <- function(meta = meta_checks()) {
   fields_check <- c(
     "_linuxdevel",
     "_macbinary",
-    "_wasmbinary",
     "_winbinary",
     "_status"
   )

R/propose_snapshot.R

@@ -0,0 +1,79 @@
+#' @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.
+#'   Writes `snapshot.json` with an R-universe-like manifest
+#'   of the packages recommended for the snapshot, and a
+#'   `snapshot.url` file containing an R-universe snapshot API URL
+#'   to download those packages. Both these files are written to the
+#'   directory given by the `path_staging` argument.
+#' @return `NULL` (invisibly). Called for its side effects.
+#'   [propose_snapshot()] writes `snapshot.json` with an R-universe-like
+#'   manifest of the packages recommended for the snapshot, and a
+#'   `snapshot.url` file containing an R-universe snapshot API URL
+#'   to download those packages. Both these files are written to the
+#'   directory given by the `path_staging` argument.
+#' @inheritParams update_staging
+#' @param repo_staging Character string, URL of the staging universe.
+#' @param types Character vector, what to pass to the `types` field in the
+#'   snapshot API URL. Controls the types of binaries and documentation
+#'   included in the snapshot.
+#' @param r_versions Character vector of `major.minor` versions of R
+#'   to download binaries. For example, `r_versions = c("4.4", "4.3")`.
+#'   Set to `NULL` to let R-universe choose default versions.
+#' @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",
+  types = c("win", "mac"),
+  r_versions = NULL,
+  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)
+  if (!is.null(r_versions)) {
+    r_versions <- paste0("&binaries=", paste(r_versions, collapse = ","))
+  }
+  url <- paste0(
+    "https://staging.r-multiverse.org/api/snapshot/zip",
+    "?types=",
+    paste(types, collapse = ","),
+    r_versions,
+    "&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

inst/WORDLIST

@@ -6,3 +6,4 @@ repo
 pkgdown
 pre
 POSIXlt
+WASM

tests/testthat/test-issues_checks.R

@@ -2,37 +2,32 @@ test_that("issues_checks() mocked", {
   issues <- issues_checks(meta = mock_meta_checks)
   url <- "https://github.com/r-universe/r-multiverse/actions/runs"
   expected <- list(
-    httpgd = list(
-      "_linuxdevel" = "success", "_macbinary" = "success",
-      "_wasmbinary" = "none", "_winbinary" = "success", "_status" = "success",
-      "_buildurl" = file.path(url, "9403635056")
-    ),
     INLA = list(
       "_linuxdevel" = "src-failure", "_macbinary" = "src-failure",
-      "_wasmbinary" = "src-failure", "_winbinary" = "src-failure",
+      "_winbinary" = "src-failure",
       "_status" = "src-failure",
       "_buildurl" = file.path(url, "9296256187")
     ),
     polars = list(
       "_linuxdevel" = "failure", "_macbinary" = "arm64-failure",
-      "_wasmbinary" = "none", "_winbinary" = "success", "_status" = "success",
+      "_winbinary" = "success", "_status" = "success",
       "_buildurl" = file.path(url, "9360739181")
     ),
     SBC = list(
       "_linuxdevel" = "failure", "_macbinary" = "success",
-      "_wasmbinary" = "success", "_winbinary" = "success",
+      "_winbinary" = "success",
       "_status" = "failure",
       "_buildurl" = file.path(url, "9412009979")
     ),
     stantargets = list(
       "_linuxdevel" = "failure", "_macbinary" = "success",
-      "_wasmbinary" = "success", "_winbinary" = "success",
+      "_winbinary" = "success",
       "_status" = "success",
       "_buildurl" = file.path(url, "9412009826")
     ),
     tidytensor = list(
       "_linuxdevel" = "failure", "_macbinary" = "success",
-      "_wasmbinary" = "success", "_winbinary" = "success",
+      "_winbinary" = "success",
       "_status" = "failure",
       "_buildurl" = file.path(url, "9412009544")
     )

tests/testthat/test-propose_snapshot.R

@@ -0,0 +1,65 @@
+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)
+  expect_equal(
+    readLines(file.path(path_staging, "snapshot.url")),
+    paste0(
+      "https://staging.r-multiverse.org/api/snapshot/zip",
+      "?types=win,mac&packages=good1,good2"
+    )
+  )
+  propose_snapshot(
+    path_staging = path_staging,
+    mock = list(staging = meta_staging),
+    r_versions = c("4.5", "4.4")
+  )
+  expect_equal(
+    readLines(file.path(path_staging, "snapshot.url")),
+    paste0(
+      "https://staging.r-multiverse.org/api/snapshot/zip",
+      "?types=win,mac&binaries=4.5,4.4&packages=good1,good2"
+    )
+  )
+})

tests/testthat/test-record_issues.R

@@ -15,7 +15,6 @@ test_that("record_issues() mocked", {
     sort(
       c(
         "audio.whisper",
-        "httpgd",
         "INLA",
         "polars",
         "SBC",
@@ -34,7 +33,6 @@ test_that("record_issues() mocked", {
       checks = list(
         "_linuxdevel" = "src-failure",
         "_macbinary" = "src-failure",
-        "_wasmbinary" = "src-failure",
         "_winbinary" = "src-failure",
         "_status" = "src-failure",
         "_buildurl" = file.path(runs, "9296256187")
@@ -53,7 +51,6 @@ test_that("record_issues() mocked", {
       checks = list(
         "_linuxdevel" = "failure",
         "_macbinary" = "success",
-        "_wasmbinary" = "success",
         "_winbinary" = "success",
         "_status" = "success",
         "_buildurl" = file.path(runs, "9412009826")
@@ -128,7 +125,6 @@ test_that("record_issues() date works", {
     expect_equal(date, "2024-01-01")
   }
   never_fixed <- c(
-    "httpgd",
     "INLA",
     "stantargets",
     "tidytensor",
@@ -251,7 +247,6 @@ test_that("record_issues() with dependency problems", {
       checks = list(
         "_linuxdevel" = "success",
         "_macbinary" = "success",
-        "_wasmbinary" = "success",
         "_winbinary" = "failure",
         "_status" = "success",
         "_buildurl" = file.path(