Convert to httr2

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: BiocFileCache
 Title: Manage Files Across Sessions
-Version: 2.17.0
+Version: 2.99.0
 Authors@R: c(person("Lori", "Shepherd",
       email = "lori.shepherd@roswellpark.org",
       role = c("aut", "cre")),
@@ -24,7 +24,7 @@ Imports:
     DBI,
     filelock,
     curl,
-    httr
+    httr2
 BugReports: https://github.com/Bioconductor/BiocFileCache/issues
 DevelopmentURL: https://github.com/Bioconductor/BiocFileCache
 License: Artistic-2.0

NAMESPACE

@@ -59,7 +59,7 @@ exportMethods(removebfc)
 exportMethods(show)
 import(RSQLite)
 import(dbplyr)
-import(httr)
+import(httr2)
 import(methods)
 importFrom(DBI,dbExecute)
 importFrom(DBI,dbSendStatement)

NEWS

@@ -1,3 +1,10 @@
+CHANGES IN VERSION 2.99.0
+----------------------
+
+MAJOR UPDATES
+
+    o Update downloading method from httr to httr2
+
 CHANGES IN VERSION 2.15
 ----------------------
 

R/BiocFileCache-class.R

@@ -1,5 +1,5 @@
 #' @import methods
-#' @import httr
+#' @import httr2
 #' @importFrom utils tar zip untar unzip
 #' @importFrom dplyr mutate
 #' @importFrom tools R_user_dir
@@ -342,13 +342,16 @@ setMethod("bfcadd", "missing",
 #'     the file to the cache directory; or \code{asis} leave the file
 #'     in current location but save the path in the cache. If 'rtype
 #'     == "relative"', action can not be "asis".
-#' @param proxy character(1) (Optional) proxy server.
+#' @param proxy character(1) (Optional) proxy server passed to
+#'     \code{httr2::req_proxy}
 #' @param download logical(1) If \code{rtype=web}, should remote
 #'     resource be downloaded locally immediately.
-#' @param config list() passed as config argument in \code{httr::GET}
+#' @param config list() passed as argument to \code{httr2::req_options}. The
+#'     names of items shoudl be valid curl options as defined in
+#'     \code{curl::curl_options}.
 #' @param ... For 'bfcadd', 'bfcupdate' and 'bfcdownload': Additional
 #'     arguments passed to internal download functions for use with
-#'     \code{httr::GET}. For 'bfcrpaths': Additional arguments passed
+#'     \code{httr2::req_perform}. For 'bfcrpaths': Additional arguments passed
 #'     to 'bfcadd', or \code{exact} passed to 'bfcquery'. For
 #'     'bfcquery': Additional arguments passed to \code{grepl}. For
 #'     'exportbfc': Additional arguments to the selected outputMethod
@@ -374,7 +377,7 @@ setMethod("bfcadd", "missing",
 #' file.exists(fl3)                                # TRUE
 #'
 #' # add a remote resource
-#' url <- "http://httpbin.org/get"
+#' url <- "https://httpbin.org/get"
 #' bfcadd(bfc0, "TestWeb", fpath=url)
 #' @aliases bfcadd
 #' @exportMethod bfcadd

R/httr.R

@@ -1,23 +1,74 @@
+# taken/based on httr::parse_http_date
+.fmt_http_date <- function(x, failure = structure(NA_real_, class = "Date")) {
+    if (length(x) == 0)
+        return(NULL)
+    fmts <- c("%a, %d %b %Y %H:%M:%S", "%A, %d-%b-%y %H:%M:%S",
+        "%a %b %d %H:%M:%S %Y")
+    for (fmt in fmts) {
+        parsed <- as.POSIXct(strptime(x, fmt, tz = "GMT"))
+        if (all(!is.na(parsed)))
+            return(parsed)
+    }
+    rep(failure, length(x))
+}
+
+# taken/based on httr::parse_cache_control
+.fmt_cache_control <- function(cachecontrol){
+    if (is.null(cachecontrol))
+        return(list())
+    pieces <- strsplit(cachecontrol, ",")[[1]]
+    pieces <- gsub("^\\s+|\\s+$", "", pieces)
+    pieces <- tolower(pieces)
+    is_value <- grepl("=", pieces)
+    flags <- pieces[!is_value]
+    keyvalues <- strsplit(pieces[is_value], "\\s*=\\s*")
+    keys <- c(rep("flags", length(flags)), lapply(keyvalues,
+        "[[", 1))
+    values <- c(flags, lapply(keyvalues, "[[", 2))
+    stats::setNames(values, keys)
+}
+
+# taken/based on httr::cache_info
+.get_http_expires <- function(response){
+    expires <- .fmt_http_date(resp_header(response, "expires"), Inf) %||% NULL
+    control <- .fmt_cache_control(resp_header(response, "cache-control"))
+    max_age <- as.integer(control$`max-age`) %||% NULL
+    if (!is.null(max_age)) {
+        expires <- .fmt_http_date(resp_header(response, "date")) + max_age
+    } else {
+        if (!is.null(resp_header(response, "expires"))) {
+            expires <- .fmt_http_date(resp_header(response, "expires"), -Inf)
+        } else {
+            expires <- NULL
+        }
+    }
+    expires
+}
+
 .httr_get_cache_info <-
     function(link)
 {
     response = withCallingHandlers({
-        HEAD(link)
+        request(link) %>%
+            req_method("HEAD") %>%
+            req_perform()
+
     }, warning = function(w) {
         invokeRestart("muffleWarning")
+    }, error = function(e){
+        stop("Error while performing HEAD request")
     })
 
     tryCatch({
-        ci <- cache_info(response)
-        last_mod <- as.character(ci$modified)
-        etag <- gsub("\"", "",as.character(ci$etag))
-        expires <- as.character(ci$expires)
-        if (length(last_mod) == 0L)
-            last_mod <- NA_character_
-        if (length(etag) == 0L)
-            etag <- NA_character_
-        if (length(expires) == 0L)
-            expires <- NA_character_
+        etag <- ifelse(resp_header_exists(response, "etag"),
+                       gsub("\"", "",as.character(resp_header(response, "etag"))),
+                       NA_character_)
+        last_mod <- ifelse(resp_header_exists(response, "last-modified"),
+                           as.character(.fmt_http_date(resp_header(response, "last-modified"))),
+                           NA_character_)
+        expires <- .get_http_expires(response)
+        expires <- ifelse(is.null(expires), NA_character_, as.character(expires))
+
         c(etag = etag, modified = last_mod, expires = expires)
     },  error = function(err) {
 
@@ -31,11 +82,23 @@
         } else {
             modified = NA_character_
         }
-         if ("expires" %in% names(response$headers)){
-            expires = as.character(response[["headers"]]["expires"])
+        if ("cache-control" %in% names(response$headers)){
+            cachecontrol =
+                .fmt_cache_control(as.character(response[["headers"]]["cache-control"]))
+            max_age = as.integer(control$`max-age`) %||% NULL
+            if (!is.null(max_age)) {
+                expires <- .fmt_http_date(as.character(response[["headers"]]["date"])) + max_age
+            }else{
+                if ("expires" %in% names(response$headers)){
+                    expires = as.character(response[["headers"]]["expires"])
+                } else {
+                    expires = NA_character_
+                }
+            }
         } else {
             expires = NA_character_
         }
+
         c(etag = etag, modified = modified, expires = expires)
     })
 }
@@ -44,37 +107,49 @@
 .httr_download <-
     function(websource, localfile, proxy, config, ...)
 {
+
     ## retrieve file from hub to cache
     tryCatch({
 
-        if(!is(proxy, "request")){
-            if (proxy == ""){
-                proxy = NULL
-            }else{
-                proxy = use_proxy(proxy)
-            }
+        if (proxy == ""){
+            proxy <- NULL
+        }         
+
+        if((length(config)==0)){
+            config <- NULL
+        } else {
+            stopifnot(is.list(config))
         }
 
-        if (!all(file.exists(dirname(localfile))))
-            dir.create(dirname(localfile), recursive=TRUE)
+        if (!all(file.exists(dirname(localfile)))) dir.create(dirname(localfile), recursive=TRUE)
 
-        ## Download the resource in a way that supports https
-        if (interactive() && (packageVersion("httr") > "1.0.0")) {
-            response <- suppressWarnings({
-                GET(websource, progress(con = stderr()), config=config,
-                    write_disk(localfile, overwrite=TRUE), proxy, ...)
-            })
-            cat("\n") ## line break after progress bar
-        } else {
-            response <- suppressWarnings({
-                GET(websource, write_disk(localfile, overwrite=TRUE),
-                    proxy, config=config, ...)
-            })
+        # set up request using httr2
+        req <- request(websource)
+        # This enables progress bars in httr2
+        if(interactive()){
+            req <- req %>% req_progress()
+        }
+        # Apply the proxy if it's not NULL
+        if (!is.null(proxy)) {
+            req <- req %>% req_proxy(proxy)
         }
-        if (length(status_code(response))) {
-            if (status_code(response) != 302L)
-                stop_for_status(response)
+        # Apply the config if it's not NULL
+        if (!is.null(config)) {
+            req <- req %>% req_options(!!!config)
         }
+        ## httr2 req_perform does not have an overwrite
+        ## assume overwrite will occur automatically
+        ## Perform the request and capture the response
+        response <- req_perform(req, path=localfile, ...)
+
+        cat("\n") ## line break after progress bar
+
+#  No longer needed?
+#        if (length(status_code(response))) {
+#            if (status_code(response) != 302L)
+#                stop_for_status(response)
+#        }
+
         TRUE
     }, error = function(err) {
         warning("download failed",
@@ -84,4 +159,5 @@
             call.=FALSE)
         FALSE
     })
+
 }

R/zzz.R

@@ -1,3 +1,5 @@
+globalVariables(c("rid", "id", "control", "access_time"))
+
 .onLoad <- function(libname, pkgname, ...) {
     ## options from getOption or Sys.env or default, in that order
     if (is.null(getBFCOption("CACHE"))) {

tests/testthat/test_BiocFileCache_class.R

@@ -40,7 +40,7 @@ test_that("bfcadd and bfcnew works", {
     expect_true(!file.exists(fl))
 
     # test add web resource
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     path <- bfcadd(bfc, 'test-4', url, rtype="web")
     rid <- names(path)
     expect_identical(length(bfc), 4L)
@@ -61,13 +61,13 @@ test_that("bfcadd and bfcnew works", {
     expect_error(bfcadd(bfc, 'test-2', fl, rtype='local', action='asis'))
 
     # test no fpath given
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     path <- bfcadd(bfc, url)
     expect_identical(.sql_get_fpath(bfc,names(path)),
                      .sql_get_rname(bfc,names(path)))
 
     # test web resource not download
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     path <- bfcadd(bfc, 'test-noDownload', url, rtype="web", download=FALSE)
     rid <- names(path)
     expect_identical(length(bfc), 7L)
@@ -178,12 +178,12 @@ add1 <- bfcadd(bfc, 'test-1', fl)
 rid1 <- names(add1)
 add2 <- bfcadd(bfc, 'test-2', fl, rtype='local', action='asis')
 rid2 <- names(add2)
-url <- "http://httpbin.org/get"
+url <- "https://httpbin.org/get"
 add3 <- bfcadd(bfc, 'test-3', url, rtype="web")
 rid3 <- names(add3)
 path <- bfcnew(bfc, 'test-4')
 rid4 <- names(path)
-url <- "http://httpbin.org/get"
+url <- "https://httpbin.org/get"
 add5 <- bfcadd(bfc, 'test-5', url, rtype="web", download=FALSE)
 rid5 <- names(add5)
 
@@ -461,7 +461,7 @@ test_that("bfcneedsupdate works", {
     expect_error(bfcneedsupdate(bfc, 7))
 
     # test expires and last modified not available
-    link = "http://httpbin.org/get"
+    link = "https://httpbin.org/get"
     bfcupdate(bfc, rid3, fpath=link, ask=FALSE)
     expect_true(is.na(bfcneedsupdate(bfc, rid3)))
     expect_true(is.na(as.data.frame(bfcinfo(bfc,rid3))$last_modified_time))
@@ -550,12 +550,12 @@ test_that("exportbfc and importbfc works",{
     rid1 <- names(add1)
     add2 <- bfcadd(bfc, 'local', fl, rtype='local', action='asis')
     rid2 <- names(add2)
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     add3 <- bfcadd(bfc, 'web', url, rtype="web")
     rid3 <- names(add3)
     path <- bfcnew(bfc, 'notfound')
     rid4 <- names(path)
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     add5 <- bfcadd(bfc, 'webno', url, rtype="web", download=FALSE)
     rid5 <- names(add5)
 
@@ -602,7 +602,7 @@ test_that("bfcsync and bfcremove works", {
     rid1 <- names(add1)
     add2 <- bfcadd(bfc2, 'test-2', fl, rtype='local', action='asis')
     rid2 <- names(add2)
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     add3 <- bfcadd(bfc2, 'test-3', url, rtype="web")
     rid3 <- names(add3)
     path <- bfcnew(bfc2, 'test-4')

tests/testthat/test_httr.R

@@ -1,9 +1,9 @@
-context("httr")
+context("httr2")
 
 test_that("internal .httr_get_cache_info works", {
 
     # example neither
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     info <- .httr_get_cache_info(url)
     expect_true(all(is.na(info)))
     expect_identical(length(info), 3L)

tests/testthat/test_makeBiocFileCacheFromDataFrame.R

@@ -6,7 +6,7 @@ test_that("makeBiocFileCacheFromDataFrame works",{
     fl <- tempfile(); file.create(fl)
     add1 <- bfcadd(bfc2, 'relative', fl)
     add2 <- bfcadd(bfc2, 'local', fl, rtype='local', action='asis')
-    url <- "http://httpbin.org/get"
+    url <- "https://httpbin.org/get"
     add3 <- bfcadd(bfc2, 'noDown', url, rtype="web", download=FALSE)
     url  <- "https://www.wikipedia.org/"
     add4 <- bfcadd(bfc2, 'web', url, rtype="web")