fix #126 add ability to show body diff

- can be shown upon a non-match to any stubs
- can be done manually as well with a new function
- uses diffobj package to do diffing

DESCRIPTION

@@ -37,7 +37,8 @@ Suggests:
     xml2,
     vcr,
     httr,
-    httr2
+    httr2,
+    diffobj
 RoxygenNote: 7.3.2
 X-schema.org-applicationCategory: Web
 X-schema.org-keywords: http, https, API, web-services, curl, mock, mocking, fakeweb, http-mocking, testing, testing-tools, tdd

NAMESPACE

@@ -34,11 +34,14 @@ export(excluding)
 export(httr2_mock)
 export(httr_mock)
 export(including)
+export(last_request)
+export(last_stub)
 export(mock_file)
 export(pluck_body)
 export(remove_request_stub)
 export(request_registry)
 export(request_registry_clear)
+export(stub_body_diff)
 export(stub_registry)
 export(stub_registry_clear)
 export(stub_request)
@@ -66,5 +69,6 @@ importFrom(magrittr,"%>%")
 importFrom(rlang,abort)
 importFrom(rlang,check_installed)
 importFrom(rlang,is_empty)
+importFrom(rlang,is_list)
 importFrom(rlang,is_na)
 importFrom(rlang,is_null)

R/RequestPattern.R

@@ -467,6 +467,9 @@ BodyPattern <- R6::R6Class(
       if (!inherits(pattern, "list")) {
         return(FALSE)
       }
+      if (!rlang::is_list(body)) {
+        return(FALSE)
+      }
 
       pattern_char <- rapply(pattern, as.character, how = "replace")
       body_char <- rapply(body, as.character, how = "replace")
@@ -496,6 +499,7 @@ BodyPattern <- R6::R6Class(
     },
     body_as_hash = function(body, content_type) {
       if (inherits(body, "form_file")) body <- unclass(body)
+      if (is_empty(content_type)) content_type <- ""
       bctype <- BODY_FORMATS[[content_type]] %||% ""
       if (bctype == "json") {
         jsonlite::fromJSON(body, FALSE)

R/adapter.R

@@ -197,25 +197,29 @@ Adapter <- R6::R6Class("Adapter",
         }
 
         # no stubs found and net connect not allowed - STOP
-        x <- "Real HTTP connections are disabled.\nUnregistered request:\n "
-        y <- "\n\nYou can stub this request with the following snippet:\n\n  "
-        z <- "\n\nregistered request stubs:\n\n"
-        msgx <- paste(x, request_signature$to_s())
+        x <- c("Real HTTP connections are disabled.", "!" = "Unregistered request:")
+        y <- "\nYou can stub this request with the following snippet:\n"
+        z <- "\nregistered request stubs:\n"
+        # msgx <- paste(x, request_signature$to_s())
+        msgx <- c(x, "i" = request_signature$to_s())
         msgy <- ""
         if (webmockr_conf_env$show_stubbing_instructions) {
           msgy <- paste(y, private$make_stub_request_code(request_signature))
         }
+        msgz <- ""
         if (length(webmockr_stub_registry$request_stubs)) {
           msgz <- paste(
             z,
             paste0(vapply(webmockr_stub_registry$request_stubs, function(z)
               z$to_s(), ""), collapse = "\n ")
           )
-        } else {
-          msgz <- ""
+        }
+        msg_diff <- ""
+        if (webmockr_conf_env$show_body_diff) {
+          msg_diff <- private$make_body_diff(request_signature)
         }
         ending <- "\n============================================================"
-        abort(paste0(msgx, msgy, msgz, ending))
+        abort(c(msgx, msgy, msgz, msg_diff, ending))
       }
 
       return(resp)
@@ -377,6 +381,23 @@ Adapter <- R6::R6Class("Adapter",
       }
 
       return(response)
+    },
+
+    make_body_diff = function(request_signature) {
+      check_installed("diffobj")
+      prefix <- "\n\nBody diff:"
+      stubs <- webmockr_stub_registry$request_stubs
+      comps <- lapply(stubs, \(stub) {
+        diffobj::diffObj(stub$body, request_signature$body)
+      })
+      num_diffs <- vapply(comps, \(w) attr(w@diffs, "meta")$diffs[2], 1)
+      if (length(stubs) > 1) {
+        num_diffs_msg <- "diffs: >1 stub found, showing diff with least differences"
+        diff_to_show <- comps[which.min(num_diffs)][[1]]
+        c(prefix, "i" = num_diffs_msg, as.character(diff_to_show))
+      } else {
+        c(prefix, as.character(comps[[1]]))
+      }
     }
 
   )

R/last.R

@@ -0,0 +1,50 @@
+#' Get the last HTTP request made
+#' 
+#' @export
+#' @return `NULL` if no requests registered; otherwise the last
+#' registered request made as a `RequestSignature` class
+#' @examplesIf interactive()
+#' # no requests
+#' request_registry_clear()
+#' last_request()
+#' 
+#' # a request is found
+#' enable()
+#' stub_request("head", "https://nytimes.com")
+#' library(crul)
+#' crul::ok("https://nytimes.com")
+#' last_request()
+#' 
+#' # cleanup
+#' request_registry_clear()
+#' stub_registry_clear()
+last_request <- function() {
+	last(webmockr_request_registry$request_signatures$hash)$sig
+}
+
+#' Get the last stub created
+#' 
+#' @export
+#' @return `NULL` if no stubs found; otherwise the last stub created 
+#' as a `StubbedRequest` class
+#' @examplesIf interactive()
+#' # no requests
+#' stub_registry_clear()
+#' last_stub()
+#' 
+#' # a stub is found
+#' stub_request("head", "https://nytimes.com")
+#' last_stub()
+#' 
+#' stub_request("post", "https://nytimes.com/stories")
+#' last_stub()
+#' 
+#' # cleanup
+#' stub_registry_clear()
+last_stub <- function() {
+	tmp <- last(webmockr_stub_registry$request_stubs)
+	if (rlang::is_empty(tmp)) {
+		return(NULL)
+	}
+	tmp
+}

R/stub_body_diff.R

@@ -0,0 +1,50 @@
+#' Get a diff of a stub request body and a request body from an http request
+#' 
+#' @export
+#' @param stub object of class `StubbedRequest`. required. default is to 
+#' call [last_stub()], which gets the last stub created
+#' @param request object of class `RequestSignature`. required. default is to
+#' call [last_request()], which gets the last stub created
+#' @return object of class `Diff` from the \pkg{diffobj} package
+#' @details If either `stub` or `request` are `NULL`, this function will
+#' return an error message. You may not intentionally pass in a `NULL`, but
+#' the return value of [last_stub()] and [last_request()] when there's 
+#' nothing found is `NULL`.
+#' @examplesIf interactive()
+#' # stops with error if no stub and request
+#' request_registry_clear()
+#' stub_registry_clear()
+#' stub_body_diff()
+#' 
+#' # Gives diff when there's a stub and request found - however, no request body
+#' stub_request("get", "https://hb.opencpu.org/get")
+#' enable()
+#' library(crul)
+#' HttpClient$new("https://hb.opencpu.org")$get(path = "get")
+#' stub_body_diff()
+#' 
+#' # Gives diff when there's a stub and request found - with request body
+#' stub_request("post", "https://hb.opencpu.org/post") %>% 
+#' 	wi_th(body = list(apple = "green"))
+#' enable()
+#' library(crul)
+#' HttpClient$new("https://hb.opencpu.org")$post(
+#' 	path = "post", body = list(apple = "red"))
+#' stub_body_diff()
+#' 
+#' # Gives diff when there's a stub and request found - with request body
+#' stub_request("post", "https://hb.opencpu.org/post") %>% 
+#' 	wi_th(body = "the quick brown fox")
+#' HttpClient$new("https://hb.opencpu.org")$post(
+#' 	path = "post", body = "the quick black fox")
+#' stub_body_diff()
+stub_body_diff <- function(stub = last_stub(), request = last_request()) {
+	check_installed("diffobj")
+	if (is_empty(stub) || is_empty(request)) {
+		abort(c("`stub` and/or `request` are NULL or otherwise empty",
+			"see `?stub_body_diff`"))
+	}
+	assert(stub, "StubbedRequest")
+	assert(request, "RequestSignature")
+  diffobj::diffObj(stub$body, request$body)
+}

R/webmockr-opts.R

@@ -7,6 +7,8 @@
 #' all others are not allowed)
 #' @param show_stubbing_instructions (logical) Default: `TRUE`. If `FALSE`,
 #' stubbing instructions are not shown
+#' @param show_body_diff (logical) Default: `FALSE`. If `TRUE` show's
+#' a diff of the stub's request body and the http request body
 #' @param uri (character) a URI/URL as a character string - to determine
 #' whether or not it is allowed
 #'
@@ -35,18 +37,23 @@
 #' webmockr_disable_net_connect(allow = "google.com")
 #' ### is a specific URI allowed?
 #' webmockr_net_connect_allowed("google.com")
+#'
+#' # show body diff
+#' webmockr_configure(show_body_diff = TRUE)
 #' }
 webmockr_configure <- function(
   allow_net_connect = FALSE,
   allow_localhost = FALSE,
   allow = NULL,
-  show_stubbing_instructions = TRUE) {
+  show_stubbing_instructions = TRUE,
+  show_body_diff = FALSE) {
 
   opts <- list(
     allow_net_connect = allow_net_connect,
     allow_localhost = allow_localhost,
     allow = allow,
-    show_stubbing_instructions = show_stubbing_instructions
+    show_stubbing_instructions = show_stubbing_instructions,
+    show_body_diff = show_body_diff
   )
   for (i in seq_along(opts)) {
     assign(names(opts)[i], opts[[i]], envir = webmockr_conf_env)
@@ -126,6 +133,8 @@ print.webmockr_config <- function(x, ...) {
   cat(paste0("  allow: ", x$allow %||% ""), sep = "\n")
   cat(paste0("  show_stubbing_instructions: ", x$show_stubbing_instructions),
       sep = "\n")
+  cat(paste0("  show_body_diff: ", x$show_body_diff),
+      sep = "\n")
 }
 
 webmockr_conf_env <- new.env()

R/webmockr-package.R

@@ -22,6 +22,6 @@
 #' @importFrom fauxpas HTTPRequestTimeout
 #' @importFrom crul mock
 #' @importFrom base64enc base64encode
-#' @importFrom rlang abort check_installed
+#' @importFrom rlang abort check_installed is_list
 ## usethis namespace: end
 NULL