From 6ab04359992fdbf92c046cbb6915d1716b9129b5 Mon Sep 17 00:00:00 2001
From: Hadley Wickham <h.wickham@gmail.com>
Date: Tue, 16 Jan 2024 17:23:31 -0600
Subject: [PATCH] Proof of concept for better binary detection

Initial implementation improves handling in `req_dry_run()`. For `req_verbose()` we'd need to ensure that the output isn't compresed by overriding the `Accept-Encoding` header, and think more carefully about where we store the data since the enclosing environment might apply to multiple requests.

Fixes #91
---
 R/content-type.R | 24 ++++++++++++++++++++++--
 R/req-options.R  | 15 ++++++++-------
 R/req-perform.R  | 22 ++++++++++++++++++++--
 3 files changed, 50 insertions(+), 11 deletions(-)

diff --git a/R/content-type.R b/R/content-type.R
index d204db25..c414c9c7 100644
--- a/R/content-type.R
+++ b/R/content-type.R
@@ -85,6 +85,7 @@ parse_content_type <- function(x) {
   list(
     type = match[[2]],
     subtype = match[[3]],
+    prefix = paste0(match[[2]], "/", match[[3]]),
     suffix = if (match[[4]] != "") match[[4]] else ""
   )
 }
@@ -95,9 +96,8 @@ check_content_type <- function(content_type,
                                inform_check_type = FALSE,
                                call = caller_env()) {
   parsed <- parse_content_type(content_type)
-  base_type <- paste0(parsed$type, "/", parsed$subtype)
 
-  if (is.null(valid_types) || base_type %in% valid_types) {
+  if (is.null(valid_types) || parsed$prefix %in% valid_types) {
     return()
   }
   if (!is.null(valid_suffix) && parsed$suffix == valid_suffix) {
@@ -115,3 +115,23 @@ check_content_type <- function(content_type,
     call = call
   )
 }
+
+is_text_type <- function(content_type) {
+  parsed <- parse_content_type(content_type)
+  if (parsed$type == "text") {
+    return(TRUE)
+  }
+
+  special_cases <- c(
+    "application/xml",
+    "application/x-www-form-urlencoded",
+    "application/json",
+    "application/ld+json",
+    "multipart/form-data"
+  )
+  if (parsed$prefix %in% special_cases) {
+    return(TRUE)
+  }
+
+  FALSE
+}
diff --git a/R/req-options.R b/R/req-options.R
index 0b2429e4..5ae501f3 100644
--- a/R/req-options.R
+++ b/R/req-options.R
@@ -189,15 +189,14 @@ req_verbose <- function(req,
 
 # helpers -----------------------------------------------------------------
 
-verbose_message <- function(prefix, x) {
-  if (any(x > 128)) {
-    # This doesn't handle unicode, but it seems like most output
-    # will be compressed in some way, so displaying bodies is unlikely
-    # to be useful anyway.
-    lines <- paste0(length(x), " bytes of binary data")
-  } else {
+verbose_message <- function(prefix, x, is_text = NULL) {
+  is_text <- is_text %||% all(x <= 128)
+
+  if (is_text) {
     x <- readBin(x, character())
     lines <- unlist(strsplit(x, "\r?\n", useBytes = TRUE))
+  } else {
+    lines <- paste0(length(x), " bytes of binary data")
   }
   cli::cat_line(prefix, lines)
 }
@@ -214,6 +213,8 @@ verbose_header <- function(prefix, x, redact = TRUE, to_redact = NULL) {
       cli::cat_line(prefix, line)
     }
   }
+
+  invisible(x)
 }
 
 auth_flags <- function(x = "basic") {
diff --git a/R/req-perform.R b/R/req-perform.R
index 3a36fe2f..0905b126 100644
--- a/R/req-perform.R
+++ b/R/req-perform.R
@@ -250,9 +250,27 @@ req_dry_run <- function(req, quiet = FALSE, redact_headers = TRUE) {
 
   if (!quiet) {
     to_redact <- attr(req$headers, "redact")
+
+    headers <- raw()
+    is_text <- NULL
+
     debug <- function(type, msg) {
-      if (type == 2L) verbose_header("", msg, redact = redact_headers, to_redact = to_redact)
-      if (type == 4L) verbose_message("", msg)
+
+      if (type == 2L) {
+        headers <<- c(
+          headers,
+          verbose_header("", msg, redact = redact_headers, to_redact = to_redact)
+        )
+      }
+      if (type == 4L) {
+        if (is.character(headers)) {
+          headers <- as_headers(headers)
+          if (has_name(headers, "Content-Type")) {
+            is_text <- is_text_type(headers$"Content-Type")
+          }
+        }
+        verbose_message("", msg, is_text = is_text)
+      }
     }
     req <- req_options(req, debugfunction = debug, verbose = TRUE)
   }