Add support for viewer-based credentials on Posit Connect.

This commit brings support for Posit Connect's "viewer-based
credentials" feature [0] to `gh`.

Checks for viewer-based credentials are designed to fall back gracefully
to existing authentication methods. This is intended to allow users to
-- for example -- develop and test a Shiny app that uses GitHub
credentials in desktop Positron/RStudio or Posit Workbench and deploy it
with no code changes to Connect.

Most of the actual work is outsourced to a new shared package,
`connectcreds` [1].

Unit tests are included.

[0]: https://docs.posit.co/connect/user/oauth-integrations/
[1]: https://github.com/posit-dev/connectcreds/

Signed-off-by: Aaron Jacobs <[email protected]>

Author: atheriel

DESCRIPTION

@@ -23,6 +23,7 @@ Imports:
     lifecycle,
     rlang (>= 1.0.0)
 Suggests:
+    connectcreds,
     covr,
     knitr,
     rmarkdown,
@@ -39,4 +40,5 @@ Language: en-US
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Remotes:  
+    posit-dev/connectcreds,
     r-lib/httr2

NEWS.md

@@ -4,6 +4,9 @@
 * `gh()` now uses a cache provided by httr2. This cache lives in `tools::R_user_dir("gh", "cache")`, maxes out at 100 MB, and can be disabled by setting `options(gh_cache = FALSE)` (#203).
 * Removes usage of mockery (@tanho63, #197)
 
+* `gh_token()` can now pick up on GitHub credentials from the current Shiny
+  session when running on Posit Connect (@atheriel, #217).
+
 # gh 1.4.1
 
 * `gh_next()`, `gh_prev()`, `gh_first()` and `gh_last()`

R/gh_token.R

@@ -46,8 +46,18 @@
 gh_token <- function(api_url = NULL) {
   api_url <- api_url %||% default_api_url()
   stopifnot(is.character(api_url), length(api_url) == 1)
+  host_url <- get_hosturl(api_url)
+  # Session credentials take precedence over static credentials.
+  session <- get_connect_session()
+  if (!is.null(session)) {
+    check_installed("connectcreds", "for viewer-based authentication")
+    if (connectcreds::has_viewer_token(session, host_url)) {
+      token <- connectcreds::connect_viewer_token(session, host_url)
+      return(gh_pat(token))
+    }
+  }
   token <- tryCatch(
-    gitcreds::gitcreds_get(get_hosturl(api_url)),
+    gitcreds::gitcreds_get(host_url),
     error = function(e) NULL
   )
   gh_pat(token$password %||% "")
@@ -56,15 +66,7 @@ gh_token <- function(api_url = NULL) {
 #' @export
 #' @rdname gh_token
 gh_token_exists <- function(api_url = NULL) {
-  api_url <- api_url %||% default_api_url()
-  tryCatch(
-    {
-      token <- gitcreds::gitcreds_get(get_hosturl(api_url))
-      gh_pat(token$password)
-      TRUE
-    } ,
-    error = function(e) FALSE
-  )
+  tryCatch(nzchar(gh_token(api_url)), error = function(e) FALSE)
 }
 
 gh_auth <- function(token) {
@@ -142,3 +144,30 @@ obfuscate <- function(x, first = 4, last = 4) {
     substr(x, start = nchar(x) - last + 1, stop = nchar(x))
   )
 }
+
+get_connect_session <- function() {
+  if (!identical(Sys.getenv("RSTUDIO_PRODUCT"), "CONNECT")) {
+    return(NULL)
+  }
+  if (!isNamespaceLoaded("shiny")) {
+    return(NULL)
+  }
+  if (is_installed("connectcreds")) {
+    # Avoid taking a Suggests dependency on Shiny, which is otherwise
+    # irrelevant to gh.
+    f <- get("getDefaultReactiveDomain", envir = asNamespace("shiny"))
+    return(f())
+  }
+  cli::cli_inform(
+    c(
+      "Viewer-based credentials for GitHub require the {.pkg connectcreds} \
+       package, but it is not installed.",
+      "i" = "Redeploy with {.pkg connectcreds} as a dependency if you wish to \
+             use viewer-based credentials. The most common way to do this is \
+             to add {.code library(connectcreds)} to your {.file app.R} file."
+    ),
+    .frequency = "once",
+    .frequency_id = "connectcreds_missing"
+  )
+  NULL
+}

tests/testthat/_snaps/gh_token.md

@@ -0,0 +1,75 @@
+# missing viewer credentials can be debugged
+
+    Code
+      . <- gh_token()
+    Message
+      No viewer-based credentials found.
+      Caused by error in `connect_viewer_token()`:
+      ! Viewer-based credentials are not supported by this version of Connect.
+
+# token exchange requests to Connect look correct
+
+    Code
+      list(url = req$url, headers = req$headers, body = req$body$data)
+    Output
+      $url
+      [1] "localhost:3030/__api__/v1/oauth/integrations/credentials"
+      
+      $headers
+      $headers$Authorization
+      [1] "Key key"
+      
+      $headers$Accept
+      [1] "application/json"
+      
+      attr(,"redact")
+      [1] "Authorization"
+      
+      $body
+      $body$grant_type
+      [1] "urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Atoken-exchange"
+      
+      $body$subject_token
+      [1] "user-token"
+      
+      $body$subject_token_type
+      [1] "urn%3Aposit%3Aconnect%3Auser-session-token"
+      
+      $body$resource
+      [1] "https%3A%2F%2Fgithub.com"
+      
+      
+
+---
+
+    Code
+      list(url = req$url, headers = req$headers, body = req$body$data)
+    Output
+      $url
+      [1] "localhost:3030/__api__/v1/oauth/integrations/credentials"
+      
+      $headers
+      $headers$Authorization
+      [1] "Key key"
+      
+      $headers$Accept
+      [1] "application/json"
+      
+      attr(,"redact")
+      [1] "Authorization"
+      
+      $body
+      $body$grant_type
+      [1] "urn%3Aietf%3Aparams%3Aoauth%3Agrant-type%3Atoken-exchange"
+      
+      $body$subject_token
+      [1] "user-token"
+      
+      $body$subject_token_type
+      [1] "urn%3Aposit%3Aconnect%3Auser-session-token"
+      
+      $body$resource
+      [1] "https%3A%2F%2Fgithub.com"
+      
+      
+

tests/testthat/test-gh_token.R

@@ -163,3 +163,37 @@ test_that("get_apiurl() works", {
   expect_equal(get_apiurl("https://github.acme.com/OWNER/REPO"), x)
   expect_equal(get_apiurl("https://github.acme.com/api/v3"), x)
 })
+
+test_that("missing viewer credentials can be debugged", {
+  # Mock a Connect environment that *does not* support viewer-based credentials.
+  withr::local_envvar(RSTUDIO_PRODUCT = "CONNECT")
+  local_mocked_bindings(get_connect_session = function() {
+    structure(list(request = list()), class = "ShinySession")
+  })
+  local_options(connectcreds_debug = TRUE)
+  expect_snapshot(. <- gh_token())
+})
+
+test_that("token exchange requests to Connect look correct", {
+  # Mock a Connect environment that supports viewer-based credentials.
+  withr::local_envvar(
+    RSTUDIO_PRODUCT = "CONNECT",
+    CONNECT_SERVER = "localhost:3030",
+    CONNECT_API_KEY = "key"
+  )
+  local_mocked_bindings(get_connect_session = function() {
+    structure(
+      list(request = list(HTTP_POSIT_CONNECT_USER_SESSION_TOKEN = "user-token")),
+      class = "ShinySession"
+    )
+  })
+  token <- strrep("a", 40)
+  httr2::local_mocked_responses(function(req) {
+    # Snapshot relevant fields of the outgoing request.
+    expect_snapshot(
+      list(url = req$url, headers = req$headers, body = req$body$data)
+    )
+    httr2::response_json(body = list(access_token = token))
+  })
+  expect_equal(gh_token(), gh_pat(token))
+})