R/RequestPattern.R
In ropenscilabs/webmockr: Stubbing and Setting Expectations on 'HTTP' Requests
Defines functions
get_body
get_query
get_method
drop_query_params
uri_port
uri_path
uri_host
uri_fetch
parse_a_url
is_localhost
is_url
prune_port
prune_trailing_slash
normalize_uri
esc
add_scheme
#' @title RequestPattern class
#' @description class handling all request matchers
#' @export
#' @seealso pattern classes for HTTP method [MethodPattern], headers
#' [HeadersPattern], body [BodyPattern], and URI/URL [UriPattern]
#' @examples \dontrun{
#' (x <- RequestPattern$new(method = "get", uri = "httpbin.org/get"))
#' x$body_pattern
#' x$headers_pattern
#' x$method_pattern
#' x$uri_pattern
#' x$to_s()
#'
#' # make a request signature
#' rs <- RequestSignature$new(method = "get", uri = "http://httpbin.org/get")
#'
#' # check if it matches
#' x$matches(rs)
#'
#' # regex uri
#' (x <- RequestPattern$new(method = "get", uri_regex = ".+ossref.org"))
#' x$uri_pattern
#' x$uri_pattern$to_s()
#' x$to_s()
#'
#' # uri with query parameters
#' (x <- RequestPattern$new(
#' method = "get", uri = "https://httpbin.org/get",
#' query = list(foo = "bar")
#' ))
#' x$to_s()
#' ## query params included in url, not separately
#' (x <- RequestPattern$new(
#' method = "get", uri = "https://httpbin.org/get?stuff=things"
#' ))
#' x$to_s()
#' x$query_params
#'
#' # just headers (via setting method=any & uri_regex=.+)
#' headers <- list(
#' 'User-Agent' = 'Apple',
#' 'Accept-Encoding' = 'gzip, deflate',
#' 'Accept' = 'application/json, text/xml, application/xml, */*')
#' x <- RequestPattern$new(
#' method = "any",
#' uri_regex = ".+",
#' headers = headers)
#' x$to_s()
#' rs <- RequestSignature$new(method = "any", uri = "http://foo.bar",
#' options = list(headers = headers))
#' rs
#' x$matches(rs)
#'
#' # body
#' x <- RequestPattern$new(method = "post", uri = "httpbin.org/post",
#' body = list(y = crul::upload(system.file("CITATION"))))
#' x$to_s()
#' rs <- RequestSignature$new(method = "post", uri = "http://httpbin.org/post",
#' options = list(
#' body = list(y = crul::upload(system.file("CITATION")))))
#' rs
#' x$matches(rs)
#' }
RequestPattern <- R6::R6Class(
'RequestPattern',
public = list(
#' @field method_pattern xxx
method_pattern = NULL,
#' @field uri_pattern xxx
uri_pattern = NULL,
#' @field body_pattern xxx
body_pattern = NULL,
#' @field headers_pattern xxx
headers_pattern = NULL,
#' @description Create a new `RequestPattern` object
#' @param method the HTTP method (any, head, options, get, post, put,
#' patch, trace, or delete). "any" matches any HTTP method. required.
#' @param uri (character) request URI. required or uri_regex
#' @param uri_regex (character) request URI as regex. required or uri
#' @param query (list) query parameters, optional
#' @param body (list) body request, optional
#' @param headers (list) headers, optional
#' @return A new `RequestPattern` object
initialize = function(method, uri = NULL, uri_regex = NULL,
query = NULL, body = NULL, headers = NULL) {
if (is.null(uri) && is.null(uri_regex)) {
stop("one of uri or uri_regex is required", call. = FALSE)
}
self$method_pattern <- MethodPattern$new(pattern = method)
self$uri_pattern <- if (is.null(uri_regex)) {
UriPattern$new(pattern = uri)
} else {
UriPattern$new(regex_pattern = uri_regex)
}
self$uri_pattern$add_query_params(query)
self$body_pattern <- if (!is.null(body)) BodyPattern$new(pattern = body)
self$headers_pattern <- if (!is.null(headers))
HeadersPattern$new(pattern = headers)
# FIXME: all private methods used in the below line, see if needed or remove
# if (length(options)) private$assign_options(options)
},
#' @description does a request signature match the selected matchers?
#' @param request_signature a [RequestSignature] object
#' @return a boolean
matches = function(request_signature) {
assert(request_signature, "RequestSignature")
c_type <- if (!is.null(request_signature$headers)) request_signature$headers$`Content-Type` else NULL
if (!is.null(c_type)) c_type <- strsplit(c_type, ';')[[1]][1]
self$method_pattern$matches(request_signature$method) &&
self$uri_pattern$matches(request_signature$uri) &&
(is.null(self$body_pattern) || self$body_pattern$matches(request_signature$body, c_type %||% "")) &&
(is.null(self$headers_pattern) || self$headers_pattern$matches(request_signature$headers))
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() {
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$headers_pattern)) paste0(" with headers ", self$headers_pattern$to_s())
))
}
),
private = list(
# assign_options = function(options) {
# #self$validate_keys(options, 'body', 'headers', 'query', 'basic_auth')
# set_basic_auth_as_headers(options)
# self$body_pattern <- if ('body' %in% names(options)) BodyPattern$new(options['body'])
# self$headers_pattern <- if ('headers' %in% names(options)) HeadersPattern$new(options['headers'])
# if ('query' %in% names(options)) self$uri_pattern$add_query_params(options['query'])
# },
# validate_keys = function(x, ...) {
# valid_keys <- unlist(list(...), recursive = FALSE)
# for (i in seq_along(x)) {
# if (!names(x)[i] %in% valid_keys) {
# stop(
# sprintf("Unknown key: %s. Valid keys are: %s",
# names(x)[i],
# paste0(valid_keys, collapse = ", "),
# call. = FALSE
# )
# )
# }
# }
# },
set_basic_auth_as_headers = function(options) {
if ('basic_auth' %in% names(options)) {
private$validate_basic_auth(options$basic_auth)
options$headers <- list()
options$headers$Authorization <-
private$make_basic_auth(options$basic_auth[1], options$basic_auth[2])
}
},
validate_basic_auth = function(x) {
if (!inherits(x, "list") || length(unique(unname(unlist(x)))) == 1) {
stop(
"'basic_auth' option should be a list of length 2: username and password",
call. = FALSE
)
}
},
make_basic_auth = function(x, y) {
jsonlite::base64_enc(paste0(x, ":", y))
}
)
)
#' @title MethodPattern
#' @description method matcher
#' @export
#' @keywords internal
#' @details Matches regardless of case. e.g., POST will match to post
#' @examples
#' (x <- MethodPattern$new(pattern = "post"))
#' x$pattern
#' x$matches(method = "post")
#' x$matches(method = "POST")
#'
#' # all matches() calls should be TRUE
#' (x <- MethodPattern$new(pattern = "any"))
#' x$pattern
#' x$matches(method = "post")
#' x$matches(method = "GET")
#' x$matches(method = "HEAD")
MethodPattern <- R6::R6Class(
'MethodPattern',
public = list(
#' @field pattern (character) an http method
pattern = NULL,
#' @description Create a new `MethodPattern` object
#' @param pattern (character) a HTTP method, lowercase
#' @return A new `MethodPattern` object
initialize = function(pattern) {
self$pattern <- tolower(pattern)
},
#' @description test if the pattern matches a given http method
#' @param method (character) a HTTP method, lowercase
#' @return a boolean
matches = function(method) {
self$pattern == tolower(method) || self$pattern == "any"
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
)
)
#' @title HeadersPattern
#' @description headers matcher
#' @export
#' @keywords internal
#' @details
#' `webmockr` normalises headers and treats all forms of same headers as equal:
#' i.e the following two sets of headers are equal:
#' `list(Header1 = "value1", content_length = 123, X_CuStOm_hEAder = "foo")`
#' and
#' `list(header1 = "value1", "Content-Length" = 123, "x-cuSTOM-HeAder" = "foo")`
#' @examples
#' (x <- HeadersPattern$new(pattern = list(a = 5)))
#' x$pattern
#' x$matches(list(a = 5))
#'
#' # different cases
#' (x <- HeadersPattern$new(pattern = list(Header1 = "value1")))
#' x$pattern
#' x$matches(list(header1 = "value1"))
#' x$matches(list(header1 = "value2"))
#'
#' # different symbols
#' (x <- HeadersPattern$new(pattern = list(`Hello_World` = "yep")))
#' x$pattern
#' x$matches(list(`hello-world` = "yep"))
#' x$matches(list(`hello-worlds` = "yep"))
#'
#' headers <- list(
#' 'User-Agent' = 'Apple',
#' 'Accept-Encoding' = 'gzip, deflate',
#' 'Accept' = 'application/json, text/xml, application/xml, */*')
#' (x <- HeadersPattern$new(pattern = headers))
#' x$to_s()
#' x$pattern
#' x$matches(headers)
HeadersPattern <- R6::R6Class(
'HeadersPattern',
public = list(
#' @field pattern a list
pattern = NULL,
#' @description Create a new `HeadersPattern` object
#' @param pattern (list) a pattern, as a named list, must be named,
#' e.g,. `list(a = 5, b = 6)`
#' @return A new `HeadersPattern` object
initialize = function(pattern) {
stopifnot(is.list(pattern))
pattern <- private$normalize_headers(pattern)
self$pattern <- pattern
},
#' @description Match a list of headers against that stored
#' @param headers (list) named list of headers, e.g,. `list(a = 5, b = 6)`
#' @return a boolean
matches = function(headers) {
if (self$empty_headers(self$pattern)) {
self$empty_headers(headers)
} else {
if (self$empty_headers(headers)) return(FALSE)
headers <- private$normalize_headers(headers)
out <- c()
for (i in seq_along(self$pattern)) {
out[i] <- names(self$pattern)[i] %in% names(headers) &&
self$pattern[[i]] == headers[[names(self$pattern)[i]]]
}
all(out)
}
},
#' @description Are headers empty? tests if null or length==0
#' @param headers named list of headers
#' @return a boolean
empty_headers = function(headers) {
is.null(headers) || length(headers) == 0
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() hdl_lst2(self$pattern)
),
private = list(
normalize_headers = function(x) {
# normalize names
names(x) <- tolower(names(x))
# normalize symbols
## underscores to single dash
names(x) <- gsub("_", "-", names(x))
return(x)
}
)
)
#' @title BodyPattern
#' @description body matcher
#' @export
#' @keywords internal
#' @examples
#' # make a request signature
#' bb <- RequestSignature$new(
#' method = "get",
#' uri = "https:/httpbin.org/get",
#' options = list(
#' body = list(foo = "bar", a = 5)
#' )
#' )
#'
#' # make body pattern object
#' ## FALSE
#' z <- BodyPattern$new(pattern = list(foo = "bar"))
#' z$pattern
#' z$matches(bb$body)
#' ## TRUE
#' z <- BodyPattern$new(pattern = list(foo = "bar", a = 5))
#' z$pattern
#' z$matches(bb$body)
#'
#' # uploads in bodies
#' ## upload NOT in a list
#' bb <- RequestSignature$new(
#' method = "post", uri = "https:/httpbin.org/post",
#' options = list(body = crul::upload(system.file("CITATION"))))
#' bb$body
#' z <- BodyPattern$new(pattern =
#' crul::upload(system.file("CITATION")))
#' z$pattern
#' z$matches(bb$body)
#'
#' ## upload in a list
#' bb <- RequestSignature$new(
#' method = "post", uri = "https:/httpbin.org/post",
#' options = list(body = list(y = crul::upload(system.file("CITATION")))))
#' bb$body
#' z <- BodyPattern$new(pattern =
#' list(y = crul::upload(system.file("CITATION"))))
#' z$pattern
#' z$matches(bb$body)
BodyPattern <- R6::R6Class(
'BodyPattern',
public = list(
#' @field pattern a list
pattern = 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"))
self$pattern <- unclass(pattern)
else
self$pattern <- pattern
},
#' @description Match a request body pattern against a pattern
#' @param body (list) the body
#' @param content_type (character) content type
#' @return a boolean
matches = function(body, content_type = "") {
if (inherits(self$pattern, "list")) {
if (length(self$pattern) == 0) return(TRUE)
private$matching_hashes(private$body_as_hash(body, content_type), self$pattern)
} else {
(private$empty_string(self$pattern) && private$empty_string(body)) || all(self$pattern == body)
}
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
),
private = list(
empty_string = function(string) {
is.null(string) || !nzchar(string)
},
matching_hashes = function(z, pattern) {
if (is.null(z)) return(FALSE)
if (!inherits(z, "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)
}
}
return(TRUE)
},
body_as_hash = function(body, content_type) {
if (inherits(body, "form_file")) body <- unclass(body)
bctype <- BODY_FORMATS[[content_type]] %||% ""
if (bctype == 'json') {
jsonlite::fromJSON(body, FALSE)
} else if (bctype == 'xml') {
check_for_pkg("xml2")
xml2::read_xml(body)
} else {
query_mapper(body)
}
}
)
)
BODY_FORMATS <- list(
'text/xml' = 'xml',
'application/xml' = 'xml',
'application/json' = 'json',
'text/json' = 'json',
'application/javascript' = 'json',
'text/javascript' = 'json',
'text/html' = 'html',
'application/x-yaml' = 'yaml',
'text/yaml' = 'yaml',
'text/plain' = 'plain'
)
#' @title UriPattern
#' @description uri matcher
#' @export
#' @keywords internal
#' @examples
#' # trailing slash
#' (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"))
#' z$matches("http://foobar.com") # TRUE
#' z$matches("http://foobar.com/") # TRUE
#' z$matches("https://foobar.com") # FALSE
#' z$matches("https://foobar.com/") # FALSE
#' ## to match https, you'll have to give the complete url
#' (z <- UriPattern$new(pattern = "https://foobar.com"))
#' z$matches("https://foobar.com/") # TRUE
#' z$matches("http://foobar.com/") # FALSE
#'
#' # default ports
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$matches("http://foobar.com:80") # TRUE
#' z$matches("http://foobar.com:80/") # TRUE
#' z$matches("http://foobar.com:443") # TRUE
#' z$matches("http://foobar.com:443/") # TRUE
#'
#' # user info - FIXME, not sure we support this yet
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$matches("http://user:pass@foobar.com")
#'
#' # regex
#' (z <- UriPattern$new(regex_pattern = ".+ample\\.."))
#' z$matches("http://sample.org") # TRUE
#' z$matches("http://example.com") # TRUE
#' z$matches("http://tramples.net") # FALSE
#'
#' # add query parameters
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$add_query_params(list(pizza = "cheese", cheese = "cheddar"))
#' z
#' z$pattern
#' z$matches("http://foobar.com?pizza=cheese&cheese=cheddar") # TRUE
#' z$matches("http://foobar.com?pizza=cheese&cheese=swiss") # FALSE
#'
#' # query parameters in the uri
#' (z <- UriPattern$new(pattern = "https://httpbin.org/get?stuff=things"))
#' 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
UriPattern <- R6::R6Class(
'UriPattern',
public = list(
#' @field pattern (character) pattern holder
pattern = NULL,
#' @field regex a logical
regex = FALSE,
#' @field query_params a list, or `NULL` if empty
query_params = NULL,
#' @description Create a new `UriPattern` object
#' @param pattern (character) a uri, as a character string. if scheme
#' is missing, it is added (we assume http)
#' @param regex_pattern (character) a uri as a regex character string,
#' see [base::regex]. if scheme is missing, it is added (we assume
#' http)
#' @return A new `UriPattern` object
initialize = function(pattern = NULL, regex_pattern = NULL) {
stopifnot(xor(is.null(pattern), is.null(regex_pattern)))
if (!is.null(regex_pattern)) self$regex <- TRUE
pattern <- if (!is.null(pattern)) pattern else regex_pattern
if (self$regex) pattern <- add_scheme(pattern)
self$pattern <- normalize_uri(pattern, self$regex)
},
#' @description Match a uri against a pattern
#' @param uri (character) a uri
#' @return a boolean
matches = function(uri) {
uri <- normalize_uri(uri, self$regex)
if (self$regex)
grepl(self$pattern, uri)
else
self$pattern_matches(uri) && self$query_params_matches(uri)
},
#' @description Match a URI
#' @param uri (character) a uri
#' @return a boolean
pattern_matches = function(uri) {
if (!self$regex) return(uri == self$pattern) # not regex
grepl(drop_query_params(self$pattern), uri) # regex
},
#' @description Match query parameters of a URI
#' @param uri (character) a uri
#' @return a boolean
query_params_matches = function(uri) {
identical(self$query_params, self$extract_query(uri))
},
#' @description Extract query parameters as a named list
#' @param uri (character) a uri
#' @return named list, or `NULL` if no query parameters
extract_query = function(uri) {
params <- parse_a_url(uri)$parameter
if (all(is.na(params))) return(NULL)
params
},
#' @description Add query parameters to the URI
#' @param query_params (list|character) list or character
#' @return nothing returned, updates uri pattern
add_query_params = function(query_params) {
if (self$regex) return(NULL)
if (missing(query_params) || is.null(query_params)) {
self$query_params <- self$extract_query(self$pattern)
} else {
self$query_params <- query_params
if (
inherits(query_params, "list") ||
inherits(query_params, "character")
) {
pars <- paste0(unname(Map(function(x, y) paste(x, esc(y), sep = "="),
names(query_params), query_params)), collapse = "&")
self$pattern <- paste0(self$pattern, "?", pars)
}
}
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
)
)
add_scheme <- function(x) {
if (is.na(urltools::url_parse(x)$scheme)) {
paste0('https?://', x)
} else {
x
}
}
esc <- function(x) curl::curl_escape(x)
normalize_uri <- function(x, regex = FALSE) {
x <- prune_trailing_slash(x)
x <- prune_port(x)
if (!regex)
if (is.na(urltools::url_parse(x)$scheme))
x <- paste0('http://', x)
tmp <- urltools::url_parse(x)
if (is.na(tmp$path)) return(x)
if (!regex) tmp$path <- esc(tmp$path)
urltools::url_compose(tmp)
}
prune_trailing_slash <- function(x) sub("/$", "", x)
prune_port <- function(x) gsub("(:80)|(:443)", "", x)
# matcher helpers --------------------------
## URI stuff
is_url <- function(x) {
grepl("https?://", x, ignore.case = TRUE) ||
grepl("localhost:[0-9]{4}", x, ignore.case = TRUE)
}
is_localhost <- function(x) {
grepl("localhost|127.0.0.1|0.0.0.0", x, ignore.case = TRUE)
}
parse_a_url <- function(url) {
tmp <- urltools::url_parse(url)
tmp <- as.list(tmp)
if (!is.na(tmp$parameter)) {
tmp$parameter <- unlist(
lapply(
strsplit(tmp$parameter, "&")[[1]], function(x) {
z <- strsplit(x, split = "=")[[1]]
as.list(stats::setNames(z[2], z[1]))
}),
recursive = FALSE
)
}
tmp$default_port <- 443
return(tmp)
}
uri_fetch <- function(x) {
x <- as.character(x)
tmp <- x[vapply(x, FUN = is_url, FUN.VALUE = logical(1))]
if (length(tmp) == 0) NULL else tmp
}
uri_host <- function(x) parse_a_url(x)$domain
uri_path <- function(x) parse_a_url(x)$path
uri_port <- function(x) parse_a_url(x)$port
drop_query_params <- function(x) {
x <- urltools::url_parse(x)
x$parameter <- NA_character_
x <- urltools::url_compose(x)
# prune trailing slash
sub("\\/$", "", x)
}
## http method
get_method <- function(x) {
x <- as.character(x)
tmp <- grep(
"(get)$|(post)$|(put)$|(delete)$|(options)$|(patch)$|(head)$",
tolower(x), value = TRUE)
tmp <- sub("httr::", "", tmp)
if (length(tmp) == 0) NULL else tmp
}
## query and body stuff
get_query <- function(x) {
if ("query" %in% names(x)) {
x[["query"]]
} else {
NULL
}
}
get_body <- function(x) {
if ("body" %in% names(x)) {
x[["body"]]
} else {
NULL
}
}
ropenscilabs/webmockr documentation built on May 25, 2023, 4:39 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions get_body get_query get_method drop_query_params uri_port uri_path uri_host uri_fetch parse_a_url is_localhost is_url prune_port prune_trailing_slash normalize_uri esc add_scheme
#' @title RequestPattern class
#' @description class handling all request matchers
#' @export
#' @seealso pattern classes for HTTP method [MethodPattern], headers
#' [HeadersPattern], body [BodyPattern], and URI/URL [UriPattern]
#' @examples \dontrun{
#' (x <- RequestPattern$new(method = "get", uri = "httpbin.org/get"))
#' x$body_pattern
#' x$headers_pattern
#' x$method_pattern
#' x$uri_pattern
#' x$to_s()
#'
#' # make a request signature
#' rs <- RequestSignature$new(method = "get", uri = "http://httpbin.org/get")
#'
#' # check if it matches
#' x$matches(rs)
#'
#' # regex uri
#' (x <- RequestPattern$new(method = "get", uri_regex = ".+ossref.org"))
#' x$uri_pattern
#' x$uri_pattern$to_s()
#' x$to_s()
#'
#' # uri with query parameters
#' (x <- RequestPattern$new(
#' method = "get", uri = "https://httpbin.org/get",
#' query = list(foo = "bar")
#' ))
#' x$to_s()
#' ## query params included in url, not separately
#' (x <- RequestPattern$new(
#' method = "get", uri = "https://httpbin.org/get?stuff=things"
#' ))
#' x$to_s()
#' x$query_params
#'
#' # just headers (via setting method=any & uri_regex=.+)
#' headers <- list(
#' 'User-Agent' = 'Apple',
#' 'Accept-Encoding' = 'gzip, deflate',
#' 'Accept' = 'application/json, text/xml, application/xml, */*')
#' x <- RequestPattern$new(
#' method = "any",
#' uri_regex = ".+",
#' headers = headers)
#' x$to_s()
#' rs <- RequestSignature$new(method = "any", uri = "http://foo.bar",
#' options = list(headers = headers))
#' rs
#' x$matches(rs)
#'
#' # body
#' x <- RequestPattern$new(method = "post", uri = "httpbin.org/post",
#' body = list(y = crul::upload(system.file("CITATION"))))
#' x$to_s()
#' rs <- RequestSignature$new(method = "post", uri = "http://httpbin.org/post",
#' options = list(
#' body = list(y = crul::upload(system.file("CITATION")))))
#' rs
#' x$matches(rs)
#' }
RequestPattern <- R6::R6Class(
'RequestPattern',
public = list(
#' @field method_pattern xxx
method_pattern = NULL,
#' @field uri_pattern xxx
uri_pattern = NULL,
#' @field body_pattern xxx
body_pattern = NULL,
#' @field headers_pattern xxx
headers_pattern = NULL,
#' @description Create a new `RequestPattern` object
#' @param method the HTTP method (any, head, options, get, post, put,
#' patch, trace, or delete). "any" matches any HTTP method. required.
#' @param uri (character) request URI. required or uri_regex
#' @param uri_regex (character) request URI as regex. required or uri
#' @param query (list) query parameters, optional
#' @param body (list) body request, optional
#' @param headers (list) headers, optional
#' @return A new `RequestPattern` object
initialize = function(method, uri = NULL, uri_regex = NULL,
query = NULL, body = NULL, headers = NULL) {
if (is.null(uri) && is.null(uri_regex)) {
stop("one of uri or uri_regex is required", call. = FALSE)
}
self$method_pattern <- MethodPattern$new(pattern = method)
self$uri_pattern <- if (is.null(uri_regex)) {
UriPattern$new(pattern = uri)
} else {
UriPattern$new(regex_pattern = uri_regex)
}
self$uri_pattern$add_query_params(query)
self$body_pattern <- if (!is.null(body)) BodyPattern$new(pattern = body)
self$headers_pattern <- if (!is.null(headers))
HeadersPattern$new(pattern = headers)
# FIXME: all private methods used in the below line, see if needed or remove
# if (length(options)) private$assign_options(options)
},
#' @description does a request signature match the selected matchers?
#' @param request_signature a [RequestSignature] object
#' @return a boolean
matches = function(request_signature) {
assert(request_signature, "RequestSignature")
c_type <- if (!is.null(request_signature$headers)) request_signature$headers$`Content-Type` else NULL
if (!is.null(c_type)) c_type <- strsplit(c_type, ';')[[1]][1]
self$method_pattern$matches(request_signature$method) &&
self$uri_pattern$matches(request_signature$uri) &&
(is.null(self$body_pattern) || self$body_pattern$matches(request_signature$body, c_type %||% "")) &&
(is.null(self$headers_pattern) || self$headers_pattern$matches(request_signature$headers))
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() {
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$headers_pattern)) paste0(" with headers ", self$headers_pattern$to_s())
))
}
),
private = list(
# assign_options = function(options) {
# #self$validate_keys(options, 'body', 'headers', 'query', 'basic_auth')
# set_basic_auth_as_headers(options)
# self$body_pattern <- if ('body' %in% names(options)) BodyPattern$new(options['body'])
# self$headers_pattern <- if ('headers' %in% names(options)) HeadersPattern$new(options['headers'])
# if ('query' %in% names(options)) self$uri_pattern$add_query_params(options['query'])
# },
# validate_keys = function(x, ...) {
# valid_keys <- unlist(list(...), recursive = FALSE)
# for (i in seq_along(x)) {
# if (!names(x)[i] %in% valid_keys) {
# stop(
# sprintf("Unknown key: %s. Valid keys are: %s",
# names(x)[i],
# paste0(valid_keys, collapse = ", "),
# call. = FALSE
# )
# )
# }
# }
# },
set_basic_auth_as_headers = function(options) {
if ('basic_auth' %in% names(options)) {
private$validate_basic_auth(options$basic_auth)
options$headers <- list()
options$headers$Authorization <-
private$make_basic_auth(options$basic_auth[1], options$basic_auth[2])
}
},
validate_basic_auth = function(x) {
if (!inherits(x, "list") || length(unique(unname(unlist(x)))) == 1) {
stop(
"'basic_auth' option should be a list of length 2: username and password",
call. = FALSE
)
}
},
make_basic_auth = function(x, y) {
jsonlite::base64_enc(paste0(x, ":", y))
}
)
)
#' @title MethodPattern
#' @description method matcher
#' @export
#' @keywords internal
#' @details Matches regardless of case. e.g., POST will match to post
#' @examples
#' (x <- MethodPattern$new(pattern = "post"))
#' x$pattern
#' x$matches(method = "post")
#' x$matches(method = "POST")
#'
#' # all matches() calls should be TRUE
#' (x <- MethodPattern$new(pattern = "any"))
#' x$pattern
#' x$matches(method = "post")
#' x$matches(method = "GET")
#' x$matches(method = "HEAD")
MethodPattern <- R6::R6Class(
'MethodPattern',
public = list(
#' @field pattern (character) an http method
pattern = NULL,
#' @description Create a new `MethodPattern` object
#' @param pattern (character) a HTTP method, lowercase
#' @return A new `MethodPattern` object
initialize = function(pattern) {
self$pattern <- tolower(pattern)
},
#' @description test if the pattern matches a given http method
#' @param method (character) a HTTP method, lowercase
#' @return a boolean
matches = function(method) {
self$pattern == tolower(method) || self$pattern == "any"
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
)
)
#' @title HeadersPattern
#' @description headers matcher
#' @export
#' @keywords internal
#' @details
#' `webmockr` normalises headers and treats all forms of same headers as equal:
#' i.e the following two sets of headers are equal:
#' `list(Header1 = "value1", content_length = 123, X_CuStOm_hEAder = "foo")`
#' and
#' `list(header1 = "value1", "Content-Length" = 123, "x-cuSTOM-HeAder" = "foo")`
#' @examples
#' (x <- HeadersPattern$new(pattern = list(a = 5)))
#' x$pattern
#' x$matches(list(a = 5))
#'
#' # different cases
#' (x <- HeadersPattern$new(pattern = list(Header1 = "value1")))
#' x$pattern
#' x$matches(list(header1 = "value1"))
#' x$matches(list(header1 = "value2"))
#'
#' # different symbols
#' (x <- HeadersPattern$new(pattern = list(`Hello_World` = "yep")))
#' x$pattern
#' x$matches(list(`hello-world` = "yep"))
#' x$matches(list(`hello-worlds` = "yep"))
#'
#' headers <- list(
#' 'User-Agent' = 'Apple',
#' 'Accept-Encoding' = 'gzip, deflate',
#' 'Accept' = 'application/json, text/xml, application/xml, */*')
#' (x <- HeadersPattern$new(pattern = headers))
#' x$to_s()
#' x$pattern
#' x$matches(headers)
HeadersPattern <- R6::R6Class(
'HeadersPattern',
public = list(
#' @field pattern a list
pattern = NULL,
#' @description Create a new `HeadersPattern` object
#' @param pattern (list) a pattern, as a named list, must be named,
#' e.g,. `list(a = 5, b = 6)`
#' @return A new `HeadersPattern` object
initialize = function(pattern) {
stopifnot(is.list(pattern))
pattern <- private$normalize_headers(pattern)
self$pattern <- pattern
},
#' @description Match a list of headers against that stored
#' @param headers (list) named list of headers, e.g,. `list(a = 5, b = 6)`
#' @return a boolean
matches = function(headers) {
if (self$empty_headers(self$pattern)) {
self$empty_headers(headers)
} else {
if (self$empty_headers(headers)) return(FALSE)
headers <- private$normalize_headers(headers)
out <- c()
for (i in seq_along(self$pattern)) {
out[i] <- names(self$pattern)[i] %in% names(headers) &&
self$pattern[[i]] == headers[[names(self$pattern)[i]]]
}
all(out)
}
},
#' @description Are headers empty? tests if null or length==0
#' @param headers named list of headers
#' @return a boolean
empty_headers = function(headers) {
is.null(headers) || length(headers) == 0
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() hdl_lst2(self$pattern)
),
private = list(
normalize_headers = function(x) {
# normalize names
names(x) <- tolower(names(x))
# normalize symbols
## underscores to single dash
names(x) <- gsub("_", "-", names(x))
return(x)
}
)
)
#' @title BodyPattern
#' @description body matcher
#' @export
#' @keywords internal
#' @examples
#' # make a request signature
#' bb <- RequestSignature$new(
#' method = "get",
#' uri = "https:/httpbin.org/get",
#' options = list(
#' body = list(foo = "bar", a = 5)
#' )
#' )
#'
#' # make body pattern object
#' ## FALSE
#' z <- BodyPattern$new(pattern = list(foo = "bar"))
#' z$pattern
#' z$matches(bb$body)
#' ## TRUE
#' z <- BodyPattern$new(pattern = list(foo = "bar", a = 5))
#' z$pattern
#' z$matches(bb$body)
#'
#' # uploads in bodies
#' ## upload NOT in a list
#' bb <- RequestSignature$new(
#' method = "post", uri = "https:/httpbin.org/post",
#' options = list(body = crul::upload(system.file("CITATION"))))
#' bb$body
#' z <- BodyPattern$new(pattern =
#' crul::upload(system.file("CITATION")))
#' z$pattern
#' z$matches(bb$body)
#'
#' ## upload in a list
#' bb <- RequestSignature$new(
#' method = "post", uri = "https:/httpbin.org/post",
#' options = list(body = list(y = crul::upload(system.file("CITATION")))))
#' bb$body
#' z <- BodyPattern$new(pattern =
#' list(y = crul::upload(system.file("CITATION"))))
#' z$pattern
#' z$matches(bb$body)
BodyPattern <- R6::R6Class(
'BodyPattern',
public = list(
#' @field pattern a list
pattern = 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"))
self$pattern <- unclass(pattern)
else
self$pattern <- pattern
},
#' @description Match a request body pattern against a pattern
#' @param body (list) the body
#' @param content_type (character) content type
#' @return a boolean
matches = function(body, content_type = "") {
if (inherits(self$pattern, "list")) {
if (length(self$pattern) == 0) return(TRUE)
private$matching_hashes(private$body_as_hash(body, content_type), self$pattern)
} else {
(private$empty_string(self$pattern) && private$empty_string(body)) || all(self$pattern == body)
}
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
),
private = list(
empty_string = function(string) {
is.null(string) || !nzchar(string)
},
matching_hashes = function(z, pattern) {
if (is.null(z)) return(FALSE)
if (!inherits(z, "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)
}
}
return(TRUE)
},
body_as_hash = function(body, content_type) {
if (inherits(body, "form_file")) body <- unclass(body)
bctype <- BODY_FORMATS[[content_type]] %||% ""
if (bctype == 'json') {
jsonlite::fromJSON(body, FALSE)
} else if (bctype == 'xml') {
check_for_pkg("xml2")
xml2::read_xml(body)
} else {
query_mapper(body)
}
}
)
)
BODY_FORMATS <- list(
'text/xml' = 'xml',
'application/xml' = 'xml',
'application/json' = 'json',
'text/json' = 'json',
'application/javascript' = 'json',
'text/javascript' = 'json',
'text/html' = 'html',
'application/x-yaml' = 'yaml',
'text/yaml' = 'yaml',
'text/plain' = 'plain'
)
#' @title UriPattern
#' @description uri matcher
#' @export
#' @keywords internal
#' @examples
#' # trailing slash
#' (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"))
#' z$matches("http://foobar.com") # TRUE
#' z$matches("http://foobar.com/") # TRUE
#' z$matches("https://foobar.com") # FALSE
#' z$matches("https://foobar.com/") # FALSE
#' ## to match https, you'll have to give the complete url
#' (z <- UriPattern$new(pattern = "https://foobar.com"))
#' z$matches("https://foobar.com/") # TRUE
#' z$matches("http://foobar.com/") # FALSE
#'
#' # default ports
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$matches("http://foobar.com:80") # TRUE
#' z$matches("http://foobar.com:80/") # TRUE
#' z$matches("http://foobar.com:443") # TRUE
#' z$matches("http://foobar.com:443/") # TRUE
#'
#' # user info - FIXME, not sure we support this yet
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$matches("http://user:pass@foobar.com")
#'
#' # regex
#' (z <- UriPattern$new(regex_pattern = ".+ample\\.."))
#' z$matches("http://sample.org") # TRUE
#' z$matches("http://example.com") # TRUE
#' z$matches("http://tramples.net") # FALSE
#'
#' # add query parameters
#' (z <- UriPattern$new(pattern = "http://foobar.com"))
#' z$add_query_params(list(pizza = "cheese", cheese = "cheddar"))
#' z
#' z$pattern
#' z$matches("http://foobar.com?pizza=cheese&cheese=cheddar") # TRUE
#' z$matches("http://foobar.com?pizza=cheese&cheese=swiss") # FALSE
#'
#' # query parameters in the uri
#' (z <- UriPattern$new(pattern = "https://httpbin.org/get?stuff=things"))
#' 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
UriPattern <- R6::R6Class(
'UriPattern',
public = list(
#' @field pattern (character) pattern holder
pattern = NULL,
#' @field regex a logical
regex = FALSE,
#' @field query_params a list, or `NULL` if empty
query_params = NULL,
#' @description Create a new `UriPattern` object
#' @param pattern (character) a uri, as a character string. if scheme
#' is missing, it is added (we assume http)
#' @param regex_pattern (character) a uri as a regex character string,
#' see [base::regex]. if scheme is missing, it is added (we assume
#' http)
#' @return A new `UriPattern` object
initialize = function(pattern = NULL, regex_pattern = NULL) {
stopifnot(xor(is.null(pattern), is.null(regex_pattern)))
if (!is.null(regex_pattern)) self$regex <- TRUE
pattern <- if (!is.null(pattern)) pattern else regex_pattern
if (self$regex) pattern <- add_scheme(pattern)
self$pattern <- normalize_uri(pattern, self$regex)
},
#' @description Match a uri against a pattern
#' @param uri (character) a uri
#' @return a boolean
matches = function(uri) {
uri <- normalize_uri(uri, self$regex)
if (self$regex)
grepl(self$pattern, uri)
else
self$pattern_matches(uri) && self$query_params_matches(uri)
},
#' @description Match a URI
#' @param uri (character) a uri
#' @return a boolean
pattern_matches = function(uri) {
if (!self$regex) return(uri == self$pattern) # not regex
grepl(drop_query_params(self$pattern), uri) # regex
},
#' @description Match query parameters of a URI
#' @param uri (character) a uri
#' @return a boolean
query_params_matches = function(uri) {
identical(self$query_params, self$extract_query(uri))
},
#' @description Extract query parameters as a named list
#' @param uri (character) a uri
#' @return named list, or `NULL` if no query parameters
extract_query = function(uri) {
params <- parse_a_url(uri)$parameter
if (all(is.na(params))) return(NULL)
params
},
#' @description Add query parameters to the URI
#' @param query_params (list|character) list or character
#' @return nothing returned, updates uri pattern
add_query_params = function(query_params) {
if (self$regex) return(NULL)
if (missing(query_params) || is.null(query_params)) {
self$query_params <- self$extract_query(self$pattern)
} else {
self$query_params <- query_params
if (
inherits(query_params, "list") ||
inherits(query_params, "character")
) {
pars <- paste0(unname(Map(function(x, y) paste(x, esc(y), sep = "="),
names(query_params), query_params)), collapse = "&")
self$pattern <- paste0(self$pattern, "?", pars)
}
}
},
#' @description Print pattern for easy human consumption
#' @return a string
to_s = function() self$pattern
)
)
add_scheme <- function(x) {
if (is.na(urltools::url_parse(x)$scheme)) {
paste0('https?://', x)
} else {
x
}
}
esc <- function(x) curl::curl_escape(x)
normalize_uri <- function(x, regex = FALSE) {
x <- prune_trailing_slash(x)
x <- prune_port(x)
if (!regex)
if (is.na(urltools::url_parse(x)$scheme))
x <- paste0('http://', x)
tmp <- urltools::url_parse(x)
if (is.na(tmp$path)) return(x)
if (!regex) tmp$path <- esc(tmp$path)
urltools::url_compose(tmp)
}
prune_trailing_slash <- function(x) sub("/$", "", x)
prune_port <- function(x) gsub("(:80)|(:443)", "", x)
# matcher helpers --------------------------
## URI stuff
is_url <- function(x) {
grepl("https?://", x, ignore.case = TRUE) ||
grepl("localhost:[0-9]{4}", x, ignore.case = TRUE)
}
is_localhost <- function(x) {
grepl("localhost|127.0.0.1|0.0.0.0", x, ignore.case = TRUE)
}
parse_a_url <- function(url) {
tmp <- urltools::url_parse(url)
tmp <- as.list(tmp)
if (!is.na(tmp$parameter)) {
tmp$parameter <- unlist(
lapply(
strsplit(tmp$parameter, "&")[[1]], function(x) {
z <- strsplit(x, split = "=")[[1]]
as.list(stats::setNames(z[2], z[1]))
}),
recursive = FALSE
)
}
tmp$default_port <- 443
return(tmp)
}
uri_fetch <- function(x) {
x <- as.character(x)
tmp <- x[vapply(x, FUN = is_url, FUN.VALUE = logical(1))]
if (length(tmp) == 0) NULL else tmp
}
uri_host <- function(x) parse_a_url(x)$domain
uri_path <- function(x) parse_a_url(x)$path
uri_port <- function(x) parse_a_url(x)$port
drop_query_params <- function(x) {
x <- urltools::url_parse(x)
x$parameter <- NA_character_
x <- urltools::url_compose(x)
# prune trailing slash
sub("\\/$", "", x)
}
## http method
get_method <- function(x) {
x <- as.character(x)
tmp <- grep(
"(get)$|(post)$|(put)$|(delete)$|(options)$|(patch)$|(head)$",
tolower(x), value = TRUE)
tmp <- sub("httr::", "", tmp)
if (length(tmp) == 0) NULL else tmp
}
## query and body stuff
get_query <- function(x) {
if ("query" %in% names(x)) {
x[["query"]]
} else {
NULL
}
}
get_body <- function(x) {
if ("body" %in% names(x)) {
x[["body"]]
} else {
NULL
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.