Add support for using Workbench's generic OAuth2 code capture.

For data scientists using local tools or working in the IDE,
authentication with APIs or databases that use the OAuth2 authorisation
code flow (e.g. Google, Azure, or GitHub) typically work by running a
temporary HTTP server on localhost and using that as the redirect URL.
When a user gets redirected to localhost, the temporary HTTP server
captures the code automatically and surfaces it to the caller.

Unfortunately, this doesn't work at all on Workbench, because you can't
just "redirect to localhost" like you can on your desktop.

In r-lib#248 and follow-ups we added a workaround for this issue that we term
the "pseudo out-of-band" flow -- that mechanism was pioneered by the
{gargle} package in response to Google deprecating the original
"out-of-band" flow.

This commit adds support for a *third* mechanism for the auth code flow
which uses a feature of the upcoming Workbench release that allows it to
serve as a redirect URL for arbitrary OAuth2 applications on a static
/oauth_redirect_callback endpoint. httr2 can retrieve any code sent to
this URL by calling a simple JSON API at a static /oauth_code endpoint.

This mechanism has strong appeal over the pseudo out-of-band flow
because it sidesteps the requirement that users copy & paste the code,
making it feel much more natural and automatic. It also avoids the need
to ask users to host a static "capture your code" page, a la
<https://www.tidyverse.org/google-callback/>, because every Workbench
instance now has one.

(This Workbench feature was explicitly designed for packages like httr2
to make use of so that the auth code flow starts feeling like magic once
again.)

I've decided to introduce client-specific environment variables here --
specifically, HTTR2_OAUTH_REDIRECT_URL and HTTR2_OAUTH_CODE_SOURCE_URL
-- rather than having platform-specific ones prefixed with `WORKBENCH_`.

If you're running a daily build of Workbench locally, you can test this
as follows:

    local({
      # Automatically determine the Workbench server's URL. We use
      # RSTUDIO_HTTP_REFERER here, which is only set in RStudio Pro sessions.
      url_split <- strsplit(Sys.getenv("RSTUDIO_HTTP_REFERER"), "/s/", fixed = TRUE)[[1]]
      if (nchar(url_split[1]) != 0L && length(url_split) == 2L) {
        base_url <- url_split[1]
        Sys.setenv(
          HTTR2_OAUTH_REDIRECT_URL = sprintf("%s/oauth_redirect_callback", base_url),
          HTTR2_OAUTH_CODE_SOURCE_URL = sprintf("%s/oauth_code", base_url)
        )
      }
    })

    client <- oauth_client(
      id = "28acfec0674bb3da9f38",
      secret = obfuscated(paste0(
        "J9iiGmyelHltyxqrHXW41ZZPZamyUNxSX1_uKnv",
        "PeinhhxET_7FfUs2X0LLKotXY2bpgOMoHRCo"
      )),
      token_url = "https://github.com/login/oauth/access_token",
      name = "hadley-oauth-test"
    )

    oauth_flow_auth_code(
      client, auth_url = "https://github.com/login/oauth/authorize"
    )

In the future we can set the environment variables in Workbench sessions
directly.

Unit tests are included.

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

NAMESPACE

@@ -15,6 +15,7 @@ S3method(str,httr2_obfuscated)
 export("%>%")
 export(curl_help)
 export(curl_translate)
+export(default_redirect_uri)
 export(example_url)
 export(jwt_claim)
 export(jwt_encode_hmac)

R/oauth-flow-auth-code.R

@@ -59,7 +59,7 @@ req_oauth_auth_code <- function(req, client,
                                 pkce = TRUE,
                                 auth_params = list(),
                                 token_params = list(),
-                                redirect_uri = "http://localhost",
+                                redirect_uri = default_redirect_uri(),
                                 host_name = deprecated(),
                                 host_ip = deprecated(),
                                 port = deprecated()
@@ -98,8 +98,11 @@ req_oauth_auth_code <- function(req, client,
 #' 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.
+#' like RStudio Server), provide a custom redirect URI and httr2 will prompt the
+#' user to enter the code manually instead.
+#'
+#' `default_redirect_uri()` returns `http://localhost` but also respects the
+#' `HTTR2_OAUTH_REDIRECT_URL` environment variable.
 #'
 #' The remaining low-level functions can be used to assemble a custom flow for
 #' APIs that are further from the spec:
@@ -130,19 +133,27 @@ req_oauth_auth_code <- function(req, client,
 #' @param redirect_uri URL to redirect back to after authorization is complete.
 #'   Often this must be registered with the API in advance.
 #'
-#'   httr2 supports two forms of redirect. Firstly, you can use a `localhost`
+#'   httr2 supports three forms of redirect. Firstly, you can use a `localhost`
 #'   url (the default), where httr2 will set up a temporary webserver to listen
 #'   for the OAuth redirect. In this case, httr2 will automatically append a
 #'   random port. If you need to set it to a fixed port because the API requires
 #'   it, then specify it with (e.g.) `"http://localhost:1011"`. This technique
 #'   works well when you are working on your own computer.
 #'
-#'   Alternatively, you can provide a URL to a website that uses javascript to
+#'   Secondly, you can provide a URL to a website that uses Javascript to
 #'   give the user a code to copy and paste back into the R session (see
 #'   <https://www.tidyverse.org/google-callback/> and
 #'   <https://github.com/r-lib/gargle/blob/main/inst/pseudo-oob/google-callback/index.html>
 #'   for examples). This is less convenient (because it requires more
-#'   user interaction) but also works in hosted environments.
+#'   user interaction) but also works in hosted environments like RStudio
+#'   Server.
+#'
+#'   Finally, hosted platforms might set the `HTTR2_OAUTH_REDIRECT_URL` and
+#'   `HTTR2_OAUTH_CODE_SOURCE_URL` environment variables. In this case, httr2
+#'   will use `HTTR2_OAUTH_REDIRECT_URL` for redirects by default, and poll the
+#'   `HTTR2_OAUTH_CODE_SOURCE_URL` endpoint with the state parameter until it
+#'   receives a code in the response (or encounters an error). This delegates
+#'   completion of the authorization flow to the hosted platform.
 #'
 #' @returns An [oauth_token].
 #' @export
@@ -167,7 +178,7 @@ oauth_flow_auth_code <- function(client,
                                  pkce = TRUE,
                                  auth_params = list(),
                                  token_params = list(),
-                                 redirect_uri = "http://localhost",
+                                 redirect_uri = default_redirect_uri(),
                                  host_name = deprecated(),
                                  host_ip = deprecated(),
                                  port = deprecated()
@@ -201,7 +212,12 @@ oauth_flow_auth_code <- function(client,
   )
   utils::browseURL(user_url)
 
-  if (redirect$localhost) {
+  if (redirect$can_fetch_code) {
+    # Wait a bit to give the user a chance to click through the authorisation
+    # process.
+    sys_sleep(2, "for browser-based authentication", progress = FALSE)
+    code <- oauth_flow_auth_code_fetch(state)
+  } else if (redirect$localhost) {
     # Listen on localhost for the result
     result <- oauth_flow_auth_code_listen(redirect$uri)
     code <- oauth_flow_auth_code_parse(result, state)
@@ -270,11 +286,18 @@ normalize_redirect_uri <- function(redirect_uri,
 
   list(
     uri = url_build(parsed),
-    localhost = localhost
+    localhost = localhost,
+    can_fetch_code = can_fetch_oauth_code(redirect_uri)
   )
 
 }
 
+#' @export
+#' @rdname oauth_flow_auth_code
+default_redirect_uri <- function() {
+  Sys.getenv("HTTR2_OAUTH_REDIRECT_URL", "http://localhost")
+}
+
 # Authorisation request: make a url that the user navigates to
 # https://datatracker.ietf.org/doc/html/rfc6749#section-4.1.1
 #' @export
@@ -440,3 +463,28 @@ oauth_flow_auth_code_read <- function(state) {
 read_line <- function(prompt = "") {
   readline(prompt)
 }
+
+# Determine whether we can fetch the OAuth authorization code from an external
+# source without user interaction.
+can_fetch_oauth_code <- function(redirect_url) {
+  nchar(Sys.getenv("HTTR2_OAUTH_CODE_SOURCE_URL")) &&
+    Sys.getenv("HTTR2_OAUTH_REDIRECT_URL") == redirect_url
+}
+
+# Fetch the authorization code from an external source that is serving as a
+# redirect URL. This assumes a very simple API that takes the state parameter in
+# the query string and returns a JSON object with a `code` key.
+oauth_flow_auth_code_fetch <- function(state) {
+  req <- request(Sys.getenv("HTTR2_OAUTH_CODE_SOURCE_URL"))
+  req <- req_url_query(req, state = state)
+  req <- req_retry(
+    req,
+    max_seconds = 60,
+    # The endpoint may temporarily return a 404 when no code is found for a
+    # given state because the user hasn't finished clicking through yet.
+    is_transient = ~ resp_status(.x) %in% c(404, 429, 503)
+  )
+  resp <- req_perform(req)
+  body <- resp_body_json(resp)
+  body$code
+}

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

@@ -90,5 +90,70 @@ test_that("forwards oauth error", {
     oauth_flow_auth_code_parse(query2, "abc")
     oauth_flow_auth_code_parse(query3, "abc")
   })
+})
+
+# can_fetch_auth_code -----------------------------------------------------
+
+test_that("external auth code sources are detected correctly", {
+  # False by default.
+  expect_false(can_fetch_oauth_code("http://localhost:8080/redirect"))
+
+  # Only true in the presence of certain environment variables.
+  env <- c(
+    "HTTR2_OAUTH_CODE_SOURCE_URL" = "http://localhost:8080/code",
+    "HTTR2_OAUTH_REDIRECT_URL" = "http://localhost:8080/redirect"
+  )
+  withr::with_envvar(env, {
+    expect_true(can_fetch_oauth_code("http://localhost:8080/redirect"))
+
+    # Non-matching redirect URLs should not count as external sources, either.
+    expect_false(can_fetch_oauth_code("http://localhost:9090/redirect"))
+  })
+})
 
+# ouath_flow_auth_code_fetch ----------------------------------------------
+
+test_that("auth codes can be retrieved from an external source", {
+  # Run a mock HTTP server that returns an auth code when requested, but *only*
+  # if we've been "authorized" first.
+  authorized <- FALSE
+  listen <- function(env) {
+    if (!authorized) {
+      authorized <<- TRUE
+      return(list(
+        status = 404L,
+        headers = list("Content-Type" = "text/plain"),
+        body = "Not found"
+      ))
+    }
+    list(
+      status = 200L,
+      headers = list("Content-Type" = "application/json"),
+      body = '{"code":"abc123"}'
+    )
+  }
+  port <- httpuv::randomPort()
+  server <- httpuv::startServer("127.0.0.1", port, list(call = listen))
+  withr::defer(httpuv::stopServer(server))
+
+  # Transmogrify curl::curl_fetch_memory() into an "async" version that allows
+  # interleaving calls to httpuv::service().
+  local_mocked_bindings(
+    curl_fetch_memory = function(url, handle) {
+      resp <- NULL
+      curl::curl_fetch_multi(url, function(x) resp <<- x)
+      while (is.null(resp)) {
+        curl::multi_run(timeout = 0, poll = 1L)
+        httpuv::service(NA)
+      }
+      resp
+    },
+    .package = "curl"
+  )
+
+  base_url <- paste0("http://localhost:", port)
+  env <- c("HTTR2_OAUTH_CODE_SOURCE_URL" = paste0(base_url, "/code"))
+  withr::with_envvar(env, {
+    expect_equal(oauth_flow_auth_code_fetch("ignored"), "abc123")
+  })
 })