Improve control over redirects during auth code flows.

When sheparding a user through an interactive authorisation code flow to
access APIs protected by OAuth2, the oauth_flow_auth_code() function
runs a temporary webserver on localhost to capture the code. This is a
very common technique for OAuth client libraries.

Unfortunately, this doesn't work in environments where localhost is
probably inaccessible to users -- which is normally the case on RStudio
Server and Posit Workbench. Previously the oauth_flow_auth_code()
function would hang indefinitely in these environments.

This commit fixes this failure mode by attempting to detect when this
temporary localhost server will actually work and only runs one if it
will.

Of course, this doesn't resolve the issue for users that can't run a
localhost server -- so in this situation, we now allow users to manually
paste the authorisation code into the console from... somewhere. In the
likely event that they don't want to be redirected to localhost for this
step, this commit also fulfills the longstanding request for control
over the redirect URL.

The combination of a manual copy & paste step with a custom redirect URL
is what the gargle package terms the "pseudo out-of-band" flow, and the
design used here is largely based on that package.

Because of this compatibility, users could register the existing public
page at https://www.tidyverse.org/google-callback/ with their OAuth
provider, host their own clone, or create a variant.

Control over the redirect URL is backwards-compatible but does require
making the 'host_name' parameter deprecated, unfortunately.

Unit tests for new functions are included, as are various updates to the
documentation.

Fixes #165 and #176.

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

DESCRIPTION

@@ -18,6 +18,7 @@ Imports:
     cli (>= 3.0.0),
     curl,
     glue,
+    lifecycle,
     magrittr,
     openssl,
     R6,

NAMESPACE

@@ -109,4 +109,5 @@ export(with_verbosity)
 import(R6)
 import(rlang)
 importFrom(glue,glue)
+importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")

NEWS.md

@@ -13,6 +13,13 @@
 * `oauth_flow_refresh()` now only warns if the `refresh_token` changes, making
   it a little easier to use in manual workflows (#186).
 
+* `oauth_flow_auth_code()` now attempts to detect when a temporary webserver can
+  be run on `localhost`. If not, it allows users to enter the authorisation code
+  into the console manually (#248).
+
+* `oauth_flow_auth_code()` gains a `redirect_uri` argument rather than deriving
+  this URL automatically from the `host_name` and `port` (#248).
+
 # httr2 0.2.3
 
 * New `example_url()` to launch a local server, making tests and examples 

R/oauth-flow-auth-code.R

@@ -58,7 +58,8 @@ req_oauth_auth_code <- function(req, client,
                                 token_params = list(),
                                 host_name = "localhost",
                                 host_ip = "127.0.0.1",
-                                port = httpuv::randomPort()
+                                port = httpuv::randomPort(),
+                                redirect_uri = "http://localhost"
                                 ) {
 
   params <- list(
@@ -70,7 +71,8 @@ req_oauth_auth_code <- function(req, client,
     token_params = token_params,
     host_name = host_name,
     host_ip = host_ip,
-    port = port
+    port = port,
+    redirect_uri = redirect_uri
   )
 
   cache <- cache_choose(client, cache_disk, cache_key)
@@ -85,14 +87,20 @@ req_oauth_auth_code <- function(req, client,
 #' Section 4.1. This is the most commonly used OAuth flow where the user is
 #' opens a page in their browser, approves the access, and then returns to R.
 #'
-#' `oauth_flow_auth_code()` is a high-level wrapper that should
-#' work with APIs that adhere relatively closely to the spec. The remaining
-#' low-level functions can be used to assemble a custom flow for APIs that are
-#' further from the spec:
+#' `oauth_flow_auth_code()` is a high-level wrapper that should work with APIs
+#' that adhere relatively closely to the spec. When possible, it redirects the
+#' browser back to a temporary local webserver to capture the authorization
+#' code. When this is not possible -- for example, when running on a hosted
+#' platform like RStudio Server -- it prompts the user to enter the code
+#' manually instead.
 #'
-#' * `oauth_flow_auth_code_url()` generates the url where the user is sent.
-#' * `oauth_flow_auth_code_listen()` starts an webserver that listens for
-#'   the response from the resource server.
+#' The remaining low-level functions can be used to assemble a custom flow for
+#' APIs that are further from the spec:
+#'
+#' * `oauth_flow_auth_code_url()` generates the url that should be opened in a
+#'   browser.
+#' * `oauth_flow_auth_code_listen()` starts a temporary local webserver that
+#'   listens for the response from the resource server.
 #' * `oauth_flow_auth_code_parse()` parses the query parameters returned from
 #'   the server redirect, verifying that the `state` is correct, and returning
 #'   the authorisation code.
@@ -110,12 +118,17 @@ req_oauth_auth_code <- function(req, client,
 #' @param auth_params List containing additional parameters passed to `oauth_flow_auth_code_url()`
 #' @param token_params List containing additional parameters passed to the
 #'   `token_url`.
-#' @param host_name Host name used to generate `redirect_uri`
-#' @param host_ip IP address web server will be bound to.
-#' @param port Port to bind web server to. By default, this uses a random port.
-#'   You may need to set it to a fixed port if the API requires that the
+#' @param host_name `r lifecycle::badge("deprecated")` Use `redirect_uri`
+#'   instead.
+#' @param host_ip IP address for the temporary webserver used to capture the
+#'   authorization code.
+#' @param port Port to bind the temporary webserver to. Used only when
+#'   `redirect_uri` is `"http(s)://localhost"`. By default, this uses a random
+#'   port. You may need to set it to a fixed port if the API requires that the
 #'   `redirect_uri` specified in the client exactly matches the `redirect_uri`
 #'   generated by this function.
+#' @param redirect_uri URL to redirect back to after authorization is complete.
+#'   Often this must be registered with the API in advance.
 #' @returns An [oauth_token].
 #' @export
 #' @keywords internal
@@ -133,18 +146,35 @@ req_oauth_auth_code <- function(req, client,
 #'   token <- oauth_flow_auth_code(client, auth_url = "https://github.com/login/oauth/authorize")
 #'   token
 #' }
+#' @importFrom lifecycle deprecated
 oauth_flow_auth_code <- function(client,
                                  auth_url,
                                  scope = NULL,
                                  pkce = TRUE,
                                  auth_params = list(),
                                  token_params = list(),
-                                 host_name = "localhost",
+                                 host_name = deprecated(),
                                  host_ip = "127.0.0.1",
-                                 port = httpuv::randomPort()
+                                 port = httpuv::randomPort(),
+                                 redirect_uri = "http://localhost"
 ) {
   oauth_flow_check("authorization code", client, interactive = TRUE)
-  check_installed("httpuv")
+
+  # For backwards compatibility, fall back to the original redirect URL
+  # construction.
+  if (lifecycle::is_present(host_name)) {
+    lifecycle::deprecate_warn(
+      when = "0.3.0",
+      what = "oauth_flow_auth_code(host_name)",
+      with = "oauth_flow_auth_code(redirect_uri)"
+    )
+    redirect_uri <- paste0("http://", host_name, ":", port, "/")
+  }
+
+  # Only append a port if we have a bare HTTP(s) localhost redirect.
+  if (grepl("https?://localhost$", redirect_uri)) {
+    redirect_uri <- paste0(redirect_uri, ":", port, "/")
+  }
 
   if (pkce) {
     code <- oauth_flow_auth_code_pkce()
@@ -154,26 +184,34 @@ oauth_flow_auth_code <- function(client,
   }
 
   state <- base64_url_rand(32)
-  redirect_url <- paste0("http://", host_name, ":", port, "/")
 
-  # Redirect user to authorisation url, and listen for result
+  # Redirect user to authorisation url.
   user_url <- oauth_flow_auth_code_url(client,
     auth_url = auth_url,
-    redirect_uri = redirect_url,
+    redirect_uri = redirect_uri,
     scope = scope,
     state = state,
     auth_params = auth_params
   )
   utils::browseURL(user_url)
-  result <- oauth_flow_auth_code_listen(host_ip, port)
-  code <- oauth_flow_auth_code_parse(result, state)
+
+  if (!is_hosted_session() && is_installed("httpuv")) {
+    # Listen on localhost for the result.
+    result <- oauth_flow_auth_code_listen(host_ip, port)
+    code <- oauth_flow_auth_code_parse(result, state)
+  } else {
+    # Allow the user to retrieve the token out of band manually and enter it
+    # into the console. This is what {gargle} terms the "pseudo out-of-band"
+    # flow.
+    code <- oauth_flow_auth_code_read(state)
+  }
 
   # Get access/refresh token from authorisation code
   # https://datatracker.ietf.org/doc/html/rfc6749#section-4.1.3
   oauth_client_get_token(client,
     grant_type = "authorization_code",
     code = code,
-    redirect_uri = redirect_url,
+    redirect_uri = redirect_uri,
     !!!token_params
   )
 }
@@ -182,7 +220,6 @@ oauth_flow_auth_code <- function(client,
 # https://datatracker.ietf.org/doc/html/rfc6749#section-4.1.1
 #' @export
 #' @rdname oauth_flow_auth_code
-#' @param redirect_uri URL to which user should be redirected.
 #' @param state Random state generated by `oauth_flow_auth_code()`. Used to
 #'   verify that we're working with an authentication request that we created.
 #'   (This is an unlikely threat for R packages since the webserver that
@@ -296,3 +333,47 @@ oauth_flow_auth_code_pkce <- function() {
     challenge = base64_url_encode(openssl::sha256(charToRaw(verifier)))
   )
 }
+
+# Try to determine whether we can redirect the user's browser to a server on
+# localhost, which isn't possible if we are running on a hosted platform.
+#
+# Currently this detects RStudio Server, Posit Workbench, and Google Colab. It
+# is based on the strategy pioneered by the {gargle} package.
+is_hosted_session <- function() {
+  if (nzchar(Sys.getenv("COLAB_RELEASE_TAG"))) {
+    return(TRUE)
+  }
+  # If RStudio Server or Posit Workbench is running locally (which is possible,
+  # though unusual), it's not acting as a hosted environment.
+  Sys.getenv("RSTUDIO_PROGRAM_MODE") == "server" &&
+    !grepl("localhost", Sys.getenv("RSTUDIO_HTTP_REFERER"), fixed = TRUE)
+}
+
+oauth_flow_auth_code_read <- function(state) {
+  code <- trimws(read_line("Enter authorization code: "))
+  # We support two options here:
+  #
+  # 1) The original {gargle} style, where the user copy & pastes a
+  #    base64-encoded JSON object with both the code and state. This is used on
+  #    https://www.tidyverse.org/google-callback/; and
+  #
+  # 2) The full manual approach, where the code and state are entered
+  #    independently.
+  result <- tryCatch(
+   jsonlite::fromJSON(rawToChar(openssl::base64_decode(code))),
+   error = function(e) {
+    list(
+      code = code,
+      state = trimws(read_line("Enter state parameter: "))
+    )
+  })
+  if (!identical(result$state, state)) {
+    abort("Authentication failure: state does not match")
+  }
+  result$code
+}
+
+# base::readline() wrapper so we can mock user input during testing.
+read_line <- function(prompt = "") {
+  readline(prompt)
+}

tests/testthat/test-oauth-flow-auth-code.R

@@ -0,0 +1,38 @@
+test_that("so-called 'hosted' sessions are detected correctly", {
+  withr::with_envvar(c("RSTUDIO_PROGRAM_MODE" = "server"), {
+    expect_true(is_hosted_session())
+  })
+  # Emulate running outside RStudio Server if we happen to be running our tests
+  # under it.
+  withr::with_envvar(c("RSTUDIO_PROGRAM_MODE" = NA), {
+    expect_false(is_hosted_session())
+  })
+})
+
+test_that("JSON-encoded authorisation codes can be input manually", {
+  state <- base64_url_rand(32)
+  input <- list(state = state, code = "abc123")
+  encoded <- openssl::base64_encode(jsonlite::toJSON(input))
+  local_mocked_bindings(
+    read_line = function(prompt = "") encoded
+  )
+  expect_equal(oauth_flow_auth_code_read(state), "abc123")
+  expect_error(oauth_flow_auth_code_read("invalid"), "state does not match")
+})
+
+test_that("bare authorisation codes can be input manually", {
+  state <- base64_url_rand(32)
+  sent_code <- FALSE
+  local_mocked_bindings(
+    read_line = function(prompt = "") {
+      if (sent_code) {
+        state
+      } else {
+        sent_code <<- TRUE
+        "zyx987"
+      }
+    }
+  )
+  expect_equal(oauth_flow_auth_code_read(state), "zyx987")
+  expect_error(oauth_flow_auth_code_read("invalid"), "state does not match")
+})