make request body matching work for partial matches, tweaks to BodyPa…

…ttern class to make things cleaner, resave rda files, tweak tests

R/RequestPattern.R

@@ -369,17 +369,41 @@ HeadersPattern <- R6::R6Class(
 #' )
 #' z$pattern
 #' z$matches(bb$body)
+#'
+#' # partial matching
+#' ## including
+#' partial_incl <- including(list(foo = "bar"))
+#' z <- BodyPattern$new(pattern = partial_incl)
+#' z$pattern
+#' z$matches(list(foo = "bar", a = 5)) # TRUE
+#'
+#' ## excluding
+#' partial_excl <- excluding(list(hello = "world"))
+#' z <- BodyPattern$new(pattern = partial_excl)
+#' z$pattern
+#' z$matches(list(a = 5)) # TRUE
+#' z$matches(list(hello = "mars", a = 5)) # TRUE
+#' z$matches(list(hello = "world")) # FALSE
 BodyPattern <- R6::R6Class(
   "BodyPattern",
   public = list(
     #' @field pattern a list
     pattern = NULL,
+     #' @field partial bool, default: `FALSE`
+    partial = FALSE,
+    #' @field partial_type a string, default: NULL
+    partial_type = NULL,
 
     #' @description Create a new `BodyPattern` object
     #' @param pattern (list) a body object
     #' @return A new `BodyPattern` object
     initialize = function(pattern) {
-      if (inherits(pattern, "form_file")) {
+      if (inherits(pattern, "partial")) {
+        self$partial <- attr(pattern, "partial_match") %||% FALSE
+        self$partial_type <- attr(pattern, "partial_type")
+        pattern <- drop_partial_attrs(pattern)
+        self$pattern <- unclass(pattern)
+      } else if (inherits(pattern, "form_file")) {
         self$pattern <- unclass(pattern)
       } else {
         self$pattern <- pattern
@@ -395,8 +419,9 @@ BodyPattern <- R6::R6Class(
         if (length(self$pattern) == 0) {
           return(TRUE)
         }
-        private$matching_hashes(private$body_as_hash(body, content_type), self$pattern)
+        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)
       }
     },
@@ -409,29 +434,31 @@ BodyPattern <- R6::R6Class(
     empty_string = function(string) {
       is.null(string) || !nzchar(string)
     },
-    matching_hashes = function(z, pattern) {
-      if (is.null(z)) {
+    matching_hashes = function(pattern, body) {
+      if (is.null(pattern)) {
         return(FALSE)
       }
-      if (!inherits(z, "list")) {
+      if (!inherits(pattern, "list")) {
         return(FALSE)
       }
-      if (!all(sort(names(z)) %in% sort(names(pattern)))) {
-        return(FALSE)
-      }
-      for (i in seq_along(z)) {
-        expected <- pattern[[names(z)[i]]]
-        actual <- z[[i]]
-        if (inherits(actual, "list") && inherits(expected, "list")) {
-          if (!private$matching_hashes(actual, expected)) {
-            return(FALSE)
-          }
-        } else {
-          if (!identical(as.character(actual), as.character(expected))) {
-            return(FALSE)
-          }
+
+      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,
+          include = identical(intersect(pattern_char, body_char), pattern_char),
+          exclude = length(intersect(pattern_char, body_char)) == 0
+        )
+        if (!names_values_check) {
+          return(FALSE)
+        }
+      } else {
+        if (!identical(pattern_char, body_char)) {
+          return(FALSE)
         }
       }
+
+      # return TRUE (a match) if no FALSE's returned above
       return(TRUE)
     },
     body_as_hash = function(body, content_type) {
@@ -614,7 +641,7 @@ UriPattern <- R6::R6Class(
     query_params_matches = function(uri) {
       if (self$partial) {
         uri_qp <- self$extract_query(uri)
-        qp <- private$drop_partial_attrs(self$query_params)
+        qp <- drop_partial_attrs(self$query_params)
 
         bools <- vector(mode = "logical")
         for (i in seq_along(qp)) {
@@ -673,16 +700,14 @@ UriPattern <- R6::R6Class(
     #' @description Print pattern for easy human consumption
     #' @return a string
     to_s = function() self$pattern
-  ),
-  private = list(
-    drop_partial_attrs = function(x) {
-      attr(x, "partial_match") <- NULL
-      attr(x, "partial_type") <- NULL
-      return(x)
-    }
   )
 )
 
+drop_partial_attrs <- function(x) {
+  attr(x, "partial_match") <- NULL
+  attr(x, "partial_type") <- NULL
+  return(x)
+}
 
 add_scheme <- function(x) {
   if (is.na(urltools::url_parse(x)$scheme)) {

R/StubRegistry.R

@@ -123,7 +123,7 @@ json_validate <- function(x) {
 make_body <- function(x) {
   if (is.null(x)) return("")
   if (inherits(x, "mock_file")) x <- x$payload
-  if (inherits(x, "form_file")) x <- unclass(x)
+  if (inherits(x, c("form_file", "partial"))) x <- unclass(x)
   clzzes <- vapply(x, function(z) inherits(z, "form_file"), logical(1))
   if (any(clzzes)) for(i in seq_along(x)) x[[i]] <- unclass(x[[i]])
   if (json_validate(x))

R/stub_request.R

@@ -149,19 +149,41 @@
 #' con$get("get")$parse("UTF-8")
 #'
 #' # partial matching
+#' ## query parameters
 #' library(httr)
-#' ## matches
+#' enable()
+#' ### matches
 #' stub_request("get", "https://hb.opencpu.org/get") %>%
 #'   wi_th(query = including(list(fruit = "pear"))) %>%
 #'   to_return(body = "matched on partial query!")
-#' resp <- GET("https://hb.opencpu.org/get", query = list(fruit = "pear"))
+#' resp <- GET("https://hb.opencpu.org/get",
+#'   query = list(fruit = "pear", bread = "scone"))
 #' rawToChar(content(resp))
-#' ## doesn't match
+#' ### doesn't match
 #' stub_registry_clear()
 #' stub_request("get", "https://hb.opencpu.org/get") %>%
 #'   wi_th(query = list(fruit = "pear")) %>%
 #'   to_return(body = "didn't match, ugh!")
-#' # GET("https://hb.opencpu.org/get", query = list(fruit = "pear", meat = "chicken"))
+#' # GET("https://hb.opencpu.org/get",
+#' #  query = list(fruit = "pear", meat = "chicken"))
+#'
+#' ## request body
+#' ### matches - including
+#' stub_request("post", "https://hb.opencpu.org/post") %>%
+#'   wi_th(body = including(list(fruit = "pear"))) %>%
+#'   to_return(body = "matched on partial body!")
+#' resp <- POST("https://hb.opencpu.org/post",
+#'   body = list(fruit = "pear", meat = "chicken"))
+#' rawToChar(content(resp))
+#' ### matches - excluding
+#' stub_request("post", "https://hb.opencpu.org/post") %>%
+#'   wi_th(body = excluding(list(fruit = "pear"))) %>%
+#'   to_return(body = "matched on partial body!")
+#' res <- POST("https://hb.opencpu.org/post",
+#'   body = list(color = "blue"))
+#' rawToChar(content(res))
+#' # POST("https://hb.opencpu.org/post",
+#' #  body = list(fruit = "pear", meat = "chicken"))
 #'
 #' # clear all stubs
 #' stub_registry()

tests/testthat/test-RequestPattern.R

@@ -118,6 +118,9 @@ test_that("BodyPattern: structure is correct", {
   aaa <- BodyPattern$new(pattern = list(foo = "bar", a = 5))
   expect_true(aaa$matches(bb$body))
 
+  aaaa <- BodyPattern$new(pattern = list(foo = "bar", a = 5, b = "asdad"))
+  expect_false(aaaa$matches(bb$body))
+
   # with pattern empty
   bb <- BodyPattern$new(pattern = list())
   expect_true(bb$matches(list()))

tests/testthat/test-partial_matching.R

@@ -145,3 +145,64 @@ test_that("exclude query parameters, just keys", {
   # cleanup
   stub_registry_clear()
 })
+
+
+test_that("include request body", {
+  enable(adapter = "httr")
+  on.exit({
+    disable(adapter = "httr")
+    unloadNamespace("vcr")
+  })
+
+  ## matches
+  stub_request("post", "https://hb.opencpu.org/post") %>%
+    wi_th(body = including(list(fruit = "pear"))) %>%
+    to_return(body = "matched on including partial body!")
+
+  resp_matched <- POST("https://hb.opencpu.org/post", 
+    body = list(fruit = "pear", meat = "chicken"))
+
+  expect_equal(resp_matched$status_code, 200)
+  expect_equal(rawToChar(content(resp_matched)), "matched on including partial body!")
+
+  stub_registry_clear()
+
+  ## doesn't match when request body does not include what the stub has
+  expect_error(
+    POST("https://hb.opencpu.org/post", query = list(meat = "chicken")),
+    "Real HTTP connections are disabled"
+  )
+
+  # cleanup
+  stub_registry_clear()
+})
+
+test_that("exclude request body", {
+  enable(adapter = "httr")
+  on.exit({
+    disable(adapter = "httr")
+    unloadNamespace("vcr")
+  })
+
+  ## matches
+  stub_request("post", "https://hb.opencpu.org/post") %>%
+    wi_th(body = excluding(list(fruit = "pear"))) %>%
+    to_return(body = "matched on excluding partial body!")
+
+  resp_matched <- POST("https://hb.opencpu.org/post",
+    body = list(color = "blue"))
+
+  expect_equal(resp_matched$status_code, 200)
+  expect_equal(rawToChar(content(resp_matched)), "matched on excluding partial body!")
+
+  stub_registry_clear()
+
+  ## doesn't match when request body does not include what the stub has
+  expect_error(
+    POST("https://hb.opencpu.org/post", body = list(fruit = "pear", meat = "chicken")),
+    "Real HTTP connections are disabled"
+  )
+
+  # cleanup
+  stub_registry_clear()
+})