diff --git a/DESCRIPTION b/DESCRIPTION index 69fbb40a..0912b27b 100644 --- a/DESCRIPTION +++ b/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 diff --git a/NAMESPACE b/NAMESPACE index 5c542521..2d338821 100644 --- a/NAMESPACE +++ b/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) diff --git a/NEWS.md b/NEWS.md index cc39b280..63c30d3b 100644 --- a/NEWS.md +++ b/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). @@ -11,6 +15,15 @@ `PKGCACHE_HTTP_VERSION` environment variable. Closes https://github.com/r-lib/pkgcache/issues/140. +* pkgcache now supports the custom binary package types of R 4.6.0 and + later. + +* `current_r_platform_data()` gained a `pkg_type` column, for custom binary + package types. + +* `current_r_platform()` now handles setting `PKG_CURRENT_PLATFORM` to + a non-Linux platform correctly. + * New `PKG_USE_BIOCONDUCTOR` environment variable and new `pkg.use_bioconductor` option to opt out from automatic Bioconductor support. diff --git a/R/async-http.R b/R/async-http.R index 5caa58c1..37f0e353 100644 --- a/R/async-http.R +++ b/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) }) } diff --git a/R/auth.R b/R/auth.R index c096dd35..e3cf891a 100644 --- a/R/auth.R +++ b/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 +} diff --git a/R/cran-app.R b/R/cran-app.R index 99b070b7..d85815e5 100644 --- a/R/cran-app.R +++ b/R/cran-app.R @@ -54,7 +54,7 @@ dummy_so <- function() { make_dummy_binary <- function( data, path, - platform = get_platform(), + platform = current_r_platform(), r_version = getRversion() ) { # Need these files: @@ -99,15 +99,13 @@ make_dummy_binary <- function( asNamespace("tools")$.install_package_description(package, package) asNamespace("tools")$.install_package_namespace_info(package, package) - if (platform == "windows") { - pkgfile <- paste0(package, "_", data$Version, ".zip") + # The extension is the one pkgcache expects in the repository, incl. the + # `_R_.tar.gz` form that PPM uses for Linux binaries. + ext <- get_cran_extension(platform) + pkgfile <- paste0(package, "_", data$Version, ext) + if (ext == ".zip") { zip::zip(pkgfile, package) - } else if (platform == "macos") { - pkgfile <- paste0(package, "_", data$Version, ".tgz") - utils::tar(pkgfile, package) } else { - # Other binary package, we use .tar.gz like on PPM - pkgfile <- paste0(package, "_", data$Version, ".tar.gz") utils::tar(pkgfile, package) } @@ -115,6 +113,18 @@ make_dummy_binary <- function( pkgfile } +platform_pkg_db_type <- function(platform) { + if (platform == "source") { + return("source") + } + switch( + get_cran_extension(platform), + ".zip" = "win.binary", + ".tgz" = "mac.binary", + "source" + ) +} + standardize_dummy_packages <- function(packages) { packages <- packages %||% data.frame( @@ -156,13 +166,16 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { mkdirp(repo) options[["platform"]] <- options[["platform"]] %||% "source" - options[["rversion"]] <- options[["rversion"]] %||% format(getRversion()) + options[["r_version"]] <- options[["r_version"]] %||% format(getRversion()) packages <- standardize_dummy_packages(packages) if (!is.null(options$repo_prefix)) { repo <- file.path(repo, options$repo_prefix) } - pkgdirs <- get_all_package_dirs(options[["platform"]], getRversion()) + pkgdirs <- get_all_package_dirs( + options[["platform"]], + options[["r_version"]] + ) mkdirp(pkgs_dir <- file.path(repo, pkgdirs$contriburl)) extra <- packages @@ -204,7 +217,8 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { fn <- make_dummy_binary( packages[i, , drop = FALSE], pkg_dir, - options[["platform"]] + options[["platform"]], + options[["r_version"]] ) } extra$file[i] <- fn @@ -212,12 +226,10 @@ make_dummy_repo_platform <- function(repo, packages = NULL, options = list()) { file.create(file.path(pkgs_dir, "PACKAGES")) - if (grepl("windows", pkgdirs$contriburl)) { - pkg_type <- "win.binary" - } else { - pkg_type <- "source" - } - tools::write_PACKAGES(pkgs_dir, type = pkg_type) + tools::write_PACKAGES( + pkgs_dir, + type = platform_pkg_db_type(options[["platform"]]) + ) if (isTRUE(options$no_packages)) { file.remove(file.path(pkgs_dir, "PACKAGES")) diff --git a/R/metadata-cache.R b/R/metadata-cache.R index 86598008..eade5253 100644 --- a/R/metadata-cache.R +++ b/R/metadata-cache.R @@ -131,7 +131,9 @@ cmc__data <- new.env(parent = emptyenv()) #' column is either #' * `"source"` for source packages, #' * a platform string, e.g. `x86_64-apple-darwin17.0` for macOS -#' packages compatible with macOS High Sierra or newer. +#' packages compatible with macOS High Sierra or newer, +#' * a platform string with a custom binary package type, e.g. +#' `aarch64-w64-mingw32-windows.binary.clang-aarch64`. #' * `needscompilation`: Whether the package needs compilation. #' * `type`: `bioc` or `cran` currently. #' * `target`: The path of the package file inside the repository. @@ -487,7 +489,6 @@ cmc__get_cache_files <- function(self, private, which) { version = private$cache_version )) - str_platforms <- paste(private$platforms, collapse = "+") rds_file <- paste0("pkgs-", substr(repo_hash, 1, 10), ".rds") repo_enc <- rep(repo_encode(private$repos), each = nrow(private$dirs)) @@ -1168,6 +1169,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) diff --git a/R/onload.R b/R/onload.R index 01e4be3c..1c679b4b 100644 --- a/R/onload.R +++ b/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"), diff --git a/R/package-cache.R b/R/package-cache.R index 6264fe7c..b0075fa5 100644 --- a/R/package-cache.R +++ b/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) diff --git a/R/platform-linux.R b/R/platform-linux.R index 12e9d39f..d665a31d 100644 --- a/R/platform-linux.R +++ b/R/platform-linux.R @@ -11,7 +11,10 @@ current_r_platform_data_linux <- function(raw, etc = "/etc") { ) cbind( - raw[, setdiff(names(raw), c("distribution", "release")), drop = FALSE], + raw[, + setdiff(names(raw), c("distribution", "release", "pkg_type")), + drop = FALSE + ], parse_linux_platform_info(os, rh) ) } diff --git a/R/platform.R b/R/platform.R index 53d87e50..8ce836b2 100644 --- a/R/platform.R +++ b/R/platform.R @@ -41,6 +41,20 @@ #' - `x86_64-pc-linux-gnu-unknown`: Unknown Linux Distribution on x86_64. #' - `s390x-ibm-linux-gnu-ubuntu-20.04`: Ubuntu Linux 20.04 on S390x. #' - `amd64-portbld-freebsd12.1`: FreeBSD 12.1 on x86_64. +#' * A platform string as above, followed by a custom binary package type. +#' From R 4.6.0 `.Platform$pkgType` may be `.binary.`, and +#' then binary packages live in `bin///contrib/` in +#' the repository, see [utils::contrib.url()]. pkgcache includes the +#' package type in the platform name, so that two builds of R for the +#' same platform triple remain distinguishable. Examples: +#' - `aarch64-w64-mingw32-windows.binary.clang-aarch64`: Windows on arm64, +#' built with clang. +#' - `aarch64-apple-darwin23-mac.binary.sonoma-arm64`: macOS Sonoma on +#' arm64. (This is the same as `aarch64-apple-darwin23`, which pkgcache +#' already knows about, so `current_r_platform()` uses the shorter form.) +#' +#' A package type on its own, without a platform triple, is not a valid +#' platform name. #' #' @return `current_r_platform()` returns a character scalar. #' @@ -51,6 +65,7 @@ #' * `os`, #' * `distribution` (only on Linux), #' * `release` (only on Linux), +#' * `pkg_type` (only for a custom binary package type), #' * `platform`: the concatenation of the other columns, separated by #' a dash. #' @export @@ -74,9 +89,16 @@ current_r_platform_data <- function() { if (platform$os == "linux" || substr(platform$os, 1, 6) == "linux-") { platform <- current_r_platform_data_linux(platform) } + # Must come after the Linux amendment, `pkg_type` is the last column + pkg_type <- current_r_custom_pkg_type(platform$os) + if (!is.null(pkg_type)) { + platform$pkg_type <- pkg_type + } } - platform$platform <- apply(platform, 1, paste, collapse = "-") + platform$platform <- apply(platform, 1, function(x) { + paste0(na_omit(x), collapse = "-") + }) platform } @@ -92,8 +114,9 @@ forced_platform <- function() { } if (!valid_platform_string(opt)) { stop( - "The pkg.current_platform` option must be a valid platform ", - "triple: `cpu-vendor-os`. \"", + "The pkg.current_platform` option must be a valid platform name: ", + "`cpu-vendor-os`, optionally followed by a Linux distribution and ", + "release, or a binary package type. \"", opt, "\" is not." ) @@ -105,7 +128,8 @@ forced_platform <- function() { if (is.na(env) || !valid_platform_string(env)) { stop( "The `PKG_CURRENT_PLATFORM` environment variable must be a valid ", - "platform triple: \"cpu-vendor-os\". \"", + "platform name: \"cpu-vendor-os\", optionally followed by a Linux ", + "distribution and release, or a binary package type. \"", env, "\" is not." ) @@ -120,8 +144,81 @@ get_platform <- function(forced = TRUE) { (if (forced) forced_platform()) %||% R.version$platform } +re_pkg_type <- function() { + paste0( + "^", + "(?P[[:lower:]]+)", + "[.]binary", + "(?:|[.](?P[[:alnum:]_-]+))", + "$" + ) +} + +# NULL if `x` is not a binary package type + +parse_pkg_type <- function(x) { + mch <- re_match(x, re_pkg_type()) + if (is.na(mch$.match)) { + return(NULL) + } + system <- switch(mch$system, mac = "macosx", win = "windows", mch$system) + list( + system = system, + build = if (nzchar(mch$build)) mch$build else NA_character_ + ) +} + +is_custom_pkg_type <- function(x) { + !is.null(parse_pkg_type(x)) && + x != "win.binary" && + !startsWith(x, "mac.binary") +} + +current_r_pkg_type <- function() { + # `.Platform$pkgType` already includes R_PLATFORM_PKGTYPE, if set + .Platform$pkgType +} + +# The `` of the package type that we expect for an OS name. Used to +# reject package types that do not belong to the current platform. + +pkg_type_system_for_os <- function(os) { + ifelse( + is.na(os), + NA_character_, + ifelse( + os == "mingw32", + "windows", + ifelse( + grepl("^darwin", os), + "macosx", + ifelse( + os == "linux" | startsWith(os, "linux-"), + "linux", + # freebsd12.1 -> freebsd, solaris2.10 -> solaris + sub("[0-9].*$", "", os) + ) + ) + ) + ) +} + +# The custom package type of the current R, or NULL + +current_r_custom_pkg_type <- function(os) { + type <- current_r_pkg_type() + if (!is_custom_pkg_type(type)) { + return(NULL) + } + pt <- parse_pkg_type(type) + if (!identical(pt$system, pkg_type_system_for_os(os))) { + return(NULL) + } + type +} + #' @details -#' `default_platfoms()` returns the default platforms for the current R +#' `default_platforms()` returns the default platforms for the current R #' session. These typically consist of the detected platform of the current #' R session, and `"source"`, for source packages. #' @@ -137,6 +234,11 @@ default_platforms <- function() { } parse_platform <- function(x) { + # custom binary package via .Platform$pkgType? + pkgtype <- re_match(x, re_platform_pkg_type()) + haspt <- !is.na(pkgtype$.match) + x[haspt] <- pkgtype$rest[haspt] + pcs <- strsplit(x, "-", fixed = TRUE) plt <- data.frame( stringsAsFactors = FALSE, @@ -154,9 +256,22 @@ parse_platform <- function(x) { linuxos$release[linuxos$release == ""] <- NA_character_ plt <- cbind(plt, linuxos[, c("distribution", "release")]) } + if (any(haspt)) { + plt$pkg_type <- ifelse(haspt, pkgtype$pkg_type, NA_character_) + } plt } +re_platform_pkg_type <- function() { + paste0( + "^", + "(?P.*)", + "[-]", + "(?P[[:lower:]]+[.]binary(?:[.][[:alnum:]_-]+)?)", + "$" + ) +} + re_linux_platform <- function() { paste0( "^", @@ -170,19 +285,14 @@ re_linux_platform <- function() { get_cran_extension <- function(platform) { res <- rep(NA_character_, length(platform)) res[platform == "source"] <- ".tar.gz" - res[ - platform %in% - c( - "windows", - "i386+x86_64-w64-mingw32", - "x86_64-w64-mingw32", - "i386-w64-mingw32" - ) - ] <- ".zip" + # These are not platform triples, `parse_platform()` cannot help + res[platform == "windows"] <- ".zip" res[platform == "macos"] <- ".tgz" dtl <- parse_platform(platform) - res[!is.na(dtl$os) & grepl("^darwin", dtl$os)] <- ".tgz" + res[is.na(res) & !is.na(dtl$os) & dtl$os == "mingw32"] <- ".zip" + res[is.na(res) & !is.na(dtl$os) & grepl("^darwin", dtl$os)] <- ".tgz" + if (anyNA(res)) { res[is.na(res)] <- paste0("_R_", platform[is.na(res)], ".tar.gz") } @@ -228,6 +338,19 @@ get_package_dirs_for_platform <- function(pl, minors) { return(cbind("source", "*", "src/contrib")) } + # Custom binary package type in the platform name. This is unambiguous, + # the `` and `` come straight from the package type, we do + # not need to look at the OS at all. + ppl <- parse_platform(pl) + if (!is.null(ppl$pkg_type) && !is.na(ppl$pkg_type)) { + pt <- parse_pkg_type(ppl$pkg_type) + return(cbind( + pl, + minors, + contrib_url_path(pt$system, pt$build, minors) + )) + } + if ( pl %in% c("x86_64-w64-mingw32", "i386-w64-mingw32", "i386+x86_64-w64-mingw32") @@ -235,7 +358,7 @@ get_package_dirs_for_platform <- function(pl, minors) { return(cbind( pl, minors, - paste0("bin/windows/contrib/", minors) + contrib_url_path("windows", NA_character_, minors) )) } @@ -243,7 +366,7 @@ get_package_dirs_for_platform <- function(pl, minors) { return(cbind( "i386+x86_64-w64-mingw32", minors, - paste0("bin/windows/contrib/", minors) + contrib_url_path("windows", NA_character_, minors) )) } @@ -263,12 +386,7 @@ get_package_dirs_for_platform <- function(pl, minors) { cbind( rpl$platform, v, - paste0( - "bin/macosx/", - ifelse(nchar(rpl$subdir), paste0(rpl$subdir, "/"), ""), - "contrib/", - v - ) + contrib_url_path("macosx", rpl$subdir, v) ) } }) @@ -281,10 +399,9 @@ get_package_dirs_for_platform <- function(pl, minors) { rbind( if (nrow(cranmrv)) { - dirs <- paste0( - "bin/macosx/", - ifelse(nchar(cranmrv$subdir), paste0(cranmrv$subdir, "/"), ""), - "contrib/", + dirs <- contrib_url_path( + "macosx", + cranmrv$subdir, cranmrv$rversion ) cbind(pl, cranmrv$rversion, dirs) @@ -293,6 +410,17 @@ get_package_dirs_for_platform <- function(pl, minors) { ) } +contrib_url_path <- function(system, build, rversion) { + paste0( + "bin/", + system, + "/", + ifelse(is.na(build) | !nzchar(build), "", paste0(build, "/")), + "contrib/", + rversion + ) +} + macos_cran_platforms <- utils::read.table( header = TRUE, stringsAsFactors = FALSE, diff --git a/R/ppm-sso-app.R b/R/ppm-sso-app.R new file mode 100644 index 00000000..18a60f8e --- /dev/null +++ b/R/ppm-sso-app.R @@ -0,0 +1,293 @@ +# nocov start + +# Fake PPM server that proxies to Auth0, for testing ppm_sso_device_flow(). +# Auth0 device flow does not use PKCE, so we verify the PKCE challenge +# locally and forward only the device_code to Auth0's /oauth/token. +ppm_sso_auth0_app <- function( + auth0_domain, + client_id, + audience = NULL, + scope = "openid profile email", + redirect_url = "https://packagemanager.posit.co" +) { + app <- webfakes::new_app() + + app$use("logger" = webfakes::mw_log()) + app$use("urlencoded body parser" = webfakes::mw_urlencoded()) + app$use("json body parser" = webfakes::mw_json()) + + app$locals$challenges <- new.env(parent = emptyenv()) + app$locals$auth0_domain <- auth0_domain + app$locals$client_id <- client_id + app$locals$audience <- audience + app$locals$scope <- scope + + # Bearer-token check used by ppm_sso_can_authenticate(): any token passes. + app$get("/", function(req, res) { + res$set_status(200L)$send("ok") + }) + + app$post("/__api__/device", function(req, res) { + challenge <- req$form$code_challenge + method <- req$form$code_challenge_method %||% "S256" + if (!identical(method, "S256")) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_challenge_method") + )) + } + + payload <- list( + client_id = app$locals$client_id, + scope = app$locals$scope, + audience = app$locals$audience + ) + + upstream <- ppm_sso_post_form( + paste0("https://", app$locals$auth0_domain, "/oauth/device/code"), + payload + ) + + if (upstream$status >= 400L) { + return(res$set_status(upstream$status)$send_json( + auto_unbox = TRUE, + upstream$body + )) + } + + assign(upstream$body$device_code, challenge, envir = app$locals$challenges) + + res$send_json( + auto_unbox = TRUE, + list( + device_code = upstream$body$device_code, + user_code = upstream$body$user_code, + verification_uri = upstream$body$verification_uri, + verification_uri_complete = upstream$body$verification_uri_complete, + expires_in = upstream$body$expires_in, + interval = upstream$body$interval %||% 5L + ) + ) + }) + + app$post("/__api__/device_access", function(req, res) { + device_code <- req$form$device_code + verifier <- req$form$code_verifier + + if (!exists(device_code, envir = app$locals$challenges, inherits = FALSE)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "expired_token") + )) + } + expected <- get( + device_code, + envir = app$locals$challenges, + inherits = FALSE + ) + actual <- ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) + if (!identical(expected, actual)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "invalid_grant") + )) + } + + upstream <- ppm_sso_post_form( + paste0("https://", app$locals$auth0_domain, "/oauth/token"), + list( + grant_type = "urn:ietf:params:oauth:grant-type:device_code", + device_code = device_code, + client_id = app$locals$client_id + ) + ) + + if (upstream$status == 200L) { + rm(list = device_code, envir = app$locals$challenges) + return(res$send_json( + auto_unbox = TRUE, + list(id_token = upstream$body$id_token) + )) + } + + # Auth0 returns 403 for authorization_pending / slow_down; the PPM client + # only treats 400 as a soft pending state, so translate the status. + res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = upstream$body$error %||% "unknown_error") + ) + }) + + # Trivial token exchange: echo subject_token back as access_token. + app$post("/__api__/token", function(req, res) { + if ( + !identical( + req$form$grant_type, + "urn:ietf:params:oauth:grant-type:token-exchange" + ) + ) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_grant_type") + )) + } + res$send_json( + auto_unbox = TRUE, + list( + access_token = req$form$subject_token, + token_type = "Bearer", + issued_token_type = "urn:ietf:params:oauth:token-type:access_token" + ) + ) + }) + + # Everything we don't handle locally (package metadata, downloads, etc.) + # is proxied to the real PPM via a redirect, preserving path and query. + # 307 keeps the method and body intact for non-GET requests. + app$all(webfakes::new_regexp("^/.*$"), function(req, res) { + target <- paste0(redirect_url, req$path) + if (nzchar(req$query_string)) { + target <- paste0(target, "?", req$query_string) + } + res$redirect(target, 307L) + }) + + app +} + +ppm_sso_app <- function(redirect_url = "https://packagemanager.posit.co") { + app <- webfakes::new_app() + + app$use("logger" = webfakes::mw_log()) + app$use("urlencoded body parser" = webfakes::mw_urlencoded()) + app$use("json body parser" = webfakes::mw_json()) + + app$locals$challenges <- new.env(parent = emptyenv()) + + app$get("/", function(req, res) { + res$set_status(200L)$send("ok") + }) + + app$post("/__api__/device", function(req, res) { + challenge <- req$form$code_challenge + method <- req$form$code_challenge_method %||% "S256" + if (!identical(method, "S256")) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_challenge_method") + )) + } + + device_code <- ppm_sso_base64url_encode(.Call(pkgcache_rand_bytes, 32L)) + user_code <- "ABCD-EFGH" + verification_uri <- "https://example.invalid/activate" + + assign(device_code, challenge, envir = app$locals$challenges) + + res$send_json( + auto_unbox = TRUE, + list( + device_code = device_code, + user_code = user_code, + verification_uri = verification_uri, + verification_uri_complete = paste0( + verification_uri, + "?user_code=", + user_code + ), + expires_in = 300L, + interval = 1L + ) + ) + }) + + app$post("/__api__/device_access", function(req, res) { + device_code <- req$form$device_code + verifier <- req$form$code_verifier + + if (!exists(device_code, envir = app$locals$challenges, inherits = FALSE)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "expired_token") + )) + } + expected <- get( + device_code, + envir = app$locals$challenges, + inherits = FALSE + ) + actual <- ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) + if (!identical(expected, actual)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "invalid_grant") + )) + } + + rm(list = device_code, envir = app$locals$challenges) + res$send_json( + auto_unbox = TRUE, + list(id_token = ppm_sso_local_make_jwt()) + ) + }) + + app$post("/__api__/token", function(req, res) { + if ( + !identical( + req$form$grant_type, + "urn:ietf:params:oauth:grant-type:token-exchange" + ) + ) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_grant_type") + )) + } + res$send_json( + auto_unbox = TRUE, + list( + access_token = req$form$subject_token, + token_type = "Bearer", + issued_token_type = "urn:ietf:params:oauth:token-type:access_token" + ) + ) + }) + + # Everything we don't handle locally (package metadata, downloads, etc.) + # is proxied to the real PPM via a redirect, preserving path and query. + # 307 keeps the method and body intact for non-GET requests. + app$all(webfakes::new_regexp("^/.*$"), function(req, res) { + target <- paste0(redirect_url, req$path) + if (nzchar(req$query_string)) { + target <- paste0(target, "?", req$query_string) + } + res$redirect(target, 307L) + }) + + app +} + +ppm_sso_local_make_jwt <- function( + iss = "https://ppm-sso-local.invalid/", + sub = "ppm-sso-local-user", + aud = "ppm-sso-local", + ttl = 3600L, + now = unclass(Sys.time()) +) { + header <- list(alg = "none", typ = "JWT") + payload <- list( + iss = iss, + sub = sub, + aud = aud, + iat = as.integer(now), + exp = as.integer(now + ttl) + ) + enc <- function(x) { + ppm_sso_base64url_encode(charToRaw( + jsonlite::toJSON(x, auto_unbox = TRUE) + )) + } + paste0(enc(header), ".", enc(payload), ".") +} + +# nocov end diff --git a/R/ppm-sso.R b/R/ppm-sso.R new file mode 100644 index 00000000..cc489367 --- /dev/null +++ b/R/ppm-sso.R @@ -0,0 +1,659 @@ +#' Posit Package Manager single sign-on (SSO) authentication +#' +#' @details +#' ## Set up SSO authentication: +#' - Set the `PACKAGEMANAGER_ADDRESS` environment variable to the URL of +#' your RStudio Package Manager instance. For example, add this line to +#' your `.Renviron` file: +#' ``` +#' PACKAGEMANAGER_ADDRESS=https:// +#' ``` +#' Alternatively, you can also set it in your shell profile on Unix, +#' or in the System or User environment variables on Windows. +#' - Set `options(repos)` to include a repository from your Package Manager +#' instance. Include `__token__` as the username in the URL. For example: +#' ``` +#' options(repos = c( +#' PPM = "https://__token__@/", +#' getOption("repos") +#' )) +#' ``` +#' You probably want to add this to your `.Rprofile` file, so that it is +#' set in every R session. +#' - Call [repo_get()] to trigger authentication and caching of the token. +#' You should be prompted to log in via your browser, and the obtained +#' token will be cached for future use. Call [ppm_sso_status()] to check +#' the status of your authentication, including the path of the cached +#' token and its expiration time. +#' - Alternatively, you can call `ppm_sso_login()` directly to trigger +#' the login process directly. +#' +#' `ppm_sso_login()` initiates the SSO login process. You should be +#' prompted to log in via your browser, and the obtained token will be +#' cached for future use. +#' +#' @return `ppm_sso_login()` returns the obtained token invisibly. +#' +#' @seealso +#' @export +#' @examplesIf FALSE +#' Sys.setenv(PACKAGEMANAGER_ADDRESS = "https://") +#' options(repos = c( +#' PPM = "https://__token__@/", +#' getOption("repos") +#' )) +#' ppm_sso_login() +#' ppm_sso_status() +#' ppm_sso_status(connect = TRUE) +#' ppm_sso_logout() + +ppm_sso_login <- function() { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + + identity_token <- ppm_sso_get_identity_token_from_file() %||% + ppm_sso_device_flow(ppm_url) + ppm_token <- ppm_sso_identity_to_ppm_token(ppm_url, identity_token) + ppm_sso_write_token_to_file(ppm_url, ppm_token) + + invisible(ppm_token) +} + +#' @rdname ppm_sso_login +#' @details +#' `ppm_sso_logout()` removes the cached token, effectively logging you +#' out. If there is no cached token, it does nothing. +#' @return `ppm_sso_logout()` does not return anything. +#' @export + +ppm_sso_logout <- function() { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + + # remove from cache if there + try_catch_null(suppressWarnings(rm( + list = ppm_url, + envir = pkgenv$ppm_sso_cache, + inherits = FALSE + ))) + parsed <- parse_url(ppm_url) + try_catch_null(suppressWarnings(rm( + list = parsed$host, + envir = pkgenv$credentials, + inherits = FALSE + ))) + + token_file_path <- ppm_sso_token_path() + if (!file.exists(token_file_path)) { + return(invisible()) + } + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("connections", TRUE, "address")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.na(idx)) { + return(invisible()) + } + + tokens <- tsitter::ts_tree_delete( + tsitter::ts_tree_select(tokens, list("connections", idx)) + ) + + tsitter::ts_tree_write(tokens, token_file_path) + + invisible() +} + +#' @rdname ppm_sso_login +#' @param connect If `TRUE`, also checks if the token is valid by making a test +#' request to the Package Manager instance. This requires an active internet +#' connection and may take a few seconds. If `FALSE`, only checks if a +#' token is cached and not expired. +#' @details +#' `ppm_sso_status()` checks the status of your authentication, including +#' the path of the cached token and its expiration time. +#' @return `ppm_sso_status()` returns a list with the following components: +#' - `ppm_url`: The URL of the Package Manager instance. +#' - `token_file`: The path of the cached token file. +#' - `token`: The cached token (partially masked for display) or `NA` if +#' no token is found locally. +#' - `valid`: `TRUE` if the token is valid (only if `connect = TRUE`), +#' `FALSE` if invalid, or `NA` if not checked. +#' - `issuer`: The issuer of the token, or `NA` if not available. +#' - `subject`: The subject of the token, or `NA` if not available. +#' - `audience`: The audience of the token, or `NA` if not available. +#' - `issued_at`: The issue time of the token as a POSIXct object, or `NA` +#' if not available. +#' - `expires_at`: The expiration time of the token as a POSIXct object, +#' or `NA` if not available. +#' - `expired`: `TRUE` if the token is expired, `FALSE` if not expired, +#' or `NA` if expiration time is not available. +#' - `expires_in`: The time until expiration as a difftime object, or +#' `NA` if expiration time is not available or the token is already +#' expired. +#' @export + +ppm_sso_status <- function(connect = FALSE) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + ppm_sso_check_url(ppm_url) + token <- ppm_sso_get_cached_token(ppm_url, alive = TRUE) %||% + ppm_sso_get_existing_token(ppm_url, valid = FALSE) + + jwt <- token %&&% jwt_split(token) + iat <- .POSIXct(jwt$payload$iat %||% NA_real_) + exp <- .POSIXct(jwt$payload$exp %||% NA_real_) + now <- Sys.time() + auth <- if (connect) { + token %&&% + try_catch_null(ppm_sso_can_authenticate(ppm_url, token)) %||% + FALSE + } else { + NA + } + + structure( + list( + ppm_url = ppm_url, + token_file = ppm_sso_token_path(), + token = token %||% NA_character_, + valid = auth, + issuer = jwt$payload$iss %||% NA_character_, + subject = jwt$payload$sub %||% NA_character_, + audience = jwt$payload$aud %||% NA_character_, + issued_at = iat, + expires_at = exp, + expired = exp < now, + expires_in = if (!is.na(exp) && now < exp) { + exp - now + } else { + as.difftime(NA_real_, units = "secs") + } + ), + class = "ppm_sso_status" + ) +} + +jwt_split <- function(jwt) { + input <- strsplit(jwt, ".", fixed = TRUE)[[1]] + stopifnot(length(input) %in% c(2, 3)) + header <- jsonlite::fromJSON(rawToChar(ppm_sso_base64url_decode(input[1]))) + if (length(header$typ)) { + stopifnot(toupper(header$typ) == "JWT") + } + if (is.na(input[3])) { + input[3] <- "" + } + sig <- ppm_sso_base64url_decode(input[3]) + payload <- jsonlite::fromJSON(rawToChar(ppm_sso_base64url_decode(input[2]))) + data <- charToRaw(paste(input[1:2], collapse = ".")) + if (!grepl("^none|EdDSA|[HRE]S(256|384|512)$", header$alg)) { + stop("Invalid algorithm: ", header$alg) + } + if (grepl(".S\\d\\d\\d", header$alg)) { + type <- match.arg(substring(header$alg, 1, 1), c("HMAC", "RSA", "ECDSA")) + keysize <- as.numeric(substring(header$alg, 3)) + } else { + type <- header$alg + keysize <- NULL + } + list( + type = type, + keysize = keysize, + data = data, + sig = sig, + payload = payload, + header = header + ) +} + +#' @export + +print.ppm_sso_status <- function(x, ...) { + writeLines(format(x, ...)) + invisible(x) +} + +#' @export + +format.ppm_sso_status <- function(x, ...) { + token <- if (!is.na(x$token)) { + paste0( + substr(x$token, 1, 3), + "...", + substr(x$token, nchar(x$token) - 3, nchar(x$token)) + ) + } else { + NA_character_ + } + key <- function(x) { + cli::col_cyan(x) + } + url <- function(x) { + if (!is.na(x) && startsWith(x, "http")) { + cli::style_hyperlink(x, x) + } else { + x + } + } + tick <- function(x, invert = FALSE) { + txt <- if (isTRUE(x)) { + "yes" + } else if (isFALSE(x)) { + "no" + } else { + "?" + } + if (invert) { + x <- !x + } + if (isTRUE(x)) { + cli::col_green(txt) + } else if (isFALSE(x)) { + cli::col_magenta(txt) + } else { + txt + } + } + ein <- if (is.na(x$expires_in)) "-" else format_time$pretty_dt(x$expires_in) + c( + cli::rule("PPM SSO Status"), + paste(key("PPM URL: "), url(x$ppm_url)), + paste(key("Token file: "), x$token_file), + paste(key("Token: "), token), + paste(key("Valid: "), tick(x$valid)), + paste(key("Issuer: "), url(x$issuer)), + paste(key("Subject: "), x$subject), + paste(key("Audience: "), x$audience), + paste(key("Issued at: "), x$issued_at), + paste(key("Expires at: "), x$expires_at), + paste(key("Expired: "), tick(x$expired, invert = TRUE)), + paste(key("Expires in: "), ein), + NULL + ) +} + + +ppm_sso_check_url <- function(ppm_url) { + if (is.na(ppm_url)) { + stop( + "Please set the PACKAGEMANAGER_ADDRESS environment variable to ", + "the URL of your RStudio Package Manager instance." + ) + } + + if (is.na(parse_url(ppm_url)$host)) { + stop( + "The PACKAGEMANAGER_ADDRESS environment variable must be a valid URL, ", + "but got: ", + ppm_url + ) + } +} + +ppm_sso_auth <- function(repo) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + parsed <- tryCatch( + parse_url(repo), + error = function(e) { + stop("Failed to parse repository URL: ", repo) + } + ) + repo_host <- paste0(parsed$protocol, "://", parsed$host) + if (repo_host != ppm_url) { + stop( + "The repository URL (", + repo_host, + ") does not match the configured ", + "Package Manager URL (", + ppm_url, + ")." + ) + } + + token <- ppm_sso_get_cached_token(ppm_url, alive = TRUE) %||% + ppm_sso_get_existing_token(ppm_url, valid = TRUE) %||% + ppm_sso_login() + + pkgenv$ppm_sso_cache[[ppm_url]] <- token + + token +} + +ppm_sso_get_cached_token <- function(ppm_url, alive = TRUE) { + token <- pkgenv$ppm_sso_cache[[ppm_url]] + + # no token in cache + if (is.null(token)) { + return(NULL) + } + + # no need to test if token is live + if (!alive) { + return(token) + } + + # no expiration date + jwt <- jwt_split(token) + exp <- jwt$payload$exp + if (is.null(exp)) { + return(token) + } + + # check if token is still valid + if (.POSIXct(exp) > Sys.time()) { + return(token) + } + + # not valid any more, remove from cache + pkgenv$ppm_sso_cache[[ppm_url]] <- NULL + + NULL +} + +ppm_sso_post_form <- function(url, payload) { + payload <- payload[!vapply(payload, is.null, logical(1))] + body <- paste( + paste0( + curl::curl_escape(names(payload)), + "=", + curl::curl_escape(unlist(payload, use.names = FALSE)) + ), + collapse = "&" + ) + h <- curl::new_handle() + curl::handle_setheaders( + h, + "Content-Type" = "application/x-www-form-urlencoded" + ) + curl::handle_setopt(h, post = TRUE, postfields = body) + resp <- curl::curl_fetch_memory(url, handle = h) + list( + status = resp$status_code, + body = tryCatch( + jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE), + error = function(e) { + resp$content + } + ) + ) +} + +ppm_sso_token_path <- function() { + Sys.getenv( + "PACKAGEMANAGER_SSO_TOKEN_FILE", + file.path( + path.expand("~"), + ".ppm", + "tokens.toml" + ) + ) +} + +ppm_sso_get_existing_token <- function(ppm_url, valid = TRUE) { + path <- ppm_sso_token_path() + try_catch_null({ + ts_tokens <- suppressWarnings(tstoml::ts_read_toml(path)) + for (conn in ts_tokens[[list("connections", TRUE)]]) { + if (identical(conn$address, ppm_url)) { + if (valid && !ppm_sso_can_authenticate(ppm_url, conn$token)) { + return(NULL) + } + return(conn$token) + } + } + }) +} + +ppm_sso_get_identity_token_from_file <- function() { + token_file <- Sys.getenv("PACKAGEMANAGER_IDENTITY_TOKEN_FILE", unset = NA) + if (is.na(token_file)) { + return(NULL) + } + try_catch_null({ + trimws(readLines(token_file, n = 1, warn = FALSE)) + }) +} + +ppm_sso_device_flow_init <- function(ppm_url) { + verifier <- ppm_sso_new_pkce_verifier() + challenge <- ppm_sso_new_pkce_challenge(verifier) + + # 1. Initiate Device Auth + init_url <- paste0(ppm_url, "/__api__/device") + payload <- list( + code_challenge_method = "S256", + code_challenge = challenge + ) + init_resp <- ppm_sso_post_form(init_url, payload) + if (init_resp$status >= 400) { + stop( + "Failed to initiate device authorization (HTTP ", + init_resp$status, + ")." + ) + } + init_resp_body <- init_resp$body + + display_uri <- init_resp_body$verification_uri_complete %||% + init_resp_body$verification_uri + if (is.null(display_uri)) { + stop("No verification URI found in device auth response.") + } + + list( + verifier = verifier, + display_uri = display_uri, + user_code = init_resp_body$user_code, + device_code = init_resp_body$device_code, + expires_in = init_resp_body$expires_in, + interval = init_resp_body$interval + ) +} + +ppm_sso_device_flow_message <- function(ppm_url, init_result) { + cli::cli_rule("PPM SSO Login") + cli::cli_text("Login at {.url {init_result$display_uri}}") + cli::cli_text( + "and enter code {.emph {cli::col_magenta(init_result$user_code)}} + when prompted." + ) + if (is_interactive()) { + readline("Press ENTER to open in browser...") + utils::browseURL(init_result$display_uri) + } else if (isTRUE(getOption("pak.is_worker"))) { + # called from pak, make the UI slightly nicer. + # unfortunately we cannot interact with the user here + utils::browseURL(init_result$display_uri) + } +} + +ppm_sso_device_flow <- function(ppm_url) { + init_result <- ppm_sso_device_flow_init(ppm_url) + ppm_sso_device_flow_message(ppm_url, init_result) + token <- ppm_sso_device_flow_complete(ppm_url, init_result) + if (is.null(token)) { + stop("Failed to complete device authorization or obtain identity token.") + } + token +} + +ppm_sso_can_authenticate <- function(ppm_url, token) { + h <- curl::new_handle() + curl::handle_setheaders(h, "Authorization" = paste("Bearer", token)) + resp <- curl::curl_fetch_memory(ppm_url, handle = h) + status <- resp$status_code + status < 500 && status != 401 && status != 403 +} + +ppm_sso_identity_to_ppm_token <- function(ppm_url, identity_token) { + url <- paste0(ppm_url, "/__api__/token") + payload <- list( + grant_type = "urn:ietf:params:oauth:grant-type:token-exchange", + subject_token = identity_token, + subject_token_type = "urn:ietf:params:oauth:token-type:id_token" + ) + + resp <- ppm_sso_post_form(url, payload) + if (resp$status >= 400) { + stop( + "Failed to exchange identity token for PPM token (HTTP ", + resp$status, + ")." + ) + } + + token_data <- resp$body + if (is.null(token_data$access_token)) { + stop("Failed to exchange identity token for PPM token.") + } + + token_data$access_token +} + +ppm_sso_write_token_to_file <- function(ppm_url, token) { + # this is more difficult than it should be because TOML is unable + # to represent an empty array of tables + token_file_path <- ppm_sso_token_path() + mkdirp(dirname(token_file_path)) + new_conn <- list( + address = ppm_url, + token = token, + auth_type = "sso" + ) + + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("connections", TRUE, "address")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.null(tokens)) { + tokens <- tstoml::ts_parse_toml("") + tokens <- tsitter::ts_tree_insert( + tokens, + key = "connections", + list(new_conn) + ) + } else if (!is.na(idx)) { + tokens <- tsitter::ts_tree_update( + tsitter::ts_tree_select(tokens, list("connections", idx, "token")), + new_conn$token + ) + } else if (length(urls) == 0) { + tokens <- tsitter::ts_tree_insert( + tokens, + key = "connections", + list(new_conn) + ) + } else { + tokens <- tsitter::ts_tree_insert( + tsitter::ts_tree_select(tokens, "connections"), + list(new_conn) + ) + } + + bytes <- as.raw(tokens) + file.create(token_file_path) + Sys.chmod(token_file_path, "600") + writeBin(bytes, token_file_path) +} + +ppm_sso_base64url_decode <- function(x) { + # Add padding if missing + padding_needed <- (4 - nchar(x) %% 4) %% 4 + x <- paste0(x, strrep("=", padding_needed)) + # Replace URL-safe characters + x <- gsub("-", "+", gsub("_", "/", x)) + processx::base64_decode(x) +} + +ppm_sso_base64url_encode <- function(x) { + encoded <- processx::base64_encode(x) + # Make it URL-safe + gsub("\\+", "-", gsub("\\/", "_", gsub("=+$", "", encoded))) +} + +ppm_sso_hex_to_raw <- function(s) { + n <- nchar(s) + as.raw(strtoi(substring(s, seq(1L, n, 2L), seq(2L, n, 2L)), 16L)) +} + +ppm_sso_sha256_raw <- function(x) { + ppm_sso_hex_to_raw(cli::hash_sha256(x)) +} + +ppm_sso_new_pkce_verifier <- function() { + ppm_sso_base64url_encode(.Call(pkgcache_rand_bytes, 32L)) +} + +ppm_sso_new_pkce_challenge <- function(verifier) { + ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) +} + +ppm_sso_device_flow_complete <- function(ppm_url, init_result) { + device_code <- init_result$device_code + verifier <- init_result$verifier + interval <- init_result$interval %||% 5 + expires_in <- init_result$expires_in %||% 300 + + url <- paste0(ppm_url, "/__api__/device_access") + start_time <- Sys.time() + payload <- list( + device_code = device_code, + code_verifier = verifier + ) + + # PPM might not respond until the user completes auth, so show this + oldopt <- options(cli.progress_show_after = 0) + on.exit(options(oldopt), add = TRUE) + cli::cli_progress_bar( + format = "{cli::pb_spin} Waiting for browser." + ) + cli::cli_progress_update() + + while (as.numeric(Sys.time() - start_time) < expires_in) { + resp <- ppm_sso_post_form(url, payload) + status <- resp$status + + if (status == 200) { + cli::cli_progress_done() + cli::cli_alert_success("Authorization successful.") + return(resp$body$id_token) + } else if (status == 400) { + error_code <- resp$body$error + if (error_code == "access_denied") { + cli::cli_progress_done() + cli::cli_alert_danger("Authorization denied by user.") + stop("Access denied by user.") + } + if (error_code == "expired_token") { + cli::cli_progress_done() + cli::cli_alert_danger("Device authorization request expired.") + stop("Device authorization request expired.") + } + # For "authorization_pending" or "slow_down", just wait and retry. + } else { + cli::cli_progress_done() + cli::cli_alert_danger( + "Device authorization failed (HTTP {status})." + ) + stop("Device authorization failed.") + } + + deadline <- Sys.time() + interval + while (Sys.time() < deadline) { + Sys.sleep(.1) + cli::cli_progress_update() + } + } + + cli::cli_progress_done() + cli::cli_alert_danger("Device authorization timed out.") + stop("Device authorization timed out.") +} diff --git a/R/repo-set.R b/R/repo-set.R index 11e3a248..28725a01 100644 --- a/R/repo-set.R +++ b/R/repo-set.R @@ -92,7 +92,7 @@ repo_resolve <- function(spec, username = NULL) { repo_add <- function(..., .list = NULL, username = NULL) { repo_add_internal(..., .list = .list, username = username) - invisible(suppressMessages(repo_get())) + invisible(repo_get()) } repo_add_internal <- function(..., .list = NULL, username = NULL) { diff --git a/R/utils.R b/R/utils.R index ae0a111a..9e09983c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,6 +2,10 @@ repoman_data <- new.env(parent = emptyenv()) `%||%` <- function(l, r) if (is.null(l)) r else l +`%&&%` <- function(l, r) if (is.null(l)) NULL else r + +isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x + vcapply <- function(X, FUN, ...) { vapply(X, FUN, FUN.VALUE = character(1), ...) } @@ -250,3 +254,13 @@ is_rcmd_check <- function() { random_key <- function() { basename(tempfile()) } + +is_interactive <- function() { + if (isTRUE(getOption("rlib.interactive"))) { + TRUE + } else if (isFALSE(getOption("rlib.interactive"))) { + FALSE + } else { + interactive() + } +} diff --git a/README.md b/README.md index 4070bb97..2574de94 100644 --- a/README.md +++ b/README.md @@ -204,6 +204,10 @@ configure Bioconductor support. `2` forces HTTP/1.1 and `0` lets libcurl choose. It defaults to HTTP/1.1, because HTTP/2 has caused transport-level failures with some client and server combinations. +- `pkgcache_retry` configures whether and how failed HTTP requests are + retried. It is either a number, to set the maximum number of retries, or + `TRUE` (the default) or `FALSE` to enable or disable retries. It can also + be a named list for finer control over the retry policy. ## Package environment variables @@ -217,7 +221,7 @@ configure Bioconductor support. platform string for the current platform for the `current_r_platform()` function. This is useful if pkgcache didn’t detect the platform correctly. Alternatively, you can use the - `pkg.current_platofrm` option, which takes. priority over the + `pkg.current_platform` option, which takes priority over the environment variable. - `PKGCACHE_PPM_REPO` is the name of the Posit Package Manager repository to use. Defaults to `"cran"`. @@ -252,6 +256,10 @@ configure Bioconductor support. because HTTP/2 has caused transport-level failures with some client and server combinations. The `pkgcache_http_version` option has priority over this, if set. +- `PKGCACHE_RETRY` configures whether and how failed HTTP requests are + retried. It is either a number, to set the maximum number of retries, or + `TRUE` (the default) or `FALSE` to enable or disable retries. The + `pkgcache_retry` option has priority over this, if set. - `R_PKG_CACHE_DIR` is used for the cache directory, if set. (Otherwise `tools::R_user_dir("pkgcache", "cache")` is used, see also `meta_cache_summary()` and `pkg_cache_summary()`). diff --git a/_pkgdown.yml b/_pkgdown.yml index 5580059e..de79e6f4 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -32,6 +32,9 @@ reference: - ppm_r_versions - ppm_repo_url - ppm_snapshots + - ppm_sso_login + - ppm_sso_logout + - ppm_sso_status - repo_auth - repo_get - repo_status diff --git a/inst/WORDLIST b/inst/WORDLIST index 44bd7d32..e3f4643f 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -13,18 +13,22 @@ Encodings FreeBSD MRAN PBC +POSIXct README ROR RSPM RStudio SHA +SSO Solaris +Sonoma Sur UTF UUID archs async devel +difftime encodings funder html diff --git a/man/cranlike_metadata_cache.Rd b/man/cranlike_metadata_cache.Rd index cc649357..df59c181 100644 --- a/man/cranlike_metadata_cache.Rd +++ b/man/cranlike_metadata_cache.Rd @@ -147,7 +147,9 @@ column is either \itemize{ \item \code{"source"} for source packages, \item a platform string, e.g. \code{x86_64-apple-darwin17.0} for macOS -packages compatible with macOS High Sierra or newer. +packages compatible with macOS High Sierra or newer, +\item a platform string with a custom binary package type, e.g. +\code{aarch64-w64-mingw32-windows.binary.clang-aarch64}. } \item \code{needscompilation}: Whether the package needs compilation. \item \code{type}: \code{bioc} or \code{cran} currently. diff --git a/man/current_r_platform.Rd b/man/current_r_platform.Rd index 162d4b51..21100321 100644 --- a/man/current_r_platform.Rd +++ b/man/current_r_platform.Rd @@ -23,6 +23,7 @@ scalar columns: \item \code{os}, \item \code{distribution} (only on Linux), \item \code{release} (only on Linux), +\item \code{pkg_type} (only for a custom binary package type), \item \code{platform}: the concatenation of the other columns, separated by a dash. } @@ -77,9 +78,25 @@ builds might have the same platform string, unfortunately.) \item \code{s390x-ibm-linux-gnu-ubuntu-20.04}: Ubuntu Linux 20.04 on S390x. \item \code{amd64-portbld-freebsd12.1}: FreeBSD 12.1 on x86_64. } +\item A platform string as above, followed by a custom binary package type. +From R 4.6.0 \code{.Platform$pkgType} may be \verb{.binary.}, and +then binary packages live in \verb{bin///contrib/} in +the repository, see \code{\link[utils:contrib.url]{utils::contrib.url()}}. pkgcache includes the +package type in the platform name, so that two builds of R for the +same platform triple remain distinguishable. Examples: +\itemize{ +\item \code{aarch64-w64-mingw32-windows.binary.clang-aarch64}: Windows on arm64, +built with clang. +\item \code{aarch64-apple-darwin23-mac.binary.sonoma-arm64}: macOS Sonoma on +arm64. (This is the same as \code{aarch64-apple-darwin23}, which pkgcache +already knows about, so \code{current_r_platform()} uses the shorter form.) +} + +A package type on its own, without a platform triple, is not a valid +platform name. } -\code{default_platfoms()} returns the default platforms for the current R +\code{default_platforms()} returns the default platforms for the current R session. These typically consist of the detected platform of the current R session, and \code{"source"}, for source packages. } diff --git a/man/pkgcache-package.Rd b/man/pkgcache-package.Rd index f57969f1..689edf57 100644 --- a/man/pkgcache-package.Rd +++ b/man/pkgcache-package.Rd @@ -209,7 +209,7 @@ this, if set. platform string for the current platform for the \code{current_r_platform()} function. This is useful if pkgcache didn’t detect the platform correctly. Alternatively, you can use the -\code{pkg.current_platofrm} option, which takes. priority over the +\code{pkg.current_platform} option, which takes priority over the environment variable. \item \code{PKGCACHE_PPM_REPO} is the name of the Posit Package Manager repository to use. Defaults to \code{"cran"}. diff --git a/man/ppm_sso_login.Rd b/man/ppm_sso_login.Rd new file mode 100644 index 00000000..4ebf46d7 --- /dev/null +++ b/man/ppm_sso_login.Rd @@ -0,0 +1,109 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppm-sso.R +\name{ppm_sso_login} +\alias{ppm_sso_login} +\alias{ppm_sso_logout} +\alias{ppm_sso_status} +\title{Posit Package Manager single sign-on (SSO) authentication} +\usage{ +ppm_sso_login() + +ppm_sso_logout() + +ppm_sso_status(connect = FALSE) +} +\arguments{ +\item{connect}{If \code{TRUE}, also checks if the token is valid by making a test +request to the Package Manager instance. This requires an active internet +connection and may take a few seconds. If \code{FALSE}, only checks if a +token is cached and not expired.} +} +\value{ +\code{ppm_sso_login()} returns the obtained token invisibly. + +\code{ppm_sso_logout()} does not return anything. + +\code{ppm_sso_status()} returns a list with the following components: +\itemize{ +\item \code{ppm_url}: The URL of the Package Manager instance. +\item \code{token_file}: The path of the cached token file. +\item \code{token}: The cached token (partially masked for display) or \code{NA} if +no token is found locally. +\item \code{valid}: \code{TRUE} if the token is valid (only if \code{connect = TRUE}), +\code{FALSE} if invalid, or \code{NA} if not checked. +\item \code{issuer}: The issuer of the token, or \code{NA} if not available. +\item \code{subject}: The subject of the token, or \code{NA} if not available. +\item \code{audience}: The audience of the token, or \code{NA} if not available. +\item \code{issued_at}: The issue time of the token as a POSIXct object, or \code{NA} +if not available. +\item \code{expires_at}: The expiration time of the token as a POSIXct object, +or \code{NA} if not available. +\item \code{expired}: \code{TRUE} if the token is expired, \code{FALSE} if not expired, +or \code{NA} if expiration time is not available. +\item \code{expires_in}: The time until expiration as a difftime object, or +\code{NA} if expiration time is not available or the token is already +expired. +} +} +\description{ +Posit Package Manager single sign-on (SSO) authentication +} +\details{ +\subsection{Set up SSO authentication:}{ +\itemize{ +\item Set the \code{PACKAGEMANAGER_ADDRESS} environment variable to the URL of +your RStudio Package Manager instance. For example, add this line to +your \code{.Renviron} file: + +\if{html}{\out{
}}\preformatted{PACKAGEMANAGER_ADDRESS=https:// +}\if{html}{\out{
}} + +Alternatively, you can also set it in your shell profile on Unix, +or in the System or User environment variables on Windows. +\item Set \code{options(repos)} to include a repository from your Package Manager +instance. Include \verb{__token__} as the username in the URL. For example: + +\if{html}{\out{
}}\preformatted{options(repos = c( + PPM = "https://__token__@/", + getOption("repos") +)) +}\if{html}{\out{
}} + +You probably want to add this to your \code{.Rprofile} file, so that it is +set in every R session. +\item Call \code{\link[=repo_get]{repo_get()}} to trigger authentication and caching of the token. +You should be prompted to log in via your browser, and the obtained +token will be cached for future use. Call \code{\link[=ppm_sso_status]{ppm_sso_status()}} to check +the status of your authentication, including the path of the cached +token and its expiration time. +\item Alternatively, you can call \code{ppm_sso_login()} directly to trigger +the login process directly. +} + +\code{ppm_sso_login()} initiates the SSO login process. You should be +prompted to log in via your browser, and the obtained token will be +cached for future use. +} + +\code{ppm_sso_logout()} removes the cached token, effectively logging you +out. If there is no cached token, it does nothing. + +\code{ppm_sso_status()} checks the status of your authentication, including +the path of the cached token and its expiration time. +} +\examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +Sys.setenv(PACKAGEMANAGER_ADDRESS = "https://") +options(repos = c( + PPM = "https://__token__@/", + getOption("repos") +)) +ppm_sso_login() +ppm_sso_status() +ppm_sso_status(connect = TRUE) +ppm_sso_logout() +\dontshow{\}) # examplesIf} +} +\seealso{ +\url{https://docs.posit.co/rspm/admin/authentication/} +} diff --git a/src/init.c b/src/init.c index 97944f83..9334b0ab 100644 --- a/src/init.c +++ b/src/init.c @@ -30,6 +30,8 @@ static const R_CallMethodDef callMethods[] = { REG(pkgcache_parse_packages_raw, 1), REG(pkgcache_graphics_api_version, 0), + REG(pkgcache_rand_bytes, 1), + REG(pkgcache__gcov_flush, 0), { NULL, NULL, 0 } }; diff --git a/src/pkgcache.h b/src/pkgcache.h index de0922f5..05c0a169 100644 --- a/src/pkgcache.h +++ b/src/pkgcache.h @@ -12,3 +12,5 @@ SEXP pkgcache_parse_descriptions(SEXP paths, SEXP lowercase); SEXP pkgcache_parse_packages_raw(SEXP raw); SEXP pkgcache_graphics_api_version(void); + +SEXP pkgcache_rand_bytes(SEXP n); diff --git a/src/rand.c b/src/rand.c new file mode 100644 index 00000000..f3b67e81 --- /dev/null +++ b/src/rand.c @@ -0,0 +1,85 @@ +#include "pkgcache.h" + +#include + +#if defined(_WIN32) +# include +# define RtlGenRandom SystemFunction036 +# ifdef __cplusplus +extern "C" +# endif +BOOLEAN NTAPI RtlGenRandom(PVOID RandomBuffer, ULONG RandomBufferLength); +# pragma comment(lib, "advapi32.lib") +#elif defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || \ + defined(__NetBSD__) || defined(__DragonFly__) +# include +#else +# include +# include +# include +# if defined(__linux__) +# include +# endif +#endif + +SEXP pkgcache_rand_bytes(SEXP n) { + int size = Rf_asInteger(n); + if (size == NA_INTEGER || size < 0) { + Rf_error("Invalid number of random bytes requested"); + } + SEXP res = PROTECT(Rf_allocVector(RAWSXP, size)); + if (size == 0) { + UNPROTECT(1); + return res; + } + unsigned char *buf = RAW(res); + +#if defined(_WIN32) + if (!RtlGenRandom((PVOID) buf, (ULONG) size)) { + Rf_error("Failed to obtain random bytes from RtlGenRandom"); + } + +#elif defined(__APPLE__) || defined(__FreeBSD__) || defined(__OpenBSD__) || \ + defined(__NetBSD__) || defined(__DragonFly__) + arc4random_buf(buf, (size_t) size); + +#else + size_t off = 0; +# if defined(__linux__) && defined(SYS_getrandom) + while (off < (size_t) size) { + long r = syscall(SYS_getrandom, buf + off, (size_t) size - off, 0); + if (r > 0) { + off += (size_t) r; + } else if (r < 0 && (errno == EINTR || errno == EAGAIN)) { + continue; + } else { + break; /* fall through to /dev/urandom */ + } + } +# endif + if (off < (size_t) size) { + int fd; + do { + fd = open("/dev/urandom", O_RDONLY); + } while (fd < 0 && errno == EINTR); + if (fd < 0) { + Rf_error("Failed to open /dev/urandom: %s", strerror(errno)); + } + while (off < (size_t) size) { + ssize_t r = read(fd, buf + off, (size_t) size - off); + if (r > 0) { + off += (size_t) r; + } else if (r < 0 && errno == EINTR) { + continue; + } else { + close(fd); + Rf_error("Failed to read from /dev/urandom: %s", strerror(errno)); + } + } + close(fd); + } +#endif + + UNPROTECT(1); + return res; +} diff --git a/tests/testthat/_snaps/auth.md b/tests/testthat/_snaps/auth.md index 546a4d58..e895e9ee 100644 --- a/tests/testthat/_snaps/auth.md +++ b/tests/testthat/_snaps/auth.md @@ -18,6 +18,7 @@ [2] "https://ppm.internal/healthz" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] NA @@ -51,6 +52,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal/cran/latest" @@ -84,6 +86,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal/cran/latest" @@ -119,6 +122,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] NA @@ -151,6 +155,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal/cran/latest" @@ -180,6 +185,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal/cran/latest" @@ -208,6 +214,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal/cran/latest" @@ -243,6 +250,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal" @@ -272,6 +280,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal" @@ -300,6 +309,7 @@ [2] "https://ppm.internal/cran/latest" [3] "https://username@ppm.internal" [4] "https://ppm.internal" + [5] "ppm.internal" $auth_domain [1] "https://ppm.internal" @@ -362,9 +372,9 @@ Code cmc$update() Message - ! Cannot find credentials for URL , credential lookup + ! Cannot find credentials for URL , credential lookup failed. Keyring backend: "env". - x Did not find credentials for repo , keyring + x Did not find credentials for repo , keyring lookup failed (env backend). v Updated metadata database: in file. i source packages are missing from CRAN: Unauthorized (HTTP 401). @@ -388,7 +398,7 @@ Code cmc$update() Message - v Found credentials for repo (keyring:env). + v Found credentials for repo (keyring:env). v Updated metadata database: in file. i Updating metadata database v Updating metadata database ... done @@ -613,6 +623,7 @@ $auth_domains [1] "http://username@foo.bar.com/path" "http://foo.bar.com/path" [3] "http://username@foo.bar.com" "http://foo.bar.com" + [5] "foo.bar.com" $auth_domain [1] "foo.bar.com" diff --git a/tests/testthat/_snaps/platform.md b/tests/testthat/_snaps/platform.md index 30a4b702..905d6a83 100644 --- a/tests/testthat/_snaps/platform.md +++ b/tests/testthat/_snaps/platform.md @@ -1,3 +1,82 @@ +# parse_pkg_type + + Code + parse_pkg_type("source") + Output + NULL + Code + parse_pkg_type("win.binary") + Output + $system + [1] "windows" + + $build + [1] NA + + Code + parse_pkg_type("mac.binary") + Output + $system + [1] "macosx" + + $build + [1] NA + + Code + parse_pkg_type("mac.binary.big-sur-arm64") + Output + $system + [1] "macosx" + + $build + [1] "big-sur-arm64" + + Code + parse_pkg_type("windows.binary.clang-aarch64") + Output + $system + [1] "windows" + + $build + [1] "clang-aarch64" + + Code + parse_pkg_type("windows.binary") + Output + $system + [1] "windows" + + $build + [1] NA + + Code + parse_pkg_type("linux.binary.clang19") + Output + $system + [1] "linux" + + $build + [1] "clang19" + + Code + parse_pkg_type("Windows.Binary.X") + Output + NULL + Code + parse_pkg_type("win.binary.a.b") + Output + NULL + +# current_r_platform_data, custom binary package type + + Code + current_r_platform_data() + Output + cpu vendor os pkg_type + 1 aarch64 w64 mingw32 windows.binary.clang-aarch64 + platform + 1 aarch64-w64-mingw32-windows.binary.clang-aarch64 + # parse_platform Code @@ -24,6 +103,21 @@ 12 aarch64 pc linux-gnu ubuntu 24.04-libc++ 13 aarch64 pc linux-musl alpine 13.4 +# parse_platform, custom binary package types + + Code + parse_platform(c("aarch64-w64-mingw32-windows.binary.clang-aarch64", + "x86_64-w64-mingw32", "aarch64-apple-darwin23-mac.binary.sonoma-arm64", + "aarch64-w64-mingw32-windows.binary", + "x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19")) + Output + cpu vendor os distribution release pkg_type + 1 aarch64 w64 mingw32 windows.binary.clang-aarch64 + 2 x86_64 w64 mingw32 + 3 aarch64 apple darwin23 mac.binary.sonoma-arm64 + 4 aarch64 w64 mingw32 windows.binary + 5 x86_64 pc linux-gnu ubuntu 24.04 linux.binary.clang19 + # re_linux_platform Code @@ -59,7 +153,19 @@ Error in `get_package_dirs_for_platform()`: ! pkgcache does not support packages for R versions before R 3.2 ---- +# get_all_package_dirs, custom binary package types + + Code + get_all_package_dirs(c("aarch64-w64-mingw32-windows.binary.clang-aarch64", + "source"), "4.7.0") + Output + # A data frame: 2 x 3 + platform rversion contriburl + * + 1 aarch64-w64-mingw32-windows.binary.clang-aarch64 4.7 bin/windows/clang-a~ + 2 source * src/contrib + +# get_all_package_dirs 2 Code get_all_package_dirs("windows", "2.15.0") @@ -580,7 +686,7 @@ current_r_platform() Condition Error in `forced_platform()`: - ! The pkg.current_platform` option must be a valid platform triple: `cpu-vendor-os`. "foobar" is not. + ! The pkg.current_platform` option must be a valid platform name: `cpu-vendor-os`, optionally followed by a Linux distribution and release, or a binary package type. "foobar" is not. --- @@ -588,7 +694,7 @@ current_r_platform() Condition Error in `forced_platform()`: - ! The `PKG_CURRENT_PLATFORM` environment variable must be a valid platform triple: "cpu-vendor-os". "foobar" is not. + ! The `PKG_CURRENT_PLATFORM` environment variable must be a valid platform name: "cpu-vendor-os", optionally followed by a Linux distribution and release, or a binary package type. "foobar" is not. # platform with flavors @@ -607,3 +713,13 @@ Output [1] "x86_64-pc-linux-gnu-ubuntu-22.04-libc++" +# forced platform with a custom binary package type + + Code + current_r_platform_data() + Output + cpu vendor os pkg_type + 1 aarch64 w64 mingw32 windows.binary.clang-aarch64 + platform + 1 aarch64-w64-mingw32-windows.binary.clang-aarch64 + diff --git a/tests/testthat/_snaps/repo-status.md b/tests/testthat/_snaps/repo-status.md index cfa5ceda..d754bcbc 100644 --- a/tests/testthat/_snaps/repo-status.md +++ b/tests/testthat/_snaps/repo-status.md @@ -15,9 +15,9 @@ stat Output # A data frame: 1 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 Code summary(stat) Output @@ -41,10 +41,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 FALSE NA Code summary(stat) Output @@ -68,12 +68,12 @@ stat Output # A data frame: 4 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.1 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 - 3 CRAN http://127.0.0.1:3000/ cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.1 4.1 FALSE NA - 4 CRAN http://127.0.0.1:3000/ cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.1 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 + 3 CRAN http://127.0.0.1:3000 cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.1 4.1 FALSE NA + 4 CRAN http://127.0.0.1:3000 cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 FALSE NA Code summary(stat) Output @@ -98,10 +98,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran x86_64-apple-darwin17.0 bin/macosx/contrib/4.2 4.2 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran x86_64-apple-darwin17.0 bin/macosx/contrib/4.2 4.2 FALSE NA Code summary(stat) Output @@ -125,10 +125,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran i386+x86_64-w64-mingw32 bin/windows/contrib/4.2 4.2 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran i386+x86_64-w64-mingw32 bin/windows/contrib/4.2 4.2 FALSE NA Code summary(stat) Output @@ -152,10 +152,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.0 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran i386+x86_64-w64-mingw32 bin/windows/contrib/4.0 4.0 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.0 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran i386+x86_64-w64-mingw32 bin/windows/contrib/4.0 4.0 FALSE NA Code summary(stat) Output @@ -179,10 +179,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 3.6 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran i386+x86_64-w64-mingw32 bin/windows/contrib/3.6 3.6 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 3.6 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran i386+x86_64-w64-mingw32 bin/windows/contrib/3.6 3.6 FALSE NA Code summary(stat) Output @@ -206,10 +206,10 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 3.5 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran i386+x86_64-w64-mingw32 bin/windows/contrib/3.5 3.5 FALSE NA + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 3.5 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran i386+x86_64-w64-mingw32 bin/windows/contrib/3.5 3.5 FALSE NA Code summary(stat) Output @@ -226,7 +226,7 @@ # A data frame: 6 x 10 name url type bioc_version platform path r_version ok ping error - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 2 BioCsoft http://127.0.0.1:3000//packages/3.16/bioc bioc 3.16 source src/contrib 4.2 TRUE 0.1 3 BioCann http://127.0.0.1:3000//packages/3.16/data/annotation bioc 3.16 source src/contrib 4.2 TRUE 0.1 4 BioCexp http://127.0.0.1:3000//packages/3.16/data/experiment bioc 3.16 source src/contrib 4.2 TRUE 0.1 @@ -251,16 +251,29 @@ stat Output # A data frame: 2 x 10 - name url type bioc_version platform path r_version ok ping error - - 1 CRAN http://127.0.0.1:3000/ cran source src/contrib 4.2 TRUE 0.1 - 2 CRAN http://127.0.0.1:3000/ cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 TRUE 0.1 + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.2 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran aarch64-apple-darwin20 bin/macosx/big-sur-arm64/contrib/4.2 4.2 TRUE 0.1 Code summary(stat) Output Repository summary: source aarch64-apple-darwin20 CRAN @ 127.0.0.1:3000 OK OK (100ms) +# repo with custom binary package type + + Code + stat <- repo_status(platforms = platforms, r_version = "4.7", bioc = FALSE) + stat$ping[stat$ok] <- 0.1 + stat + Output + # A data frame: 2 x 10 + name url type bioc_version platform path r_version ok ping error + + 1 CRAN http://127.0.0.1:3000 cran source src/contrib 4.7 TRUE 0.1 + 2 CRAN http://127.0.0.1:3000 cran aarch64-w64-mingw32-windows.binary.clang-aarch64 bin/windows/clang-aarch64/contrib/4.7 4.7 TRUE 0.1 + # repo_status unicode output [fancy] Code diff --git a/tests/testthat/helper-mock.R b/tests/testthat/helper-mock.R index 0e90b9db..33d85438 100644 --- a/tests/testthat/helper-mock.R +++ b/tests/testthat/helper-mock.R @@ -100,10 +100,10 @@ fake <- local({ tree } - fake <- function(where, what, how) { + fake <- function(where, what, how, test_env = parent.frame()) { + force(test_env) where_name <- deparse(substitute(where)) stopifnot(is.character(what), length(what) == 1) - test_env <- parent.frame() tree <- build_function_tree(test_env, where, where_name) fake_through_tree(tree, what, how) } diff --git a/tests/testthat/test-1-metadata-cache-3.R b/tests/testthat/test-1-metadata-cache-3.R index 71230b6b..f4e687f4 100644 --- a/tests/testthat/test-1-metadata-cache-3.R +++ b/tests/testthat/test-1-metadata-cache-3.R @@ -70,6 +70,12 @@ test_that("cmc__get_repos", { res$bioc_version, c(NA_character_, NA_character_, "3.8", "3.8", "3.8", "3.8") ) + + ## Trailing slashes are dropped, so we don't create URLs with a double + ## slash. See r-lib/pak#888. + repos <- c(CRAN = "https://example.com/repo/", EXTRA = "https://x.com//") + res <- cmc__get_repos(repos, FALSE, "https://example.com/repo/", "3.5") + expect_equal(res$url, c("https://example.com/repo", "https://x.com")) }) test_that("cleanup", { diff --git a/tests/testthat/test-4-async-http.R b/tests/testthat/test-4-async-http.R index 5c538a07..b1b9314c 100644 --- a/tests/testthat/test-4-async-http.R +++ b/tests/testthat/test-4-async-http.R @@ -4,7 +4,8 @@ local_clear_http_options <- function(.local_envir = parent.frame()) { "connecttimeout", "low_speed_time", "low_speed_limit", - "http_version" + "http_version", + "retry" ) opts <- c(paste0("pkgcache_", nms), paste0("pkg_http_", nms)) withr::local_options( @@ -343,12 +344,15 @@ test_that("download_files, no errors", { expect_s3_class(ret[[3]], "async_http_error") }) -test_that("set_pkgcache_curl_options", { +test_that("set_pkgcache_http_options", { local_clear_http_options() # nothing configured: leave the options untouched, no defaults added - expect_equal(set_pkgcache_curl_options(list()), list()) - expect_equal(set_pkgcache_curl_options(list(foo = "bar")), list(foo = "bar")) + expect_equal(set_pkgcache_http_options(list())$options, list()) + expect_equal( + set_pkgcache_http_options(list(foo = "bar"))$options, + list(foo = "bar") + ) # pkgcache_* options are picked up and coerced to integer withr::local_options( @@ -359,7 +363,7 @@ test_that("set_pkgcache_curl_options", { pkgcache_http_version = 2 ) expect_equal( - set_pkgcache_curl_options(list(foo = "bar")), + set_pkgcache_http_options(list(foo = "bar"))$options, list( foo = "bar", timeout = 100L, @@ -372,7 +376,7 @@ test_that("set_pkgcache_curl_options", { # an explicit option in the request wins over the pkgcache_* option expect_equal( - set_pkgcache_curl_options(list(http_version = 3))$http_version, + set_pkgcache_http_options(list(http_version = 3))$options$http_version, 3L ) @@ -385,25 +389,25 @@ test_that("set_pkgcache_curl_options", { pkgcache_http_version = NULL ) withr::local_envvar(PKGCACHE_HTTP_VERSION = "3") - expect_equal(set_pkgcache_curl_options(list())$http_version, 3L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 3L) # an unset pkgcache_* option must not add a curl option, so that the # async_http_* option and the async default still apply downstream withr::local_envvar(PKGCACHE_HTTP_VERSION = NA_character_) - expect_equal(set_pkgcache_curl_options(list()), list()) + expect_equal(set_pkgcache_http_options(list())$options, list()) }) -test_that("set_pkgcache_curl_options, pkg_http_ fallback", { +test_that("set_pkgcache_http_options, pkg_http_ fallback", { local_clear_http_options() # pkg_http_* option is used when nothing with higher priority is set withr::local_options(pkg_http_http_version = 2) - expect_equal(set_pkgcache_curl_options(list())$http_version, 2L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 2L) # PKG_HTTP_* env var is used when no option is set withr::local_options(pkg_http_http_version = NULL) withr::local_envvar(PKG_HTTP_HTTP_VERSION = "2") - expect_equal(set_pkgcache_curl_options(list())$http_version, 2L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 2L) # full precedence: pkgcache_ option > PKGCACHE_ env > pkg_http_ option > # PKG_HTTP_ env @@ -415,16 +419,49 @@ test_that("set_pkgcache_curl_options, pkg_http_ fallback", { pkgcache_http_version = 3, pkg_http_http_version = 6 ) - expect_equal(set_pkgcache_curl_options(list())$http_version, 3L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 3L) withr::local_options(pkgcache_http_version = NULL) - expect_equal(set_pkgcache_curl_options(list())$http_version, 4L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 4L) withr::local_envvar(PKGCACHE_HTTP_VERSION = NA_character_) - expect_equal(set_pkgcache_curl_options(list())$http_version, 6L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 6L) withr::local_options(pkg_http_http_version = NULL) - expect_equal(set_pkgcache_curl_options(list())$http_version, 5L) + expect_equal(set_pkgcache_http_options(list())$options$http_version, 5L) +}) + +test_that("set_pkgcache_http_options, retry", { + local_clear_http_options() + + # nothing configured and nothing passed: fall back to the default `TRUE` + expect_equal(set_pkgcache_http_options(list())$retry, TRUE) + # an explicit (non-`NULL`) retry in the request is kept as-is + expect_equal(set_pkgcache_http_options(list(), retry = FALSE)$retry, FALSE) + + # a configured retry is used when none is passed, and is coerced + withr::local_options(pkgcache_retry = 5) + expect_equal(set_pkgcache_http_options(list())$retry, 5) + + # an explicit `retry` in the request wins over the configured one + expect_equal(set_pkgcache_http_options(list(), retry = 1)$retry, 1) + + # options are used as-is, e.g. a list configuring the retry policy + withr::local_options(pkgcache_retry = list(limit = 3)) + expect_equal(set_pkgcache_http_options(list())$retry, list(limit = 3)) + + # environment variables arrive as strings and are coerced + withr::local_options(pkgcache_retry = NULL) + withr::local_envvar(PKGCACHE_RETRY = "4") + expect_equal(set_pkgcache_http_options(list())$retry, 4L) + + withr::local_envvar(PKGCACHE_RETRY = "FALSE") + expect_equal(set_pkgcache_http_options(list())$retry, FALSE) + + # pkg_http_ fallback works for retry too + withr::local_envvar(PKGCACHE_RETRY = NA_character_) + withr::local_options(pkg_http_retry = 2) + expect_equal(set_pkgcache_http_options(list())$retry, 2) }) test_that("http requests honor pkgcache_* options", { diff --git a/tests/testthat/test-5-cache.R b/tests/testthat/test-5-cache.R index dc540e7b..99c936f6 100644 --- a/tests/testthat/test-5-cache.R +++ b/tests/testthat/test-5-cache.R @@ -281,3 +281,48 @@ test_that("update_or_add, cache is current", { attr(hit2, "action") <- "Current" expect_equal(hit2, hit) }) + +test_that("corrupt db file gives helpful error", { + pc <- package_cache$new(tmp <- tempfile()) + on.exit(unlink(tmp, recursive = TRUE)) + + # corrupt the cache database file + dbfile <- get_db_file(tmp) + writeLines("this is not an RDS file", dbfile) + + err <- tryCatch(pc$list(), error = function(e) e) + # classed condition, so callers (e.g. pak) can handle it specifically + expect_s3_class(err, "pkgcache_corrupt_db_error") + expect_equal(err$dbfile, dbfile) + expect_match( + conditionMessage(err), + "cache file is possibly corrupt, call" + ) + # the original readRDS error is kept as the parent condition + expect_false(is.null(err$parent)) +}) + +test_that("can delete everything even if db file is corrupt", { + pc <- package_cache$new(tmp <- tempfile()) + on.exit(unlink(tmp, recursive = TRUE)) + cat("f1\n", file = f1 <- tempfile()) + pc$add(f1, path = file.path("src", "contrib", "p_1.0.tar.gz"), package = "p") + + # corrupt the cache database file + dbfile <- get_db_file(tmp) + writeLines("this is not an RDS file", dbfile) + + # deleting everything must still work and reset the cache + expect_silent(pc$delete()) + expect_false(file.exists(file.path(tmp, "src", "contrib", "p_1.0.tar.gz"))) + # the corrupt database file is removed, and recreated empty on demand + expect_false(file.exists(get_db_file(tmp))) + expect_equal(nrow(package_cache$new(tmp)$list()), 0L) + + # ... but a selective delete cannot, and reports the corruption + writeLines("this is not an RDS file", dbfile) + expect_error( + pc$delete(package = "p"), + "cache file is possibly corrupt, call" + ) +}) diff --git a/tests/testthat/test-platform.R b/tests/testthat/test-platform.R index 4e9ad321..c98503f6 100644 --- a/tests/testthat/test-platform.R +++ b/tests/testthat/test-platform.R @@ -4,9 +4,110 @@ if (Sys.getenv("R_COVR") == "true") { test_that("current_r_platform_data", { fake(current_r_platform_data, "get_platform", "x86_64-apple-darwin17.0") + fake(current_r_platform_data, "current_r_custom_pkg_type", NULL) expect_equal(current_r_platform_data()$platform, "x86_64-apple-darwin17.0") }) +test_that("parse_pkg_type", { + expect_snapshot({ + parse_pkg_type("source") + parse_pkg_type("win.binary") + parse_pkg_type("mac.binary") + parse_pkg_type("mac.binary.big-sur-arm64") + parse_pkg_type("windows.binary.clang-aarch64") + parse_pkg_type("windows.binary") + parse_pkg_type("linux.binary.clang19") + # not a package type: upper case, and a dot in the build + parse_pkg_type("Windows.Binary.X") + parse_pkg_type("win.binary.a.b") + }) + + expect_false(is_custom_pkg_type("source")) + expect_false(is_custom_pkg_type("win.binary")) + expect_false(is_custom_pkg_type("mac.binary")) + expect_false(is_custom_pkg_type("mac.binary.sonoma-arm64")) + expect_true(is_custom_pkg_type("windows.binary.clang-aarch64")) + expect_true(is_custom_pkg_type("windows.binary")) + expect_true(is_custom_pkg_type("linux.binary.clang19")) +}) + +test_that("pkg_type_system_for_os", { + expect_equal( + pkg_type_system_for_os(c( + "mingw32", + "darwin20", + "darwin17.0", + "linux", + "linux-gnu", + "linux-musl", + "freebsd12.1", + "solaris2.10", + NA_character_ + )), + c( + "windows", + "macosx", + "macosx", + "linux", + "linux", + "linux", + "freebsd", + "solaris", + NA_character_ + ) + ) +}) + +test_that("current_r_platform_data, custom binary package type", { + # a custom package type is added to the platform name + fake(current_r_platform_data, "get_platform", "aarch64-w64-mingw32") + fake( + current_r_platform_data, + "current_r_custom_pkg_type", + "windows.binary.clang-aarch64" + ) + expect_snapshot(current_r_platform_data()) + expect_equal( + current_r_platform_data()$platform, + "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) +}) + +test_that("current_r_platform_data, standard binary package type", { + # `win.binary` and `mac.binary.*` are not custom, nothing is added + fake(current_r_platform_data, "get_platform", "x86_64-w64-mingw32") + fake(current_r_platform_data, "current_r_custom_pkg_type", NULL) + expect_equal(current_r_platform_data()$platform, "x86_64-w64-mingw32") +}) + +test_that("current_r_custom_pkg_type", { + fake(current_r_custom_pkg_type, "current_r_pkg_type", "source") + expect_null(current_r_custom_pkg_type("mingw32")) + + fake(current_r_custom_pkg_type, "current_r_pkg_type", "win.binary") + expect_null(current_r_custom_pkg_type("mingw32")) + + fake( + current_r_custom_pkg_type, + "current_r_pkg_type", + "mac.binary.sonoma-arm64" + ) + expect_null(current_r_custom_pkg_type("darwin23")) + + fake( + current_r_custom_pkg_type, + "current_r_pkg_type", + "windows.binary.clang-aarch64" + ) + expect_equal( + current_r_custom_pkg_type("mingw32"), + "windows.binary.clang-aarch64" + ) + # the package type must belong to the platform + expect_null(current_r_custom_pkg_type("darwin23")) + expect_null(current_r_custom_pkg_type(NA_character_)) +}) + test_that("default_platforms", { fake(default_platforms, "current_r_platform", "macos") expect_equal(default_platforms(), c("macos", "source")) @@ -38,6 +139,35 @@ test_that("parse_platform", { }) }) +test_that("parse_platform, custom binary package types", { + # a package type suffix is split off first, so it can coexist with the + # Linux distribution and release + expect_snapshot({ + parse_platform(c( + "aarch64-w64-mingw32-windows.binary.clang-aarch64", + "x86_64-w64-mingw32", + "aarch64-apple-darwin23-mac.binary.sonoma-arm64", + "aarch64-w64-mingw32-windows.binary", + "x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19" + )) + }) + + # the platform name is the columns pasted together, in order + plt <- c( + "aarch64-w64-mingw32-windows.binary.clang-aarch64", + "x86_64-w64-mingw32", + "aarch64-apple-darwin23-mac.binary.sonoma-arm64", + "x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19", + "x86_64-pc-linux-gnu-ubuntu-22.04-libc++" + ) + expect_equal( + apply(parse_platform(plt), 1, function(x) { + paste0(na_omit(x), collapse = "-") + }), + plt + ) +}) + test_that("re_linux_platform", { expect_snapshot({ re_match( @@ -81,6 +211,51 @@ test_that("get_all_package_dirs", { expect_equal(res2, res3) }) +test_that("get_all_package_dirs, custom binary package types", { + # these must agree with `utils::contrib.url()` + expect_equal( + get_all_package_dirs( + "aarch64-w64-mingw32-windows.binary.clang-aarch64", + "4.7.0" + )$contriburl, + "bin/windows/clang-aarch64/contrib/4.7" + ) + expect_equal( + get_all_package_dirs( + "aarch64-apple-darwin23-mac.binary.sonoma-arm64", + "4.7.0" + )$contriburl, + "bin/macosx/sonoma-arm64/contrib/4.7" + ) + # a package type without a `` part + expect_equal( + get_all_package_dirs( + "aarch64-w64-mingw32-windows.binary", + "4.7.0" + )$contriburl, + "bin/windows/contrib/4.7" + ) + expect_equal( + get_all_package_dirs( + "x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19", + "4.7.0" + )$contriburl, + "bin/linux/clang19/contrib/4.7" + ) + + expect_snapshot( + get_all_package_dirs( + c("aarch64-w64-mingw32-windows.binary.clang-aarch64", "source"), + "4.7.0" + ) + ) + + # A platform without a package type is unchanged, in particular a plain + # `aarch64-w64-mingw32` must not be served the x86_64 binaries from + # `bin/windows/contrib`. + expect_equal(nrow(get_all_package_dirs("aarch64-w64-mingw32", "4.7.0")), 0L) +}) + test_that("get_cran_extension", { expect_equal(get_cran_extension("source"), ".tar.gz") expect_equal(get_cran_extension("windows"), ".zip") @@ -94,9 +269,52 @@ test_that("get_cran_extension", { get_cran_extension("foobar"), "_R_foobar.tar.gz" ) + expect_equal( + get_cran_extension(c( + "i386+x86_64-w64-mingw32", + "x86_64-w64-mingw32", + "i386-w64-mingw32" + )), + c(".zip", ".zip", ".zip") + ) }) -test_that("get_all_package_dirs", { +test_that("get_cran_extension, custom binary package types", { + # `R CMD INSTALL --build` creates a `.zip` on Windows and a `.tgz` on + # macOS, also for a custom package type + expect_equal( + get_cran_extension("aarch64-w64-mingw32-windows.binary.clang-aarch64"), + ".zip" + ) + expect_equal( + get_cran_extension("aarch64-w64-mingw32-windows.binary"), + ".zip" + ) + expect_equal( + get_cran_extension("aarch64-apple-darwin23-mac.binary.sonoma-arm64"), + ".tgz" + ) + # Linux is not special cased, so we get the same fallback as for a Linux + # platform without a package type. Repositories serving Linux binaries + # include a `File` field in `PACKAGES`, so this is rarely used. + expect_equal( + get_cran_extension("x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19"), + "_R_x86_64-pc-linux-gnu-ubuntu-24.04-linux.binary.clang19.tar.gz" + ) + + # mixed with platforms that have no package type + expect_equal( + get_cran_extension(c( + "source", + "aarch64-w64-mingw32-windows.binary.clang-aarch64", + "x86_64-pc-linux-musl", + "x86_64-apple-darwin17.0" + )), + c(".tar.gz", ".zip", "_R_x86_64-pc-linux-musl.tar.gz", ".tgz") + ) +}) + +test_that("get_all_package_dirs 2", { if (grepl("^aarch64-apple-", R.version$platform)) { skip("M1") } @@ -279,10 +497,16 @@ test_that("valid_platform_string", { expect_true(valid_platform_string("foo-bar-cup")) expect_true(valid_platform_string("foo-bar-cup-boo")) + expect_true(valid_platform_string( + "aarch64-w64-mingw32-windows.binary.clang-aarch64" + )) + expect_false(valid_platform_string("-a-b-c")) expect_false(valid_platform_string("a---c")) expect_false(valid_platform_string("foo-bar")) expect_false(valid_platform_string("foobar")) + # a bare package type is not a platform name + expect_false(valid_platform_string("windows.binary.clang-aarch64")) }) test_that("option, env var", { @@ -318,3 +542,32 @@ test_that("platform with flavors", { expect_snapshot(current_r_platform_data()) expect_snapshot(current_r_platform()) }) + +test_that("forced platform with a custom binary package type", { + withr::local_options( + pkg.current_platform = "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) + expect_snapshot(current_r_platform_data()) + expect_equal( + current_r_platform(), + "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) + + withr::local_options(pkg.current_platform = NULL) + withr::local_envvar( + PKG_CURRENT_PLATFORM = "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) + expect_equal( + current_r_platform(), + "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) +}) + +test_that("forced platform without a distribution", { + # the unset distribution and release must not end up in the platform name + withr::local_options(pkg.current_platform = "x86_64-pc-linux-gnu") + expect_equal(current_r_platform(), "x86_64-pc-linux-gnu") + + withr::local_options(pkg.current_platform = "x86_64-pc-linux-gnu-ubuntu") + expect_equal(current_r_platform(), "x86_64-pc-linux-gnu-ubuntu") +}) diff --git a/tests/testthat/test-ppm-sso.R b/tests/testthat/test-ppm-sso.R new file mode 100644 index 00000000..31d81f9f --- /dev/null +++ b/tests/testthat/test-ppm-sso.R @@ -0,0 +1,231 @@ +local_token_path <- function(envir = parent.frame()) { + tmp <- withr::local_tempdir(.local_envir = envir) + path <- file.path(tmp, ".ppm", "tokens.toml") + fake( + ppm_sso_write_token_to_file, + "ppm_sso_token_path", + function() path, + envir + ) + path +} + +read_connections <- function(path) { + tokens <- suppressWarnings(tstoml::ts_read_toml(path)) + tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("connections", TRUE)) + ) +} + +test_that("ppm_sso_write_token_to_file: token file does not exist", { + path <- local_token_path() + expect_false(file.exists(path)) + + ppm_sso_write_token_to_file("https://ppm.example.com", "tkn1") + + expect_true(file.exists(path)) + conns <- read_connections(path) + expect_equal( + conns, + list(list( + address = "https://ppm.example.com", + token = "tkn1", + auth_type = "sso" + )) + ) +}) + +test_that("ppm_sso_write_token_to_file: token file is empty", { + path <- local_token_path() + mkdirp(dirname(path)) + file.create(path) + + ppm_sso_write_token_to_file("https://ppm.example.com", "tkn1") + + conns <- read_connections(path) + expect_equal( + conns, + list(list( + address = "https://ppm.example.com", + token = "tkn1", + auth_type = "sso" + )) + ) +}) + +test_that("ppm_sso_write_token_to_file: non-empty file, creating connections table", { + path <- local_token_path() + mkdirp(dirname(path)) + writeLines( + c( + "top_level = \"keep me\"", + "", + "[meta]", + "version = 1" + ), + path + ) + + ppm_sso_write_token_to_file("https://ppm.example.com", "tkn1") + + tokens <- suppressWarnings(tstoml::ts_read_toml(path)) + conns <- tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("connections", TRUE)) + ) + expect_equal( + conns, + list(list( + address = "https://ppm.example.com", + token = "tkn1", + auth_type = "sso" + )) + ) + expect_equal( + tsitter::ts_tree_unserialize(tsitter::ts_tree_select(tokens, "top_level"))[[ + 1 + ]], + "keep me" + ) + expect_equal( + tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("meta", "version")) + )[[1]], + 1L + ) +}) + +test_that("ppm_sso_write_token_to_file: appending to existing connections table", { + path <- local_token_path() + mkdirp(dirname(path)) + writeLines( + c( + "[[connections]]", + "address = \"https://other.example.com\"", + "token = \"other-tkn\"", + "auth_type = \"sso\"" + ), + path + ) + + ppm_sso_write_token_to_file("https://ppm.example.com", "tkn1") + + conns <- read_connections(path) + expect_equal( + conns, + list( + list( + address = "https://other.example.com", + token = "other-tkn", + auth_type = "sso" + ), + list( + address = "https://ppm.example.com", + token = "tkn1", + auth_type = "sso" + ) + ) + ) +}) + +test_that("ppm_sso_write_token_to_file: updating existing entry", { + path <- local_token_path() + mkdirp(dirname(path)) + writeLines( + c( + "[[connections]]", + "address = \"https://ppm.example.com\"", + "token = \"old-tkn\"", + "auth_type = \"sso\"" + ), + path + ) + + ppm_sso_write_token_to_file("https://ppm.example.com", "new-tkn") + + conns <- read_connections(path) + expect_equal( + conns, + list(list( + address = "https://ppm.example.com", + token = "new-tkn", + auth_type = "sso" + )) + ) +}) + +test_that("ppm_sso_write_token_to_file: updating preserves extra data", { + path <- local_token_path() + mkdirp(dirname(path)) + writeLines( + c( + "top_level = \"keep me\"", + "", + "[[connections]]", + "address = \"https://other.example.com\"", + "token = \"other-tkn\"", + "auth_type = \"sso\"", + "extra = \"keep this too\"", + "", + "[[connections]]", + "address = \"https://ppm.example.com\"", + "token = \"old-tkn\"", + "auth_type = \"sso\"", + "user = \"alice\"", + "", + "[meta]", + "version = 1" + ), + path + ) + + ppm_sso_write_token_to_file("https://ppm.example.com", "new-tkn") + + tokens <- suppressWarnings(tstoml::ts_read_toml(path)) + conns <- tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("connections", TRUE)) + ) + expect_equal( + conns, + list( + list( + address = "https://other.example.com", + token = "other-tkn", + auth_type = "sso", + extra = "keep this too" + ), + list( + address = "https://ppm.example.com", + token = "new-tkn", + auth_type = "sso", + user = "alice" + ) + ) + ) + expect_equal( + tsitter::ts_tree_unserialize(tsitter::ts_tree_select(tokens, "top_level"))[[ + 1 + ]], + "keep me" + ) + expect_equal( + tsitter::ts_tree_unserialize( + tsitter::ts_tree_select(tokens, list("meta", "version")) + )[[1]], + 1L + ) +}) + +test_that("ppm_sso_device_flow works against a fake PPM app", { + srv <- webfakes::local_app_process(ppm_sso_app()) + withr::local_options("rlib.interactive" = FALSE) + ppm_url <- sub("/$", "", srv$url()) + + token <- suppressMessages(ppm_sso_device_flow(ppm_url)) + + expect_type(token, "character") + jwt <- jwt_split(token) + expect_equal(jwt$payload$iss, "https://ppm-sso-local.invalid/") + expect_equal(jwt$payload$sub, "ppm-sso-local-user") + expect_equal(jwt$payload$aud, "ppm-sso-local") + expect_true(jwt$payload$exp > unclass(Sys.time())) +}) diff --git a/tests/testthat/test-repo-status.R b/tests/testthat/test-repo-status.R index cfd1044a..bfe0a6b6 100644 --- a/tests/testthat/test-repo-status.R +++ b/tests/testthat/test-repo-status.R @@ -57,10 +57,6 @@ test_that("bioc repo status", { }) test_that("repo with binary packages", { - if (getRversion() < "4.2.0" || getRversion() >= "4.3.0") { - skip("Need R 4.2.x") - } - withr::local_options(width = 1000) platforms <- c("aarch64-apple-darwin20", "source") @@ -88,6 +84,64 @@ test_that("repo with binary packages", { ) }) +test_that("repo with custom binary package type", { + withr::local_options(width = 1000) + + platforms <- c( + "aarch64-w64-mingw32-windows.binary.clang-aarch64", + "source" + ) + fake_cran <- webfakes::local_app_process( + cran_app( + cran_app_pkgs, + options = list(platforms = platforms, r_version = "4.7") + ), + opts = webfakes::server_opts(num_threads = 3) + ) + withr::local_options(repos = c(CRAN = fake_cran$url())) + + expect_snapshot( + { + stat <- repo_status( + platforms = platforms, + r_version = "4.7", + bioc = FALSE + ) + stat$ping[stat$ok] <- 0.1 + stat + }, + transform = fix_port_number + ) + + # the metadata must list the binaries, with a target that exists + cmc <- cranlike_metadata_cache$new( + platforms = platforms, + r_version = "4.7", + bioc = FALSE, + cran_mirror = fake_cran$url(), + primary_path = withr::local_tempdir(), + replica_path = withr::local_tempdir() + ) + pkgs <- cmc$list() + bin <- pkgs[pkgs$platform != "source", ] + expect_true(nrow(bin) > 0) + expect_equal( + unique(bin$platform), + "aarch64-w64-mingw32-windows.binary.clang-aarch64" + ) + expect_true(all(startsWith( + bin$target, + "bin/windows/clang-aarch64/contrib/4.7/" + ))) + expect_true(all(grepl("[.]zip$", bin$target))) + + # and the files are really there + urls <- paste0(fake_cran$url(), sub("^/", "", bin$target)) + for (u in urls) { + expect_equal(curl::curl_fetch_memory(u)$status_code, 200L) + } +}) + cli::test_that_cli(config = "fancy", "repo_status unicode output", { setup_fake_apps() withr::local_options( diff --git a/tools/README-body.Rmd b/tools/README-body.Rmd index 4ed8f3b6..2f8b9d32 100644 --- a/tools/README-body.Rmd +++ b/tools/README-body.Rmd @@ -138,6 +138,10 @@ Bioconductor support. so e.g. `2` forces HTTP/1.1 and `0` lets libcurl choose. It defaults to HTTP/1.1, because HTTP/2 has caused transport-level failures with some client and server combinations. +- `pkgcache_retry` configures whether and how failed HTTP requests are + retried. It is either a number, to set the maximum number of retries, or + `TRUE` (the default) or `FALSE` to enable or disable retries. It can also + be a named list for finer control over the retry policy. ## Package environment variables @@ -150,7 +154,7 @@ Bioconductor support. - You can use the `PKG_CURRENT_PLATFORM` environment variable to set the platform string for the current platform for the `current_r_platform()` function. This is useful if pkgcache didn't detect the platform correctly. - Alternatively, you can use the `pkg.current_platofrm` option, which takes. + Alternatively, you can use the `pkg.current_platform` option, which takes priority over the environment variable. - `PKGCACHE_PPM_REPO` is the name of the Posit Package Manager repository to use. Defaults to `"cran"`. @@ -179,6 +183,10 @@ Bioconductor support. HTTP/1.1, because HTTP/2 has caused transport-level failures with some client and server combinations. The `pkgcache_http_version` option has priority over this, if set. +- `PKGCACHE_RETRY` configures whether and how failed HTTP requests are + retried. It is either a number, to set the maximum number of retries, or + `TRUE` (the default) or `FALSE` to enable or disable retries. The + `pkgcache_retry` option has priority over this, if set. - `R_PKG_CACHE_DIR` is used for the cache directory, if set. (Otherwise `tools::R_user_dir("pkgcache", "cache")` is used, see also `meta_cache_summary()` and `pkg_cache_summary()`). diff --git a/vignettes/internals.Rmd b/vignettes/internals.Rmd index 77ca5172..7acba2dd 100644 --- a/vignettes/internals.Rmd +++ b/vignettes/internals.Rmd @@ -57,5 +57,44 @@ In light of these, this is what we do: - For `i386+x86_64-w64-mingw32` on 32 bit R, we compile for both 32 bit and 64 bit. -In summary, when compiling packages, we compile for both archs, except if +In summary, when compiling packages, we compile for both archs, except if we are in a 64 bit R session and the platform is `x86_64-w64-mingw32`. + +#### Custom binary package types + +From R 4.6.0 `.Platform$pkgType` may be a custom binary package type of the +form `.binary.`, where `` is the lower case name of +the system and `` is the name of the build. +The author of a binary R distribution sets this with the +`R_PLATFORM_PKGTYPE` environment variable. +The matching repository layout, from `utils::contrib.url()`, is +`bin///contrib/`, with `mac` mapped to `macosx` and +`win` mapped to `windows`. +This is a generalization of the `mac.binary.` types that macOS has +been using for a long time. + +In light of this, this is what we do: + +- The platform name is the usual `cpu-vendor-os` platform string, with the + package type appended, e.g. + `aarch64-w64-mingw32-windows.binary.clang-aarch64` for Windows on arm64. + Two different builds of R for the same platform triple must remain + distinguishable, and the platform triple on its own cannot do that. +- We keep the literal `.binary` in the platform name. + It makes it clear that the suffix is a `.Platform$pkgType`, and it is a + reliable anchor when parsing a platform name, because no other part of a + platform name may contain it. + This is what makes a package type work together with the Linux + distribution and release parts of a platform name. +- We only append the package type if it is a *custom* one, i.e. not + `win.binary` and not `mac.binary[.]`. + pkgcache has always had platform names for those, so the platform names + on Windows and macOS do not change. +- The file extension follows ``: `.zip` for `windows` and `.tgz` + for `macosx`, the same as `R CMD INSTALL --build` produces, no matter + whether the package type is a custom one. +- A platform name without a package type is unchanged. + In particular a plain `aarch64-w64-mingw32` must not be served the + x86_64 binaries from `bin/windows/contrib`. +- A package type on its own is not a valid platform name, it needs the + platform triple as well.