diff --git a/DESCRIPTION b/DESCRIPTION index 2ef565c..a146b89 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,7 +30,6 @@ Imports: urltools (>= 1.6.0), fauxpas, crul (>= 0.7.0), - base64enc, rlang, cli Suggests: diff --git a/NAMESPACE b/NAMESPACE index c1b30d8..7785b54 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -62,12 +62,15 @@ export(webmockr_reset) export(wi_th) export(wi_th_) importFrom(R6,R6Class) -importFrom(base64enc,base64encode) importFrom(cli,ansi_collapse) importFrom(cli,cli_abort) importFrom(cli,format_error) importFrom(crul,mock) importFrom(fauxpas,HTTPRequestTimeout) +importFrom(jsonlite,base64_enc) +importFrom(jsonlite,fromJSON) +importFrom(jsonlite,toJSON) +importFrom(jsonlite,validate) importFrom(magrittr,"%>%") importFrom(rlang,abort) importFrom(rlang,caller_arg) diff --git a/R/RequestPattern.R b/R/RequestPattern.R index 2e2f31b..c65c8b8 100644 --- a/R/RequestPattern.R +++ b/R/RequestPattern.R @@ -69,6 +69,22 @@ #' ) #' rs #' x$matches(rs) +#' +#' # basic auth +#' x <- RequestPattern$new( +#' method = "post", +#' uri = "httpbin.org/post", +#' basic_auth = c("user", "pass") +#' ) +#' x +#' x$headers_pattern$to_s() +#' x$to_s() +#' rs <- RequestSignature$new( +#' method = "post", uri = "http://httpbin.org/post", +#' options = list(auth = list(user = "user", pass = "pass")) +#' ) +#' rs +#' x$matches(rs) #' } RequestPattern <- R6::R6Class( "RequestPattern", @@ -90,9 +106,12 @@ RequestPattern <- R6::R6Class( #' @param query (list) query parameters, optional #' @param body (list) body request, optional #' @param headers (list) headers, optional + #' @param basic_auth (list) vector of length 2 (username, passwdord), + #' optional #' @return A new `RequestPattern` object initialize = function(method, uri = NULL, uri_regex = NULL, - query = NULL, body = NULL, headers = NULL) { + query = NULL, body = NULL, headers = NULL, + basic_auth = NULL) { if (is.null(uri) && is.null(uri_regex)) { abort("one of uri or uri_regex is required") } @@ -105,11 +124,11 @@ RequestPattern <- R6::R6Class( } self$uri_pattern$add_query_params(query) self$body_pattern <- if (!is.null(body)) BodyPattern$new(pattern = body) + auth_headers <- private$set_basic_auth_as_headers(basic_auth) + headers <- c(headers, auth_headers) 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? @@ -141,46 +160,24 @@ RequestPattern <- R6::R6Class( } ), 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]) + set_basic_auth_as_headers = function(x) { + if (!is_null(x)) { + private$validate_basic_auth(x) + list( + Authorization = private$make_basic_auth(x[1], x[2]) + ) } }, validate_basic_auth = function(x) { - if (!inherits(x, "list") || length(unique(unname(unlist(x)))) == 1) { + if (!inherits(x, "character") || length(unique(unname(unlist(x)))) == 1) { abort(c( "error in basic auth", - "'basic_auth' option should be list of length 2: username, password" + "'basic_auth' option should be a length 2 vector" )) } }, make_basic_auth = function(x, y) { - jsonlite::base64_enc(paste0(x, ":", y)) + paste0("Basic ", jsonlite::base64_enc(paste0(x, ":", y))) } ) ) @@ -315,14 +312,14 @@ HeadersPattern <- R6::R6Class( normalize_headers = function(x) { # normalize names names(x) <- tolower(names(x)) - # normalize symbols - ## underscores to single dash + # underscores to single dash names(x) <- gsub("_", "-", names(x)) return(x) } ) ) +#' @importFrom jsonlite fromJSON seems_like_json <- function(x) { res <- tryCatch(jsonlite::fromJSON(x), error = function(msg) msg) !inherits(res, "error") @@ -398,7 +395,7 @@ BodyPattern <- R6::R6Class( public = list( #' @field pattern a list pattern = NULL, - #' @field partial bool, default: `FALSE` + #' @field partial bool, default: `FALSE` partial = FALSE, #' @field partial_type a string, default: NULL partial_type = NULL, @@ -505,14 +502,18 @@ BodyPattern <- R6::R6Class( jsonlite::fromJSON(body, FALSE) } else if (bctype == "xml") { check_installed("xml2") - try_xml2list <- rlang::try_fetch({ - body_xml <- xml2::read_xml(body) - xml_as_list <- xml2::as_list(body_xml) - lapply(xml_as_list, promote_attr) - }, error = function(e) e) + try_xml2list <- rlang::try_fetch( + { + body_xml <- xml2::read_xml(body) + xml_as_list <- xml2::as_list(body_xml) + lapply(xml_as_list, promote_attr) + }, + error = function(e) e + ) if (rlang::is_error(try_xml2list)) { rlang::warn("xml to list conversion failed; using xml string for comparison", - use_cli_format = TRUE, .frequency = "always") + use_cli_format = TRUE, .frequency = "always" + ) body } else { try_xml2list diff --git a/R/StubRegistry.R b/R/StubRegistry.R index c429218..74296bb 100644 --- a/R/StubRegistry.R +++ b/R/StubRegistry.R @@ -113,6 +113,7 @@ StubRegistry <- R6::R6Class( ) ) +#' @importFrom jsonlite validate json_validate <- function(x) { res <- tryCatch(jsonlite::validate(x), error = function(e) e) if (inherits(res, "error")) return(FALSE) @@ -146,7 +147,10 @@ make_query <- function(x) { paste0(" with query params ", txt) } -# make headers info for print method +#' make headers info for print method +#' @importFrom jsonlite toJSON +#' @param x a named list +#' @noRd make_headers <- function(x) { if (is.null(x)) return("") paste0(" with headers ", jsonlite::toJSON(x, auto_unbox = TRUE)) diff --git a/R/StubbedRequest.R b/R/StubbedRequest.R index f2b6fea..2b88fda 100644 --- a/R/StubbedRequest.R +++ b/R/StubbedRequest.R @@ -402,7 +402,8 @@ StubbedRequest <- R6::R6Class( self$responses_sequences <- cc(c(self$responses_sequences, list(x))) }, response = function(status = NULL, body = NULL, headers = NULL, - body_raw = NULL, timeout = FALSE, raise = FALSE, exceptions = list()) { + body_raw = NULL, timeout = FALSE, raise = FALSE, + exceptions = list()) { list( status = status, body = body, @@ -416,17 +417,16 @@ StubbedRequest <- R6::R6Class( ) ) +#' @importFrom jsonlite base64_enc basic_auth_header <- function(x) { assert_is(x, "character") stopifnot(length(x) == 1) - encoded <- base64enc::base64encode(charToRaw(x)) - return(paste0("Basic ", encoded)) + encoded <- jsonlite::base64_enc(x) + paste0("Basic ", encoded) } + prep_auth <- function(x) { - if (is.null(x)) { - return(NULL) - } - if (!is.null(x)) { + if (!is_null(x)) { list(Authorization = basic_auth_header(x)) } } diff --git a/R/webmockr-package.R b/R/webmockr-package.R index d5b3b9c..901f7a0 100644 --- a/R/webmockr-package.R +++ b/R/webmockr-package.R @@ -21,7 +21,6 @@ #' @importFrom R6 R6Class #' @importFrom fauxpas HTTPRequestTimeout #' @importFrom crul mock -#' @importFrom base64enc base64encode #' @importFrom rlang abort warn check_installed is_list is_function is_error #' caller_arg try_fetch caller_env #' @importFrom cli cli_abort ansi_collapse format_error diff --git a/R/wi_th.R b/R/wi_th.R index 6f0b820..003beb2 100644 --- a/R/wi_th.R +++ b/R/wi_th.R @@ -31,12 +31,11 @@ #' they supplied `NULL` to indicate an empty body. #' - headers: (list) a named list #' - basic_auth: (character) a length two vector, username and password. -#' authentication type (basic/digest/ntlm/etc.) is ignored. that is, -#' mocking authenciation right now does not take into account the -#' authentication type. We don't do any checking of the username/password -#' except to detect edge cases where for example, the username/password +#' We don't do any checking of the username/password except to detect +#' edge cases where for example, the username/password #' were probably not set by the user on purpose (e.g., a URL is -#' picked up by an environment variable) +#' picked up by an environment variable). Only basic authentication +#' supported . #' #' Note that there is no regex matching on query, body, or headers. They #' are tested for matches in the following ways: @@ -90,6 +89,12 @@ #' wi_th(req, body = including(list(foo = "bar"))) #' ## excluding #' wi_th(req, body = excluding(list(foo = "bar"))) +#' +#' # basic auth +#' ## including +#' wi_th(req, body = including(list(foo = "bar"))) +#' ## excluding +#' wi_th(req, body = excluding(list(foo = "bar"))) wi_th <- function(.data, ..., .list = list()) { handle_stub_removal(.data, { assert_is(.data, "StubbedRequest") diff --git a/man/RequestPattern.Rd b/man/RequestPattern.Rd index 10768be..c65fe4a 100644 --- a/man/RequestPattern.Rd +++ b/man/RequestPattern.Rd @@ -73,6 +73,22 @@ rs <- RequestSignature$new( ) rs x$matches(rs) + +# basic auth +x <- RequestPattern$new( + method = "post", + uri = "httpbin.org/post", + basic_auth = c("user", "pass") +) +x +x$headers_pattern$to_s() +x$to_s() +rs <- RequestSignature$new( + method = "post", uri = "http://httpbin.org/post", + options = list(auth = list(user = "user", pass = "pass")) +) +rs +x$matches(rs) } } \seealso{ @@ -113,7 +129,8 @@ Create a new \code{RequestPattern} object uri_regex = NULL, query = NULL, body = NULL, - headers = NULL + headers = NULL, + basic_auth = NULL )}\if{html}{\out{}} } @@ -132,6 +149,9 @@ patch, trace, or delete). "any" matches any HTTP method. required.} \item{\code{body}}{(list) body request, optional} \item{\code{headers}}{(list) headers, optional} + +\item{\code{basic_auth}}{(list) vector of length 2 (username, passwdord), +optional} } \if{html}{\out{}} } diff --git a/man/wi_th.Rd b/man/wi_th.Rd index 6af511a..2c24617 100644 --- a/man/wi_th.Rd +++ b/man/wi_th.Rd @@ -42,12 +42,11 @@ with \code{NULL} we can't determine if the user did not supply a body or they supplied \code{NULL} to indicate an empty body. \item headers: (list) a named list \item basic_auth: (character) a length two vector, username and password. -authentication type (basic/digest/ntlm/etc.) is ignored. that is, -mocking authenciation right now does not take into account the -authentication type. We don't do any checking of the username/password -except to detect edge cases where for example, the username/password +We don't do any checking of the username/password except to detect +edge cases where for example, the username/password were probably not set by the user on purpose (e.g., a URL is -picked up by an environment variable) +picked up by an environment variable). Only basic authentication +supported \url{https://en.wikipedia.org/wiki/Basic_access_authentication}. } Note that there is no regex matching on query, body, or headers. They @@ -106,6 +105,12 @@ wi_th(req, query = excluding(list(foo = "bar"))) wi_th(req, body = including(list(foo = "bar"))) ## excluding wi_th(req, body = excluding(list(foo = "bar"))) + +# basic auth +## including +wi_th(req, body = including(list(foo = "bar"))) +## excluding +wi_th(req, body = excluding(list(foo = "bar"))) } \seealso{ \code{\link[=including]{including()}} diff --git a/tests/testthat/test-RequestPattern.R b/tests/testthat/test-RequestPattern.R index 8aaec59..b9689a5 100644 --- a/tests/testthat/test-RequestPattern.R +++ b/tests/testthat/test-RequestPattern.R @@ -193,6 +193,18 @@ test_that("should warn when xml parsing fails and fall back to the xml string", #expect_warning(pattern$matches(rs_xml_parse_fail)) # FIXME: should throw warning }) +test_that("should work with basic_auth", { + pattern <- RequestPattern$new(method = "get", uri = hb("/get"), + basic_auth = c("user", "pass")) + + expect_equal(pattern$headers_pattern$to_s(), "authorization=\"Basic dXNlcjpwYXNz\"") + + rs_basic_auth <- RequestSignature$new( + method = "get", uri = hb("/get"), + options = list(headers = prep_auth("user:pass")) + ) + expect_true(pattern$matches(rs_basic_auth)) +}) context("MethodPattern")