fix #133 basic auth support and matching

DESCRIPTION

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

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)

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

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))

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))
   }
 }

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

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 <https://en.wikipedia.org/wiki/Basic_access_authentication>.
 #'
 #' 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")

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")