Update embedded async, simplify http tests

Now that async's retry can customize the backoff.

Author: gaborcsardi

R/aaa-async.R

@@ -2978,9 +2978,13 @@ sseapp <- function() {
 #'     - `status_codes`: integer vector of HTTP status codes to retry on.
 #'       Defaults to 408, 413, 429, 500, 502, 503, 504, 521, 522 and 524.
 #'     - `errors`: whether to retry on connection errors, defaults to `TRUE`.
+#'     - `backoff`: a function that takes the (integer) retry attempt number
+#'       and returns the number of seconds to wait before the next attempt.
+#'       Defaults to an exponential backoff.
 #'
 #'   Between retries `async` waits with an exponential backoff, unless the
-#'   response has a `Retry-After` header, which is then honored.
+#'   response has a `Retry-After` header, which is then honored. Use the
+#'   `backoff` entry to customize the wait.
 #' @return Deferred object.
 #'
 #' @section Progress bars:
@@ -3333,7 +3337,7 @@ make_deferred_http <- function(cb, file, method = "GET", retry = TRUE) {
           value$status_code %in% retry$status_codes
       ) {
         did <<- did + 1L
-        wait <- http_retry_after(value) %||% default_backoff(did)
+        wait <- http_retry_after(value) %||% retry$backoff(did)
         delay(wait)$then(function() once())$then(self)
       } else {
         resolve(value)
@@ -3342,7 +3346,7 @@ make_deferred_http <- function(cb, file, method = "GET", retry = TRUE) {
     parent_reject = function(value, resolve) {
       if (retry$errors && did < retry$limit) {
         did <<- did + 1L
-        delay(default_backoff(did))$then(function() once())$then(self)
+        delay(retry$backoff(did))$then(function() once())$then(self)
       } else {
         stop(value)
       }
@@ -3388,7 +3392,8 @@ http_retry_defaults <- list(
   limit = 2L,
   methods = c("GET", "PUT", "HEAD", "DELETE", "OPTIONS", "TRACE", "QUERY"),
   status_codes = c(408L, 413L, 429L, 500L, 502L, 503L, 504L, 521L, 522L, 524L),
-  errors = TRUE
+  errors = TRUE,
+  backoff = default_backoff
 )
 
 get_default_http_retry <- function(retry, method) {

tests/async/test-event-loop.R

@@ -59,7 +59,9 @@ test_that("repeated delay", {
   expect_null(error)
   expect_equal(result, 1:10)
   expect_true(end - start >= as.difftime(1, units = "secs"))
-  expect_true(end - start <= as.difftime(2, units = "secs"))
+  # Loose upper bound: this is only a sanity check that the loop isn't wildly
+  # slow. A tight bound flakes on busy CI runners.
+  expect_true(end - start <= as.difftime(5, units = "secs"))
 })
 
 test_that("nested event loops", {

tests/async/test-http.R

@@ -395,7 +395,6 @@ test_that("http_retry_after parses the header", {
 })
 
 test_that("retryable status codes are retried", {
-  local_mocked_bindings(default_backoff = function(i) 0)
   app <- webfakes::new_app()
   app$locals$n <- 0L
   app$get("/flaky", function(req, res) {
@@ -410,23 +409,26 @@ test_that("retryable status codes are retried", {
   proc <- webfakes::new_app_process(app)
   on.exit(proc$stop(), add = TRUE)
 
-  # default limit is 2, so the third attempt (a 200) succeeds
-  resp <- synchronise(http_get(proc$url("/flaky")))
+  # default limit is 2, so the third attempt (a 200) succeeds.
+  # `backoff` is set to zero so the test does not sleep between retries.
+  resp <- synchronise(http_get(
+    proc$url("/flaky"),
+    retry = list(backoff = function(i) 0)
+  ))
   expect_equal(resp$status_code, 200L)
   expect_equal(rawToChar(resp$content), "3")
 })
 
 test_that("retries are exhausted and the last response is returned", {
-  local_mocked_bindings(default_backoff = function(i) 0)
   resp <- synchronise(http_get(
     http$url("/status/503"),
-    retry = list(limit = 1)
+    retry = list(limit = 1, backoff = function(i) 0)
   ))
   expect_equal(resp$status_code, 503L)
 })
 
 test_that("retry = FALSE and non-retryable codes do not retry", {
-  local_mocked_bindings(default_backoff = function(i) 0)
+  # neither request retries, so no backoff happens
   # 404 is not in the default status_codes
   resp <- synchronise(http_get(http$url("/status/404")))
   expect_equal(resp$status_code, 404L)
@@ -436,9 +438,11 @@ test_that("retry = FALSE and non-retryable codes do not retry", {
 })
 
 test_that("connection errors are retried unless disabled", {
-  local_mocked_bindings(default_backoff = function(i) 0)
   err <- tryCatch(
-    synchronise(http_get("http://127.0.0.1:1/nope", retry = list(limit = 1))),
+    synchronise(http_get(
+      "http://127.0.0.1:1/nope",
+      retry = list(limit = 1, backoff = function(i) 0)
+    )),
     error = identity
   )
   expect_s3_class(err, "async_rejected")

tests/testthat/test-1-metadata-cache-2.R

@@ -41,7 +41,7 @@ test_that("check_update", {
   cat("foobar2\n", file = rep_files$rds)
   cat("foobar\n", file = pri_files$pkgs$path[1])
   cat("foobar2\n", file = pri_files$rds)
-  data2 <- cmc$check_update()
+  data2 <- suppressMessages(cmc$check_update())
   expect_identical(data, data2)
   expect_equal(read_lines(rep_files$pkgs$path[1]), "foobar")