fixes to make include/exclude work for keys only, add rlang dep, add …

…more tests

DESCRIPTION

@@ -30,7 +30,8 @@ Imports:
     urltools (>= 1.6.0),
     fauxpas,
     crul (>= 0.7.0),
-    base64enc
+    base64enc,
+    rlang
 Suggests:
     testthat,
     xml2,

NAMESPACE

@@ -1,6 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,mock_file)
+S3method(print,partial)
 S3method(print,webmockr_config)
 export("%>%")
 export(Adapter)
@@ -62,3 +63,4 @@ importFrom(base64enc,base64encode)
 importFrom(crul,mock)
 importFrom(fauxpas,HTTPRequestTimeout)
 importFrom(magrittr,"%>%")
+importFrom(rlang,is_empty)

R/RequestPattern.R

@@ -448,7 +448,7 @@ BODY_FORMATS <- list(
 #' (z <- UriPattern$new(pattern = "http://foobar.com"))
 #' z$matches("http://foobar.com") # TRUE
 #' z$matches("http://foobar.com/") # TRUE
-#' 
+#'
 #' # without scheme
 #' ## matches http by default: does not match https by default
 #' (z <- UriPattern$new(pattern = "foobar.com"))
@@ -491,44 +491,50 @@ BODY_FORMATS <- list(
 #' z$add_query_params() # have to run this method to gather query params
 #' z$matches("https://httpbin.org/get?stuff=things") # TRUE
 #' z$matches("https://httpbin.org/get?stuff2=things") # FALSE
-#' 
+#'
 #' # regex add query parameters
 #' (z <- UriPattern$new(regex_pattern = "https://foobar.com/.+/order"))
 #' z$add_query_params(list(pizza = "cheese"))
 #' z
 #' z$pattern
 #' z$matches("https://foobar.com/pizzas/order?pizza=cheese") # TRUE
 #' z$matches("https://foobar.com/pizzas?pizza=cheese") # FALSE
-#' 
+#'
 #' # query parameters in the regex uri
 #' (z <- UriPattern$new(regex_pattern = "https://x.com/.+/order\\?fruit=apple"))
 #' z$add_query_params() # have to run this method to gather query params
 #' z$matches("https://x.com/a/order?fruit=apple") # TRUE
 #' z$matches("https://x.com/a?fruit=apple") # FALSE
-#' 
+#'
 #' # any pattern
 #' (z <- UriPattern$new(regex_pattern = "stuff\\.com.+"))
 #' z$regex
 #' z$pattern
 #' z$matches("http://stuff.com") # FALSE
 #' z$matches("https://stuff.com/stff") # TRUE
 #' z$matches("https://stuff.com/apple?bears=brown&bats=grey") # TRUE
-#' 
+#'
 #' # partial matching
 #' ## including
 #' z <- UriPattern$new(pattern = "http://foobar.com")
 #' z$add_query_params(including(list(hello = "world")))
 #' z$matches(uri = "http://foobar.com?hello=world&bye=mars") # TRUE
 #' z$matches("http://foobar.com?bye=mars") # FALSE
-#' 
+#'
 #' ## excluding
 #' z <- UriPattern$new(pattern = "http://foobar.com")
 #' z$add_query_params(excluding(list(hello = "world")))
 #' z$matches(uri = "http://foobar.com?hello=world&bye=mars") # FALSE
 #' z$matches("http://foobar.com?bye=mars") # TRUE
-
+#'
+#' ## match on list keys (aka: names) only, ignore values 0
+#' z <- UriPattern$new(pattern = "http://foobar.com")
+#' z$add_query_params(including(list(hello = NULL)))
+#' z$matches(uri = "http://foobar.com?hello=world&bye=mars") # TRUE
+#' z$matches("http://foobar.com?hello=stuff") # TRUE
+#' z$matches("http://foobar.com?bye=stuff") # FALSE
 UriPattern <- R6::R6Class(
-  'UriPattern',
+  "UriPattern",
   public = list(
     #' @field pattern (character) pattern holder
     pattern = NULL,
@@ -575,17 +581,28 @@ UriPattern <- R6::R6Class(
       grepl(drop_query_params(self$pattern), just_uri(uri)) # regex
     },
 
+    #' @importFrom rlang is_empty
     #' @description Match query parameters of a URI
     #' @param uri (character) a uri
     #' @return a boolean
     query_params_matches = function(uri) {
       if (self$partial) {
         uri_qp <- self$extract_query(uri)
         qp <- private$drop_partial_attrs(self$query_params)
-        bools <- uri_qp %in% qp
-        return(switch(self$partial_type, 
-          include = any(bools), 
-          exclude = !any(bools)))
+
+        bools <- vector(mode = "logical")
+        for (i in seq_along(qp)) {
+          if (rlang::is_empty(qp[[i]])) {
+            bools[i] <- names(qp) %in% names(uri_qp)
+          } else {
+            bools[i] <- qp %in% uri_qp
+          }
+        }
+        out <- switch(self$partial_type,
+          include = any(bools),
+          exclude = !any(bools)
+        )
+        return(out)
       }
       identical(self$query_params, self$extract_query(uri))
     },
@@ -625,7 +642,6 @@ UriPattern <- R6::R6Class(
     #' @return a string
     to_s = function() self$pattern
   ),
-
   private = list(
     drop_partial_attrs = function(x) {
       attr(x, "partial_match") <- NULL
@@ -635,6 +651,7 @@ UriPattern <- R6::R6Class(
   )
 )
 
+
 add_scheme <- function(x) {
   if (is.na(urltools::url_parse(x)$scheme)) {
     paste0('https?://', x)

R/StubbedRequest.R

@@ -237,7 +237,7 @@ StubbedRequest <- R6::R6Class(
     #' @return nothing returned; sets only
     with = function(query = NULL, body = NULL, headers = NULL, basic_auth = NULL) {
       if (!is.null(query)) {
-        query <- lapply(query, as.character)
+        query[] <- lapply(query, as.character)
       }
       self$query <- query
       self$body <- body

R/include_exclude.R

@@ -1,24 +1,47 @@
-#' Partially match query parameters or request bodies
-#' 
+#' Partially match request query parameters or request bodies
+#'
+#' For use inside [wi_th()]
+#'
 #' @export
-#' @param x various objects
-#' @return same as `x`, but with attributes added
+#' @param x (list) a list; may support other classes in the future
+#' @return same as `x`, but with two attributes added:
+#' - partial_match: always `TRUE`
+#' - partial_type: the type of match, one of `include` or `exclude`
+#' @aliases partial
+#' @section Headers:
+#' Matching on headers already handles partial matching. That is,
+#' `wi_th(headers = list(Fruit = "pear"))` matches any request
+#' that has any request header that matches - the request can have
+#' other request headers, but those don't matter as long as there is
+#' a match. These helpers (`including`/`excluding`) are needed
+#' for query parameters and bodies because by default matching must be
+#' exact for those.
 #' @examples
 #' including(list(foo = "bar"))
-#' # just keys by setting values as NULL
+#' excluding(list(foo = "bar"))
+#'
+#' # get just keys by setting values as NULL
 #' including(list(foo = NULL, bar = NULL))
-#' 
+#'
 #' # in a stub
 #' req <- stub_request("get", "https://httpbin.org/get")
-#' 
+#' req
+#'
 #' ## query
 #' wi_th(req, query = list(foo = "bar"))
 #' wi_th(req, query = including(list(foo = "bar")))
 #' wi_th(req, query = excluding(list(foo = "bar")))
-#' 
+#'
+#' ## body
+#' wi_th(req, body = list(foo = "bar"))
+#' wi_th(req, body = including(list(foo = "bar")))
+#' wi_th(req, body = excluding(list(foo = "bar")))
+#'
 #' # cleanup
 #' stub_registry_clear()
 including <- function(x) {
+  assert(x, "list")
+  class(x) <- "partial"
   attr(x, "partial_match") <- TRUE
   attr(x, "partial_type") <- "include"
   return(x)
@@ -27,7 +50,16 @@ including <- function(x) {
 #' @export
 #' @rdname including
 excluding <- function(x) {
+  assert(x, "list")
+  class(x) <- "partial"
   attr(x, "partial_match") <- TRUE
   attr(x, "partial_type") <- "exclude"
   return(x)
 }
+
+#' @export
+print.partial <- function(x, ...) {
+  cat("<partial match>", sep = "\n")
+  cat(paste0("  partial type: ", attr(x, "partial_type")), sep = "\n")
+  cat(paste0("  length: ", length(x)), sep = "\n")
+}

R/stub_request.R

@@ -20,25 +20,25 @@
 #' If multiple stubs match the same request, we use the first stub. So if you
 #' want to use a stub that was created after an earlier one that matches,
 #' remove the earlier one(s).
-#' 
+#'
 #' Note on `wi_th()`: If you pass `query` values are coerced to character
 #' class in the recorded stub. You can pass numeric, integer, etc., but
 #' all will be coerced to character.
-#' 
+#'
 #' See [wi_th()] for details on request body/query/headers and
 #' [to_return()] for details on how response status/body/headers
 #' are handled
-#' 
+#'
 #' @note Trailing slashes are dropped from stub URIs before matching
-#' 
+#'
 #' @section uri vs. uri_regex:
 #' When you use `uri`, we compare the URIs without query params AND
-#' also the query params themselves without the URIs. 
-#' 
+#' also the query params themselves without the URIs.
+#'
 #' When you use `uri_regex` we don't compare URIs and query params;
 #' we just use your regex string defined in `uri_regex` as the pattern
 #' for a call to [grepl]
-#' 
+#'
 #' @section Mocking writing to disk:
 #' See [mocking-disk-writing]
 #' @seealso [wi_th()], [to_return()], [to_timeout()], [to_raise()],
@@ -98,7 +98,7 @@
 #' # pass a list to .list
 #' z <- stub_request("get", "https://httpbin.org/get")
 #' wi_th(z, .list = list(query = list(foo = "bar")))
-#' 
+#'
 #' # just body
 #' stub_request("any", uri_regex = ".+") %>%
 #'    wi_th(body = list(foo = 'bar'))
@@ -113,11 +113,11 @@
 #' httr_mock()
 #' POST('https://example.com', body = list(foo = 'bar'))
 #' PUT('https://google.com', body = list(foo = 'bar'))
-#' 
-#' 
+#'
+#'
 #' # just headers
 #' headers <- list(
-#'   'Accept-Encoding' = 'gzip, deflate', 
+#'   'Accept-Encoding' = 'gzip, deflate',
 #'   'Accept' = 'application/json, text/xml, application/xml, */*')
 #' stub_request("any", uri_regex = ".+") %>% wi_th(headers = headers)
 #' library(crul)
@@ -126,26 +126,41 @@
 #' x$post('post')
 #' x$put('put', body = list(foo = 'bar'))
 #' x$get('put', query = list(stuff = 3423234L))
-#' 
+#'
 #' # many responses
 #' ## the first response matches the first to_return call, and so on
-#' stub_request("get", "https://httpbin.org/get") %>% 
-#'   to_return(status = 200, body = "foobar", headers = list(a = 5)) %>% 
+#' stub_request("get", "https://httpbin.org/get") %>%
+#'   to_return(status = 200, body = "foobar", headers = list(a = 5)) %>%
 #'   to_return(status = 200, body = "bears", headers = list(b = 6))
 #' con <- crul::HttpClient$new(url = "https://httpbin.org")
 #' con$get("get")$parse("UTF-8")
 #' con$get("get")$parse("UTF-8")
-#' 
+#'
 #' ## OR, use times with to_return() to repeat the same response many times
 #' library(fauxpas)
-#' stub_request("get", "https://httpbin.org/get") %>% 
-#'   to_return(status = 200, body = "apple-pie", times = 2) %>% 
+#' stub_request("get", "https://httpbin.org/get") %>%
+#'   to_return(status = 200, body = "apple-pie", times = 2) %>%
 #'   to_raise(HTTPUnauthorized)
 #' con <- crul::HttpClient$new(url = "https://httpbin.org")
 #' con$get("get")$parse("UTF-8")
 #' con$get("get")$parse("UTF-8")
 #' con$get("get")$parse("UTF-8")
 #'
+#' # partial matching
+#' library(httr)
+#' ## 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"))
+#' rawToChar(content(resp))
+#' ## 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"))
+#'
 #' # clear all stubs
 #' stub_registry()
 #' stub_registry_clear()

R/wi_th.R

@@ -16,6 +16,7 @@
 #' @return an object of class `StubbedRequest`, with print method describing
 #' the stub
 #' @note see more examples in [stub_request()]
+#' @seealso [including()]
 #' @details 
 #' Values for query, body, headers, and basic_auth:
 #'
@@ -83,9 +84,9 @@
 #' 
 #' # partial matching, body
 #' ## including
-#' # wi_th(req, body = including(list(foo = "bar")))
+#' wi_th(req, body = including(list(foo = "bar")))
 #' ## excluding
-#' # wi_th(req, body = excluding(list(foo = "bar")))
+#' wi_th(req, body = excluding(list(foo = "bar")))
 wi_th <- function(.data, ..., .list = list()) {
   assert(.data, "StubbedRequest")
   assert(.list, "list")
@@ -99,7 +100,7 @@ wi_th <- function(.data, ..., .list = list()) {
     stop("'wi_th' only accepts query, body, headers, basic_auth")
   }
   if (any(duplicated(names(z)))) stop("can not have duplicated names")
-  assert(z$query, "list")
+  assert(z$query, c("list", "partial"))
   if (!all(hz_namez(z$query))) stop("'query' must be a named list")
   assert(z$headers, "list")
   if (!all(hz_namez(z$headers))) stop("'headers' must be a named list")

R/zzz.R

@@ -25,21 +25,25 @@ subs <- function(x, n) {
 
 l2c <- function(w) paste(names(w), as.character(w), sep = " = ", collapse = "")
 
+has_attr <- function(x, at) {
+  !is.null(attr(x, at, exact = TRUE))
+}
+
 hdl_lst <- function(x) {
   if (is.null(x) || length(x) == 0) return("")
   if (is.raw(x)) return(paste0("raw bytes, length: ", length(x)))
   if (inherits(x, "form_file"))
     return(sprintf("crul::upload(\"%s\", type=\"%s\")", x$path, x$type))
   if (inherits(x, "mock_file")) return(paste0("mock file, path: ", x$path))
-  if (inherits(x, "list")) {
+  if (inherits(x, c("list", "partial"))) {
     if (is_nested(x)) {
       # substring(l2c(x), 1, 80)
       subs(l2c(x), 80)
     } else {
       txt <- paste(names(x), subs(unname(unlist(x)), 20), sep = "=",
         collapse = ", ")
       txt <- substring(txt, 1, 80)
-      if (attr(x, "partial_match") %||% FALSE) {
+      if (has_attr(x, "partial_match")) {
         txt <- sprintf("%s(%s)",
           switch(attr(x, "partial_type"),
             include = "including", exclude = "excluding"), txt)