Add support for viewer-based credentials on Posit Connect

DESCRIPTION

@@ -35,6 +35,7 @@ Imports:
 Suggests: 
     aws.ec2metadata,
     aws.signature,
+    connectcreds,
     covr,
     httpuv,
     knitr,
@@ -50,3 +51,5 @@ Encoding: UTF-8
 Language: en-US
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
+Remotes:
+    posit-dev/connectcreds

NAMESPACE

@@ -20,6 +20,7 @@ export(cred_funs_set)
 export(cred_funs_set_default)
 export(credentials_app_default)
 export(credentials_byo_oauth2)
+export(credentials_connect)
 export(credentials_external_account)
 export(credentials_gce)
 export(credentials_service_account)

NEWS.md

@@ -1,5 +1,8 @@
 # gargle (development version)
 
+* gargle can now pick up on Google credentials from the current Shiny session
+  when running on Posit Connect (@atheriel, #289).
+
 # gargle 1.5.2
 
 * Fixed a bug in an internal helper that validates input specifying a service

R/AuthState-class.R

@@ -106,7 +106,7 @@ AuthState <- R6::R6Class("AuthState", list(
   api_key = NULL,
   #' @field auth_active Logical, indicating whether auth is active.
   auth_active = NULL,
-  #' @field cred Credentials.
+  #' @field cred Global credentials.
   cred = NULL,
   #' @description Create a new AuthState
   #' @details For more details on the parameters, see [init_AuthState()]
@@ -200,25 +200,58 @@ AuthState <- R6::R6Class("AuthState", list(
   },
   #' @description Set credentials
   #' @param cred User credentials.
-  set_cred = function(cred) {
-    self$cred <- cred
+  #' @param id An identifier for these credentials, or `NULL` to set the global
+  #'   credentials.
+  set_cred = function(cred, id = NULL) {
+    if (hasName(cred, "id")) {
+      id <- cred$id
+    }
+    if (!is.null(id)) {
+      env_poke(private$session_creds, hash(id), cred)
+    } else {
+      self$cred <- cred
+    }
     invisible(self)
   },
   #' @description Clear credentials
-  clear_cred = function() {
-    self$set_cred(NULL)
+  #' @param id An identifier for the credentials, or `NULL` to clear the global
+  #'   credentials.
+  clear_cred = function(id = current_session_id()) {
+    if (!is.null(id) && env_has(private$session_creds, hash(id))) {
+      env_unbind(private$session_creds, hash(id))
+    } else {
+      self$cred <- NULL
+    }
+    invisible(self)
   },
   #' @description Get credentials
-  get_cred = function() {
+  #' @param id An identifier for the credentials, or `NULL` to get the global
+  #'   credentials.
+  get_cred = function(id = current_session_id()) {
+    if (!is.null(id)) {
+      cred <- env_get(private$session_creds, hash(id), default = NULL)
+      if (!is.null(cred)) {
+        return(cred)
+      }
+    }
     self$cred
   },
   #' @description Report if we have credentials
-  has_cred = function() {
+  #' @param id An identifier for the credentials, or `NULL` to check the global
+  #'   credentials.
+  has_cred = function(id = current_session_id()) {
     ## FIXME(jennybc): how should this interact with auth_active? should it?
-    !is.null(self$cred)
+    !is.null(self$get_cred(id = id))
   }
+), private = list(
+  session_creds = new_environment()
 ))
 
+current_session_id <- function() {
+  # For now, only Connect's notion of a session is relevant.
+  connect_session_id()
+}
+
 make_package_hint <- function(pkg) {
   hint <- NULL
   if (is_string(pkg)) {

R/cred_funs.R

@@ -142,6 +142,7 @@ cred_funs_clear <- function() {
 cred_funs_list_default <- function() {
   list(
     credentials_byo_oauth2       = credentials_byo_oauth2,
+    credentials_connect          = credentials_connect,
     credentials_service_account  = credentials_service_account,
     credentials_external_account = credentials_external_account,
     credentials_app_default      = credentials_app_default,

R/credentials_connect.R

@@ -0,0 +1,135 @@
+#' Get a token on Posit Connect
+#'
+#' @description
+#'
+#' `r lifecycle::badge('experimental')`
+#'
+#' Shiny apps running on Posit Connect [can retrieve Google credentials for each
+#' individual viewer](https://docs.posit.co/connect/user/oauth-integrations/).
+#'
+#' Requires the \pkg{connectcreds} package.
+#'
+#' @inheritParams token_fetch
+#' @returns A [httr::Token2.0()] or `NULL`.
+#' @family credential functions
+#' @examples
+#' credentials_connect()
+#' @export
+credentials_connect <- function(scopes = NULL, ...) {
+  gargle_debug("trying {.fun credentials_connect}")
+  if (!identical(Sys.getenv("RSTUDIO_PRODUCT"), "CONNECT")) {
+    gargle_debug(c("x" = "We don't seem to be on Posit Connect."))
+    return(NULL)
+  }
+  session <- current_shiny_session()
+  if (is.null(session)) {
+    gargle_debug(c("x" = "Viewer-based credentials only work in Shiny."))
+    return(NULL)
+  }
+  if (!is_installed("connectcreds")) {
+    gargle_debug(c(
+      "x" = "Viewer-based credentials 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."
+    ))
+    return(NULL)
+  }
+  token <- ConnectToken$new(session, scopes = normalize_scopes(scopes))
+  gargle_debug("Connect token: {.val {token$id}}")
+  token
+}
+
+current_shiny_session <- function() {
+  if (!isNamespaceLoaded("shiny")) {
+    return(NULL)
+  }
+  # Avoid taking a Suggests dependency on Shiny, which is otherwise irrelevant
+  # to gargle.
+  f <- get("getDefaultReactiveDomain", envir = asNamespace("shiny"))
+  f()
+}
+
+connect_session_id <- function(session = current_shiny_session()) {
+  if (is.null(session)) {
+    return(NULL)
+  }
+  session$request$HTTP_POSIT_CONNECT_USER_SESSION_TOKEN
+}
+
+#' @noRd
+ConnectToken <- R6::R6Class("ConnectToken", inherit = httr::Token2.0, list(
+  #' @field id The session identifier associated with this token.
+  id = NULL,
+
+  #' @description Get a token on Posit Connect.
+  #' @param session A Shiny session.
+  #' @param scopes A list of scopes to request for the token.
+  #' @return A ConnectToken.
+  initialize = function(session, scopes = NULL) {
+    gargle_debug("ConnectToken initialize")
+    self$id <- connect_session_id(session)
+    self$params <- list(scopes = scopes)
+    private$session <- session
+    self$init_credentials()
+  },
+
+  #' @description Enact the actual token exchange with Posit Connect.
+  init_credentials = function() {
+    gargle_debug("ConnectToken init_credentials")
+    scope <- NULL
+    if (!is.null(self$params$scopes)) {
+      scope <- paste(self$params$scopes, collapse = " ")
+    }
+    self$credentials <- connectcreds::connect_viewer_token(
+      private$session,
+      scope = scope
+    )
+    self
+  },
+
+  #' @description Refreshes the token, which means re-doing the entire token
+  #'   flow in this case.
+  refresh = function() {
+    gargle_debug("ConnectToken refresh")
+    # This is a slight misuse of httr's notion of "refreshing" a token, but it
+    # works in most cases.
+    self$init_credentials()
+  },
+
+  #' @description Format a [ConnectToken()].
+  #' @param ... Not used.
+  format = function(...) {
+    x <- list(
+      id = self$id,
+      scopes = self$params$scopes,
+      credentials = commapse(names(self$credentials))
+    )
+    c(
+      cli::cli_format_method(
+        cli::cli_h1("<ConnectToken (via {.pkg gargle})>")
+      ),
+      glue("{fr(names(x))}: {fl(x)}")
+    )
+  },
+
+  #' @description Print a [ConnectToken()].
+  #' @param ... Not used.
+  print = function(...) cli::cat_line(self$format()),
+
+  #' @description Returns `TRUE` if the token can be refreshed.
+  can_refresh = function() TRUE,
+
+  #' @description Placeholder implementation of required method. Returns self.
+  cache = function() self,
+
+  #' @description Placeholder implementation of required method. Returns self.
+  load_from_cache = function() self,
+
+  #' @description Placeholder implementation of required method. Not used.
+  validate = function() {},
+
+  #' @description Placeholder implementation of required method. Not used.
+  revoke = function() {}
+), private = list(session = NULL))