Add new write_board_manifest() function

NAMESPACE

@@ -134,6 +134,12 @@ S3method(required_pkgs,pins_board_ms365)
 S3method(required_pkgs,pins_board_rsconnect)
 S3method(required_pkgs,pins_board_s3)
 S3method(str,pins_hidden)
+S3method(write_board_manifest_yaml,default)
+S3method(write_board_manifest_yaml,pins_board_azure)
+S3method(write_board_manifest_yaml,pins_board_folder)
+S3method(write_board_manifest_yaml,pins_board_ms365)
+S3method(write_board_manifest_yaml,pins_board_s3)
+S3method(write_board_manifest_yaml,pins_board_url)
 export("%>%")
 export(board_azure)
 export(board_browse)
@@ -216,6 +222,8 @@ export(pin_write)
 export(required_pkgs)
 export(ui_addin_pin_find)
 export(ui_connection_create)
+export(write_board_manifest)
+export(write_board_manifest_yaml)
 import(rlang)
 importFrom(generics,required_pkgs)
 importFrom(glue,glue)

NEWS.md

@@ -15,6 +15,11 @@
   of files on disk. This means caches will no longer persist between sessions
   but will be much less likely to end up in a broken state (#667).
 
+* Added `write_board_manifest()` to write a manifest file `_pins.yaml` 
+  recording all pins and their versions to the board's root directory.
+  This function only works for boards that are not read-only
+  (#661, based on work of @ijlyttle).
+
 
 # pins 1.0.3
 

R/board.R

@@ -160,6 +160,99 @@ board_deparse.pins_board <- function(board, ...) {
   abort("This board doesn't support deparsing")
 }
 
+#' Write board manifest file to board's root directory
+#'
+#' A board manifest file records all the pins, along with their
+#' versions, stored on a board.
+#' This can be useful for a board built using, for example,
+#' [board_folder()] or [board_s3()], then served as a website,
+#' such that others can consume using [board_url()].
+#' The manifest file is _not_ versioned like a pin is, and this function
+#' will overwrite any existing `_pins.yaml` file on your board. It is
+#' your responsibility as the user to keep the manifest up to date.
+#'
+#' @details This function is not supported for read-only boards.
+#' It is called for the side-effect of writing a manifest file,
+#' `_pins.yaml`, to the root directory of the  `board`. (This will
+#' not work in the unlikely event that you attempt to create a pin
+#' called `"_pins.yaml"`.)
+#'
+#' The behavior of the legacy API (for example, [pin_find()]) is unspecified
+#' once you have written a board manifest file to a board's root directory.
+#' We recommend you only use `write_board_manifest()` with modern boards.
+#'
+#' @param board A pin board that is *not* read-only.
+#' @inheritParams pin_read
+#'
+#' @return The board, invisibly
+#' @export
+#'
+#' @examples
+#' board <- board_temp()
+#' pin_write(board, mtcars, "mtcars-csv", type = "csv")
+#' pin_write(board, mtcars, "mtcars-json", type = "json")
+#'
+#' write_board_manifest(board)
+#'
+#' # see the manifest's format:
+#' fs::path(board$path, "_pins.yaml") %>% readLines() %>% cat(sep = "\n")
+#'
+#' # if you write another pin, the manifest file is out of date:
+#' pin_write(board, 1:10, "nice-numbers", type = "json")
+#'
+#' # you decide when to update the manifest:
+#' write_board_manifest(board)
+#'
+write_board_manifest <- function(board, ...) {
+  manifest <- make_manifest(board)
+  write_board_manifest_yaml(board, manifest, ...)
+  pins_inform("Manifest file written to root folder of board, as `{manifest_pin_yaml_filename}`")
+  invisible(board)
+}
+
+manifest_pin_yaml_filename <- "_pins.yaml"
+
+make_manifest <- function(board) {
+  # given board, return named list:
+  #   - names are pin names
+  #   - values are relative paths to version directories
+
+  pin_names <- pin_list(board)
+
+  result <- map(
+    pin_names,
+    ~fs::path(.x, pin_versions(board, name = .x)$version) %>%
+      append_slash() %>% # versions usually don't include slash
+      as.list()
+  )
+  names(result) <- pin_names
+
+  result
+}
+
+#' Write a manifest YAML file for a board
+#'
+#' This is a low-level function that powers [write_board_manifest()]. It is
+#' needed primarily for folks developing new board types, and should not
+#' generally be called directly.
+#'
+#' @return `write_board_manifest_yaml()` is called for its side-effect of
+#' writing a manifest YAML file.
+#' @export
+#' @keywords internal
+#' @inheritParams write_board_manifest
+#' @param manifest Contents to be written to the manifest file, as a list.
+#'
+write_board_manifest_yaml <- function(board, manifest, ...) {
+  ellipsis::check_dots_used()
+  UseMethod("write_board_manifest_yaml")
+}
+
+#' @export
+write_board_manifest_yaml.default <- function(board, manifest, ...) {
+  abort(glue::glue("Manifest not supported for {class(board)[[1]]}"))
+}
+
 
 # helpers -----------------------------------------------------------------
 

R/board_azure.R

@@ -201,6 +201,24 @@ board_deparse.pins_board_azure <- function(board, ...) {
   expr(board_azure(!!container, path = !!board$path))
 }
 
+#' @export
+write_board_manifest_yaml.pins_board_azure <- function(board, manifest, ...) {
+
+  paths <- AzureStor::list_storage_files(board$container, info = "name")
+
+  if (manifest_pin_yaml_filename %in% paths) {
+    AzureStor::delete_storage_file(
+      board$container,
+      manifest_pin_yaml_filename,
+      confirm = FALSE
+    )
+  }
+
+  temp_file <- withr::local_tempfile()
+  yaml::write_yaml(manifest, file = temp_file)
+  azure_upload_file(board, src = temp_file, dest = manifest_pin_yaml_filename)
+}
+
 #' @rdname required_pkgs.pins_board
 #' @export
 required_pkgs.pins_board_azure <- function(x, ...) {
@@ -226,13 +244,11 @@ azure_ls <- function(board, dir = "") {
   paths <- AzureStor::list_storage_files(
     board$container,
     dir = dir,
-    recursive = FALSE,
-    info = "name"
+    recursive = FALSE
   )
-  unique(fs::path_file(paths))
+  unique(fs::path_file(paths$name[paths$isdir] %||% character(0)))
 }
 
-# TODO: implement this in AzureStor
 azure_dir_exists <- function(board, path) {
   dir <- azure_normalize_path(board, path)
   AzureStor::storage_dir_exists(board$container, dir)

R/board_folder.R

@@ -124,3 +124,11 @@ board_deparse.pins_board_folder <- function(board, ...) {
   path <- check_board_deparse(board, "path")
   expr(board_folder(path = !!as.character(path)))
 }
+
+#' @export
+write_board_manifest_yaml.pins_board_folder <- function(board, manifest, ...) {
+  yaml::write_yaml(
+    manifest,
+    file = fs::path(board$path, manifest_pin_yaml_filename)
+  )
+}

R/board_ms365.R

@@ -94,7 +94,8 @@ board_ms365 <- function(drive, path, versioned = TRUE, cache = NULL, delete_by_i
   }
 
   cache <- cache %||% board_cache_path(paste0("ms365-", hash(folder$properties$id)))
-  new_board_v1("pins_board_ms365",
+  new_board_v1(
+    "pins_board_ms365",
     folder = folder,
     path = path,
     cache = cache,
@@ -215,14 +216,21 @@ pin_store.pins_board_ms365 <- function(board, name, paths, metadata,
   name
 }
 
+#' @export
+write_board_manifest_yaml.pins_board_ms365 <- function(board, manifest, ...) {
+  temp_file <- withr::local_tempfile()
+  yaml::write_yaml(manifest, file = temp_file)
+  board$folder$upload(temp_file, manifest_pin_yaml_filename)
+}
+
 #' @rdname required_pkgs.pins_board
 #' @export
 required_pkgs.pins_board_ms365 <- function(x, ...) {
   ellipsis::check_dots_empty()
   "Microsoft365R"
 }
 
-# helpers
+# Helpers -----------------------------------------------------------------
 
 # list all the directories inside 'path', which is assumed to live in the board folder
 ms365_list_dirs <- function(board, path = "") {

R/board_s3.R

@@ -85,17 +85,17 @@
 #'
 #' }
 board_s3 <- function(
-                    bucket,
-                    prefix = NULL,
-                    versioned = TRUE,
-                    access_key = NULL,
-                    secret_access_key = NULL,
-                    session_token = NULL,
-                    credential_expiration = NULL,
-                    profile = NULL,
-                    region = NULL,
-                    endpoint = NULL,
-                    cache = NULL) {
+    bucket,
+    prefix = NULL,
+    versioned = TRUE,
+    access_key = NULL,
+    secret_access_key = NULL,
+    session_token = NULL,
+    credential_expiration = NULL,
+    profile = NULL,
+    region = NULL,
+    endpoint = NULL,
+    cache = NULL) {
 
   check_installed("paws.storage")
 
@@ -118,12 +118,12 @@ board_s3 <- function(
 
   cache <- cache %||% board_cache_path(paste0("s3-", bucket))
   new_board_v1("pins_board_s3",
-    name = "s3",
-    bucket = bucket,
-    prefix = prefix,
-    svc = svc,
-    cache = cache,
-    versioned = versioned
+               name = "s3",
+               bucket = bucket,
+               prefix = prefix,
+               svc = svc,
+               cache = cache,
+               versioned = versioned
   )
 }
 
@@ -134,11 +134,11 @@ board_s3_test <- function(...) {
   )
 
   board_s3("pins-test-hadley",
-    region = "us-east-2",
-    cache = tempfile(),
-    access_key = Sys.getenv("PINS_AWS_ACCESS_KEY"),
-    secret_access_key = Sys.getenv("PINS_AWS_SECRET_ACCESS_KEY"),
-    ...
+           region = "us-east-2",
+           cache = tempfile(),
+           access_key = Sys.getenv("PINS_AWS_ACCESS_KEY"),
+           secret_access_key = Sys.getenv("PINS_AWS_SECRET_ACCESS_KEY"),
+           ...
   )
 }
 
@@ -258,6 +258,11 @@ empty_string_to_null <- function(x) {
   if (is.null(x) || nchar(x) == 0) NULL else x
 }
 
+#' @export
+write_board_manifest_yaml.pins_board_s3 <- function(board, manifest, ...) {
+  s3_upload_yaml(board, key = manifest_pin_yaml_filename, yaml = manifest, ...)
+}
+
 #' @rdname required_pkgs.pins_board
 #' @export
 required_pkgs.pins_board_s3 <- function(x, ...) {

R/board_url.R

@@ -137,7 +137,12 @@ pin_delete.pins_board_url <- function(board, names, ...) {
 
 #' @export
 pin_store.pins_board_url <- function(board, name, paths, metadata,
-                                              versioned = NULL, ...) {
+                                     versioned = NULL, ...) {
+  abort_board_read_only("board_url")
+}
+
+#' @export
+write_board_manifest_yaml.pins_board_url <- function(board, manifest, ...) {
   abort_board_read_only("board_url")
 }
 

R/testthat.R

@@ -175,6 +175,23 @@ test_api_versioning <- function(board) {
 
 }
 
+test_api_manifest <- function(board) {
+  # assume that test_api_basic() has passed
+  name1 <- local_pin(board, 1:10, type = "csv")
+  name2 <- local_pin(board, 11:20, type = "json")
+  write_board_manifest(board)
+
+  testthat::test_that("manifest is not a pin", {
+    testthat::expect_false(pin_exists(board, manifest_pin_yaml_filename))
+    testthat::expect_false(manifest_pin_yaml_filename %in% pin_list(board))
+    testthat::expect_error(
+      pin_meta(board, manifest_pin_yaml_filename),
+      class = "pins_pin_missing"
+    )
+  })
+
+}
+
 # errors live here for now since they're closely bound to the tests
 
 abort_pin_missing <- function(name) {

R/utils.R

@@ -21,6 +21,12 @@ is_url <- function(x) {
   grepl("^http://|^https://", x)
 }
 
+append_slash <- function(x) {
+  has_slash <- grepl("/$", x)
+  x[!has_slash] <- paste0(x[!has_slash], "/")
+  x
+}
+
 is_testing <- function() {
   identical(Sys.getenv("TESTTHAT"), "true")
 }

_pkgdown.yml

@@ -36,6 +36,7 @@ reference:
 - title: Other functions
   contents:
   - cache_browse
+  - write_board_manifest
 
 - title: Legacy API
   desc: >