Merge pull request #30 from wlandau/production

Production

.Rbuildignore

@@ -1,11 +1,9 @@
 ^.*~$
-^.*\.json$
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^LICENSE\.md$
 ^main$
 ^pull_request$
-^packages\.json$
 ^\.lintr$
 ^\.git$
 ^\.github$

.gitignore

@@ -1,5 +1,5 @@
 *~
-*.json
+.DS_Store
 .Rproj.user
 .Rhistory
 .RData

DESCRIPTION

@@ -2,7 +2,7 @@ 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.4
+Version: 0.2.5
 License: MIT + file LICENSE
 URL: https://github.com/r-multiverse/multiverse.internals
 BugReports: https://github.com/r-multiverse/multiverse.internals/issues
@@ -35,7 +35,8 @@ Imports:
   pkgsearch,
   utils,
   vctrs
-Suggests: 
+Suggests:
+  gert,
   testthat (>= 3.0.0)
 Encoding: UTF-8
 Language: en-US

NAMESPACE

@@ -16,6 +16,7 @@ export(record_versions)
 export(review_pull_request)
 export(review_pull_requests)
 export(try_message)
+export(update_production)
 importFrom(gh,gh)
 importFrom(igraph,V)
 importFrom(igraph,graph)

NEWS.md

@@ -1,3 +1,7 @@
+# multiverse.internals 0.2.5
+
+* Add `update_production()`.
+
 # multiverse.internals 0.2.4
 
 * Updates R-Multiverse repository to `community.r-multiverse.org`.

R/issues_versions.R

@@ -15,8 +15,6 @@
 #'   release recorded.
 #' @inheritParams record_versions
 #' @examples
-#'   # See https://github.com/r-multiverse/checks/blob/main/versions.json
-#'   # for the official versions JSON for R-multiverse.
 #'   lines <- c(
 #'     "[",
 #'     " {",

R/meta_checks.R

@@ -31,5 +31,6 @@ meta_checks <- function(repo = "https://community.r-multiverse.org") {
     simplifyMatrix = TRUE
   )
   colnames(out) <- tolower(colnames(out))
+  rownames(out) <- out$package
   out
 }

R/meta_packages.R

@@ -23,5 +23,6 @@ meta_packages <- function(repo = "https://community.r-multiverse.org") {
     simplifyMatrix = TRUE
   )
   colnames(out) <- tolower(colnames(out))
+  rownames(out) <- out$package
   out
 }

R/record_issues.R

@@ -9,7 +9,7 @@
 #'   Only packages that pass these checks go to the production repository at
 #'   <https://production.r-multiverse.org>. For a complete list of checks, see
 #'   the `issues_*()` functions listed at
-#'   <https://r-multiverse.org/multiverse.internals/reference.html>.
+#'   <https://r-multiverse.org/multiverse.internals/reference/index.html>.
 #'   [record_versions()] updates the version number history
 #'   of releases in R-multiverse, and [record_issues()] gathers
 #'   together all the issues about R-multiverse packages.

R/record_versions.R

@@ -15,9 +15,6 @@
 #' @inheritParams meta_checks
 #' @param versions Character of length 1, file path to a JSON manifest
 #'   tracking the history of released versions of packages.
-#'   The official versions file for R-multiverse is maintained and
-#'   updated periodically at
-#'   <https://github.com/r-multiverse/checks/blob/main/versions.json>.
 #' @param current A data frame of current versions and hashes of packages
 #'   in `repo`. This argument is exposed for testing only.
 #' @examples

R/update_production.R

@@ -0,0 +1,171 @@
+#' @title Update production
+#' @export
+#' @description Update the production universe.
+#' @details [update_production()] controls how packages enter and leave
+#'   the production universe. It updates the production `packages.json`
+#'   manifest depending on the contents of the community
+#'   universe and issues with package checks. There are 3 phases:
+#'   1. Demote packages: packages with any check issues in production
+#'     are given `days_notice` days to fix the problems. If the problems
+#'     are fixed on time, then the package stays in
+#'     production, and the notice period resets (the next problem is given
+#'     the full `days_notice` notice period from scratch). Otherwise,
+#'     if there are still issues after `days_notice` days, then the package
+#'     is removed from the `packages.json` manifest and added to a special
+#'     `removing.json` manifest in production. `removing.json` ensures
+#'     that the builds are actually removed from production before the
+#'     package can be promoted again. That way, if the next automatic
+#'     promotion fails production checks, no build will be available
+#'     to install from <https://production.r-multiverse.org>.
+#'   2. Clear removals: a demoted package stays in `removing.json` until
+#'     the builds are removed from <https://production.r-multiverse.org>.
+#'     After the builds are gone, the package is removed from `removing.json`
+#'     so it can be promoted again. No build will become available again
+#'     until the package passes all production checks.
+#'   3. Promote packages: a package in the community universe is moved
+#'     to production if:
+#'       * It passes description checks from [issues_descriptions()].
+#'       * It passes version checks from [issues_versions()].
+#'       * The package is available to install from
+#'         <https://community.r-multiverse.org>.
+#'       * The package is not in `removing.json`.
+#'     To promote the package, an entry is created in the production
+#'     `packages.json` with the Git hash of the latest release.
+#' @return `NULL` (invisibly)
+#' @inheritParams record_issues
+#' @param path_production Character string, directory path to the source
+#'   files of the production universe.
+#' @param path_community Character string, directory path to the source
+#'   files of the community universe.
+#' @param repo_production Character string, URL of the production universe.
+#' @param repo_community Character string, URL of the community universe.
+#' @param days_notice Integer scalar, number of days between the
+#'   detection of a production issue and removal from the production universe.
+#' @examples
+#' \dontrun{
+#' url_production = "https://github.com/r-multiverse/production"
+#' url_community = "https://github.com/r-multiverse/community"
+#' path_production <- tempfile()
+#' path_community <- tempfile()
+#' gert::git_clone(url = url_production, path = path_production)
+#' gert::git_clone(url = url_community, path = path_community)
+#' update_production(
+#'   repo_production = "https://production.r-multiverse.org",
+#'   repo_community = "https://community.r-multiverse.org",
+#'   path_production = tempfile(),
+#'   path_community = tempfile(),
+#'   days_notice = 28L
+#' )
+#' }
+update_production <- function(
+  path_production,
+  path_community,
+  repo_production = "https://production.r-multiverse.org",
+  repo_community = "https://community.r-multiverse.org",
+  days_notice = 28L,
+  mock = NULL
+) {
+  meta_production <- mock$production %||% meta_packages(repo_production)
+  meta_community <- mock$community %||% meta_packages(repo_community)
+  demote_packages(
+    path_production = path_production,
+    days_notice = days_notice
+  )
+  clear_removed(
+    path_production = path_production,
+    meta_production = meta_production
+  )
+  promote_packages(
+    path_production = path_production,
+    path_community = path_community,
+    meta_community = meta_community
+  )
+  invisible()
+}
+
+demote_packages <- function(path_production, days_notice) {
+  packages <- get_demote(path_production, days_notice)
+  removing <- sort(unique(c(get_removing(path_production), packages)))
+  file_removing <- file.path(path_production, "removing.json")
+  jsonlite::write_json(removing, file_removing, pretty = TRUE)
+  file_production <- file.path(path_production, "packages.json")
+  json <- jsonlite::read_json(file_production, simplifyVector = TRUE)
+  json <- json[!(json$package %in% removing),, drop = FALSE] # nolint
+  jsonlite::write_json(json, file_production, pretty = TRUE)
+}
+
+clear_removed <- function(path_production, meta_production) {
+  removing <- intersect(
+    get_removing(path_production),
+    meta_production$package
+  )
+  jsonlite::write_json(
+    removing,
+    file.path(path_production, "removing.json"),
+    pretty = TRUE
+  )
+}
+
+promote_packages <- function(
+  path_production,
+  path_community,
+  meta_community
+) {
+  packages <- get_promote(path_production, path_community, meta_community)
+  file_production <- file.path(path_production, "packages.json")
+  file_community <- file.path(path_community, "packages.json")
+  json_production <- jsonlite::read_json(
+    file_production,
+    simplifyVector = TRUE
+  )
+  json_community <- jsonlite::read_json(file_community, simplifyVector = TRUE)
+  promote <- json_community[json_community$package %in% packages,, drop = FALSE] # nolint
+  promote <- merge(promote, meta_community, all.x = TRUE, all.y = FALSE)
+  promote$branch <- promote$remotesha
+  promote$remotesha <- NULL
+  replace <- !(json_production$package %in% packages)
+  json_production <- json_production[replace,, drop = FALSE] # nolint
+  json_production <- rbind(json_production, promote)
+  json_production <- json_production[order(json_production$package),, drop = FALSE ] # nolint
+  jsonlite::write_json(json_production, file_production, pretty = TRUE)
+}
+
+get_demote <- function(path_production, days_notice) {
+  file <- file.path(path_production, "packages.json")
+  packages <- jsonlite::read_json(file, simplifyVector = TRUE)$package
+  issues <- list.files(file.path(path_production, "issues"))
+  Filter(
+    x = intersect(packages, issues),
+    f = function(package) {
+      file <- file.path(path_production, "issues", package)
+      json <- jsonlite::read_json(path = file)
+      delay <- as.integer(Sys.Date() - as.Date(as.character(json$date)))
+      delay > days_notice
+    }
+  )
+}
+
+get_promote <- function(path_production, path_community, meta_community) {
+  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% c("descriptions", "versions"))
+    }
+  )
+  removing <- get_removing(path_production)
+  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, c(issues, removing))
+}
+
+get_removing <- function(path_production) {
+  file <- file.path(path_production, "removing.json")
+  if (!file.exists(file)) {
+    return(character(0L))
+  }
+  jsonlite::read_json(file, simplifyVector = TRUE)
+}

README.md

@@ -6,5 +6,3 @@
 `multiverse.internals` is an R package to support the internal infrastructure for the R-multiverse project.
 
 To learn about specific pieces of the R-multiverse infrastructure for reviewing and checking packages, please visit <https://r-multiverse.org/multiverse.internals/reference>.
-
-For all other matters, please refer to <https://r-multiverse.org>.

_pkgdown.yml

@@ -23,3 +23,6 @@ reference:
   contents:
   - record_issues
   - record_versions
+- title: Production
+  contents:
+  - update_production

inst/mock/community/issues/community-descriptions

@@ -0,0 +1,16 @@
+{
+  "checks": {
+    "_linuxdevel": ["failure"],
+    "_macbinary": ["success"],
+    "_wasmbinary": ["success"],
+    "_winbinary": ["success"],
+    "_status": ["success"],
+    "_buildurl": ["https://github.com/r-universe/r-multiverse/actions/runs/9624565626"]
+  },
+  "descriptions": {
+    "remotes": ["hyunjimoon/SBC", "stan-dev/cmdstanr"]
+  },
+  "date": ["2024-06-21"],
+  "version": ["0.1.1"],
+  "remote_hash": ["bbdda1b4a44a3d6a22041e03eed38f27319d8f32"]
+}

inst/mock/community/issues/community-notice

@@ -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/9624561349"]
+  },
+  "date": ["9999-12-31"],
+  "version": ["2.0.2"],
+  "remote_hash": ["b0a5ec38638ca69e3adbc7b24d815757e5f74817"]
+}

inst/mock/community/issues/community-remove

@@ -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/9624562787"]
+  },
+  "date": ["1980-01-01"],
+  "version": ["2.0.2"],
+  "remote_hash": ["476886da2b41a4d937543278dc12044889c9d4ca"]
+}

inst/mock/community/issues/community-versions

@@ -0,0 +1,11 @@
+{
+  "versions": {
+    "version_current": ["0.0.1"],
+    "hash_current": ["hash_0.0.1"],
+    "version_highest": ["1.0.0"],
+    "hash_highest": ["hash_1.0.0"]
+  },
+  "date": ["2024-01-01"],
+  "version": [],
+  "remote_hash": []
+}

inst/mock/community/issues/production-notice

@@ -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/9624561349"]
+  },
+  "date": ["9999-12-31"],
+  "version": ["2.0.2"],
+  "remote_hash": ["b0a5ec38638ca69e3adbc7b24d815757e5f74817"]
+}

inst/mock/community/issues/production-remove

@@ -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/9624562787"]
+  },
+  "date": ["1980-01-01"],
+  "version": ["2.0.2"],
+  "remote_hash": ["476886da2b41a4d937543278dc12044889c9d4ca"]
+}

inst/mock/community/issues/production-removing

@@ -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/9624562787"]
+  },
+  "date": ["1980-01-01"],
+  "version": ["2.0.2"],
+  "remote_hash": ["476886da2b41a4d937543278dc12044889c9d4ca"]
+}