PPM SSO Auth

DESCRIPTION

@@ -23,6 +23,8 @@ Imports:
     processx (>= 3.3.0.9001),
     R6,
     tools,
+    tsitter,
+    tstoml,
     utils
 Suggests:
     debugme,
@@ -38,6 +40,9 @@ Suggests:
     webfakes (>= 1.1.5),
     withr,
     zip
+Remotes:
+    r-lib/tsitter,
+    gaborcsardi/tstoml
 Config/Needs/website: tidyverse/tidytemplate
 Config/testthat/edition: 3
 Config/usethis/last-upkeep: 2025-04-30

NAMESPACE

@@ -1,7 +1,9 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method("[",pkgcache_repo_status_summary)
+S3method(format,ppm_sso_status)
 S3method(print,pkgcache_repo_status_summary)
+S3method(print,ppm_sso_status)
 S3method(summary,pkgcache_repo_status)
 export(bioc_devel_version)
 export(bioc_release_version)
@@ -41,6 +43,9 @@ export(ppm_platforms)
 export(ppm_r_versions)
 export(ppm_repo_url)
 export(ppm_snapshots)
+export(ppm_sso_login)
+export(ppm_sso_logout)
+export(ppm_sso_status)
 export(repo_add)
 export(repo_auth)
 export(repo_get)

NEWS.md

@@ -1,5 +1,9 @@
 # pkgcache (development version)
 
+* Better behavior for a corrupt package cache database: better error
+  message, and cleaning the cache does not fail in this case
+  (https://github.com/r-lib/pak/issues/884).
+
 * pkgcache now treats `PACKAGES` entries with `Path` and/or `File`
   fields correctly (#141, @jeroen).
 

R/async-http.R

@@ -1,17 +1,4 @@
-# The embedded async `http_get()` etc. only look at the `async_http_*` options
-# (via `get_default_curl_options()`). `set_pkgcache_curl_options()` reads the
-# pkgcache-level options and environment variables and sets the corresponding
-# curl options, so that pkgcache's HTTP requests honor them. For each curl
-# option it looks, in decreasing priority, at the `pkgcache_*` option, the
-# `PKGCACHE_*` environment variable, the `pkg_http_*` option and the
-# `PKG_HTTP_*` environment variable.
-#
-# It only sets an option when it is actually configured. An unset option must
-# not be turned into an explicit curl option, otherwise it would override the
-# `async_http_*` option and the async default further downstream in
-# `get_default_curl_options()`.
-
-set_pkgcache_curl_options <- function(options) {
+set_pkgcache_http_options <- function(options, retry = NULL) {
   nms <- c(
     "timeout",
     "connecttimeout",
@@ -41,16 +28,34 @@ set_pkgcache_curl_options <- function(options) {
       options[[nm]] <- as.integer(v)
     }
   }
-  options
+
+  if (is.null(retry)) {
+    v <- getopt("retry")
+    retry <- if (is.null(v)) TRUE else coerce_retry(v)
+  }
+
+  list(options = options, retry = retry)
+}
+
+coerce_retry <- function(v) {
+  if (!is.character(v)) {
+    return(v)
+  }
+  if (toupper(v) %in% c("TRUE", "FALSE")) {
+    as.logical(v)
+  } else {
+    as.integer(v)
+  }
 }
 
 # Wrap an embedded async HTTP function so that it applies the pkgcache-level
-# HTTP options and environment variables (see `set_pkgcache_curl_options()`)
+# HTTP options and environment variables (see `set_pkgcache_http_options()`)
 # to every request.
 wrap_pkgcache_http <- function(fun) {
   force(fun)
-  mark_as_async(function(url, ..., options = list()) {
-    fun(url, ..., options = set_pkgcache_curl_options(options))
+  mark_as_async(function(url, ..., options = list(), retry = NULL) {
+    http <- set_pkgcache_http_options(options, retry)
+    fun(url, ..., options = http$options, retry = http$retry)
   })
 }
 

R/auth.R

@@ -176,7 +176,7 @@ repo_auth_headers <- function(
   # - host URL w/o username
   # We try each with and without a keyring username
   urls <- unique(unlist(
-    parsed_url[c("repouserurl", "repourl", "hostuserurl", "hosturl")]
+    parsed_url[c("repouserurl", "repourl", "hostuserurl", "hosturl", "host")]
   ))
 
   if (use_cache) {
@@ -199,10 +199,18 @@ repo_auth_headers <- function(
     error = NULL
   )
 
-  pwd <- repo_auth_netrc(parsed_url$host, parsed_url$username)
+  pwd <- repo_auth_sso(parsed_url$repourl, parsed_url$username)
   if (!is.null(pwd)) {
     res$auth_domain <- parsed_url$host
-    res$source <- paste0(".netrc")
+    res$source <- "SSO"
+  }
+
+  if (is.null(pwd)) {
+    pwd <- repo_auth_netrc(parsed_url$host, parsed_url$username)
+    if (!is.null(pwd)) {
+      res$auth_domain <- parsed_url$host
+      res$source <- paste0(".netrc")
+    }
   }
 
   if (is.null(pwd) && !requireNamespace("keyring", quietly = TRUE)) {
@@ -461,3 +469,28 @@ repo_auth_netrc <- function(host, username) {
 
   NULL
 }
+
+repo_auth_sso <- function(repourl, username) {
+  ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_)
+  if (is.na(ppm_url)) {
+    return(NULL)
+  }
+
+  if (!startsWith(repourl, ppm_url)) {
+    return(NULL)
+  }
+
+  token <- tryCatch(
+    ppm_sso_auth(repourl),
+    error = function(e) {
+      cli::cli_alert_warning(
+        "PPM SSO authentication failed for repo {.url {repourl}}: {conditionMessage(e)}"
+      )
+      cli::cli_alert_info(
+        "Try calling {.code ppm_sso_login()} directly."
+      )
+      NULL
+    }
+  )
+  token
+}

R/metadata-cache.R

@@ -1168,6 +1168,8 @@ cmc__get_repos <- function(repos, bioc, cran_mirror, r_version, auth = TRUE) {
     }
   }
 
+  # avoid duplicate //
+  res$url <- sub("/+$", "", res$url)
   res <- res[!duplicated(res$url), ]
   if (auth) {
     res <- add_auth_status(res)

R/onload.R

@@ -1,6 +1,7 @@
 ## nocov start
 
 pkgenv <- new.env(parent = emptyenv())
+pkgenv$ppm_sso_cache <- new.env(parent = emptyenv())
 
 pkgenv$r_versions <- list(
   list(version = "0.60", date = "1997-12-04T08:47:58.000000Z"),

R/package-cache.R

@@ -121,7 +121,7 @@ package_cache <- R6Class(
       l <- private$lock(exclusive = FALSE)
       on.exit(filelock::unlock(l), add = TRUE)
       dbfile <- get_db_file(private$path)
-      readRDS(dbfile)
+      read_db_rds(dbfile)
     },
 
     find = function(..., .list = NULL) {
@@ -152,7 +152,7 @@ package_cache <- R6Class(
       l <- private$lock(exclusive = TRUE)
       on.exit(filelock::unlock(l), add = TRUE)
       dbfile <- get_db_file(private$path)
-      db <- readRDS(dbfile)
+      db <- read_db_rds(dbfile)
 
       extra <- c(list(...), .list)
 
@@ -429,13 +429,23 @@ package_cache <- R6Class(
       l <- private$lock(exclusive = TRUE)
       on.exit(filelock::unlock(l), add = TRUE)
       dbfile <- get_db_file(private$path)
-
-      ex <- private$find_locked(..., .list = .list)
-      if (nrow(ex) != 0) {
-        unlink(file.path(private$path, ex$path))
-        db <- delete_from_data_frame(readRDS(dbfile), ..., .list = .list)
-        save_rds(db, dbfile)
+      pkgs <- c(list(...), .list)
+
+      if (length(pkgs) == 0) {
+        files <- list.files(private$path, recursive = TRUE, full.names = TRUE)
+        files <- setdiff(files, get_lock_file(private$path))
+        unlink(files, recursive = TRUE, force = TRUE)
+        unlink(dbfile, force = TRUE)
+      } else {
+        db <- read_db_rds(dbfile)
+        idx <- find_in_data_frame(db, .list = pkgs)
+        if (length(idx) != 0) {
+          unlink(file.path(private$path, db$path[idx]))
+          save_rds(db[-idx, ], dbfile)
+        }
       }
+
+      invisible()
     }
   ),
 
@@ -449,7 +459,7 @@ package_cache <- R6Class(
     },
     find_locked = function(..., .list = NULL) {
       dbfile <- get_db_file(private$path)
-      db <- readRDS(dbfile)
+      db <- read_db_rds(dbfile)
 
       idx <- find_in_data_frame(db, ..., .list = .list)
       db[idx, ]
@@ -468,6 +478,24 @@ get_lock_file <- function(path) {
   file.path(path, ".db.lock")
 }
 
+read_db_rds <- function(dbfile) {
+  tryCatch(
+    suppressWarnings(readRDS(dbfile)),
+    error = function(err) {
+      cond <- new_error(
+        "Failed to read the package cache database from ",
+        encodeString(dbfile, quote = "`"),
+        ". The cache file is possibly corrupt, call ",
+        "`pkgcache::pkg_cache_delete_files()` or `pak::cache_clean()` ",
+        "to reset the cache, and then try again."
+      )
+      cond$dbfile <- dbfile
+      class(cond) <- c("pkgcache_corrupt_db_error", class(cond))
+      throw(cond, parent = err)
+    }
+  )
+}
+
 create_empty_db_file_if_needed <- function(path) {
   mkdirp(path)