fix #129 use rlang throughout where useful

- reworked assert_* fxns to use rlang and throw better error messages that allow better trace back
- add section to stub_request about error handling
- new helper functions in error-handling.R file to help with stub removal upon appropriate error
- use withCallingHandlers in the fxns used with stub_request (wi_th, to_return, etc.) to catch and remove stubs upon most errors
- modify tests accordingly for above line change

DESCRIPTION

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

NAMESPACE

@@ -63,12 +63,21 @@ 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(magrittr,"%>%")
 importFrom(rlang,abort)
+importFrom(rlang,caller_arg)
+importFrom(rlang,caller_env)
 importFrom(rlang,check_installed)
 importFrom(rlang,is_empty)
+importFrom(rlang,is_error)
+importFrom(rlang,is_function)
 importFrom(rlang,is_list)
 importFrom(rlang,is_na)
 importFrom(rlang,is_null)
+importFrom(rlang,try_fetch)
+importFrom(rlang,warn)

R/RequestPattern.R

@@ -116,7 +116,7 @@ RequestPattern <- R6::R6Class(
     #' @param request_signature a [RequestSignature] object
     #' @return a boolean
     matches = function(request_signature) {
-      assert(request_signature, "RequestSignature")
+      assert_is(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) &&

R/RequestRegistry.R

@@ -24,7 +24,7 @@ HashCounter <- R6::R6Class(
     #' @return nothing returned; registers request and iterates
     #' internal counter
     put = function(req_sig) {
-      assert(req_sig, "RequestSignature")
+      assert_is(req_sig, "RequestSignature")
       key <- req_sig$to_s()
       self$hash[[key]] <- list(
         key = key,
@@ -37,7 +37,7 @@ HashCounter <- R6::R6Class(
     #' @param req_sig an object of class `RequestSignature`
     #' @return (integer) the count of how many times the request has been made
     get = function(req_sig) {
-      assert(req_sig, "RequestSignature")
+      assert_is(req_sig, "RequestSignature")
       self$hash[[req_sig$to_s()]]$count %||% 0
     }
   )

R/StubbedRequest.R

@@ -23,7 +23,7 @@ StubCounter <- R6::R6Class(
     #' @param x an object of class `RequestSignature`
     #' @return nothing returned; registers request & iterates internal counter
     put = function(x) {
-      assert(x, "RequestSignature")
+      assert_is(x, "RequestSignature")
       key <- x$to_s()
       self$hash[[key]] <- list(key = key, sig = x)
       private$total <- private$total + 1
@@ -417,7 +417,7 @@ StubbedRequest <- R6::R6Class(
 )
 
 basic_auth_header <- function(x) {
-  assert(x, "character")
+  assert_is(x, "character")
   stopifnot(length(x) == 1)
   encoded <- base64enc::base64encode(charToRaw(x))
   return(paste0("Basic ", encoded))

R/adapter.R

@@ -69,7 +69,7 @@ Adapter <- R6::R6Class("Adapter",
     #' @param quiet (logical) suppress messages? default: `FALSE`
     #' @return `TRUE`, invisibly
     enable = function(quiet = FALSE) {
-      assert(quiet, "logical")
+      assert_is(quiet, "logical")
       if (!quiet) message(sprintf("%s enabled!", self$name))
       webmockr_lightswitch[[self$client]] <- TRUE
 
@@ -84,7 +84,7 @@ Adapter <- R6::R6Class("Adapter",
     #' @param quiet (logical) suppress messages? default: `FALSE`
     #' @return `FALSE`, invisibly
     disable = function(quiet = FALSE) {
-      assert(quiet, "logical")
+      assert_is(quiet, "logical")
       if (!quiet) message(sprintf("%s disabled!", self$name))
       webmockr_lightswitch[[self$client]] <- FALSE
       self$remove_stubs()

R/error-handling.R

@@ -0,0 +1,37 @@
+errors_to_skip_stub_removal <- function() {
+  mssgs <- c(
+    "\".data\" is missing",
+    "must be of class StubbedRequest",
+    "not registered",
+    "Unknown"
+    # ,
+    # "all objects must be error classes"
+  )
+  paste0(mssgs, collapse = "|")
+}
+
+stub_removal_message <- c(
+  "Encountered an error constructing stub",
+  "Removed stub",
+  "To see a list of stubs run stub_registry()"
+)
+
+#' Handle stub removal
+#' @keywords internal
+#' @param .data an object of class `StubbedRequest` required
+#' @param code a code block. required
+#' @return if no error, the result of running `code`; if an error occurs
+#' [withCallingHandlers()] throws a warning and then the stub is removed
+handle_stub_removal <- function(.data, code) {
+  withCallingHandlers({
+    force(code)
+  },
+  error = function(cnd) {
+    if (!grepl(errors_to_skip_stub_removal(), cnd$message)) {
+      warn(stub_removal_message)
+      remove_request_stub(.data)
+    }
+  })
+}
+
+# FIXME: add envir handling so that error message says the exported user fxn that the error occurred in

R/last.R

@@ -24,6 +24,7 @@ last_request <- function() {
 
 #' Get the last stub created
 #' 
+#' @importFrom rlang is_empty
 #' @export
 #' @return `NULL` if no stubs found; otherwise the last stub created 
 #' as a `StubbedRequest` class

R/mock_file.R

@@ -8,8 +8,8 @@
 #' @examples
 #' mock_file(path = tempfile(), payload = "{\"foo\": \"bar\"}")
 mock_file <- function(path, payload) {
-  assert(path, "character")
-  assert(payload, c("character", "json"))
+  assert_is(path, "character")
+  assert_is(payload, c("character", "json"))
   structure(list(path = path, payload = payload), class = "mock_file")
 }
 #' @export

R/partial.R

@@ -40,7 +40,7 @@
 #' # cleanup
 #' stub_registry_clear()
 including <- function(x) {
-  assert(x, "list")
+  assert_is(x, "list")
   class(x) <- "partial"
   attr(x, "partial_match") <- TRUE
   attr(x, "partial_type") <- "include"
@@ -50,7 +50,7 @@ including <- function(x) {
 #' @export
 #' @rdname including
 excluding <- function(x) {
-  assert(x, "list")
+  assert_is(x, "list")
   class(x) <- "partial"
   attr(x, "partial_match") <- TRUE
   attr(x, "partial_type") <- "exclude"

R/pluck_body.R

@@ -42,7 +42,9 @@ pluck_body <- function(x) {
 assert_request <- function(x) {
   request_slots <- c("url", "method", "options", "headers")
   if (!is.list(x) || !all(request_slots %in% names(x))) {
-    stop(deparse(substitute(x)), " is not a valid request ", call. = FALSE)
+    webmockr_abort(
+      format_error("{.arg {deparse(substitute(x))}} is not a valid request")
+    )
   }
 }
 

R/stub_body_diff.R

@@ -44,7 +44,7 @@ stub_body_diff <- function(stub = last_stub(), request = last_request()) {
 		abort(c("`stub` and/or `request` are NULL or otherwise empty",
 			"see `?stub_body_diff`"))
 	}
-	assert(stub, "StubbedRequest")
-	assert(request, "RequestSignature")
+	assert_is(stub, "StubbedRequest")
+	assert_is(request, "RequestSignature")
   diffobj::diffObj(stub$body, request$body)
 }

R/stub_request.R

@@ -21,7 +21,7 @@
 #' 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
+#' 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.
 #'
@@ -41,6 +41,30 @@
 #'
 #' @section Mocking writing to disk:
 #' See [mocking-disk-writing]
+#' @section Error handling:
+#' To construct stubs, one uses [stub_request()] first - which registers
+#' the stub in the stub registry. Any additional calls to modify the stub
+#' with for example [wi_th()] or [to_return()] can error. In those error
+#' cases we ideally want to remove (unregister) the stub because you
+#' certainly don't want a registered stub that is not exactly what you
+#' intended. 
+#' 
+#' When you encounter an error creating a stub you should see a warning
+#' message that the stub has been removed, for example:
+#' 
+#' ```
+#' stub_request("get", "https://httpbin.org/get") %>% 
+#'   wi_th(query = mtcars)
+#' #> Error in `wi_th()`:
+#' #> ! z$query must be of class list or partial
+#' #> Run `rlang::last_trace()` to see where the error occurred.
+#' #> Warning message:
+#' #> Encountered an error constructing stub
+#' #> • Removed stub
+#' #> • To see a list of stubs run stub_registry()
+#' ```
+#' 
+#' 
 #' @seealso [wi_th()], [to_return()], [to_timeout()], [to_raise()],
 #' [mock_file()]
 #' @examples \dontrun{
@@ -190,7 +214,7 @@
 #' stub_registry_clear()
 #' }
 stub_request <- function(method = "get", uri = NULL, uri_regex = NULL) {
-  if (is.null(uri) && is.null(uri_regex)) {
+  if (is_null(uri) && is_null(uri_regex)) {
     abort("one of uri or uri_regex is required")
   }
   tmp <- StubbedRequest$new(method = method, uri = uri, uri_regex = uri_regex)

R/to_raise.R

@@ -27,17 +27,20 @@
 #' But for now, only the first exception is used until we get that fixed
 #' @note see examples in [stub_request()]
 to_raise <- function(.data, ...) {
-  assert(.data, "StubbedRequest")
-  tmp <- list(...)
-  if (!all(vapply(
-    tmp, function(x) inherits(x, "R6ClassGenerator"),
-    logical(1)
-  ))) {
-    abort("all objects must be error classes from fauxpas")
-  }
-  if (!all(vapply(tmp, function(x) grepl("HTTP", x$classname), logical(1)))) {
-    abort("all objects must be error classes from fauxpas")
-  }
-  .data$to_raise(tmp)
+  handle_stub_removal(.data, {
+    assert_is(.data, "StubbedRequest")
+    assert_stub_registered(.data)
+    tmp <- list(...)
+    if (!all(vapply(
+      tmp, function(x) inherits(x, "R6ClassGenerator"),
+      logical(1)
+    ))) {
+      abort("all objects must be error classes from fauxpas")
+    }
+    if (!all(vapply(tmp, function(x) grepl("HTTP", x$classname), logical(1)))) {
+      abort("all objects must be error classes from fauxpas")
+    }
+    .data$to_raise(tmp)
+  })
   return(.data)
 }

R/to_return.R

@@ -72,23 +72,26 @@
 #' # many of the same response using the times parameter
 #' foo() %>% to_return(body = "stuff", times = 3)
 to_return <- function(.data, ..., .list = list(), times = 1) {
-  assert(.data, "StubbedRequest")
-  assert(.list, "list")
-  assert(times, c("integer", "numeric"))
-  assert_gte(times, 1)
-  z <- list(...)
-  if (length(z) == 0) z <- NULL
-  z <- c(z, .list)
-  if (
-    !any(c("status", "body", "headers") %in% names(z)) &&
-    length(z) != 0
-  ) {
-    abort("'to_return' only accepts status, body, headers")
-  }
-  assert(z$status, c("numeric", "integer"))
-  assert(z$headers, "list")
-  if (!all(hz_namez(z$headers))) abort("'headers' must be a named list")
-  replicate(times,
-    .data$to_return(status = z$status, body = z$body, headers = z$headers))
+  handle_stub_removal(.data, {
+    assert_is(.data, "StubbedRequest")
+    assert_stub_registered(.data)
+    assert_is(.list, "list")
+    assert_is(times, c("integer", "numeric"))
+    assert_gte(times, 1)
+    z <- list(...)
+    if (length(z) == 0) z <- NULL
+    z <- c(z, .list)
+    if (
+      !any(c("status", "body", "headers") %in% names(z)) &&
+      length(z) != 0
+    ) {
+      abort("'to_return' only accepts status, body, headers")
+    }
+    assert_is(z$status, c("numeric", "integer"))
+    assert_is(z$headers, "list")
+    if (!all(hz_namez(z$headers))) abort("'headers' must be a named list")
+    replicate(times,
+      .data$to_return(status = z$status, body = z$body, headers = z$headers))
+  })
   return(.data)
 }

R/to_timeout.R

@@ -7,7 +7,10 @@
 #' the stub
 #' @note see examples in [stub_request()]
 to_timeout <- function(.data) {
-  assert(.data, "StubbedRequest")
-  .data$to_timeout()
+  handle_stub_removal(.data, {
+    assert_is(.data, "StubbedRequest")
+    assert_stub_registered(.data)
+    .data$to_timeout()
+  })
   return(.data)
 }

R/webmockr-opts.R

@@ -83,7 +83,7 @@ webmockr_allow_net_connect <- function() {
 #' @export
 #' @rdname webmockr_configure
 webmockr_disable_net_connect <- function(allow = NULL) {
-  assert(allow, "character")
+  assert_is(allow, "character")
   message("net connect disabled")
   assign('allow_net_connect', FALSE, envir = webmockr_conf_env)
   assign('allow', allow, envir = webmockr_conf_env)
@@ -92,7 +92,7 @@ webmockr_disable_net_connect <- function(allow = NULL) {
 #' @export
 #' @rdname webmockr_configure
 webmockr_net_connect_allowed <- function(uri = NULL) {
-  assert(uri, c("character", "list"))
+  assert_is(uri, c("character", "list"))
   if (is.null(uri)) return(webmockr_conf_env$allow_net_connect)
   uri <- normalize_uri(uri)
   webmockr_conf_env$allow_net_connect ||

R/webmockr-package.R

@@ -22,6 +22,8 @@
 #' @importFrom fauxpas HTTPRequestTimeout
 #' @importFrom crul mock
 #' @importFrom base64enc base64encode
-#' @importFrom rlang abort check_installed is_list
+#' @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
 ## usethis namespace: end
 NULL