Add new board_gcs() for Google Cloud Storage

.github/workflows/check-boards.yaml

@@ -21,6 +21,7 @@ jobs:
       PINS_AZURE_ACCOUNT: ${{ secrets.PINS_AZURE_ACCOUNT }}
       PINS_AWS_ACCESS_KEY: ${{ secrets.PINS_AWS_ACCESS_KEY}}
       PINS_AWS_SECRET_ACCESS_KEY: ${{ secrets.PINS_AWS_SECRET_ACCESS_KEY}}
+      PINS_GCS_PASSWORD: ${{ secrets.PINS_GCS_PASSWORD }}
       PINS_KAGGLE_USERNAME: ${{ secrets.PINS_KAGGLE_USERNAME }}
       PINS_KAGGLE_KEY: ${{ secrets.PINS_KAGGLE_KEY }}
 

.gitignore

@@ -8,3 +8,4 @@ packages
 docs
 inst/doc
 .Renviron
+google-pins.json

DESCRIPTION

@@ -48,6 +48,7 @@ Suggests:
     data.table,
     datasets,
     gitcreds,
+    googleCloudStorageR,
     knitr,
     Microsoft365R,
     mockery,
@@ -57,6 +58,7 @@ Suggests:
     rmarkdown,
     rsconnect,
     shiny,
+    sodium,
     testthat (>= 3.0.0),
     webfakes,
     xml2

NAMESPACE

@@ -10,6 +10,7 @@ S3method(board_deparse,pins_board)
 S3method(board_deparse,pins_board_azure)
 S3method(board_deparse,pins_board_connect)
 S3method(board_deparse,pins_board_folder)
+S3method(board_deparse,pins_board_gcs)
 S3method(board_deparse,pins_board_kaggle_competition)
 S3method(board_deparse,pins_board_kaggle_dataset)
 S3method(board_deparse,pins_board_s3)
@@ -54,6 +55,7 @@ S3method(pin,default)
 S3method(pin_delete,pins_board_azure)
 S3method(pin_delete,pins_board_connect)
 S3method(pin_delete,pins_board_folder)
+S3method(pin_delete,pins_board_gcs)
 S3method(pin_delete,pins_board_kaggle_competition)
 S3method(pin_delete,pins_board_kaggle_dataset)
 S3method(pin_delete,pins_board_ms365)
@@ -62,6 +64,7 @@ S3method(pin_delete,pins_board_url)
 S3method(pin_exists,pins_board_azure)
 S3method(pin_exists,pins_board_connect)
 S3method(pin_exists,pins_board_folder)
+S3method(pin_exists,pins_board_gcs)
 S3method(pin_exists,pins_board_kaggle_competition)
 S3method(pin_exists,pins_board_kaggle_dataset)
 S3method(pin_exists,pins_board_ms365)
@@ -70,6 +73,7 @@ S3method(pin_exists,pins_board_url)
 S3method(pin_fetch,pins_board_azure)
 S3method(pin_fetch,pins_board_connect)
 S3method(pin_fetch,pins_board_folder)
+S3method(pin_fetch,pins_board_gcs)
 S3method(pin_fetch,pins_board_kaggle_competition)
 S3method(pin_fetch,pins_board_kaggle_dataset)
 S3method(pin_fetch,pins_board_ms365)
@@ -78,6 +82,7 @@ S3method(pin_fetch,pins_board_url)
 S3method(pin_list,pins_board_azure)
 S3method(pin_list,pins_board_connect)
 S3method(pin_list,pins_board_folder)
+S3method(pin_list,pins_board_gcs)
 S3method(pin_list,pins_board_kaggle_competition)
 S3method(pin_list,pins_board_kaggle_dataset)
 S3method(pin_list,pins_board_local)
@@ -91,6 +96,7 @@ S3method(pin_load,table)
 S3method(pin_meta,pins_board_azure)
 S3method(pin_meta,pins_board_connect)
 S3method(pin_meta,pins_board_folder)
+S3method(pin_meta,pins_board_gcs)
 S3method(pin_meta,pins_board_kaggle_competition)
 S3method(pin_meta,pins_board_kaggle_dataset)
 S3method(pin_meta,pins_board_ms365)
@@ -103,6 +109,7 @@ S3method(pin_search,pins_board_kaggle_dataset)
 S3method(pin_store,pins_board_azure)
 S3method(pin_store,pins_board_connect)
 S3method(pin_store,pins_board_folder)
+S3method(pin_store,pins_board_gcs)
 S3method(pin_store,pins_board_kaggle_competition)
 S3method(pin_store,pins_board_kaggle_dataset)
 S3method(pin_store,pins_board_ms365)
@@ -112,13 +119,15 @@ S3method(pin_version_delete,pins_board)
 S3method(pin_version_delete,pins_board_azure)
 S3method(pin_version_delete,pins_board_connect)
 S3method(pin_version_delete,pins_board_folder)
+S3method(pin_version_delete,pins_board_gcs)
 S3method(pin_version_delete,pins_board_ms365)
 S3method(pin_version_delete,pins_board_s3)
 S3method(pin_version_delete,pins_board_url)
 S3method(pin_versions,pins_board)
 S3method(pin_versions,pins_board_azure)
 S3method(pin_versions,pins_board_connect)
 S3method(pin_versions,pins_board_folder)
+S3method(pin_versions,pins_board_gcs)
 S3method(pin_versions,pins_board_kaggle_dataset)
 S3method(pin_versions,pins_board_ms365)
 S3method(pin_versions,pins_board_s3)
@@ -130,6 +139,7 @@ S3method(print,pins_meta)
 S3method(required_pkgs,pins_board)
 S3method(required_pkgs,pins_board_azure)
 S3method(required_pkgs,pins_board_connect)
+S3method(required_pkgs,pins_board_gcs)
 S3method(required_pkgs,pins_board_ms365)
 S3method(required_pkgs,pins_board_s3)
 S3method(str,pins_hidden)
@@ -149,6 +159,7 @@ export(board_deparse)
 export(board_deregister)
 export(board_desc)
 export(board_folder)
+export(board_gcs)
 export(board_get)
 export(board_initialize)
 export(board_kaggle_competitions)

NEWS.md

@@ -13,6 +13,8 @@
 
 ## Other improvements
 
+* Added new board for Google Cloud Storage `board_gcs()` (#695).
+
 * Added vignette describing how to manage custom formats (#631, @ijlyttle).
 
 * Improved error message for `pin_versions()` (#657).

R/board_gcs.R

@@ -0,0 +1,262 @@
+#' Use a Google Cloud Storage bucket as a board
+#'
+#' Pin data to a Google Cloud Storage bucket using the googleCloudStorageR
+#' package.
+#'
+#' # Authentication
+#'
+#' `board_gcs()` is powered by the googleCloudStorageR package which provides
+#' several authentication options, as documented in its
+#' [main vignette](https://code.markedmondson.me/googleCloudStorageR/articles/googleCloudStorageR.html).
+#' The two main options are to create a service account key (a JSON file) or an
+#' authentication token; you can manage either using the [gargle](https://gargle.r-lib.org/) package.
+#'
+#' # Details
+#'
+#' * The functions in pins do not create a new bucket. You can create
+#'   a new bucket from R with [googleCloudStorageR::gcs_create_bucket()].
+#' * You can pass arguments for [googleCloudStorageR::gcs_upload] such as
+#'   `predefinedAcl` and `upload_type` through the dots of `pin_write()`.
+#' * `board_gcs()` is powered by the googleCloudStorageR package, which is a
+#'   suggested dependency of pins (not required for pins in general). If
+#'   you run into errors when deploying content to a server like
+#'   <https://shinyapps.io> or [Connect](https://posit.co/products/enterprise/connect/),
+#'   add `library(googleCloudStorageR)` to your app or document for [automatic
+#'   dependency discovery](https://support.posit.co/hc/en-us/articles/229998627-Why-does-my-app-work-locally-but-not-on-my-RStudio-Connect-server).
+#'
+#' @inheritParams new_board
+#' @param bucket Bucket name. You can only write to an existing bucket. Defaults
+#'   to [googleCloudStorageR::gcs_get_global_bucket()].
+#' @param prefix Prefix within this bucket that this board will occupy.
+#'   You can use this to maintain multiple independent pin boards within
+#'   a single GCS bucket. Will typically end with `/` to take advantage of
+#'   Google Cloud Storage's directory-like handling.
+#' @export
+#' @examples
+#' \dontrun{
+#' board <- board_gcs()
+#' board %>% pin_write(mtcars)
+#' board %>% pin_read("mtcars")
+#'
+#' # A prefix allows you to have multiple independent boards in the same pin.
+#' board_sales <- board_gcs("company-pins", prefix = "sales/")
+#' board_marketing <- board_gcs("company-pins", prefix = "marketing/")
+#' # You can make the hierarchy arbitrarily deep.
+#'
+#' # Pass arguments like `predefinedAcl` through the dots of `pin_write`:
+#' board %>% pin_write(mtcars, predefinedAcl = "publicRead")
+#' }
+board_gcs <- function(bucket = googleCloudStorageR::gcs_get_global_bucket(),
+                      prefix = NULL,
+                      versioned = TRUE,
+                      cache = NULL) {
+
+  check_installed("googleCloudStorageR")
+
+  # Check that have access to the bucket
+  invisible(googleCloudStorageR::gcs_get_bucket(bucket))
+
+  cache <- cache %||% board_cache_path(paste0("gcs-", bucket))
+  new_board_v1("pins_board_gcs",
+               name = "gcs",
+               bucket = bucket,
+               prefix = prefix,
+               cache = cache,
+               versioned = versioned
+  )
+}
+
+board_gcs_test <- function(...) {
+
+  skip_if_missing_envvars(
+    tests = "board_gcs()",
+    envvars = c("PINS_GCS_PASSWORD")
+  )
+
+  rlang::check_installed("sodium")
+  path_to_encrypted_json <- fs::path_package("pins", "secret", "pins-gcs-testing.json")
+  raw <- readBin(path_to_encrypted_json, "raw", file.size(path_to_encrypted_json))
+  pw <- Sys.getenv("PINS_GCS_PASSWORD", "")
+  json <- sodium::data_decrypt(
+    bin = raw,
+    key = sodium::sha256(charToRaw(pw)),
+    nonce = secret_nonce()
+  )
+  googleCloudStorageR::gcs_auth(json_file = rawToChar(json))
+
+  board_gcs("pins-dev",
+            cache = tempfile(),
+            ...
+  )
+}
+
+#' @export
+pin_list.pins_board_gcs <- function(board, ...) {
+  NA
+}
+
+#' @export
+pin_exists.pins_board_gcs <- function(board, name, ...) {
+  withr::local_options(list(googleAuthR.verbose = 4))
+  gcs_file_exists(board, name)
+}
+
+#' @export
+pin_delete.pins_board_gcs <- function(board, names, ...) {
+  for (name in names) {
+    check_pin_exists(board, name)
+    gcs_delete_dir(board, name)
+  }
+  invisible(board)
+}
+
+#' @export
+pin_versions.pins_board_gcs <- function(board, name, ...) {
+  check_pin_exists(board, name)
+  resp <- googleCloudStorageR::gcs_list_objects(
+    bucket = board$bucket,
+    prefix = paste0(board$prefix, name)
+  )
+  paths <- fs::path_split(unique(fs::path_dir(resp$name)))
+  version_from_path(map_chr(paths, ~ .x[[length(.x)]]))
+}
+
+#' @export
+pin_version_delete.pins_board_gcs <- function(board, name, version, ...) {
+  gcs_delete_dir(board, fs::path(name, version))
+}
+
+#' @export
+pin_meta.pins_board_gcs <- function(board, name, version = NULL, ...) {
+  withr::local_options(list(googleAuthR.verbose = 4))
+  check_pin_exists(board, name)
+  version <- check_pin_version(board, name, version)
+  metadata_blob <- fs::path(name, version, "data.txt")
+
+  if (!gcs_file_exists(board, metadata_blob)) {
+    abort_pin_version_missing(version)
+  }
+
+  path_version <- fs::path(board$cache, name, version)
+  fs::dir_create(path_version)
+  gcs_download(board, metadata_blob)
+  local_meta(
+    read_meta(fs::path(board$cache, name, version)),
+    name = name,
+    dir = path_version,
+    version = version
+  )
+}
+
+#' @export
+pin_fetch.pins_board_gcs <- function(board, name, version = NULL, ...) {
+  withr::local_options(list(googleAuthR.verbose = 4))
+  meta <- pin_meta(board, name, version = version)
+  cache_touch(board, meta)
+
+  for (file in meta$file) {
+    key <- fs::path(name, meta$local$version, file)
+    gcs_download(board, key)
+  }
+
+  meta
+}
+
+#' @export
+pin_store.pins_board_gcs <- function(board, name, paths, metadata,
+                                     versioned = NULL, x = NULL, ...) {
+  withr::local_options(list(googleAuthR.verbose = 4))
+  ellipsis::check_dots_used()
+  check_name(name)
+  version <- version_setup(board, name, version_name(metadata), versioned = versioned)
+  version_dir <- fs::path(name, version)
+  gcs_upload_yaml(
+    board,
+    fs::path(paste0(board$prefix, version_dir), "data.txt"),
+    metadata
+  )
+
+  for (path in paths) {
+    googleCloudStorageR::gcs_upload(
+      file = path,
+      bucket = board$bucket,
+      name = fs::path(paste0(board$prefix, version_dir), fs::path_file(path)),
+      ...
+    )
+  }
+
+  name
+}
+
+#' @rdname board_deparse
+#' @export
+board_deparse.pins_board_gcs <- function(board, ...) {
+  bucket <- check_board_deparse(board, "bucket")
+  expr(board_gcs(!!bucket, prefix = !!board$prefix))
+}
+
+#' @rdname required_pkgs.pins_board
+#' @export
+required_pkgs.pins_board_gcs <- function(x, ...) {
+  ellipsis::check_dots_empty()
+  "googleCloudStorageR"
+}
+
+# Helpers -----------------------------------------------------------------
+
+gcs_delete_dir <- function(board, dir) {
+  resp <- googleCloudStorageR::gcs_list_objects(
+    bucket = board$bucket,
+    prefix = paste0(board$prefix, dir, "/")
+  )
+
+  if (nrow(resp) == 0) {
+    return(invisible())
+  }
+
+  for (path in resp$name) {
+    googleCloudStorageR::gcs_delete_object(path, bucket = board$bucket)
+  }
+
+  invisible()
+}
+
+gcs_upload_yaml <- function(board, key, yaml, ...) {
+  temp_file <- withr::local_tempfile()
+  yaml::write_yaml(yaml, file = temp_file)
+  googleCloudStorageR::gcs_upload(
+    file = temp_file,
+    bucket = board$bucket,
+    type = "text/yaml",
+    name = key,
+    ...
+  )
+}
+
+gcs_download <- function(board, key) {
+  path <- fs::path(board$cache, key)
+  if (!fs::file_exists(path)) {
+    suppressMessages(googleCloudStorageR::gcs_get_object(
+      object_name = paste0(board$prefix, key),
+      bucket = board$bucket,
+      saveToDisk = path
+    ))
+    fs::file_chmod(path, "u=r")
+  }
+  path
+}
+
+gcs_file_exists <- function(board, name) {
+  resp <- googleCloudStorageR::gcs_list_objects(
+    bucket = board$bucket,
+    prefix = paste0(board$prefix, name)
+  )
+  nrow(resp) > 0
+}
+
+## for decrypting JSON for service account:
+secret_nonce <- function() {
+  sodium::hex2bin("cb36bab652dec6ae9b1827c684a7b6d21d2ea31cd9f766ac")
+}
+
+