New add_headers argument to board_url() (#732)

* New `add_headers()` argument for `board_url()`

* Test headers handling

* Redocument

* Add docs section for using new `add_headers`

* Add `board_connect_url()` and `connect_auth_headers()`, plus test the new auth

* Add tests for new auth in `board_url()` via `board_connect_url()`

* Redocument

* Update NEWS

* Use same args in `board_connect_url()` as `board_url()`

* Reuse param from `board_connect()`

* Add new board to pkgdown

* Skip if no rsconnect (because of checking for Colorado)

* Improve docs

* Apply suggestions from code review

Co-authored-by: Hadley Wickham <[email protected]>

* Switch to `headers`, a named character vector, and update tests

---------

Co-authored-by: Hadley Wickham <[email protected]>

.github/rstudio-connect.gcfg

@@ -11,6 +11,7 @@ Provider = pam
 
 [Authorization]
 DefaultUserRole = publisher
+PublishersCanManageVanities = true
 
 [RPackageRepository "CRAN"]
 URL = https://packagemanager.rstudio.com/cran/__linux__/bionic/latest

DESCRIPTION

@@ -48,6 +48,7 @@ Suggests:
     filelock,
     gitcreds,
     googleCloudStorageR,
+    ids,
     knitr,
     Microsoft365R,
     mime,

NAMESPACE

@@ -155,6 +155,7 @@ export(board_azure)
 export(board_browse)
 export(board_cache_path)
 export(board_connect)
+export(board_connect_url)
 export(board_default)
 export(board_deparse)
 export(board_deregister)
@@ -193,6 +194,7 @@ export(board_url)
 export(cache_browse)
 export(cache_info)
 export(cache_prune)
+export(connect_auth_headers)
 export(legacy_azure)
 export(legacy_datatxt)
 export(legacy_dospace)

NEWS.md

@@ -10,6 +10,9 @@
 
 * Added new check for whether a new version is the same as the previous version,
   as can happen when writing pin versions very quickly (#727).
+
+* Added new `headers` argument for `board_url()`, mostly for authentication, as 
+  well as new board for Connect vanity URLs `board_connect_url()` (#732).  
 
 # pins 1.1.0
 

R/board_connect_url.R

@@ -0,0 +1,91 @@
+#' Use a vector of Posit Connect vanity URLs as a board
+#'
+#' @description
+#' `board_connect_url()` lets you build up a board from individual
+#' [vanity urls](https://docs.posit.co/connect/user/content-settings/#custom-url).
+#'
+#' `board_connect_url()` is read only, and does not support versioning.
+#'
+#' @param vanity_urls A named character vector of
+#'   [Connect vanity URLs](https://docs.posit.co/connect/user/content-settings/#custom-url).
+#'   This board is read only, and the best way to write to a pin on Connect is
+#'   [board_connect()].
+#' @family boards
+#' @inheritParams new_board
+#' @inheritParams board_url
+#' @inheritParams board_connect
+#' @details
+#' This board is a thin wrapper around [board_url()] which uses
+#' `connect_auth_headers()` for authentication via environment variable.
+#' @export
+#' @examplesIf interactive()
+#' connect_auth_headers()
+#'
+#' board <- board_connect_url(c(
+#'     my_vanity_url_pin = "https://colorado.posit.co/rsc/great-numbers/"
+#' ))
+#'
+#' board %>% pin_read("my_vanity_url_pin")
+#'
+board_connect_url <- function(vanity_urls,
+                              cache = NULL,
+                              use_cache_on_failure = is_interactive(),
+                              headers = connect_auth_headers()) {
+  board_url(
+    urls = vanity_urls,
+    cache = cache,
+    use_cache_on_failure = use_cache_on_failure,
+    headers = headers
+  )
+}
+
+#' @export
+#' @rdname board_connect_url
+connect_auth_headers <- function(key = Sys.getenv("CONNECT_API_KEY")) {
+  c(Authorization = paste("Key", key))
+}
+
+
+vanity_url_test <- function(env = parent.frame()) {
+  board <- board_connect_test()
+  name <- pin_write(board, 1:10, random_pin_name())
+  withr::defer(if (pin_exists(board, name)) pin_delete(board, name), env)
+
+  vanity_slug <- ids::adjective_animal()
+  body_path <- withr::local_tempfile()
+  body <- list(force = FALSE, path = glue("/{vanity_slug}/"))
+  jsonlite::write_json(body, body_path, auto_unbox = TRUE)
+  body <- httr::upload_file(body_path, "application/json")
+
+  meta <- pin_meta(board, name)
+  path <- glue("v1/content/{meta$local$content_id}/vanity")
+  path <- rsc_path(board, path)
+  auth <- rsc_auth(board, path, "PUT", body_path)
+  resp <- httr::PUT(board$url, path = path, body = body, auth)
+  httr::stop_for_status(resp)
+
+  glue("{board$url}/{vanity_slug}/")
+}
+
+board_connect_url_test <- function(...) {
+  if (connect_has_colorado()) {
+    board_connect_url_colorado(...)
+  } else {
+    board_connect_url_susan(...)
+  }
+}
+
+board_connect_url_colorado <- function(...) {
+  if (!connect_has_colorado()) {
+    testthat::skip("board_connect_url_colorado() only works with Posit's demo server")
+  }
+  board_connect_url(..., cache = fs::file_temp())
+}
+
+board_connect_url_susan <- function(...) {
+  creds <- read_creds()
+  board_connect_url(
+    ...,
+    headers = connect_auth_headers(creds$susan_key)
+  )
+}

R/board_url.R

@@ -14,6 +14,8 @@
 #'   use the last cached version? Defaults to `is_interactive()` so you'll
 #'   be robust to poor internet connectivity when exploring interactively,
 #'   but you'll get clear errors when the code is deployed.
+#' @param headers Named character vector for additional HTTP headers (such as for
+#'   authentication). See [connect_auth_headers()] for Posit Connect support.
 #' @family boards
 #' @inheritParams new_board
 #' @details
@@ -42,9 +44,26 @@
 #' Using a [manifest file][write_board_manifest()] can be useful because you
 #' can serve a board of pins and allow collaborators to access the board
 #' straight from a URL, without worrying about board-level storage details.
-#'
 #' Some examples are provided in `vignette("using-board-url")`.
 #'
+#' # Authentication for `board_url()`
+#'
+#' The `headers` argument allows you to pass authentication details or other
+#' HTTP headers to the board, such as for a Posit Connect vanity URL that is
+#' not public (see [board_connect_url()]) or a private GitHub repo.
+#'
+#' ```r
+#' gh_pat_auth <- c(
+#'   Authorization = paste("token", "github_pat_XXXX")
+#' )
+#' board <- board_url(
+#'   "https://raw.githubusercontent.com/username/repo/main/path/to/pins",
+#'   headers = gh_pat_auth
+#' )
+#'
+#' board %>% pin_list()
+#' ```
+#'
 #' @export
 #' @examples
 #' github_raw <- function(x) paste0("https://raw.githubusercontent.com/", x)
@@ -69,15 +88,18 @@
 #'
 board_url <- function(urls,
                       cache = NULL,
-                      use_cache_on_failure = is_interactive()) {
+                      use_cache_on_failure = is_interactive(),
+                      headers = NULL) {
 
+  check_headers(headers)
   url_format <- get_url_format(urls)
   if (url_format == "pins_yaml") {
-    manifest <- get_manifest(urls)
+    manifest <- get_manifest(urls, headers)
     board <- board_url(
       manifest,
       cache = cache,
-      use_cache_on_failure = use_cache_on_failure
+      use_cache_on_failure = use_cache_on_failure,
+      headers = headers
     )
     return(board)
   }
@@ -92,7 +114,8 @@ board_url <- function(urls,
     urls = urls,
     cache = cache,
     versioned = versioned,
-    use_cache_on_failure = use_cache_on_failure
+    use_cache_on_failure = use_cache_on_failure,
+    headers = headers
   )
 }
 
@@ -136,7 +159,8 @@ pin_meta.pins_board_url <- function(board, name, version = NULL, ...) {
       url = paste0(url, "data.txt"),
       path_dir = cache_dir,
       path_file = "data.txt",
-      use_cache_on_failure = board$use_cache_on_failure
+      use_cache_on_failure = board$use_cache_on_failure,
+      headers = board$headers
     )
     meta <- read_meta(cache_dir)
     local_meta(
@@ -187,7 +211,8 @@ pin_fetch.pins_board_url <- function(board, name, version = NULL, ...) {
       url = url,
       path_dir = meta$local$dir,
       path_file = file,
-      use_cache_on_failure = board$use_cache_on_failure
+      use_cache_on_failure = board$use_cache_on_failure,
+      headers = board$headers
     )
   })
 
@@ -240,7 +265,7 @@ get_url_format <- function(urls) {
   }
 }
 
-get_manifest <- function(url, call = rlang::caller_env()) {
+get_manifest <- function(url, headers, call = rlang::caller_env()) {
   # if ends with "/", look for manifest
   if (grepl("/$", url)) {
     url <- paste0(url, manifest_pin_yaml_filename)
@@ -249,7 +274,7 @@ get_manifest <- function(url, call = rlang::caller_env()) {
   # if request fails or returns with error code
   tryCatch(
     {
-      resp <- httr::GET(url)
+      resp <- httr::GET(url, httr::add_headers(headers))
       httr::stop_for_status(resp)
     },
     error = function(e) {
@@ -293,6 +318,7 @@ get_manifest <- function(url, call = rlang::caller_env()) {
 
 http_download <- function(url, path_dir, path_file, ...,
                           use_cache_on_failure = FALSE,
+                          headers = NULL,
                           on_failure = NULL) {
   cache_path <- download_cache_path(path_dir)
   cache <- read_cache(cache_path)[[url]]
@@ -303,12 +329,11 @@ http_download <- function(url, path_dir, path_file, ...,
       return(cache$path)
     }
 
-    headers <- httr::add_headers(
+    headers <- c(
+      headers,
       `If-Modified-Since` = http_date(cache$modified),
       `If-None-Match` = cache$etag
     )
-  } else {
-    headers <- NULL
   }
 
   path <- fs::path(path_dir, path_file)
@@ -317,7 +342,7 @@ http_download <- function(url, path_dir, path_file, ...,
   write_out <- httr::write_disk(tmp_path)
 
   req <- tryCatch(
-    httr::GET(url, headers, ..., write_out),
+    httr::GET(url, httr::add_headers(headers), ..., write_out),
     error = function(e) {
       if (!is.null(cache) && use_cache_on_failure) {
         NULL
@@ -403,3 +428,10 @@ http_date <- function(x = Sys.time(), tz = "UTC") {
   withr::local_locale(LC_TIME = "C")
   strftime(.POSIXct(x), "%a, %d %b %Y %H:%M:%S", tz = tz, usetz = TRUE)
 }
+
+check_headers <- function(x, arg = caller_arg(x), call = caller_env()) {
+  if (!is.null(x) && (!is_character(x) || !is_named(x))) {
+    stop_input_type(x, "a named character vector", allow_null = TRUE, arg = arg, call = call)
+  }
+
+}

_pkgdown.yml

@@ -28,6 +28,7 @@ reference:
   contents:
   - board_azure
   - board_connect
+  - board_connect_url
   - board_gcs
   - board_local
   - board_ms365