Merge pull request #167 from mrc-ide/mrc-5724-upgrade-httr2

Update from httr to httr2.

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: orderly2
 Title: Orderly Next Generation
-Version: 1.99.27
+Version: 1.99.28
 Authors@R: c(person("Rich", "FitzJohn", role = c("aut", "cre"),
                     email = "[email protected]"),
              person("Robert", "Ashton", role = "aut"),
@@ -28,7 +28,7 @@ Imports:
 Suggests:
     DBI,
     RSQLite,
-    httr,
+    httr2,
     jsonvalidate (>= 1.4.0),
     knitr,
     mockery,

R/location_http.R

@@ -11,7 +11,7 @@ orderly_location_http <- R6::R6Class(
     },
 
     list = function() {
-      dat <- private$client$get("/metadata/list", parse_json = TRUE)$data
+      dat <- private$client$request("/metadata/list")$data
       data_frame(
         packet = vcapply(dat, "[[", "packet"),
         time = num_to_time(vnapply(dat, "[[", "time")),
@@ -21,8 +21,8 @@ orderly_location_http <- R6::R6Class(
     metadata = function(packet_ids) {
       ret <- vcapply(packet_ids, function(id) {
         tryCatch(
-          trimws(private$client$get(sprintf("/metadata/%s/text", id),
-                                    parse_json = FALSE)),
+          trimws(private$client$request(sprintf("/metadata/%s/text", id),
+                                        parse_json = FALSE)),
           outpack_http_client_error = function(e) {
             if (e$code == 404) {
               e$message <- sprintf("Some packet ids not found: '%s'", id)
@@ -43,7 +43,7 @@ orderly_location_http <- R6::R6Class(
       ## progress in the client, but there's not much point until
       ## then.
       tryCatch(
-        private$client$get(sprintf("/file/%s", hash), download = dest),
+        private$client$request(sprintf("/file/%s", hash), download = dest),
         outpack_http_client_error = function(e) {
           if (e$code == 404) {
             unlink(dest)
@@ -56,32 +56,36 @@ orderly_location_http <- R6::R6Class(
 
     ## TODO: we could get the schemas here from outpack_server too
     list_unknown_packets = function(ids) {
-      body <- to_json(list(ids = ids, unpacked = scalar(TRUE)), NULL)
-      content <- httr::content_type("application/json")
-      res <- private$client$post("/packets/missing", body, content)
+      res <- private$client$request("/packets/missing", function(r) {
+        httr2::req_body_json(r, list(ids = ids, unpacked = scalar(TRUE)))
+      })
       list_to_character(res$data)
     },
 
     list_unknown_files = function(hashes) {
-      body <- to_json(list(hashes = hashes), NULL)
-      res <- private$client$post("/files/missing", body,
-                                 httr::content_type("application/json"))
+      res <- private$client$request(
+        "/files/missing",
+        function(r) httr2::req_body_json(r, list(hashes = hashes)))
       list_to_character(res$data)
     },
 
     push_file = function(src, hash) {
-      body <- httr::upload_file(src, "application/octet-stream")
-      res <- private$client$post(sprintf("/file/%s", hash), body)
+      res <- private$client$request(
+        sprintf("/file/%s", hash),
+        function(r) httr2::req_body_file(r, src, "application/octet-stream"))
+
       invisible(NULL)
     },
 
     push_metadata = function(packet_id, hash, path) {
       meta <- read_string(path)
-      res <- private$client$post(sprintf("/packet/%s", hash), meta,
-                                 httr::content_type("text/plain"))
+      res <- private$client$request(
+        sprintf("/packet/%s", hash),
+        function(r) httr2::req_body_raw(r, meta, "text/plain"))
       invisible(NULL)
     }
-  ))
+  )
+)
 
 
 orderly_location_packit <- function(url, token) {

R/outpack_http_client.R

@@ -21,36 +21,37 @@ outpack_http_client <- R6::R6Class(
       }
     },
 
-    get = function(path, ...) {
+    request = function(path, customize = identity, ...) {
       self$authorise()
-      http_client_request(httr::GET, paste0(self$url, path), ...,
-                          self$auth$header)
-    },
-
-    post = function(path, body, ...) {
-      self$authorise()
-      http_client_request(httr::POST, paste0(self$url, path), body = body, ...,
-                          self$auth$header)
+      http_client_request(
+        self$url,
+        function(r) {
+          r <- httr2::req_url_path_append(r, path)
+          r <- httr2::req_headers(r, !!!self$auth$header)
+          customize(r)
+        }, ...)
     }
   ))
 
-
-http_client_request <- function(verb, url, ..., parse_json = TRUE,
-                                download = NULL) {
-  if (is.null(download)) {
-    response <- verb(url, ...)
-  } else {
-    response <- verb(url, ...,
-                     http_client_download_options(download))
+http_client_request <- function(url, customize = identity, download = NULL,
+                                parse_json = TRUE) {
+  req <- httr2::request(url)
+  if (!is.null(download)) {
+    req <- httr2::req_headers(req, Accept = "application/octet-stream")
   }
 
-  http_client_handle_error(response)
+  req <- customize(req)
+  resp <- tryCatch(
+    httr2::req_perform(req, path = download),
+    httr2_http = function(cnd) {
+      http_client_handle_error(cnd$resp)
+    })
+
   if (is.null(download)) {
-    txt <- httr::content(response, "text", encoding = "UTF-8")
     if (parse_json) {
-      from_json(txt)
+      httr2::resp_body_json(resp, simplifyVector = FALSE)
     } else {
-      txt
+      httr2::resp_body_string(resp)
     }
   } else {
     download
@@ -63,17 +64,19 @@ http_client_handle_error <- function(response) {
   ## that an expired timeout produces a certain error code we watch
   ## for that and then reauthenticate; that requires that a callback
   ## is passed through here too.
-  code <- httr::status_code(response)
-  if (httr::http_error(code)) {
-    if (httr::http_type(response) == "application/json") {
-      txt <- httr::content(response, "text", encoding = "UTF-8")
-      res <- from_json(txt)
+  if (httr2::resp_is_error(response)) {
+    if (httr2::resp_content_type(response) == "application/json") {
+      res <- httr2::resp_body_json(response)
       ## I am seeing Packit returning an element 'error' not a list of
       ## errors
       errors <- if ("error" %in% names(res)) list(res$error) else res$errors
-      stop(http_client_error(errors[[1]]$detail, code, errors))
+      stop(http_client_error(errors[[1]]$detail,
+                             httr2::resp_status(response),
+                             errors))
     } else {
-      stop(http_client_error(httr::http_status(code)$message, code, NULL))
+      stop(http_client_error(httr2::resp_status_desc(response),
+                             httr2::resp_status(response),
+                             NULL))
     }
   }
   response
@@ -87,12 +90,6 @@ http_client_error <- function(msg, code, errors) {
 }
 
 
-http_client_download_options <- function(dest) {
-  c(httr::write_disk(dest),
-    httr::accept("application/octet-stream"))
-}
-
-
 ## Logging in with packit is quite slow and we'll want to cache this;
 ## but we won't be holding a persistant handle to the root.  So for
 ## now at least we'll keep a pool of generated bearer token headers,
@@ -108,11 +105,12 @@ http_client_login <- function(name, auth) {
   key <- rlang::hash(auth)
   if (is.null(auth_cache[[key]])) {
     cli::cli_alert_info("Logging in to {name}")
-    res <- http_client_request(httr::POST, auth$url,
-                               body = auth$data, encode = "json")
+
+    res <- http_client_request(auth$url,
+                               function(r) httr2::req_body_json(r, auth$data))
+
     cli::cli_alert_success("Logged in successfully")
-    auth_cache[[key]] <- httr::add_headers(
-      "Authorization" = paste("Bearer", res$token))
+    auth_cache[[key]] <- list("Authorization" = paste("Bearer", res$token))
   }
   auth_cache[[key]]
 }

R/util.R

@@ -332,11 +332,6 @@ to_json <- function(x, schema = NULL, auto_unbox = FALSE, ...) {
 }
 
 
-from_json <- function(x, ...) {
-  jsonlite::fromJSON(x, simplifyVector = FALSE, ...)
-}
-
-
 as_json <- function(str) {
   assert_scalar_character(str)
   structure(str, class = "json")

tests/testthat/helper-outpack-http.R

@@ -5,9 +5,8 @@ mock_headers <- function(...) {
 mock_response <- function(content, status = 200L, wrap = TRUE,
                           download = NULL) {
   headers <- mock_headers()
-  if (!is.null(download)) {
+  if (is.raw(content)) {
     headers <- mock_headers("content-type" = "application/octet-stream")
-    writeBin(content, download)
   } else if (inherits(content, "json")) {
     headers <- mock_headers("content-type" = "application/json")
     if (wrap) {
@@ -16,16 +15,20 @@ mock_response <- function(content, status = 200L, wrap = TRUE,
     }
     class(content) <- NULL
     content <- c(writeBin(content, raw()), as.raw(0L))
-  } else if (inherits(content, "character")) {
+  } else if (is.character(content)) {
     headers <- mock_headers("content-type" = "text/plain")
     content <- c(writeBin(content, raw()), as.raw(0L))
   } else {
     stop("Unhandled mock response type")
   }
-  structure(list(status_code = status,
-                 headers = headers,
-                 content = content),
-            class = "response")
+
+  if (!is.null(download)) {
+    writeBin(content, download)
+  }
+
+  httr2::response(status_code = status,
+                  headers = headers,
+                  body = content)
 }
 
 
@@ -38,3 +41,9 @@ json_string <- function(s) {
 clear_auth_cache <- function() {
   rm(list = ls(auth_cache), envir = auth_cache)
 }
+
+local_mock_response <- function(..., env = rlang::caller_env()) {
+  mock <- mockery::mock(mock_response(...))
+  httr2::local_mocked_responses(function(req) mock(req), env = env)
+  mock
+}

tests/testthat/helper-outpack-server.R

@@ -10,7 +10,10 @@ outpack_server <- function(path, timeout = 10) {
   t_end <- Sys.time() + timeout
   success <- FALSE
   while (!success && px$is_alive() && Sys.time() < t_end) {
-    result <- tryCatch(httr::GET("http://localhost:8000"), error = identity)
+    r <- httr2::request("http://localhost:8000")
+    result <- tryCatch(
+       httr2::req_perform(r),
+      error = identity)
     success <- !inherits(result, "error")
   }
   if (!success) {