Authenticated CRAN-like repositories

.Rbuildignore

@@ -53,3 +53,4 @@
 ^src/library/ps/src/px$
 ^src/library/zip/src/tools/cmdunzip$
 ^src/library/zip/src/tools/cmdzip$
+^src/library/keyring/src/Makevars$

.github/workflows/nightly.yaml

@@ -290,7 +290,7 @@ jobs:
   # ------------------------------------------------------------------------
 
   linux-arm64:
-    runs-on: ubuntu-latest
+    runs-on: ubuntu-22.04-arm
     if: ${{ github.event.inputs.linux-arm64 == '' || github.event.inputs.linux-arm64 == 'yes' }}
     name: Linux aarch64 R ${{ matrix.config.r }}
 
@@ -308,12 +308,6 @@ jobs:
           - { r: '3.5' }
 
     steps:
-    - name: Set up QEMU
-      uses: docker/setup-qemu-action@v3
-
-    - name: Set up Docker Buildx
-      uses: docker/setup-buildx-action@v3
-
     - name: Checkout
       uses: actions/checkout@v4
       with:

.gitignore

@@ -41,6 +41,7 @@
 /src/library/ps/src/px
 /src/library/zip/src/tools/cmdunzip
 /src/library/zip/src/tools/cmdzip
+/src/library/keyring/src/Makevars
 /tools/build/linux/pak_*.tar.gz
 /tools/build/linux/*.done
 /vignettes/internals.html

DESCRIPTION

@@ -12,6 +12,7 @@ Authors@R: c(
     person("Maëlle", "Salmon", role = "ctb", comment = "desc, pkgsearch"),
     person("Duncan", "Temple Lang", role = "ctb", comment = "jsonlite"),
     person("Lloyd", "Hilaiel", role = "cph", comment = "jsonlite"),
+    person("Alec", "Wong", role = "ctb", comment = "keyring"),
     person("Michel Berkelaar and lpSolve authors", role = "ctb", comment = "lpSolve"),
     person("R Consortium", role = "fnd", comment = "pkgsearch"),
     person("Jay", "Loden", role = "ctb", comment = "ps"),
@@ -45,6 +46,7 @@ Suggests:
     gitcreds,
     glue (>= 1.6.2),
     jsonlite (>= 1.8.0),
+    keyring,
     pingr,
     pkgbuild (>= 1.4.2),
     pkgcache (>= 2.0.4),
@@ -55,7 +57,10 @@ Suggests:
     ps (>= 1.6.0),
     rstudioapi,
     testthat (>= 3.2.0),
+    webfakes,
     withr
+Remotes:
+    r-lib/pkgcache
 ByteCompile: true
 Config/build/extra-sources: configure*
 Config/needs/dependencies:
@@ -65,6 +70,7 @@ Config/needs/dependencies:
     curl,
     filelock,
     gaborcsardi/jsonlite,
+    r-lib/keyring,
     lpSolve,
     pkgbuild,
     r-lib/pkgcache,

NAMESPACE

@@ -58,6 +58,9 @@ export(ppm_r_versions)
 export(ppm_repo_url)
 export(ppm_snapshots)
 export(repo_add)
+export(repo_auth)
+export(repo_auth_key_get)
+export(repo_auth_key_set)
 export(repo_get)
 export(repo_ping)
 export(repo_resolve)

NEWS.md

@@ -3,6 +3,9 @@
 * pak now uses the `use_bioconductor` configuration option in `meta_*()` and
   `repo_*()` functions (#295, #726, @meztez).
 
+* pak now supports HTTP basic authentication for CRAN-like repositories.
+  See 'Authenticated repositories' in the reference manual.
+
 # pak 0.8.0
 
 * `pkg_deps()` now accepts a vector of package names.

R/auth.R

@@ -0,0 +1,133 @@
+#' Authenticated repositories
+#'
+#' @name Authenticated repositories
+#' @rdname repo-auth
+#' @description
+#' pak supports HTTP basic authentication when interacting with CRAN-like
+#' repositories.
+#'
+#' ```{r child = "man/chunks/auth.Rmd"}
+#' ```
+NULL
+
+#' Query or set repository password in the system credential store
+#'
+#' Use pak's internal copy of the keyring package to query or set a
+#' repository password in the system credential store.
+#'
+#' `repo_auth_key_get()` retrieves a password from the default keyring. It
+#' errors if it cannot find the credentials for `url`.
+#'
+#' `repo_auth_key_set()` adds or updates a password in the system
+#' crednetial store.
+#'
+#' @param url Repository URL. It may contain a username, in which case
+#'   `username` may be `NULL`.
+#' @param username User name, if it is not included in `url`.
+#' @param password Password to set.
+#' @return `repo_auth_key_get()` returns a single string, the repository
+#'   password.
+#'
+#' @export
+
+repo_auth_key_get <- function(url, username = NULL) {
+  remote(
+    function(...) asNamespace("pak")$repo_auth_key_get_internal(...),
+    list(url, username)
+  )
+}
+
+repo_auth_key_get_internal <- function(url, username = NULL) {
+  if (is.null(username)) {
+    parsed_url <- parse_url(url)
+    username <- parsed_url$username
+    if (length(username) == 0 || nchar(username) == 0) {
+      stop("Cannot get repo key for URL ", url, ", username is missing")
+    }
+  }
+  keyring::key_get(url, username)
+}
+
+#' @export
+#' @rdname repo_auth_key_get
+
+repo_auth_key_set <- function(url, password, username = NULL) {
+  remote(
+    function(...) asNamespace("pak")$repo_auth_key_set_internal(...),
+    list(url, password, username)
+  )
+  invisible(NULL)
+}
+
+repo_auth_key_set_internal <- function(url, password, username = NULL) {
+  if (is.null(username)) {
+    parsed_url <- parse_url(url)
+    username <- parsed_url$username
+    if (length(username) == 0 || nchar(username) == 0) {
+      stop("Cannot set repo key for URL ", url, ", username is missing")
+    }
+  }
+  keyring::key_set_with_value(url, username, password)
+  invisible(NULL)
+}
+
+#' CRAN proxy with authentication, for testing
+#'
+#' It needs the webfakes package.
+#'
+#' @param repo_url URL of the original CRAN repository.
+#' @param username User name.
+#' @param password Password.
+#' @return A webfakes app.
+#'
+#' @noRd
+#' @examples
+#' # Run the proxy in the current R session, use `NULL` for a random port.
+#' # Use http://[email protected]:3000 as the repo URL
+#' auth_proxy_app()$listen(3000)
+#'
+#' # Run the proxy in a subprocess, on a random port, query its URL,
+#' # and use it. This also needs the callr package.
+#' repo <- webfakes::new_app_process(auth_proxy_app())
+#' repo$url()
+#'
+#' # opt out from Bioconductor packages
+#' options(pkg.use_bioconductor = FALSE)
+#'
+#' # Add credetnails to the default keyring, password is "token"
+#' repo_auth_key_set(repo$url(), username = "username", "token")
+#'
+#' # Set repos
+#' repo_add(CRAN = repo$url(), username = "username")
+#' repo_get()
+#'
+#' # repo status
+#' repo_status()
+#' repo_ping()
+#'
+#' # repo status with auth info
+#' repo_auth()
+#'
+#' # get list pf packages
+#' meta_update()
+#' meta_list()
+
+auth_proxy_app <- function(repo_url = NULL, username = "username",
+                           password = "token") {
+  repo_url <- repo_url %||% "https://cloud.r-project.org"
+  webfakes::new_app()$get(
+    webfakes::new_regexp(""), function(req, res) {
+      # base64_encode will be exported in the next version of webfakes
+      exp <- paste("Basic", asNamespace("webfakes")$base64_encode(paste0(username, ":", password)))
+      hdr <- req$get_header("Authorization") %||% ""
+      if (exp != hdr) {
+        res$
+          set_header("WWW-Authenticate", "Basic realm=\"CRAN with auth\"")$
+          send_status(401L)
+      } else {
+        res$
+          redirect(sprintf("%s/%s", repo_url, req$path))
+      }
+    }
+  )
+}

R/parse-url.R

@@ -0,0 +1,50 @@
+
+parse_url <- function(url) {
+  re_url <- paste0(
+    "^(?<protocol>[a-zA-Z0-9]+)://",
+    "(?:(?<username>[^@/:]+)(?::(?<password>[^@/]+))?@)?",
+    "(?<host>[^/]*)",
+    "(?<path>.*)$"            # don't worry about query params here...
+  )
+
+  mch <- re_match(url, re_url)
+  mch[, setdiff(colnames(mch), c(".match", ".text")), drop = FALSE]
+}
+
+re_match <- function(text, pattern, perl = TRUE, ...) {
+
+  stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern))
+  text <- as.character(text)
+
+  match <- regexpr(pattern, text, perl = perl, ...)
+  match <- regexpr(pattern, text, perl = perl, ...)
+
+  start  <- as.vector(match)
+  length <- attr(match, "match.length")
+  end    <- start + length - 1L
+
+  matchstr <- substring(text, start, end)
+  matchstr[ start == -1 ] <- NA_character_
+
+  res <- data.frame(
+    stringsAsFactors = FALSE,
+    .text = text,
+    .match = matchstr
+  )
+
+  if (!is.null(attr(match, "capture.start"))) {
+
+    gstart  <- attr(match, "capture.start")
+    glength <- attr(match, "capture.length")
+    gend    <- gstart + glength - 1L
+
+    groupstr <- substring(text, gstart, gend)
+    groupstr[ gstart == -1 ] <- NA_character_
+    dim(groupstr) <- dim(gstart)
+
+    res <- cbind(groupstr, res, stringsAsFactors = FALSE)
+  }
+
+  names(res) <- c(attr(match, "capture.names"), ".text", ".match")
+  res
+}