Extract parsing function from oauth_flow_fetch() (#309)

And use better error management strategy in preparation for #283.

R/content-type.R

@@ -30,17 +30,17 @@ resp_check_content_type <- function(resp,
   check_response(resp)
   check_character(valid_types, allow_null = TRUE)
   check_string(valid_suffix, allow_null = TRUE)
-  check_bool(check_type)
+  check_bool(check_type, allow_na = TRUE)
 
-  if (!check_type) {
+  if (isFALSE(check_type)) {
     return(invisible())
   }
 
   check_content_type(
     resp_content_type(resp),
     valid_types = valid_types,
     valid_suffix = valid_suffix,
-    inform_check_type = TRUE,
+    inform_check_type = !is.na(check_type),
     call = call
   )
   invisible()

R/oauth-client.R

@@ -232,13 +232,16 @@ oauth_flow_check <- function(flow, client,
   }
 }
 
-oauth_client_get_token <- function(client, grant_type, ...) {
+oauth_client_get_token <- function(client,
+                                   grant_type,
+                                   ...,
+                                   error_call = caller_env()) {
   req <- request(client$token_url)
   req <- req_body_form(req, grant_type = grant_type, ...)
   req <- oauth_client_req_auth(req, client)
   req <- req_headers(req, Accept = "application/json")
 
-  resp <- oauth_flow_fetch(req)
+  resp <- oauth_flow_fetch(req, "client$token_url", error_call = error_call)
   exec(oauth_token, !!!resp)
 }
 

R/oauth-flow-device.R

@@ -105,18 +105,25 @@ oauth_flow_device <- function(client,
 # Device authorization request and response
 # https://datatracker.ietf.org/doc/html/rfc8628#section-3.1
 # https://datatracker.ietf.org/doc/html/rfc8628#section-3.2
-oauth_flow_device_request <- function(client, auth_url, scope, auth_params) {
+oauth_flow_device_request <- function(client,
+                                      auth_url,
+                                      scope,
+                                      auth_params,
+                                      error_call = caller_env()) {
   req <- request(auth_url)
   req <- req_body_form(req, scope = scope, !!!auth_params)
   req <- oauth_client_req_auth(req, client)
   req <- req_headers(req, Accept = "application/json")
 
-  oauth_flow_fetch(req)
+  oauth_flow_fetch(req, "auth_url", error_call = error_call)
 }
 
 # Device Access Token Request
 # https://datatracker.ietf.org/doc/html/rfc8628#section-3.4
-oauth_flow_device_poll <- function(client, request, token_params) {
+oauth_flow_device_poll <- function(client,
+                                   request,
+                                   token_params,
+                                   error_call = caller_env()) {
   cli::cli_progress_step("Waiting for response from server", spinner = TRUE)
 
   delay <- request$interval %||% 5
@@ -134,7 +141,8 @@ oauth_flow_device_poll <- function(client, request, token_params) {
         token <- oauth_client_get_token(client,
           grant_type = "urn:ietf:params:oauth:grant-type:device_code",
           device_code = request$device_code,
-          !!!token_params
+          !!!token_params,
+          error_call = error_call
         )
         break
       },

R/oauth-flow.R

@@ -1,30 +1,52 @@
-oauth_flow_fetch <- function(req) {
+oauth_flow_fetch <- function(req, source, error_call = caller_env()) {
   req <- req_error(req, is_error = ~ FALSE)
   resp <- req_perform(req, error_call = current_call())
 
-  # This is rather more flexible than what the spec requires, and should
-  # hopefully be general enough to handle most token endpoints. However,
-  # it would still be nice to figure out how to make user extensible,
-  # especially since you might be able to give better errors.
-  if (resp_content_type(resp) == "application/json") {
-    body <- resp_body_json(resp)
+  oauth_flow_parse(resp, source, error_call = error_call)
+}
 
-    if (has_name(body, "expires_in")) {
-      body$expires_in <- as.numeric(body$expires_in)
+oauth_flow_parse <- function(resp, source, error_call = caller_env()) {
+  withCallingHandlers(
+    body <- oauth_flow_body(resp),
+    error = function(err) {
+      cli::cli_abort(
+        "Failed to parse response from {.arg {source}} OAuth url.",
+        parent = err,
+        call = error_call
+      )
     }
-  } else {
-    body <- NULL
+  )
+
+  if (has_name(body, "expires_in")) {
+    body$expires_in <- as.numeric(body$expires_in)
   }
 
-  if ((has_name(body, "access_token") || has_name(body, "device_code")) && resp_status(resp) == 200) {
+  # This is rather more flexible than what the spec requires, and should
+  # hopefully be general enough to handle most token endpoints. However,
+  # it would still be nice to figure out how to make user extensible,
+  # especially since you might be able to give better errors.
+  if (has_name(body, "access_token") || has_name(body, "device_code")) {
     body
   } else if (has_name(body, "error")) {
-    oauth_flow_abort(body$error, body$error_description, body$error_uri)
+    oauth_flow_abort(
+      body$error,
+      body$error_description,
+      body$error_uri,
+      error_call = error_call
+    )
   } else {
-    resp_check_status(resp)
-    cli::cli_abort("Failed to process response from {.str token} endpoint.")
+    cli::cli_abort(
+      c(
+        "Failed to parse response from {.arg {source}} OAuth url.",
+        "*" = "Did not contain {.code access_token}, {.code device_code}, or {.code error} field."
+      ),
+      call = error_call
+    )
   }
+}
 
+oauth_flow_body <- function(resp) {
+  resp_body_json(resp, check_type = NA)
 }
 
 # https://datatracker.ietf.org/doc/html/rfc6749#section-4.1.2.1

tests/testthat/_snaps/oauth-flow.md

@@ -1,17 +1,34 @@
-# errors if response isn't json
+# turns oauth errors to R errors
 
     Code
-      oauth_flow_fetch(req)
+      oauth_flow_fetch(req, "test")
     Condition
-      Error in `oauth_flow_fetch()`:
-      ! Failed to process response from "token" endpoint.
+      Error:
+      ! OAuth failure [1]
+      * abc
 
-# forwards turns oauth errors to R errors
+# userful errors if response isn't parseable
 
     Code
-      oauth_flow_fetch(req)
+      oauth_flow_parse(resp1, "test")
     Condition
-      Error in `oauth_flow_fetch()`:
-      ! OAuth failure [1]
-      * abc
+      Error:
+      ! Failed to parse response from `test` OAuth url.
+      Caused by error in `resp_body_json()`:
+      ! Unexpected content type "text/plain".
+      * Expecting type "application/json" or suffix "json".
+    Code
+      oauth_flow_parse(resp2, "test")
+    Condition
+      Error:
+      ! Failed to parse response from `test` OAuth url.
+      * Did not contain `access_token`, `device_code`, or `error` field.
+
+# returns body if known good structure
+
+    Code
+      oauth_flow_parse(resp, "test")
+    Condition
+      Error:
+      ! OAuth failure [10]
 

tests/testthat/test-oauth-flow.R

@@ -1,34 +1,40 @@
-
 # oauth_flow_fetch --------------------------------------------------------
 
-test_that("errors if response isn't json", {
+test_that("turns oauth errors to R errors", {
   req <- request("http://example.com")
   local_mocked_bindings(req_perform = function(...) {
-    response(200L, headers = list(`content-type` = "text/plain"))
+    response_json(400L, body = list(error = "1", error_description = "abc"))
   })
 
-  expect_snapshot(oauth_flow_fetch(req), error = TRUE)
+  expect_snapshot(oauth_flow_fetch(req, "test"), error = TRUE)
 })
 
-test_that("forwards turns oauth errors to R errors", {
-  req <- request("http://example.com")
-  body <- list(error = "1", error_description = "abc")
-  local_mocked_bindings(req_perform = function(...) {
-    response_json(200L, body = body)
-  })
+# oauth_flow_parse --------------------------------------------------------
+
+test_that("userful errors if response isn't parseable", {
+  resp1 <- response(headers = list(`content-type` = "text/plain"))
+  resp2 <- response_json(body = list())
 
-  expect_snapshot(oauth_flow_fetch(req), error = TRUE)
+  expect_snapshot(error = TRUE, {
+    oauth_flow_parse(resp1, "test")
+    oauth_flow_parse(resp2, "test")
+  })
 })
 
+test_that("returns body if known good structure", {
+  resp <- response_json(body = list(access_token = "10"))
+  expect_equal(oauth_flow_parse(resp, "test"), list(access_token = "10"))
 
-test_that("returns body if successful", {
-  req <- request("http://example.com")
-  local_mocked_bindings(req_perform = function(...) {
-    response_json(200L, body = list(access_token = "10", expires_in = "20"))
-  })
+  resp <- response_json(body = list(device_code = "10"))
+  expect_equal(oauth_flow_parse(resp, "test"), list(device_code = "10"))
 
-  expect_equal(
-    oauth_flow_fetch(req),
-    list(access_token = "10", expires_in = 20)
-  )
+  resp <- response_json(403L, body = list(error = "10"))
+  expect_snapshot(oauth_flow_parse(resp, "test"), error = TRUE)
 })
+
+test_that("converts expires_in to numeric", {
+  resp <- response_json(200L, body = list(access_token = "10", expires_in = "20"))
+  body <- oauth_flow_parse(resp, "test")
+  expect_equal(body$expires_in, 20)
+})
+