Implement circuit breaking (#613)

Fixes #370

NEWS.md

@@ -1,5 +1,6 @@
 # httr2 (development version)
 
+* `req_retry()` now optionally implements "circuit breaking" so that if requests to the same server fail many times (i.e. because the server is down), you can choose to immediately error rather than waiting (#370).
 * Export `is_online()` as thin wrapper around `curl::has_internet()` (#512).
 * `curl_translate()` now translates cookie headers to `req_cookies_set()` (#431).
 * `curl_transform()` will now use `req_body_json_modify()` for JSON data (#258).

R/httr2-package.R

@@ -11,6 +11,7 @@ NULL
 
 the <- new_environment()
 the$throttle <- list()
+the$breaker <- new_environment()
 the$cache_throttle <- list()
 the$token_cache <- new_environment()
 the$last_response <- NULL

R/req-perform-connection.R

@@ -49,6 +49,7 @@ req_perform_connection <- function(req, blocking = TRUE) {
   deadline <- Sys.time() + retry_max_seconds(req)
   resp <- NULL
   while (tries < max_tries && Sys.time() < deadline) {
+    retry_check_breaker(req, tries)
     sys_sleep(delay, "for retry backoff")
 
     if (!is.null(resp)) {
@@ -58,6 +59,7 @@ req_perform_connection <- function(req, blocking = TRUE) {
 
     if (retry_is_transient(req, resp)) {
       tries <- tries + 1
+
       delay <- retry_after(req, resp, tries)
       signal(class = "httr2_retry", tries = tries, delay = delay)
     } else {

R/req-perform.R

@@ -107,6 +107,7 @@ req_perform <- function(
 
   delay <- 0
   while (tries < max_tries && Sys.time() < deadline) {
+    retry_check_breaker(req, tries, error_call = error_call)
     sys_sleep(delay, "for retry backoff")
     n <- n + 1
 
@@ -161,6 +162,7 @@ handle_resp <- function(req, resp, error_call = caller_env()) {
 req_perform1 <- function(req, path = NULL, handle = NULL) {
   the$last_request <- req
   the$last_response <- NULL
+  signal(class = "httr2_perform")
 
   if (!is.null(path)) {
     res <- curl::curl_fetch_disk(req$url, path, handle)

R/req-retries.R

@@ -50,6 +50,13 @@
 #'   returns either a number of seconds to wait or `NA`. `NA` indicates
 #'   that a precise wait time is not available and that the `backoff` strategy
 #'   should be used instead.
+#' @param failure_threshold,failure_timeout,failure_realm
+#'   Set `failure_threshold` to activate "circuit breaking" where if a request
+#'   continues to fail after `failure_threshold` times, cause the request to
+#'   error until a timeout of `failure_timeout` seconds has elapsed. This
+#'   timeout will persist across all requests with the same `failure_realm`
+#'   (which defaults to the hostname of the request) and is intended to detect
+#'   failing servers without needing to wait each time.
 #' @returns A modified HTTP [request].
 #' @export
 #' @seealso [req_throttle()] if the API has a rate-limit but doesn't expose
@@ -85,11 +92,16 @@ req_retry <- function(req,
                       retry_on_failure = FALSE,
                       is_transient = NULL,
                       backoff = NULL,
-                      after = NULL) {
+                      after = NULL,
+                      failure_threshold = Inf,
+                      failure_timeout = 30,
+                      failure_realm = NULL) {
 
   check_request(req)
   check_number_whole(max_tries, min = 1, allow_null = TRUE)
   check_number_whole(max_seconds, min = 0, allow_null = TRUE)
+  check_number_whole(failure_threshold, min = 1, allow_infinite = TRUE)
+  check_number_whole(failure_timeout, min = 1)
 
   if (is.null(max_tries) && is.null(max_seconds)) {
     max_tries <- 2
@@ -104,7 +116,10 @@ req_retry <- function(req,
     retry_on_failure = retry_on_failure,
     retry_is_transient = as_callback(is_transient, 1, "is_transient"),
     retry_backoff = as_callback(backoff, 1, "backoff"),
-    retry_after = as_callback(after, 1, "after")
+    retry_after = as_callback(after, 1, "after"),
+    retry_failure_threshold = failure_threshold,
+    retry_failure_timeout = failure_timeout,
+    retry_realm = failure_realm %||% url_parse(req$url)$hostname
   )
 }
 
@@ -117,6 +132,38 @@ retry_max_seconds <- function(req) {
   req$policies$retry_max_wait %||% Inf
 }
 
+retry_check_breaker <- function(req, i, error_call = caller_env()) {
+  realm <- req$policies$retry_realm
+  if (is.null(realm)) {
+    return(invisible())
+  }
+
+  now <- unix_time()
+  if (env_has(the$breaker, realm)) {
+    triggered <- the$breaker[[realm]]
+  } else if (i > req$policies$retry_failure_threshold) {
+    the$breaker[[realm]] <- triggered <- now
+  } else {
+    return(invisible())
+  }
+
+  remaining <- req$policies$retry_failure_timeout - (now - triggered)
+  if (remaining <= 0) {
+    env_unbind(the$breaker, realm)
+  } else {
+    cli::cli_abort(
+      c(
+         "Request failures have exceeded the threshold for realm {.str {realm}}.",
+        i = "The server behind {.str {realm}} is likely still overloaded or down.",
+        i = "Wait {remaining} seconds before retrying."
+
+      ),
+      call = error_call,
+      class = "httr2_breaker"
+    )
+  }
+}
+
 retry_is_transient <- function(req, resp) {
   if (is_error(resp)) {
     return(req$policies$retry_on_failure %||% FALSE)

tests/testthat/test-req-perform.R

@@ -55,11 +55,11 @@ test_that("persistent HTTP errors only get single attempt", {
 })
 
 test_that("don't retry curl errors by default", {
-  req <- request("") %>% req_retry(max_tries = 2)
+  req <- request("") %>% req_retry(max_tries = 2, failure_realm = "x")
   expect_error(req_perform(req), class = "httr2_failure")
 
   # But can opt-in to it
-  req <- request("") %>% req_retry(max_tries = 2, retry_on_failure = TRUE)
+  req <- request("") %>% req_retry(max_tries = 2, retry_on_failure = TRUE, failure_realm = "x")
   cnd <- catch_cnd(req_perform(req), "httr2_retry")
   expect_equal(cnd$tries, 1)
 })

tests/testthat/test-req-retries.R

@@ -92,3 +92,33 @@ test_that("is_number_or_na implemented correctly", {
   expect_equal(is_number_or_na(numeric()), FALSE)
   expect_equal(is_number_or_na("x"), FALSE)
 })
+
+
+# circuit breaker --------------------------------------------------------
+
+test_that("triggered after specified requests", {
+  req <- request_test("/status/:status", status = 429) %>%
+    req_retry(
+      after = function(resp) 0,
+      max_tries = 10,
+      failure_threshold = 1
+    )
+
+  # First attempt performs, retries, then errors
+  req_perform(req) %>%
+    expect_condition(class = "httr2_perform") %>%
+    expect_condition(class = "httr2_retry") %>%
+    expect_error(class = "httr2_breaker")
+
+  # Second attempt errors without performing
+  req_perform(req) %>%
+    expect_no_condition(class = "httr2_perform") %>%
+    expect_error(class = "httr2_breaker")
+
+  # Attempt on same realm errors without trying at all
+  req2 <- request_test("/status/:status", status = 200) %>%
+    req_retry()
+  req_perform(req) %>%
+    expect_no_condition(class = "httr2_perform") %>%
+    expect_error(class = "httr2_breaker")
+})