Redact headers in str() (#692)

Fixes #682

Author: hadley

NAMESPACE

@@ -4,6 +4,7 @@ S3method("$",httr2_headers)
 S3method("[",httr2_headers)
 S3method("[[",httr2_headers)
 S3method(close,httr2_response)
+S3method(format,httr2_redacted)
 S3method(print,httr2_cmd)
 S3method(print,httr2_headers)
 S3method(print,httr2_oauth_client)
@@ -12,7 +13,9 @@ S3method(print,httr2_request)
 S3method(print,httr2_response)
 S3method(print,httr2_token)
 S3method(print,httr2_url)
+S3method(str,httr2_headers)
 S3method(str,httr2_obfuscated)
+S3method(str,httr2_redacted)
 export("%>%")
 export(curl_help)
 export(curl_translate)

NEWS.md

@@ -1,5 +1,7 @@
 # httr2 (development version)
 
+* `str()` correctly redacts redacted headers (#682).
+* `req_headers()` replaces existing headers with different case (#682).
 * New `local_verbosity()` (#687).
 * Can now use `HTTR2_VERBOSITY` env var to control default verbosity (#687).
 * `req_perform_parallel(pool)` has been deprecated in favour of a new `max_active` argument (#681).

R/headers.R

@@ -1,13 +1,13 @@
-as_headers <- function(x, error_call = caller_env()) {
+as_headers <- function(x, redact = character(), error_call = caller_env()) {
   if (is.character(x) || is.raw(x)) {
     parsed <- curl::parse_headers(x)
     valid <- parsed[grepl(":", parsed, fixed = TRUE)]
     halves <- parse_in_half(valid, ":")
 
     headers <- set_names(trimws(halves$right), halves$left)
-    new_headers(as.list(headers), error_call = error_call)
+    new_headers(as.list(headers), redact = redact, error_call = error_call)
   } else if (is.list(x)) {
-    new_headers(x, error_call = error_call)
+    new_headers(x, redact = redact, error_call = error_call)
   } else {
     cli::cli_abort(
       "{.arg headers} must be a list, character vector, or raw.",
@@ -16,39 +16,54 @@ as_headers <- function(x, error_call = caller_env()) {
   }
 }
 
-new_headers <- function(x, error_call = caller_env()) {
+new_headers <- function(x, redact = character(), error_call = caller_env()) {
   if (!is_list(x)) {
     cli::cli_abort("{.arg x} must be a list.", call = error_call)
   }
   if (length(x) > 0 && !is_named(x)) {
     cli::cli_abort("All elements of {.arg x} must be named.", call = error_call)
   }
 
-  structure(x, class = "httr2_headers")
+  structure(x, redact = redact, class = "httr2_headers")
 }
 
 #' @export
 print.httr2_headers <- function(x, ..., redact = TRUE) {
-  cli::cli_text("{.cls {class(x)}}")
+  cli::cat_line(cli::format_inline("{.cls {class(x)}}"))
+  show_headers(x, redact = redact)
+  invisible(x)
+}
+
+show_headers <- function(x, redact = TRUE) {
   if (length(x) > 0) {
-    cli::cat_line(cli::style_bold(names(x)), ": ", headers_redact(x, redact))
+    vals <- lapply(headers_redact(x, redact), format)
+    cli::cat_line(cli::style_bold(names(x)), ": ", vals)
   }
-  invisible(x)
 }
 
-headers_redact <- function(x, redact = TRUE, to_redact = NULL) {
+#' @export
+str.httr2_headers <- function(object, ..., no.list = FALSE) {
+  object <- unclass(headers_redact(object))
+  cat(" <httr2_headers>\n")
+  utils::str(object, ..., no.list = TRUE)
+}
+
+headers_redact <- function(x, redact = TRUE) {
   if (!redact) {
     x
   } else {
-    to_redact <- union(attr(x, "redact"), to_redact)
+    to_redact <- attr(x, "redact")
     attr(x, "redact") <- NULL
 
     list_redact(x, to_redact, case_sensitive = FALSE)
   }
 }
 
+# https://datatracker.ietf.org/doc/html/rfc7230#section-3.2.2
 headers_flatten <- function(x) {
-  set_names(as.character(unlist(x, use.names = FALSE)), rep(names(x), lengths(x)))
+  n <- lengths(x)
+  x[n > 1] <- lapply(x[n > 1], paste, collapse = ",")
+  x
 }
 
 list_redact <- function(x, names, case_sensitive = TRUE) {
@@ -57,15 +72,25 @@ list_redact <- function(x, names, case_sensitive = TRUE) {
   } else {
     i <- match(tolower(names), tolower(names(x)))
   }
-  x[i] <- redacted()
+  x[i] <- list(redacted())
   x
 }
 
 redacted <- function() {
+  structure(list(NULL), class = "httr2_redacted")
+}
+
+#' @export
+format.httr2_redacted <- function(x, ...) {
   cli::col_grey("<REDACTED>")
 }
+#' @export
+str.httr2_redacted <- function(object, ...) {
+  cat(" ", cli::col_grey("<REDACTED>"), "\n", sep = "")
+}
+
 is_redacted <- function(x) {
-  is.character(x) && length(x) == 1 && x == redacted()
+  inherits(x, "httr2_redacted")
 }
 
 

R/oauth-token.R

@@ -55,13 +55,12 @@ oauth_token <- function(
 #' @export
 print.httr2_token <- function(x, ...) {
   cli::cli_text(cli::style_bold("<", paste(class(x), collapse = "/"), ">"))
-  redacted <- list_redact(x, c("access_token", "refresh_token", "id_token"))
-  if (has_name(redacted, "expires_at")) {
-    redacted$expires_at <- format(.POSIXct(x$expires_at))
+  if (has_name(x, "expires_at")) {
+    x$expires_at <- format(.POSIXct(x$expires_at))
   }
 
-  bullets(compact(redacted))
-
+  redacted <- list_redact(compact(x), c("access_token", "refresh_token", "id_token"))
+  bullets(redacted)
   invisible(x)
 }
 

R/req-cache.R

@@ -276,7 +276,9 @@ cache_body <- function(cached_resp, path = NULL) {
 # https://www.rfc-editor.org/rfc/rfc7232#section-4.1
 cache_headers <- function(cached_resp, resp) {
   check_response(cached_resp)
-  as_headers(modify_list(cached_resp$headers, !!!resp$headers))
+
+  headers <- modify_list(cached_resp$headers, !!!resp$headers, .ignore_case = TRUE)
+  as_headers(headers)
 }
 
 # Caching headers ---------------------------------------------------------

R/req-dry-run.R

@@ -66,18 +66,14 @@ req_dry_run <- function(req,
   if (!quiet) {
     cli::cat_line(resp$method, " ", resp$path, " HTTP/1.1")
 
-    headers <- headers_redact(
-      as_headers(as.list(resp$headers)),
-      redact = redact_headers,
-      to_redact = attr(req$headers, "redact")
-    )
+    headers <- new_headers(as.list(resp$headers), attr(req$headers, "redact"))
     if (testing_headers) {
       # curl::curl_echo() overrides
       headers$host <- NULL
       headers$`content-length` <- NULL
     }
 
-    cli::cat_line(cli::style_bold(names(headers)), ": ", headers)
+    show_headers(headers)
     cli::cat_line()
     show_body(resp$body, headers$`content-type`, pretty_json = pretty_json)
   }

R/req-headers.R

@@ -65,13 +65,13 @@ req_headers <- function(.req, ..., .redact = NULL) {
   check_request(.req)
   check_character(.redact, allow_null = TRUE)
 
-  redact_prev <- attr(.req$headers, "redact")
-  header_names <- names(list2(...))
-  .req$headers <- modify_list(.req$headers, ...)
+  headers  <- modify_list(.req$headers, ..., .ignore_case = TRUE)
 
-  .redact <- union(.redact, "Authorization")
-  .redact <- .redact[tolower(.redact) %in% tolower(header_names)]
-  attr(.req$headers, "redact") <- sort(union(.redact, redact_prev))
+  redact <- union(.redact, "Authorization")
+  redact <- redact[tolower(redact) %in% tolower(names(headers))]
+  redact <- sort(union(redact, attr(.req$headers, "redact")))
+
+  .req$headers <- new_headers(headers, redact)
 
   .req
 }

R/req-verbose.R

@@ -100,7 +100,7 @@ verbose_header <- function(prefix, x, redact = TRUE, to_redact = NULL) {
 
   for (line in lines) {
     if (grepl("^[-a-zA-z0-9]+:", line)) {
-      header <- headers_redact(as_headers(line), redact, to_redact = to_redact)
+      header <- headers_redact(as_headers(line, to_redact), redact)
       cli::cat_line(prefix, cli::style_bold(names(header)), ": ", header)
     } else {
       cli::cat_line(prefix, line)

R/resp-headers.R

@@ -169,12 +169,13 @@ resp_retry_after <- function(resp) {
 #' resp_link_url(resp, "last")
 #' resp_link_url(resp, "prev")
 resp_link_url <- function(resp, rel) {
-  if (!resp_header_exists(resp, "Link")) {
+if (!resp_header_exists(resp, "Link")) {
     return()
   }
 
   headers <- resp_headers(resp)
   link_headers <- headers[tolower(names(headers)) == "link"]
+
   links <- unlist(lapply(link_headers, parse_link), recursive = FALSE)
   sel <- map_lgl(links, ~ .$rel == rel)
   if (sum(sel) != 1L) {

R/utils.R

@@ -10,15 +10,17 @@ bullets_with_header <- function(header, x) {
 bullets <- function(x) {
   as_simple <- function(x) {
     if (is.atomic(x) && length(x) == 1) {
-      if (is_redacted(x)) {
-        x
-      } else if (is.character(x)) {
+      if (is.character(x)) {
         paste0('"', x, '"')
       } else {
         format(x)
       }
     } else {
-      paste0("<", class(x)[[1L]], ">")
+      if (is_redacted(x)) {
+        format(x)
+      } else {
+        paste0("<", class(x)[[1L]], ">")
+      }
     }
   }
   vals <- map_chr(x, as_simple)
@@ -30,7 +32,7 @@ bullets <- function(x) {
   }
 }
 
-modify_list <- function(.x, ..., error_call = caller_env()) {
+modify_list <- function(.x, ..., .ignore_case = FALSE, error_call = caller_env()) {
   dots <- list2(...)
   if (length(dots) == 0) return(.x)
 
@@ -41,9 +43,12 @@ modify_list <- function(.x, ..., error_call = caller_env()) {
     )
   }
 
+  if (.ignore_case) {
+    out <- .x[!tolower(names(.x)) %in% tolower(names(dots))]
+  } else {
+    out <- .x[!names(.x) %in% names(dots)]
+  }
 
-
-  out <- .x[!names(.x) %in% names(dots)]
   out <- c(out, compact(dots))
 
   if (length(out) == 0) {

tests/testthat/_snaps/curl.md

@@ -18,16 +18,14 @@
 
     Code
       print(curl_simplify_headers(headers, simplify_headers = TRUE))
-    Message
-      <httr2_headers>
     Output
+      <httr2_headers>
       Accept: application/vnd.api+json
       user-agent: agent
     Code
       print(curl_simplify_headers(headers, simplify_headers = FALSE))
-    Message
-      <httr2_headers>
     Output
+      <httr2_headers>
       Sec-Fetch-Dest: empty
       Sec-Fetch-Mode: cors
       sec-ch-ua-mobile: ?0

tests/testthat/_snaps/headers.md

@@ -10,16 +10,30 @@
 
     Code
       as_headers(c("X:1", "Y: 2", "Z:"))
-    Message
-      <httr2_headers>
     Output
+      <httr2_headers>
       X: 1
       Y: 2
       Z: 
     Code
       as_headers(list())
-    Message
+    Output
+      <httr2_headers>
+
+# print and str redact headers
+
+    Code
+      print(x)
+    Output
       <httr2_headers>
+      x: <REDACTED>
+      y: 2
+    Code
+      str(x)
+    Output
+       <httr2_headers>
+       $ x: <REDACTED>
+       $ y: num 2
 
 # new_headers checks inputs
 

tests/testthat/_snaps/oauth-token.md

@@ -1,3 +1,13 @@
+# new token computes expires_at
+
+    Code
+      token
+    Message
+      <httr2_token>
+      * token_type  : "bearer"
+      * access_token: <REDACTED>
+      * expires_at  : "2025-02-19 21:20:10"
+
 # printing token redacts access, id and refresh token
 
     Code

tests/testthat/_snaps/req.md

@@ -40,9 +40,7 @@
       <httr2_request>
       GET https://example.com
       Headers:
-      * A: "1"
-      * A: "2"
-      * A: "3"
+      * A: "1,2,3"
       Body: empty
 
 # check_request() gives useful error

tests/testthat/test-headers.R

@@ -18,6 +18,14 @@ test_that("has nice print method", {
   })
 })
 
+test_that("print and str redact headers", {
+  x <- new_headers(list(x = 1, y = 2), redact = "x")
+  expect_snapshot({
+    print(x)
+    str(x)
+  })
+})
+
 test_that("subsetting is case insensitive", {
   x <- new_headers(list(x = 1))
   expect_equal(x$X, 1)
@@ -30,7 +38,7 @@ test_that("redaction is case-insensitive", {
   attr(headers, "redact") <- "Authorization"
   redacted <- headers_redact(headers)
   expect_named(redacted, "AUTHORIZATION")
-  expect_match(as.character(redacted$AUTHORIZATION), "<REDACTED>")
+  expect_true(is_redacted(redacted$AUTHORIZATION))
 })
 
 test_that("new_headers checks inputs", {
@@ -41,7 +49,7 @@ test_that("new_headers checks inputs", {
 })
 
 test_that("can flatten repeated inputs", {
-  expect_equal(headers_flatten(list()), character())
-  expect_equal(headers_flatten(list(x = 1)), c(x = "1"))
-  expect_equal(headers_flatten(list(x = 1:2)), c(x = "1", x = "2"))
+  expect_equal(headers_flatten(list()), list())
+  expect_equal(headers_flatten(list(x = 1)), list(x = 1))
+  expect_equal(headers_flatten(list(x = 1:2)), list(x = "1,2"))
 })

tests/testthat/test-oauth-client.R

@@ -49,7 +49,10 @@ test_that("can authenticate using header or body", {
 
   req <- request("http://example.com")
   req_h <- oauth_client_req_auth(req, client("header"))
-  expect_equal(req_h$headers, structure(list(Authorization = "Basic aWQ6c2VjcmV0"), redact = "Authorization"))
+  expect_equal(
+    req_h$headers,
+    new_headers(list(Authorization = "Basic aWQ6c2VjcmV0"), "Authorization")
+  )
 
   req_b <- oauth_client_req_auth(req, client("body"))
   expect_equal(req_b$body$data, list(client_id = I("id"), client_secret = I("secret")))