Send auth information in the headers (#391)

* Send auth information in the headers Instead of sending it in query parameters. This way it is not printed in the logs on errors. Also refactored the download code a bit. We still respect the user's `download.file.method` option. We have tests now for the various download methods. Closes #364. * Fix download test if user has method set We need to unset the `download.file.method` while running the tests, in case the user running the tests has a default set. * Update install-github.R file * Fix download tests on windows Need to double quote, single quote is not special on Windows. * Warn if cannot send HTTP headers Older R versions cannot send headers with the wininet method. * Update install-github.R file * Add note to NEWS [ci skip]
r-lib · Jun 24, 2019 · 0c980e2 · 0c980e2
1 parent c04ca36
commit 0c980e2
Show file tree

Hide file tree

Showing 7 changed files with 648 additions and 138 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -8,6 +8,9 @@
 * The interactive menu has been modified to provide more clear instructions on
   the skipping behavior (#207)
 
+* Credentials are now passed via HTTP headers, to reduce exposure when requests
+  fail (#391).
+
 ## Minor improvements and fixes
 
 * `update_packages()` now has a more informative error message when the update

diff --git a/R/download.R b/R/download.R
@@ -1,11 +1,43 @@
 
+#' Download a file
+#'
+#' Uses either the curl package for R versions older than 3.2.0,
+#' otherwise a wrapper around [download.file()].
+#'
+#' We respect the `download.file.method` setting of the user. If it is
+#' not set, then see `download_method()` for choosing a method.
+#'
+#' Authentication can be supplied three ways:
+#' * By setting `auth_token`. This will append an HTTP `Authorization`
+#'   header: `Authorization: token {auth_token}`.
+#' * By setting `basic_auth` to a list with elements `user` and `password`.
+#'   This will append a proper `Authorization: Basic {encoded_password}`
+#'   HTTP header.
+#' * By specifying the proper `headers` directly.
+#'
+#' If both `auth_token` and `basic_auth` are specified, that's an error.
+#' `auth_token` and `basic_auth` are _appended_ to `headers`, so they
+#' take precedence over an `Authorization` header that is specified
+#' directly in `headers`.
+#'
+#' @param path Path to download to. `dirname(path)` must exist.
+#' @param url URL.
+#' @param auth_token Token for token-based authentication or `NULL`.
+#' @param basic_auth List with `user` and `password` for basic HTTP
+#'   authentication, or `NULL`.
+#' @param quiet Passed to [download.file()] or [curl::curl_download()].
+#' @param headers Named character vector of HTTP headers to use.
+#' @return `path`, if the download was successful.
+#'
+#' @keywords internal
 #' @importFrom utils compareVersion
 
 download <- function(path, url, auth_token = NULL, basic_auth = NULL,
-                     quiet = TRUE, auth_phrase = "access_token=",
-                     headers = NULL) {
+                     quiet = TRUE, headers = NULL) {
 
-  real_url <- url
+  if (!is.null(basic_auth) && !is.null(auth_token)) {
+    stop("Cannot use both Basic and Token authentication at the same time")
+  }
 
   if (!is.null(basic_auth)) {
     userpass <- paste0(basic_auth$user, ":", basic_auth$password)
@@ -14,73 +46,144 @@ download <- function(path, url, auth_token = NULL, basic_auth = NULL,
   }
 
   if (!is.null(auth_token)) {
-    sep <- if (grepl("?", url, fixed = TRUE)) "&" else "?"
-    tkn <- if (grepl("=$", auth_phrase)) auth_phrase else paste0(auth_phrase, "=")
-    real_url <- paste0(url, sep, tkn, auth_token)
+    headers <- c(headers, Authorization = paste("token", auth_token))
   }
 
-  if (compareVersion(get_r_version(), "3.2.0") == -1) {
-    curl_download(real_url, path, quiet, headers)
+  if (getRversion() < "3.2.0") {
+    curl_download(url, path, quiet, headers)
 
   } else {
 
-    base_download(real_url, path, quiet, headers)
+    base_download(url, path, quiet, headers)
   }
 
   path
  }
 
 base_download <- function(url, path, quiet, headers) {
 
-  if (getRversion() < "3.6.0") {
-    if (!is.null(headers)) {
-      get("unlockBinding", baseenv())("makeUserAgent", asNamespace("utils"))
-      orig <- get("makeUserAgent", envir = asNamespace("utils"))
-      on.exit({
-        assign("makeUserAgent", orig, envir = asNamespace("utils"))
-        lockBinding("makeUserAgent", asNamespace("utils"))
-      }, add = TRUE)
-      ua <- orig(FALSE)
-
-      flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n")
-      agent <- paste0(ua, "\r\n", flathead)
-      assign(
-        "makeUserAgent",
-        envir = asNamespace("utils"),
-        function(format = TRUE) {
-          if (format) {
-            paste0("User-Agent: ", agent, "\r\n")
-          } else {
-            agent
-          }
-        })
-    }
+  method <- download_method()
 
+  status <- if (method == "wget") {
+    base_download_wget(url, path, quiet, headers)
+  } else if (method =="curl") {
+    base_download_curl(url, path, quiet, headers)
+  } else if (getRversion() < "3.6.0") {
+    base_download_noheaders(url, path, quiet, headers, method)
+  } else {
+    base_download_headers(url, path, quiet, headers, method)
+  }
+
+  if (status != 0) stop("Cannot download file from ", url, call. = FALSE)
+
+  path
+}
+
+base_download_wget <- function(url, path, quiet, headers) {
+
+  extra <- getOption("download.file.extra")
+
+  if (length(headers)) {
+    qh <- shQuote(paste0(names(headers), ": ", headers))
+    extra <- c(extra, paste0("--header=", qh))
+  }
+
+  with_options(
+    list(download.file.extra = extra),
     suppressWarnings(
-      status <- utils::download.file(
+      utils::download.file(
         url,
         path,
-        method = download_method(),
+        method = "wget",
         quiet = quiet,
-        mode = "wb"
+        mode = "wb",
+        extra = extra
       )
     )
-  } else {
+  )
+}
+
+base_download_curl <- function(url, path, quiet, headers) {
+
+  extra <- getOption("download.file.extra")
+
+  if (length(headers)) {
+    qh <- shQuote(paste0(names(headers), ": ", headers))
+    extra <- c(extra, paste("-H", qh))
+  }
+
+  with_options(
+    list(download.file.extra = extra),
     suppressWarnings(
-      status <- utils::download.file(
+      utils::download.file(
         url,
         path,
-        method = download_method(),
+        method = "curl",
         quiet = quiet,
         mode = "wb",
-        headers = headers
+        extra = extra
       )
     )
+  )
+}
+
+base_download_noheaders <- function(url, path, quiet, headers, method) {
+
+  if (length(headers)) {
+
+    if (method == "wininet" && getRversion() < "3.6.0") {
+      warning(paste(
+        "R (< 3.6.0) cannot send HTTP headers with the `wininet` download method.",
+        "This download will likely fail. Please choose a different download",
+        "method, via the `download.file.method` option. The `libcurl` method is",
+        "best, if available, and the `wget` and `curl` methods work as well,",
+        "if the corresponding external tool is available. See `?download.file`"))
+    }
+
+    get("unlockBinding", baseenv())("makeUserAgent", asNamespace("utils"))
+    orig <- get("makeUserAgent", envir = asNamespace("utils"))
+    on.exit({
+      assign("makeUserAgent", orig, envir = asNamespace("utils"))
+      lockBinding("makeUserAgent", asNamespace("utils"))
+    }, add = TRUE)
+    ua <- orig(FALSE)
+
+    flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n")
+    agent <- paste0(ua, "\r\n", flathead)
+    assign(
+      "makeUserAgent",
+      envir = asNamespace("utils"),
+      function(format = TRUE) {
+        if (format) {
+            paste0("User-Agent: ", agent, "\r\n")
+        } else {
+          agent
+        }
+      })
   }
 
-  if (status != 0)  stop("Cannot download file from ", url, call. = FALSE)
+  suppressWarnings(
+    utils::download.file(
+      url,
+      path,
+      method = method,
+      quiet = quiet,
+      mode = "wb"
+    )
+  )
+}
 
-  path
+base_download_headers <- function(url, path, quiet, headers, method) {
+  suppressWarnings(
+    utils::download.file(
+      url,
+      path,
+      method = method,
+      quiet = quiet,
+      mode = "wb",
+      headers = headers
+    )
+  )
 }
 
 has_curl <- function() isTRUE(unname(capabilities("libcurl")))

diff --git a/R/install-gitlab.R b/R/install-gitlab.R
@@ -81,7 +81,7 @@ remote_download.gitlab_remote <- function(x, quiet = FALSE) {
             "\nfrom URL ", src)
   }
 
-  download(dest, src, auth_token = x$auth_token, auth_phrase = "private_token=")
+  download(dest, src, headers = c("Private-Token" = x$auth_token))
 }
 
 #' @export
@@ -125,7 +125,7 @@ remote_package_name.gitlab_remote <- function(remote, ...) {
     "/raw?ref=", remote$ref)
 
   dest <- tempfile()
-  res <- download(dest, src, auth_token = remote$auth_token, auth_phrase = "private_token=")
+  res <- download(dest, src, headers = c("Private-Token" = remote$auth_token))
 
   tryCatch(
     read_dcf(dest)$Package,
@@ -149,7 +149,7 @@ gitlab_commit <- function(username, repo, ref = "master",
   url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", ref)
 
   tmp <- tempfile()
-  download(tmp, url, auth_token = pat, auth_phrase = "private_token=")
+  download(tmp, url, headers = c("Private-Token" = pat))
 
   json$parse_file(tmp)$id
 }