Improve control over redirects during auth code flows

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 you're running in a 
+  hosted environment (e.g. Google Collab/Posit Workbench/Posit cloud) and 
+  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/httr2-package.R

@@ -2,9 +2,10 @@
 "_PACKAGE"
 
 ## usethis namespace: start
-#' @import rlang
 #' @import R6
+#' @import rlang
 #' @importFrom glue glue
+#' @importFrom lifecycle deprecated
 ## usethis namespace: end
 NULL
 

R/oauth-flow-auth-code.R

@@ -56,9 +56,11 @@ req_oauth_auth_code <- function(req, client,
                                 pkce = TRUE,
                                 auth_params = list(),
                                 token_params = list(),
+                                type = c("desktop", "web"),
                                 host_name = "localhost",
                                 host_ip = "127.0.0.1",
-                                port = httpuv::randomPort()
+                                port = httpuv::randomPort(),
+                                redirect_uri = "http://localhost"
                                 ) {
 
   params <- list(
@@ -68,9 +70,11 @@ req_oauth_auth_code <- function(req, client,
     pkce = pkce,
     auth_params = auth_params,
     token_params = token_params,
+    type = type,
     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 +89,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 (e.g. when running on a hosted platform
+#' like RStudio Server) set `type = "web"` to instead 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 +120,20 @@ 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 type Either `desktop` or `web`. Use desktop when running on the
+#'   desktop in an environment where you can redirect the user to `localhost`.
+#'   Use `web` when running in a hosted web environment.
+#' @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
@@ -139,12 +157,38 @@ oauth_flow_auth_code <- function(client,
                                  pkce = TRUE,
                                  auth_params = list(),
                                  token_params = list(),
-                                 host_name = "localhost",
+                                 host_name = deprecated(),
                                  host_ip = "127.0.0.1",
-                                 port = httpuv::randomPort()
+                                 type = c("desktop", "web"),
+                                 port = httpuv::randomPort(),
+                                 redirect_uri = "http://localhost"
 ) {
+
+  type <- arg_match(type)
+  if (type == "desktop") {
+    check_installed("httpuv", "desktop OAuth")
+    if (is_hosted_session()) {
+      abort("Only type='web' is supported in the current session")
+    }
+  }
+
   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 +198,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 (type == "desktop") {
+    # 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 +234,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 +347,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)
+}