a variety of fixes to (hopefully) make request body matching better

- convert the stub body pattern from json to a list if it seems like json - in body_as_hash change fromJSON to not use FALSE as second param - #134 in body_as_hash change xml approach to try catch converting xml to a list or return xml as character on error - in matches method for bodypattern add handling of pattern or request body being NA or NULL and returning false if so
ropensci · Oct 15, 2024 · 9b11d08 · 9b11d08
1 parent fe7826b
commit 9b11d08
Show file tree

Hide file tree

Showing 7 changed files with 233 additions and 21 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -64,3 +64,5 @@ importFrom(crul,mock)
 importFrom(fauxpas,HTTPRequestTimeout)
 importFrom(magrittr,"%>%")
 importFrom(rlang,is_empty)
+importFrom(rlang,is_na)
+importFrom(rlang,is_null)
diff --git a/R/RequestPattern.R b/R/RequestPattern.R
@@ -131,7 +131,11 @@ RequestPattern <- R6::R6Class(
       gsub("^\\s+|\\s+$", "", paste(
         toupper(self$method_pattern$to_s()),
         self$uri_pattern$to_s(),
-        if (!is.null(self$body_pattern)) paste0(" with body ", self$body_pattern$to_s()),
+        if (!is.null(self$body_pattern)) {
+          if (!is.null(self$body_pattern$pattern)) {
+            paste0(" with body ", self$body_pattern$to_s())
+          }
+        },
         if (!is.null(self$headers_pattern)) paste0(" with headers ", self$headers_pattern$to_s())
       ))
     }
@@ -319,6 +323,11 @@ HeadersPattern <- R6::R6Class(
   )
 )
 
+seems_like_json <- function(x) {
+  res <- tryCatch(jsonlite::fromJSON(x), error = function(msg) msg)
+  !inherits(res, "error")
+}
+
 #' @title BodyPattern
 #' @description body matcher
 #' @export
@@ -408,8 +417,14 @@ BodyPattern <- R6::R6Class(
       } else {
         self$pattern <- pattern
       }
+
+      # convert self$pattern to a list if it's json
+      if (seems_like_json(self$pattern)) {
+        self$pattern <- jsonlite::fromJSON(self$pattern)
+      }
     },
 
+    #' @importFrom rlang is_null is_na
     #' @description Match a request body pattern against a pattern
     #' @param body (list) the body
     #' @param content_type (character) content type
@@ -419,10 +434,21 @@ BodyPattern <- R6::R6Class(
         if (length(self$pattern) == 0) {
           return(TRUE)
         }
-        private$matching_hashes(self$pattern, private$body_as_hash(body, content_type))
+        private$matching_hashes(
+          self$pattern,
+          private$body_as_hash(body, content_type)
+        )
       } else {
         # FIXME: add partial approach later
-        (private$empty_string(self$pattern) && private$empty_string(body)) || all(self$pattern == body)
+        (private$empty_string(self$pattern) && private$empty_string(body)) || {
+          if (xor(is_na(self$pattern), is_na(body))) {
+            return(FALSE)
+          }
+          if (xor(is_null(self$pattern), is_null(body))) {
+            return(FALSE)
+          }
+          all(self$pattern == body)
+        }
       }
     },
 
@@ -432,10 +458,10 @@ BodyPattern <- R6::R6Class(
   ),
   private = list(
     empty_string = function(string) {
-      is.null(string) || !nzchar(string)
+      is_null(string) || !nzchar(string)
     },
     matching_hashes = function(pattern, body) {
-      if (is.null(pattern)) {
+      if (is_null(pattern)) {
         return(FALSE)
       }
       if (!inherits(pattern, "list")) {
@@ -444,6 +470,7 @@ BodyPattern <- R6::R6Class(
 
       pattern_char <- rapply(pattern, as.character, how = "replace")
       body_char <- rapply(body, as.character, how = "replace")
+
       if (self$partial) {
         names_values_check <- switch(self$partial_type,
           # unname() here not needed for R < 4.5, but is needed for R 4.5
@@ -471,10 +498,21 @@ BodyPattern <- R6::R6Class(
       if (inherits(body, "form_file")) body <- unclass(body)
       bctype <- BODY_FORMATS[[content_type]] %||% ""
       if (bctype == "json") {
-        jsonlite::fromJSON(body, FALSE)
+        jsonlite::fromJSON(body)
       } else if (bctype == "xml") {
         check_for_pkg("xml2")
-        xml2::read_xml(body)
+        try_xml2list <- rlang::try_fetch({
+          body_xml <- xml2::read_xml(body)
+          xml_as_list <- xml2::as_list(body_xml)
+          lapply(xml_as_list, promote_attr)
+        }, error = function(e) e)
+        if (rlang::is_error(try_xml2list)) {
+          rlang::warn("xml to list conversion failed; using xml string for comparison",
+            use_cli_format = TRUE, .frequency = "always")
+          body
+        } else {
+          try_xml2list
+        }
       } else {
         query_mapper(body)
       }
@@ -496,6 +534,29 @@ BODY_FORMATS <- list(
   "text/plain"                 = "plain"
 )
 
+# remove_reserved & promote_attr from https://www.garrickadenbuie.com/blog/recursive-xml-workout/
+remove_reserved <- function(this_attr) {
+  reserved_attr <- c("class", "comment", "dim", "dimnames", "names", "row.names", "tsp")
+  if (!any(reserved_attr %in% names(this_attr))) {
+    return(this_attr)
+  }
+  for (reserved in reserved_attr) {
+    if (!is.null(this_attr[[reserved]])) this_attr[[reserved]] <- NULL
+  }
+  this_attr
+}
+promote_attr <- function(ll) {
+  this_attr <- attributes(ll)
+  this_attr <- remove_reserved(this_attr)
+  if (length(ll)) {
+    # recursive case
+    c(this_attr, lapply(ll, promote_attr))
+  } else {
+    # base case (no sub-items)
+    this_attr
+  }
+}
+
 #' @title UriPattern
 #' @description uri matcher
 #' @export

diff --git a/R/wi_th.R b/R/wi_th.R
@@ -25,7 +25,10 @@
 #' all will be coerced to character.
 #' - body: various, including character string, list, raw, numeric,
 #' upload ([crul::upload()], [httr::upload_file()], [curl::form_file()], or
-#' [curl::form_data()] they both create the same object in the end)
+#' [curl::form_data()] they both create the same object in the end). for the
+#' special case of an empty request body use `NA` instead of `NULL` because
+#' with `NULL` we can't determine if the user did not supply a body or
+#' they supplied `NULL` to indicate an empty body.
 #' - headers: (list) a named list
 #' - basic_auth: (character) a length two vector, username and password.
 #' authentication type (basic/digest/ntlm/etc.) is ignored. that is,

diff --git a/man/wi_th.Rd b/man/wi_th.Rd
diff --git a/tests/testthat/test-CrulAdapter.R b/tests/testthat/test-CrulAdapter.R
@@ -192,17 +192,14 @@ test_that("crul requests with JSON-encoded bodies work", {
 
   # encoded body works
   res <- cli$post("post", body = body, encode = "json")
-  expect_is(res, "HttpResponse")
+  expect_s3_class(res, "HttpResponse")
 
   # encoded but modified body fails
   expect_error(
     cli$post("post", body = list(foo = "bar1"), encode = "json"),
     "Unregistered request"
   )
 
-  # unencoded body fails
-  expect_error(
-    cli$post("post", body = body),
-    "Unregistered request"
-  )
+  # unencoded body should work because we serialize internally
+  expect_s3_class(cli$post("post", body = body), "HttpResponse")
 })
diff --git a/tests/testthat/test-HttrAdapter.R b/tests/testthat/test-HttrAdapter.R
@@ -363,17 +363,14 @@ test_that("httr requests with JSON-encoded bodies work", {
 
   # encoded body works
   res <- httr::POST(hb("/post"), body = body, encode = "json")
-  expect_is(res, "response")
+  expect_s3_class(res, "response")
 
   # encoded but modified body fails
   expect_error(
     httr::POST(hb("/post"), body = list(foo = "bar1"), encode = "json"),
     "Unregistered request"
   )
 
-  # unencoded body fails
-  expect_error(
-    httr::POST(hb("/post"), body = body),
-    "Unregistered request"
-  )
+  # unencoded body should work because we serialize internally
+  expect_s3_class(httr::POST(hb("/post"), body = body), "response")
 })
diff --git a/tests/testthat/test-RequestPattern.R b/tests/testthat/test-RequestPattern.R
@@ -51,6 +51,155 @@ test_that("RequestPattern fails well", {
 })
 
 
+# BODY PATTERNS: plain text bodies and related
+test_that("should match if request body and body pattern are the same", {
+  aa <- RequestPattern$new(method = "get", uri = hb("/get"), body = "abc")
+  rs1 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(body = "abc"))
+  expect_true(aa$matches(rs1))
+})
+
+test_that("should match if request body and body pattern are the same with multline text", {
+  multiline_text <- "hello\nworld"
+  bb <- RequestPattern$new(method = "get", uri = hb("/get"), body = multiline_text)
+  rs2 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(body = multiline_text))
+  expect_true(bb$matches(rs2))
+})
+
+# FIXME: regex in bodies not supported yet
+test_that("regex", {})
+
+test_that("should match if pattern is missing body but is in signature", {
+  cc <- RequestPattern$new(method = "get", uri = hb("/get"))
+  rs3 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(body = "abc"))
+  expect_true(cc$matches(rs3))
+})
+
+test_that("should not match if pattern has body specified as NA but request body is not empty", {
+  dd <- RequestPattern$new(method = "get", uri = hb("/get"), body = NA)
+  rs4 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(body = "abc"))
+  expect_false(dd$matches(rs4))
+})
+
+test_that("should not match if pattern has body specified as empty string but request body is not empty", {
+  ee <- RequestPattern$new(method = "get", uri = hb("/get"), body = "")
+  rs5 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(body = "abc"))
+  expect_false(ee$matches(rs5))
+})
+
+test_that("should not match if pattern has body specified but request has no body", {
+  ff <- RequestPattern$new(method = "get", uri = hb("/get"), body = "abc")
+  rs6 <- RequestSignature$new(method = "get", uri = hb("/get"))
+  expect_false(ff$matches(rs6))
+})
+
+
+test_that("should match when pattern body is json or list", {
+  body_list <- list(
+    a = "1",
+    b = "five",
+    c = list(
+      d = c("e", "f")
+    )
+  )
+
+  # These should both be TRUE
+  pattern_as_list <- RequestPattern$new(method = "get", uri = hb("/get"), body = body_list)
+  rs7 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(
+      headers = list(`Content-Type` = "application/json"),
+      body = jsonlite::toJSON(body_list, auto_unbox = TRUE)
+    )
+  )
+  expect_true(pattern_as_list$matches(rs7))
+
+  pattern_as_json <- RequestPattern$new(method = "get", uri = hb("/get"),
+    body = jsonlite::toJSON(body_list, auto_unbox = TRUE))
+  rs7 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(
+      headers = list(`Content-Type` = "application/json"),
+      body = jsonlite::toJSON(body_list, auto_unbox = TRUE)
+    )
+  )
+  expect_true(pattern_as_json$matches(rs7))
+})
+
+test_that("should match when pattern body is a list and body is various content types", {
+  pattern <- RequestPattern$new(method = "get", uri = hb("/get"),
+    body = list(data = list(a = '1', b = 'five')))
+  rs_xml <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(
+      headers = list(`Content-Type` = "application/xml"),
+      body = '<data a="1" b="five" />'
+    )
+  )
+  expect_true(pattern$matches(rs_xml))
+
+  xml_employees_text <- '
+    <company>
+      <employees company="MacroSoft" division="Sales">
+        <employee empno="7369" ename="SMITH" job="CLERK" hiredate="17-DEC-1980"/>
+        <employee empno="7499" ename="ALLEN" job="SALESMAN" hiredate="20-FEB-1981"/>
+      </employees>
+      <employees company="MacroSoft" division="Research">
+        <employee empno="7698" ename="BLAKE" job="MANAGER" hiredate="01-MAY-1981"/>
+        <employee empno="7782" ename="CLARK" job="MANAGER" hiredate="09-JUN-1981"/>
+      </employees>
+    </company>'
+
+  xml_employees_list <- list(company = list(
+    employees = list(
+      company = "MacroSoft", division = "Sales",
+      employee = list(
+        empno = "7369", ename = "SMITH", job = "CLERK",
+        hiredate = "17-DEC-1980"
+      ), employee = list(
+        empno = "7499",
+        ename = "ALLEN", job = "SALESMAN", hiredate = "20-FEB-1981"
+      )
+    ),
+    employees = list(
+      company = "MacroSoft", division = "Research",
+      employee = list(
+        empno = "7698", ename = "BLAKE", job = "MANAGER",
+        hiredate = "01-MAY-1981"
+      ), employee = list(
+        empno = "7782",
+        ename = "CLARK", job = "MANAGER", hiredate = "09-JUN-1981"
+      )
+    )
+  ))
+
+  pattern2 <- RequestPattern$new(method = "get", uri = hb("/get"),
+    body = xml_employees_list)
+  rs_xml2 <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(
+      headers = list(`Content-Type` = "application/xml"),
+      body = xml_employees_text
+    )
+  )
+  expect_true(pattern2$matches(rs_xml2))
+})
+
+test_that("should warn when xml parsing fails and fall back to the xml string", {
+  pattern <- RequestPattern$new(method = "get", uri = hb("/get"),
+    body = '<data a="1" b="five" />')
+  rs_xml_parse_fail <- RequestSignature$new(method = "get", uri = hb("/get"),
+    options = list(
+      headers = list(`Content-Type` = "application/xml"),
+      body = '<data a="1" b="five" '
+    )
+  )
+  expect_false(pattern$matches(rs_xml_parse_fail))
+  #expect_warning(pattern$matches(rs_xml_parse_fail)) # FIXME: should throw warning
+})
+
+
+
 context("MethodPattern")
 test_that("MethodPattern: structure is correct", {
   expect_is(MethodPattern, "R6ClassGenerator")