Merge pull request #34 from wlandau/staging-freeze

Staging universe freezes and timing

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: multiverse.internals
 Title: Internal Infrastructure for R-multiverse
-Description: R-multiverse requires this internal internal infrastructure
-  package to automate contribution reviews and populate universes.
-Version: 0.2.9
+Description: R-multiverse requires this internal infrastructure package to
+  automate contribution reviews and populate universes.
+Version: 0.2.10
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues
@@ -26,7 +26,7 @@ Authors@R: c(
     role = "cph"
   ))
 Depends:
-  R (>= 3.5.0)
+  R (>= 3.6)
 Imports:
   gh,
   igraph,

NAMESPACE

@@ -15,6 +15,7 @@ export(record_issues)
 export(record_versions)
 export(review_pull_request)
 export(review_pull_requests)
+export(staging_is_active)
 export(try_message)
 export(update_staging)
 importFrom(gh,gh)

NEWS.md

@@ -1,3 +1,8 @@
+# multiverse.internals 0.2.10
+
+* Implement freezing mechanism in `update_staging()`.
+* Implement `staging_is_active()` to detect when the staging universe should be active.
+
 # multiverse.internals 0.2.9
 
 * Implement community/staging idea from (@jeroen).

R/meta_checks.R

@@ -1,6 +1,6 @@
 #' @title List metadata about R-universe package checks
 #' @export
-#' @family list
+#' @family meta
 #' @description List package checks results reported by the
 #'   R-universe package API.
 #' @return A data frame with one row per package and columns with

R/staging_is_active.R

@@ -0,0 +1,37 @@
+#' @title Check if the stating universe is active.
+#' @export
+#' @family staging
+#' @description Check if the stating universe is active.
+#' @return `TRUE` if the staging universe is active, `FALSE` otherwise.
+#' @param start Character vector of `"%m-%d"` dates that the
+#'   staging universe becomes active. Staging will then last for a full
+#'   calendar month. For example, if you supply a start date of `"01-15"`,
+#'   then the staging period will include all days from `"01-15"`
+#'   through `"02-14"` and not include `"02-15"`.
+#' @param today Character string with today's date in `"%Y-%m-%d"` format or an
+#'   object convertible to POSIXlt format.
+#' @examples
+#' staging_is_active()
+staging_is_active <- function(
+  start = c("01-15", "04-15", "07-15", "10-15"),
+  today = Sys.Date()
+) {
+  today <- as.POSIXlt(today, tz = "UTC")
+  start <- strsplit(start, split = "-", fixed = TRUE)
+  start <- lapply(start, as.integer)
+  within <- lapply(start, within_staging, today = today)
+  any(as.logical(within))
+}
+
+within_staging <- function(start, today) {
+  month <- today$mon + 1L
+  day <- today$mday
+  if (start[1L] > 28L) {
+    stop(
+      "a staging start date cannot be later than day 28 of the given month.",
+      call. = FALSE
+    )
+  }
+  (month == start[1L] && day >= start[2L]) ||
+    (month == start[1L] + 1L && day < start[2L])
+}

R/update_staging.R

@@ -1,5 +1,6 @@
 #' @title Update staging
 #' @export
+#' @family staging
 #' @description Update the staging universe.
 #' @details [update_staging()] controls how packages enter and leave
 #'   the staging universe. It updates the staging `packages.json`
@@ -32,42 +33,41 @@ update_staging <- function(
   repo_community = "https://community.r-multiverse.org",
   mock = NULL
 ) {
-  meta_community <- mock$community %||% meta_packages(repo_community)
-  packages <- promotions(path_community, meta_community)
   file_staging <- file.path(path_staging, "packages.json")
   file_community <- file.path(path_community, "packages.json")
   json_staging <- jsonlite::read_json(file_staging, simplifyVector = TRUE)
   json_community <- jsonlite::read_json(file_community, simplifyVector = TRUE)
-  index_promote <- json_community$package %in% packages
-  promote <- json_community[index_promote,, drop = FALSE] # nolint
-  meta_community <- meta_community[, c("package", "remotesha")]
-  promote <- merge(promote, meta_community, all.x = TRUE, all.y = FALSE)
-  promote$branch <- promote$remotesha
-  promote$remotesha <- NULL
-  replace <- !(json_staging$package %in% packages)
-  json_staging <- json_staging[replace,, drop = FALSE] # nolint
-  json_staging <- rbind(json_staging, promote)
-  json_staging <- json_staging[order(json_staging$package),, drop = FALSE ] # nolint
-  jsonlite::write_json(json_staging, file_staging, pretty = TRUE)
-  invisible()
-}
-
-promotions <- function(path_community, meta_community) {
-  promotion_checks <- c(
-    "descriptions",
-    "versions"
+  meta_community <- mock$community %||% meta_packages(repo_community)
+  issues <- list.files(
+    file.path(path_staging, "issues"),
+    all.files = TRUE,
+    no.. = TRUE
   )
-  issues <- Filter(
-    x = list.files(file.path(path_community, "issues")),
-    f = function(package) {
-      json <- jsonlite::read_json(
-        path = file.path(path_community, "issues", package)
-      )
-      any(names(json) %in% promotion_checks)
-    }
+  freeze <- setdiff(json_staging$package, issues)
+  update <- setdiff(json_community$package, freeze)
+  should_freeze <- json_staging$package %in% freeze
+  json_freeze <- json_staging[should_freeze, ]
+  json_update <- json_community[json_community$package %in% update, ]
+  json_freeze$subdir <- json_freeze$subdir %||%
+    rep(NA_character_, nrow(json_freeze))
+  json_update$subdir <- json_update$subdir %||%
+    rep(NA_character_, nrow(json_update))
+  branches <- meta_community[
+    meta_community$package %in% update,
+    c("package", "remotesha")
+  ]
+  json_update <- merge(
+    x = json_update,
+    y = branches,
+    by = "package",
+    all.x = TRUE,
+    all.y = FALSE
   )
-  file_community <- file.path(path_community, "packages.json")
-  json <- jsonlite::read_json(file_community, simplifyVector = TRUE)
-  candidates <- intersect(meta_community$package, json$package)
-  setdiff(candidates, issues)
+  json_update <- json_update[!is.na(json_update$remotesha),, drop = FALSE] # nolint
+  json_update$branch <- json_update$remotesha
+  json_update$remotesha <- NULL
+  json_new <- rbind(json_freeze, json_update)
+  json_new <- json_new[order(json_new$package), ]
+  jsonlite::write_json(json_new, file_staging, pretty = TRUE)
+  invisible()
 }

_pkgdown.yml

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

inst/WORDLIST

@@ -5,3 +5,4 @@ json
 repo
 pkgdown
 pre
+POSIXlt

inst/mock/community/packages.json

@@ -1,32 +1,17 @@
 [
   {
-    "package": "promote",
-    "url": "https://github.com/owner/promote",
+    "package": "add",
+    "url": "https://github.com/owner/add",
     "branch": "*release"
   },
   {
-    "package": "change",
-    "url": "https://github.com/owner/change",
+    "package": "freeze",
+    "url": "https://github.com/owner/freeze",
     "branch": "*release"
   },
   {
-    "package": "keep",
-    "url": "https://github.com/owner/keep",
-    "branch": "*release"
-  },
-  {
-    "package": "checks",
-    "url": "https://github.com/owner/checks",
-    "branch": "*release"
-  },
-  {
-    "package": "descriptions",
-    "url": "https://github.com/owner/descriptions",
-    "branch": "*release"
-  },
-  {
-    "package": "versions",
-    "url": "https://github.com/owner/versions",
+    "package": "issue",
+    "url": "https://github.com/owner/issue",
     "branch": "*release"
   }
 ]

inst/mock/staging/issues/removed-has-issue

@@ -0,0 +1,13 @@
+{
+  "checks": {
+    "_linuxdevel": ["success"],
+    "_macbinary": ["success"],
+    "_wasmbinary": ["none"],
+    "_winbinary": ["success"],
+    "_status": ["success"],
+    "_buildurl": ["https://github.com/r-universe/r-multiverse/actions/runs/12345"]
+  },
+  "date": ["1980-01-01"],
+  "version": ["2.0.2"],
+  "remote_hash": ["abcdef1234567890abcdef"]
+}

inst/mock/staging/packages.json

@@ -1,12 +1,22 @@
 [
   {
-    "package": "change",
-    "url": "https://github.com/owner/change",
+    "package": "freeze",
+    "url": "https://github.com/owner/freeze",
     "branch": "original"
   },
   {
-    "package": "keep",
-    "url": "https://github.com/owner/keep",
-    "branch": "sha-keep"
+    "package": "issue",
+    "url": "https://github.com/owner/issue",
+    "branch": "original"
+  },
+  {
+    "package": "removed-has-issue",
+    "url": "https://github.com/owner/removed-has-issue",
+    "branch": "original"
+  },
+  {
+    "package": "removed-no-issue",
+    "url": "https://github.com/owner/removed-no-issue",
+    "branch": "original"
   }
 ]

tests/testthat/test-staging_is_active.R

@@ -0,0 +1,43 @@
+test_that("staging_is_active()", {
+  start <- c("01-15", "04-15", "07-15", "10-15")
+  active <- c(
+    "2024-01-15",
+    "2024-01-16",
+    "2024-02-13",
+    "2024-04-15",
+    "2024-04-25",
+    "2024-05-14",
+    "2024-07-15",
+    "2024-08-12",
+    "2024-08-13",
+    "2024-10-15",
+    "2024-11-01",
+    "2024-11-13"
+  )
+  for (today in active) {
+    expect_true(
+      staging_is_active(
+        start = start,
+        today = today
+      )
+    )
+  }
+  inactive <- c(
+    "2024-01-12",
+    "2024-02-15",
+    "2024-04-14",
+    "2024-05-15",
+    "2024-07-12",
+    "2024-08-15",
+    "2024-10-14",
+    "2024-11-15"
+  )
+  for (today in inactive) {
+    expect_false(
+      staging_is_active(
+        start = start,
+        today = today
+      )
+    )
+  }
+})