From 0433fa60d50c6eee1c802a282eab33bcdc029f44 Mon Sep 17 00:00:00 2001 From: Scott Chamberlain Date: Tue, 8 Oct 2024 09:23:31 -0700 Subject: [PATCH] fixes to make include/exclude work for keys only, add rlang dep, add more tests --- DESCRIPTION | 3 +- NAMESPACE | 2 + R/RequestPattern.R | 43 +++++--- R/StubbedRequest.R | 2 +- R/include_exclude.R | 48 +++++++-- R/stub_request.R | 49 +++++---- R/wi_th.R | 7 +- R/zzz.R | 8 +- man/UriPattern.Rd | 7 ++ man/including.Rd | 34 ++++++- man/stub_request.Rd | 25 ++++- man/wi_th.Rd | 7 +- tests/testthat/test-partial_matching.R | 136 ++++++++++++++++++++++++- 13 files changed, 310 insertions(+), 61 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 2bcf11b..1501642 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,7 +30,8 @@ Imports: urltools (>= 1.6.0), fauxpas, crul (>= 0.7.0), - base64enc + base64enc, + rlang Suggests: testthat, xml2, diff --git a/NAMESPACE b/NAMESPACE index a0995be..f5a94c6 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/RequestPattern.R b/R/RequestPattern.R index 60d1a68..b600c4a 100644 --- a/R/RequestPattern.R +++ b/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,7 +491,7 @@ 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")) @@ -499,13 +499,13 @@ BODY_FORMATS <- list( #' 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 @@ -513,22 +513,28 @@ BODY_FORMATS <- list( #' 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,6 +581,7 @@ 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 @@ -582,10 +589,20 @@ UriPattern <- R6::R6Class( 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) diff --git a/R/StubbedRequest.R b/R/StubbedRequest.R index a42611a..7d86368 100644 --- a/R/StubbedRequest.R +++ b/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 diff --git a/R/include_exclude.R b/R/include_exclude.R index 9f58e88..7fad770 100644 --- a/R/include_exclude.R +++ b/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("", sep = "\n") + cat(paste0(" partial type: ", attr(x, "partial_type")), sep = "\n") + cat(paste0(" length: ", length(x)), sep = "\n") +} diff --git a/R/stub_request.R b/R/stub_request.R index 95f2fb2..60337a2 100644 --- a/R/stub_request.R +++ b/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() diff --git a/R/wi_th.R b/R/wi_th.R index 2d3f498..0ca8ed9 100644 --- a/R/wi_th.R +++ b/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") diff --git a/R/zzz.R b/R/zzz.R index 5aa2268..9563842 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -25,13 +25,17 @@ 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) @@ -39,7 +43,7 @@ hdl_lst <- function(x) { 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) diff --git a/man/UriPattern.Rd b/man/UriPattern.Rd index b519bdf..3de505f 100644 --- a/man/UriPattern.Rd +++ b/man/UriPattern.Rd @@ -89,6 +89,13 @@ 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 } \keyword{internal} \section{Public fields}{ diff --git a/man/including.Rd b/man/including.Rd index 3d8f5f6..d718885 100644 --- a/man/including.Rd +++ b/man/including.Rd @@ -2,35 +2,59 @@ % Please edit documentation in R/include_exclude.R \name{including} \alias{including} +\alias{partial} \alias{excluding} -\title{Partially match query parameters or request bodies} +\title{Partially match request query parameters or request bodies} \usage{ including(x) excluding(x) } \arguments{ -\item{x}{various objects} +\item{x}{(list) a list; may support other classes in the future} } \value{ -same as \code{x}, but with attributes added +same as \code{x}, but with two attributes added: +\itemize{ +\item partial_match: always \code{TRUE} +\item partial_type: the type of match, one of \code{include} or \code{exclude} +} } \description{ -Partially match query parameters or request bodies +For use inside \code{\link[=wi_th]{wi_th()}} +} +\section{Headers}{ + +Matching on headers already handles partial matching. That is, +\code{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 (\code{including}/\code{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() } diff --git a/man/stub_request.Rd b/man/stub_request.Rd index 8be7c52..2416178 100644 --- a/man/stub_request.Rd +++ b/man/stub_request.Rd @@ -137,7 +137,7 @@ 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) @@ -149,8 +149,8 @@ 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") @@ -158,14 +158,29 @@ 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() diff --git a/man/wi_th.Rd b/man/wi_th.Rd index be8ef4c..b8c17b2 100644 --- a/man/wi_th.Rd +++ b/man/wi_th.Rd @@ -100,7 +100,10 @@ wi_th(req, query = excluding(list(foo = "bar"))) # 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"))) +} +\seealso{ +\code{\link[=including]{including()}} } diff --git a/tests/testthat/test-partial_matching.R b/tests/testthat/test-partial_matching.R index c2ecb69..40bca9c 100644 --- a/tests/testthat/test-partial_matching.R +++ b/tests/testthat/test-partial_matching.R @@ -1,8 +1,9 @@ -context("partial matching") - test_that("include/exclude", { + # keys and values works aa <- including(list(foo = "bar")) - expect_is(aa, "list") + expect_output(print(aa), "") + expect_is(aa, "partial") + expect_is(unclass(aa), "list") expect_equal(length(aa), 1) expect_named(aa, "foo") expect_true(attr(aa, "partial_match")) @@ -10,10 +11,137 @@ test_that("include/exclude", { expect_equal(attr(aa, "partial_type"), "include") bb <- excluding(list(foo = "bar")) - expect_is(bb, "list") + expect_output(print(bb), "") + expect_is(bb, "partial") + expect_is(unclass(bb), "list") expect_equal(length(bb), 1) expect_named(bb, "foo") expect_true(attr(bb, "partial_match")) expect_is(attr(bb, "partial_type"), "character") expect_equal(attr(bb, "partial_type"), "exclude") + + # just keys works + cc <- including(list(foo = NULL, bar = NULL)) + expect_output(print(cc), "") + expect_is(cc, "partial") + expect_is(unclass(cc), "list") + expect_equal(length(cc), 2) +}) + +skip_if_not_installed("httr") +library(httr) + +test_that("include query parameters", { + enable(adapter = "httr") + on.exit({ + disable(adapter = "httr") + unloadNamespace("vcr") + }) + + ## matches + stub_request("get", "https://hb.opencpu.org/get") %>% + wi_th(query = including(list(fruit = "pear"))) %>% + to_return(body = "matched on including partial query!") + + resp_matched <- GET("https://hb.opencpu.org/get", query = list(fruit = "pear")) + + expect_equal(resp_matched$status_code, 200) + expect_equal(rawToChar(content(resp_matched)), "matched on including partial query!") + + stub_registry_clear() + + ## doesn't match when query params dont include what the stub has + expect_error( + GET("https://hb.opencpu.org/get", query = list(meat = "chicken")), + "Real HTTP connections are disabled" + ) + + # cleanup + stub_registry_clear() +}) + +test_that("exclude query parameters", { + enable(adapter = "httr") + on.exit({ + disable(adapter = "httr") + unloadNamespace("vcr") + }) + + ## matches + stub_request("get", "https://hb.opencpu.org/get") %>% + wi_th(query = excluding(list(fruit = "pear"))) %>% + to_return(body = "matched on excluding partial query!") + + resp_matched <- GET("https://hb.opencpu.org/get", query = list(fruit = "apple")) + + expect_equal(resp_matched$status_code, 200) + expect_equal(rawToChar(content(resp_matched)), "matched on excluding partial query!") + + ## doesn't match when query params include what's excluded + expect_error( + GET("https://hb.opencpu.org/get", query = list(fruit = "pear")), + "Real HTTP connections are disabled" + ) + + # cleanup + stub_registry_clear() +}) + + +test_that("include query parameters, just keys", { + enable(adapter = "httr") + on.exit({ + disable(adapter = "httr") + unloadNamespace("vcr") + }) + + ## matches + stub_request("get", "https://hb.opencpu.org/get") %>% + wi_th(query = including(list(fruit = NULL))) %>% + to_return(body = "matched on including key!") + + resp_matched <- GET("https://hb.opencpu.org/get", query = list(fruit = "pear")) + + expect_equal(resp_matched$status_code, 200) + expect_equal(rawToChar(content(resp_matched)), "matched on including key!") + + stub_registry_clear() + + ## doesn't match when no query param keys match the include + expect_error( + GET("https://hb.opencpu.org/get", query = list(meat = "chicken")), + "Real HTTP connections are disabled" + ) + + # cleanup + stub_registry_clear() +}) + +test_that("exclude query parameters, just keys", { + enable(adapter = "httr") + on.exit({ + disable(adapter = "httr") + unloadNamespace("vcr") + }) + + ## matches + stub_request("get", "https://hb.opencpu.org/get") %>% + wi_th(query = excluding(list(fruit = NULL))) %>% + to_return(body = "matched on excluding key!") + + resp_matched <- GET("https://hb.opencpu.org/get", query = list(stuff = "things")) + + expect_equal(resp_matched$status_code, 200) + expect_equal(rawToChar(content(resp_matched)), "matched on excluding key!") + + stub_registry_clear() + + ## doesn't match when there's a query param key that matches the exclude + expect_error( + GET("https://hb.opencpu.org/get", query = list(fruit = "pineapple")), + "Real HTTP connections are disabled" + ) + + # cleanup + stub_registry_clear() })