Add support for viewer-based Databricks & Snowflake credentials

DESCRIPTION

@@ -31,6 +31,7 @@ Imports:
 Suggests:
     covr,
     DBItest,
+    httr2,
     knitr,
     magrittr,
     rmarkdown,

NEWS.md

@@ -25,6 +25,10 @@
 
 * SQL Server: Fix issue related to writing when using SIMBA drivers (#816).
 
+* `snowflake()` and `databricks()` now accept a `session` argument for passing
+  viewer-based OAuth credentials from Shiny sessions on Posit Connect
+  (@atheriel, #853).
+
 # odbc 1.5.0
 
 ## Major changes

R/driver-databricks.R

@@ -31,6 +31,8 @@ NULL
 #'   default name.
 #' @param uid,pwd Manually specify a username and password for authentication.
 #'   Specifying these options will disable automated credential discovery.
+#' @param session A Shiny session object, when using viewer-based credentials on
+#'   Posit Connect.
 #' @param ... Further arguments passed on to [`dbConnect()`].
 #'
 #' @returns An `OdbcConnection` object with an active connection to a Databricks
@@ -42,6 +44,16 @@ NULL
 #'   odbc::databricks(),
 #'   httpPath = "sql/protocolv1/o/4425955464597947/1026-023828-vn51jugj"
 #' )
+#'
+#' # Use credentials from the viewer (when possible) in a Shiny app
+#' # deployed to Posit Connect.
+#' server <- function(input, output, session) {
+#'   conn <- DBI::dbConnect(
+#'     odbc::databricks(),
+#'     httpPath = "sql/protocolv1/o/4425955464597947/1026-023828-vn51jugj",
+#'     session = session
+#'   )
+#' }
 #' }
 #' @export
 databricks <- function() {
@@ -64,6 +76,7 @@ setMethod("dbConnect", "DatabricksOdbcDriver",
            HTTPPath,
            uid = NULL,
            pwd = NULL,
+           session = NULL,
            ...) {
     call <- caller_env()
     # For backward compatibility with RStudio connection string
@@ -74,6 +87,7 @@ setMethod("dbConnect", "DatabricksOdbcDriver",
     check_string(driver, allow_null = TRUE, call = call)
     check_string(uid, allow_null = TRUE, call = call)
     check_string(pwd, allow_null = TRUE, call = call)
+    check_shiny_session(session, allow_null = TRUE, call = call)
 
     args <- databricks_args(
       httpPath = if (missing(httpPath)) HTTPPath else httpPath,
@@ -82,6 +96,7 @@ setMethod("dbConnect", "DatabricksOdbcDriver",
       driver = driver,
       uid = uid,
       pwd = pwd,
+      session = session,
       ...
     )
     inject(dbConnect(odbc(), !!!args))
@@ -94,6 +109,7 @@ databricks_args <- function(httpPath,
                             driver = NULL,
                             uid = NULL,
                             pwd = NULL,
+                            session = NULL,
                             ...) {
   host <- databricks_host(workspace)
 
@@ -104,18 +120,21 @@ databricks_args <- function(httpPath,
     useNativeQuery = useNativeQuery
   )
 
-  auth <- databricks_auth_args(host, uid = uid, pwd = pwd)
+  auth <- databricks_auth_args(host, uid = uid, pwd = pwd, session = session)
   all <- utils::modifyList(c(args, auth), list(...))
 
   arg_names <- tolower(names(all))
   if (!"authmech" %in% arg_names && !all(c("uid", "pwd") %in% arg_names)) {
-    abort(
-      c(
-        "x" = "Failed to detect ambient Databricks credentials.",
-        "i" = "Supply `uid` and `pwd` to authenticate manually."
-      ),
-      call = quote(DBI::dbConnect())
+    msg <- c(
+      "Failed to detect ambient Databricks credentials.",
+      "i" = "Supply {.arg uid} and {.arg pwd} to authenticate manually."
     )
+    if (running_on_connect()) {
+      msg <- c(
+        msg, "i" = "Or pass {.arg session} for viewer-based credentials."
+      )
+    }
+    cli::cli_abort(msg, call = quote(DBI::dbConnect()))
   }
 
   all
@@ -202,7 +221,16 @@ databricks_user_agent <- function() {
   user_agent
 }
 
-databricks_auth_args <- function(host, uid = NULL, pwd = NULL) {
+databricks_auth_args <- function(host, uid = NULL, pwd = NULL, session = NULL) {
+  # If a session is supplied, any viewer-based auth takes precedence.
+  if (!is.null(session)) {
+    check_installed("httr2", "for viewer-based authentication")
+    access_token <- connect_viewer_token(session, paste0("https://", host))
+    if (!is.null(access_token)) {
+      return(list(authMech = 11, auth_flow = 0, auth_accesstoken = access_token))
+    }
+  }
+
   if (!is.null(uid) && !is.null(pwd)) {
     return(list(uid = uid, pwd = pwd, authMech = 3))
   } else if (xor(is.null(uid), is.null(pwd))) {

R/driver-snowflake.R

@@ -114,6 +114,8 @@ setMethod("odbcDataType", "Snowflake",
 #'   default.
 #' @param uid,pwd Manually specify a username and password for authentication.
 #'   Specifying these options will disable ambient credential discovery.
+#' @param session A Shiny session object, when using viewer-based credentials on
+#'   Posit Connect.
 #' @param ... Further arguments passed on to [`dbConnect()`].
 #'
 #' @returns An `OdbcConnection` object with an active connection to a Snowflake
@@ -138,6 +140,12 @@ setMethod("odbcDataType", "Snowflake",
 #'   uid = "me",
 #'   pwd = rstudioapi::askForPassword()
 #' )
+#'
+#' # Use credentials from the viewer (when possible) in a Shiny app
+#' # deployed to Posit Connect.
+#' server <- function(input, output, session) {
+#'   conn <- DBI::dbConnect(odbc::snowflake(), session = session)
+#' }
 #' }
 #' @export
 snowflake <- function() {
@@ -156,6 +164,7 @@ setMethod(
            schema = NULL,
            uid = NULL,
            pwd = NULL,
+           session = NULL,
            ...) {
     call <- caller_env()
     check_string(account, call = call)
@@ -164,6 +173,7 @@ setMethod(
     check_string(database, allow_null = TRUE, call = call)
     check_string(uid, allow_null = TRUE, call = call)
     check_string(pwd, allow_null = TRUE, call = call)
+    check_shiny_session(session, allow_null = TRUE, call = call)
     args <- snowflake_args(
       account = account,
       driver = driver,
@@ -172,6 +182,7 @@ setMethod(
       schema = schema,
       uid = uid,
       pwd = pwd,
+      session = session,
       ...
     )
     inject(dbConnect(odbc(), !!!args))
@@ -202,13 +213,16 @@ snowflake_args <- function(account = Sys.getenv("SNOWFLAKE_ACCOUNT"),
 
   arg_names <- tolower(names(all))
   if (!"authenticator" %in% arg_names && !all(c("uid", "pwd") %in% arg_names)) {
-    abort(
-      c(
-        "x" = "Failed to detect ambient Snowflake credentials.",
-        "i" = "Supply `uid` and `pwd` to authenticate manually."
-      ),
-      call = quote(DBI::dbConnect())
+    msg <- c(
+      "Failed to detect ambient Snowflake credentials.",
+      "i" = "Supply {.arg uid} and {.arg pwd} to authenticate manually."
     )
+    if (running_on_connect()) {
+      msg <- c(
+        msg, "i" = "Or pass {.arg session} for viewer-based credentials."
+      )
+    }
+    cli::cli_abort(msg, call = quote(DBI::dbConnect()))
   }
 
   all
@@ -270,7 +284,19 @@ snowflake_auth_args <- function(account,
                                 uid = NULL,
                                 pwd = NULL,
                                 authenticator = NULL,
+                                session = NULL,
                                 ...) {
+  # If a session is supplied, any viewer-based auth takes precedence.
+  if (!is.null(session)) {
+    check_installed("httr2", "for viewer-based authentication")
+    access_token <- connect_viewer_token(
+      session, paste0("https://", account, ".snowflakecomputing.com")
+    )
+    if (!is.null(access_token)) {
+      return(list(authenticator = "oauth", token = access_token))
+    }
+  }
+
   if (!is.null(uid) &&
       # allow for uid without pwd for externalbrowser auth (#817)
       (!is.null(pwd) || identical(authenticator, "externalbrowser"))) {

R/utils.R

@@ -454,3 +454,79 @@ replace_or_append <- function(lines, pattern, replacement) {
   }
   lines
 }
+
+check_shiny_session <- function(x,
+                                ...,
+                                allow_null = FALSE,
+                                arg = caller_arg(x),
+                                call = caller_env()) {
+  if (!missing(x)) {
+    if (inherits(x, "ShinySession")) {
+      return(invisible(NULL))
+    }
+    if (allow_null && is_null(x)) {
+      return(invisible(NULL))
+    }
+  }
+
+  stop_input_type(
+    x,
+    "a Shiny session object",
+    ...,
+    allow_null = allow_null,
+    arg = arg,
+    call = call
+  )
+}
+
+# Request an OAuth access token for the given resource from Posit Connect. The
+# OAuth token will belong to the user owning the given Shiny session.
+connect_viewer_token <- function(session, resource) {
+  # Ensure we're running on Connect.
+  server_url <- Sys.getenv("CONNECT_SERVER")
+  api_key <- Sys.getenv("CONNECT_API_KEY")
+  if (!running_on_connect() || nchar(server_url) == 0 || nchar(api_key) == 0) {
+    cli::cli_inform(c(
+      "!" = "Ignoring {.arg sesssion} parameter.",
+      "i" = "Viewer-based credentials are only available when running on Connect."
+    ))
+    return(NULL)
+  }
+
+  # Older versions or certain configurations of Connect might not supply a user
+  # session token.
+  token <- session$request$HTTP_POSIT_CONNECT_USER_SESSION_TOKEN
+  if (is.null(token)) {
+    cli::cli_abort(
+      "Viewer-based credentials are not supported by this version of Connect."
+    )
+  }
+
+  # See: https://docs.posit.co/connect/api/#post-/v1/oauth/integrations/credentials
+  req <- httr2::request(server_url)
+  req <- httr2::req_url_path_append(
+    req, "__api__/v1/oauth/integrations/credentials"
+  )
+  req <- httr2::req_headers(req,
+    Authorization = paste("Key", api_key), .redact = "Authorization"
+  )
+  req <- httr2::req_body_form(
+    req,
+    grant_type = "urn:ietf:params:oauth:grant-type:token-exchange",
+    subject_token_type = "urn:posit:connect:user-session-token",
+    subject_token = token,
+    resource = resource
+  )
+
+  # TODO: Do we need more precise error handling?
+  req <- httr2::req_error(
+    req, body = function(resp) httr2::resp_body_json(resp)$error
+  )
+
+  resp <- httr2::resp_body_json(httr2::req_perform(req))
+  resp$access_token
+}
+
+running_on_connect <- function() {
+  Sys.getenv("RSTUDIO_PRODUCT") == "CONNECT"
+}

tests/testthat/_snaps/driver-databricks.md

@@ -22,7 +22,7 @@
       . <- databricks_args1()
     Condition
       Error in `DBI::dbConnect()`:
-      ! x Failed to detect ambient Databricks credentials.
+      ! Failed to detect ambient Databricks credentials.
       i Supply `uid` and `pwd` to authenticate manually.
 
 # must supply both uid and pwd
@@ -58,3 +58,22 @@
       Error in `dbConnect()`:
       ! `httpPath` must be a single string or `NULL`, not the number 1.
 
+# we mention viewer-based credentials have no effect locally
+
+    Code
+      ignored <- databricks_args(workspace = "workspace", httpPath = "path", driver = "driver",
+        uid = "uid", pwd = "pwd", session = list())
+    Message
+      ! Ignoring `sesssion` parameter.
+      i Viewer-based credentials are only available when running on Connect.
+
+# we hint viewer-based credentials on Connect
+
+    Code
+      databricks_args(workspace = "workspace", httpPath = "path", driver = "driver")
+    Condition
+      Error in `DBI::dbConnect()`:
+      ! Failed to detect ambient Databricks credentials.
+      i Supply `uid` and `pwd` to authenticate manually.
+      i Or pass `session` for viewer-based credentials.
+