From 265c48a4f6763fad7dc16c45d733571b05bf5f3b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 12:40:38 +0200 Subject: [PATCH 01/28] Copy over SSO code from pak --- DESCRIPTION | 3 + R/ppm-sso.R | 446 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 449 insertions(+) create mode 100644 R/ppm-sso.R diff --git a/DESCRIPTION b/DESCRIPTION index af155a8..aeceb45 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,9 +29,12 @@ Suggests: debugme, desc, fs, + httr2, keyring, + openssl, pillar, pingr, + RcppTOML, rprojroot, sessioninfo, spelling, diff --git a/R/ppm-sso.R b/R/ppm-sso.R new file mode 100644 index 0000000..ac73bb1 --- /dev/null +++ b/R/ppm-sso.R @@ -0,0 +1,446 @@ +ppm_sso_data <- new.env(parent = emptyenv()) +ppm_sso_data$name <- "ppm" +ppm_sso_data$viable <- FALSE + +ppm_sso_init <- function(url = NULL) { + url <- url %||% Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + if (!is_string(url)) { + stop( + "Please set the PACKAGEMANAGER_ADDRESS environment variable to ", + "the URL of your RStudio Package Manager instance." + ) + } + + parsed_url <- regmatches( + url, + regexec("^(?:https?://)?([^/]+)", url) + )[[1]] + if (length(parsed_url) < 2) { + stop("Invalid Package Manager URL: ", url) + } + + ppm_sso_data$ppm_url <- url + ppm_sso_data$service_name <- parsed_url[2] + ppm_sso_data$token_file_path <- file.path( + path.expand("~"), + ".ppm", + "tokens.toml" + ) + ppm_sso_data$viable <- TRUE +} + +ppm_sso_login <- function(service = NULL) { + service <- service %||% + ppm_sso_data$ppm_url %||% + Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + if (!ppm_sso_data$viable) { + ppm_sso_init() + } + + if (!ppm_are_requirements_valid(service)) { + stop( + "Package Manager SSO is not properly configured. Please ensure that ", + "the PACKAGEMANAGER_ADDRESS environment variable is set to the URL of ", + "your Posit Package Manager instance." + ) + } + + existing_token <- ppm_sso_get_existing_token() + if (!is.null(existing_token) && ppm_sso_can_authenticate(existing_token)) { + return(existing_token) + } + + identity_token <- ppm_sso_get_identity_token_from_file() %||% + ppm_sso_device_flow() + ppm_token <- ppm_sso_identity_to_ppm_token(identity_token) + ppm_sso_write_token_to_file(ppm_token) + + ppm_token +} + +ppm_are_requirements_valid <- function(service) { + is_string(ppm_sso_data$ppm_url) && startsWith(service, ppm_sso_data$ppm_url) +} + +ppm_sso_get_existing_token <- function() { + if (!file.exists(ppm_sso_data$token_file_path)) { + return(NULL) + } + tryCatch( + { + tokens_data <- RcppTOML::parseTOML(ppm_sso_data$token_file_path) + for (conn in tokens_data$connection) { + if (identical(conn$url, ppm_sso_data$ppm_url)) { + return(conn$token) + } + } + }, + error = function(e) { + NULL + } + ) +} + +ppm_sso_can_authenticate <- function(token) { + req <- httr2::request(ppm_sso_data$ppm_url) |> + httr2::req_auth_bearer_token(token) |> + httr2::req_error(is_error = function(resp) FALSE) # Handle errors manually + + resp <- httr2::req_perform(req) + + status <- httr2::resp_status(resp) + status < 500 && status != 401 && status != 403 +} + +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) + } + + tryCatch( + { + trimws(readLines(token_file, n = 1, warn = FALSE)) + }, + error = function(e) { + NULL + } + ) +} + +ppm_sso_device_flow <- function() { + verifier <- ppm_sso_new_pkce_verifier() + challenge <- ppm_sso_new_pkce_challenge(verifier) + + # 1. Initiate Device Auth + init_url <- paste0(ppm_sso_data$ppm_url, "/__api__/device") + payload <- list( + code_challenge_method = "S256", + code_challenge = challenge + ) + init_resp_body <- httr2::request(init_url) |> + httr2::req_body_form(!!!payload) |> + httr2::req_perform() |> + httr2::resp_body_json() + + 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.") + } + + message("\nPlease open the following URL in your browser:") + message(paste(" ", display_uri)) + message("\nAnd enter the following code when prompted:") + message(paste(" ", init_resp_body$user_code)) + message("\nWaiting for authorization...") + + try(utils::browseURL(display_uri), silent = TRUE) + + # 2. Poll for token + token_resp_body <- ppm_sso_complete_device_auth( + init_resp_body$device_code, + verifier, + init_resp_body$interval %||% 5, + init_resp_body$expires_in %||% 300 + ) + + if (is.null(token_resp_body) || is.null(token_resp_body$id_token)) { + stop("Failed to complete device authorization or obtain identity token.") + } + + token_resp_body$id_token +} + +ppm_sso_identity_to_ppm_token <- function(identity_token) { + url <- paste0(ppm_sso_data$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 <- httr2::request(url) |> + httr2::req_body_form(!!!payload) |> + httr2::req_perform() + + token_data <- httr2::resp_body_json(resp) + 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(token) { + dir.create( + dirname(ppm_sso_data$token_file_path), + showWarnings = FALSE, + recursive = TRUE + ) + + new_connection <- list( + url = ppm_sso_data$ppm_url, + token = token, + method = "sso" + ) + + existing_data <- if (file.exists(ppm_sso_data$token_file_path)) { + tryCatch( + RcppTOML::parseTOML(ppm_sso_data$token_file_path), + error = function(e) { + list(connection = list()) + } + ) + } else { + list(connection = list()) + } + + # Find and update existing entry or add a new one + found <- FALSE + if ( + !is.null(existing_data$connection) && length(existing_data$connection) > 0 + ) { + for (i in seq_along(existing_data$connection)) { + if (identical(existing_data$connection[[i]]$url, ppm_sso_data$ppm_url)) { + existing_data$connection[[i]] <- new_connection + found <- TRUE + break + } + } + } + + if (!found) { + existing_data$connection <- c( + existing_data$connection, + list(new_connection) + ) + } + + # Manually construct TOML output + output_lines <- c() + for (conn in existing_data$connection) { + output_lines <- c( + output_lines, + "[[connection]]", + paste0("url = \"", conn$url, "\""), + paste0("token = \"", conn$token, "\""), + paste0("method = \"", conn$method, "\""), + "" + ) + } + writeLines(output_lines, ppm_sso_data$token_file_path) +} + +ppm_sso_base64url_encode <- function(x) { + encoded <- openssl::base64_encode(x) + # Make it URL-safe + gsub("\\+", "-", gsub("\\/", "_", gsub("=+$", "", encoded))) +} + +ppm_sso_new_pkce_verifier <- function() { + ppm_sso_base64url_encode(openssl::rand_bytes(32)) +} + +ppm_sso_new_pkce_challenge <- function(verifier) { + hash <- openssl::sha256(charToRaw(verifier)) + ppm_sso_base64url_encode(hash) +} + +ppm_sso_complete_device_auth = function( + device_code, + verifier, + interval, + expires_in +) { + url <- paste0(ppm_sso_data$ppm_url, "/__api__/device_access") + start_time <- Sys.time() + payload <- list( + device_code = device_code, + code_verifier = verifier + ) + + while (as.numeric(Sys.time() - start_time) < expires_in) { + resp <- httr2::request(url) |> + httr2::req_body_form(!!!payload) |> + httr2::req_error(is_error = \(resp) FALSE) |> # Handle errors manually + httr2::req_perform() + + status <- httr2::resp_status(resp) + + if (status == 200) { + return(httr2::resp_body_json(resp)) + } else if (status == 400) { + error_data <- httr2::resp_body_json(resp) + error_code <- error_data$error + if (error_code == "access_denied") { + stop("Access denied by user.") + } + if (error_code == "expired_token") { + stop("Device authorization request expired.") + } + # For "authorization_pending" or "slow_down", just wait and retry. + } else { + httr2::resp_check_status(resp) + } + + Sys.sleep(interval) + } + + stop("Device authorization timed out.") +} + +# 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_fake_app <- function( + auth0_domain, + client_id, + audience = NULL, + scope = "openid profile email" +) { + 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 + ) + if (!is.null(app$locals$audience)) { + payload$audience <- app$locals$audience + } + + upstream <- httr2::request( + paste0("https://", app$locals$auth0_domain, "/oauth/device/code") + ) |> + httr2::req_body_form(!!!payload) |> + httr2::req_error(is_error = function(r) FALSE) |> + httr2::req_perform() + + body <- httr2::resp_body_json(upstream) + if (httr2::resp_status(upstream) >= 400L) { + return(res$set_status(httr2::resp_status(upstream))$send_json( + auto_unbox = TRUE, + body + )) + } + + assign(body$device_code, challenge, envir = app$locals$challenges) + + res$send_json( + auto_unbox = TRUE, + list( + device_code = body$device_code, + user_code = body$user_code, + verification_uri = body$verification_uri, + verification_uri_complete = body$verification_uri_complete, + expires_in = body$expires_in, + interval = 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(openssl::sha256(charToRaw(verifier))) + if (!identical(expected, actual)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "invalid_grant") + )) + } + + upstream <- httr2::request( + paste0("https://", app$locals$auth0_domain, "/oauth/token") + ) |> + httr2::req_body_form( + grant_type = "urn:ietf:params:oauth:grant-type:device_code", + device_code = device_code, + client_id = app$locals$client_id + ) |> + httr2::req_error(is_error = function(r) FALSE) |> + httr2::req_perform() + + body <- httr2::resp_body_json(upstream) + if (httr2::resp_status(upstream) == 200L) { + rm(list = device_code, envir = app$locals$challenges) + return(res$send_json( + auto_unbox = TRUE, + list(id_token = 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 = 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" + ) + ) + }) + + app +} + +# nocov end From 13bfbdffd5e423a73491de96ee91d84acfb1cc49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 13:25:13 +0200 Subject: [PATCH 02/28] Wire up PPM SSO auth --- R/auth.R | 43 +++++++++++++++++++++++++++++++++++++------ 1 file changed, 37 insertions(+), 6 deletions(-) diff --git a/R/auth.R b/R/auth.R index 5b9baf6..bd6511f 100644 --- a/R/auth.R +++ b/R/auth.R @@ -83,7 +83,9 @@ repo_auth <- function( url <- res$url[w] if (check_credentials) { cred <- repo_auth_headers(url, warn = FALSE) - if (is.null(cred)) next + if (is.null(cred)) { + next + } res$username[w] <- cred$username res$has_password[w] <- cred$found res$auth_domains[w] <- list(cred$auth_domains) @@ -197,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)) { @@ -315,7 +325,9 @@ parse_url_basic_auth <- function(url) { add_auth_status <- function(repos) { maybe_has_auth <- grepl("^https?://[^/]*@", repos$url) - if (!any(maybe_has_auth)) return(repos) + if (!any(maybe_has_auth)) { + return(repos) + } key <- random_key() on.exit(clear_auth_cache(key), add = TRUE) @@ -326,7 +338,9 @@ add_auth_status <- function(repos) { for (w in which(maybe_has_auth)) { url <- repos$url[w] creds <- repo_auth_headers(url, warn = FALSE) - if (is.null(creds)) next + if (is.null(creds)) { + next + } repos$username[w] <- creds$username repos$has_password[w] <- creds$found } @@ -342,7 +356,9 @@ repo_auth_netrc <- function(host, username) { netrc_path <- path.expand("~/_netrc") } } - if (!file.exists(netrc_path)) return(NULL) + if (!file.exists(netrc_path)) { + return(NULL) + } # netrc files do not allow port numbers host <- sub(":[0-9]+$", "", host) @@ -453,3 +469,18 @@ 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 <- try_catch_null(ppm_sso_login(service = repourl)) + + token +} From 3be1c0e260ee75425d144e43d86c405b303b8613 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 14:20:46 +0200 Subject: [PATCH 03/28] Rewrite ppm_sso_app w/o httr2 --- R/ppm-sso-app.R | 169 ++++++++++++++++++++++++++++++++++++++++++++++++ R/ppm-sso.R | 155 -------------------------------------------- 2 files changed, 169 insertions(+), 155 deletions(-) create mode 100644 R/ppm-sso-app.R diff --git a/R/ppm-sso-app.R b/R/ppm-sso-app.R new file mode 100644 index 0000000..e852a55 --- /dev/null +++ b/R/ppm-sso-app.R @@ -0,0 +1,169 @@ +# 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_app <- function( + auth0_domain, + client_id, + audience = NULL, + scope = "openid profile email" +) { + 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 + + 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 = jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE) + ) + } + + # 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 <- 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(openssl::sha256(charToRaw(verifier))) + if (!identical(expected, actual)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "invalid_grant") + )) + } + + upstream <- 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" + ) + ) + }) + + app +} + +# nocov end diff --git a/R/ppm-sso.R b/R/ppm-sso.R index ac73bb1..e1f3d8d 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -289,158 +289,3 @@ ppm_sso_complete_device_auth = function( stop("Device authorization timed out.") } - -# 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_fake_app <- function( - auth0_domain, - client_id, - audience = NULL, - scope = "openid profile email" -) { - 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 - ) - if (!is.null(app$locals$audience)) { - payload$audience <- app$locals$audience - } - - upstream <- httr2::request( - paste0("https://", app$locals$auth0_domain, "/oauth/device/code") - ) |> - httr2::req_body_form(!!!payload) |> - httr2::req_error(is_error = function(r) FALSE) |> - httr2::req_perform() - - body <- httr2::resp_body_json(upstream) - if (httr2::resp_status(upstream) >= 400L) { - return(res$set_status(httr2::resp_status(upstream))$send_json( - auto_unbox = TRUE, - body - )) - } - - assign(body$device_code, challenge, envir = app$locals$challenges) - - res$send_json( - auto_unbox = TRUE, - list( - device_code = body$device_code, - user_code = body$user_code, - verification_uri = body$verification_uri, - verification_uri_complete = body$verification_uri_complete, - expires_in = body$expires_in, - interval = 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(openssl::sha256(charToRaw(verifier))) - if (!identical(expected, actual)) { - return(res$set_status(400L)$send_json( - auto_unbox = TRUE, - list(error = "invalid_grant") - )) - } - - upstream <- httr2::request( - paste0("https://", app$locals$auth0_domain, "/oauth/token") - ) |> - httr2::req_body_form( - grant_type = "urn:ietf:params:oauth:grant-type:device_code", - device_code = device_code, - client_id = app$locals$client_id - ) |> - httr2::req_error(is_error = function(r) FALSE) |> - httr2::req_perform() - - body <- httr2::resp_body_json(upstream) - if (httr2::resp_status(upstream) == 200L) { - rm(list = device_code, envir = app$locals$challenges) - return(res$send_json( - auto_unbox = TRUE, - list(id_token = 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 = 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" - ) - ) - }) - - app -} - -# nocov end From 60a20ac518eb41351f9222c7dc6604db517188ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 14:23:41 +0200 Subject: [PATCH 04/28] Avoid |> --- R/ppm-sso.R | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index e1f3d8d..183ac7e 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -82,9 +82,10 @@ ppm_sso_get_existing_token <- function() { } ppm_sso_can_authenticate <- function(token) { - req <- httr2::request(ppm_sso_data$ppm_url) |> - httr2::req_auth_bearer_token(token) |> - httr2::req_error(is_error = function(resp) FALSE) # Handle errors manually + req <- httr2::request(ppm_sso_data$ppm_url) + req <- httr2::req_auth_bearer_token(req, token) + # Handle errors manually + req <- httr2::req_error(req, is_error = function(resp) FALSE) resp <- httr2::req_perform(req) @@ -118,10 +119,9 @@ ppm_sso_device_flow <- function() { code_challenge_method = "S256", code_challenge = challenge ) - init_resp_body <- httr2::request(init_url) |> - httr2::req_body_form(!!!payload) |> - httr2::req_perform() |> - httr2::resp_body_json() + init_req <- httr2::request(init_url) + init_req <- httr2::req_body_form(init_req, !!!payload) + init_resp_body <- httr2::resp_body_json(httr2::req_perform(init_req)) display_uri <- init_resp_body$verification_uri_complete %||% init_resp_body$verification_uri @@ -160,9 +160,9 @@ ppm_sso_identity_to_ppm_token <- function(identity_token) { subject_token_type = "urn:ietf:params:oauth:token-type:id_token" ) - resp <- httr2::request(url) |> - httr2::req_body_form(!!!payload) |> - httr2::req_perform() + req <- httr2::request(url) + req <- httr2::req_body_form(req, !!!payload) + resp <- httr2::req_perform(req) token_data <- httr2::resp_body_json(resp) if (is.null(token_data$access_token)) { @@ -261,10 +261,11 @@ ppm_sso_complete_device_auth = function( ) while (as.numeric(Sys.time() - start_time) < expires_in) { - resp <- httr2::request(url) |> - httr2::req_body_form(!!!payload) |> - httr2::req_error(is_error = \(resp) FALSE) |> # Handle errors manually - httr2::req_perform() + req <- httr2::request(url) + req <- httr2::req_body_form(req, !!!payload) + # Handle errors manually + req <- httr2::req_error(req, is_error = function(resp) FALSE) + resp <- httr2::req_perform(req) status <- httr2::resp_status(resp) From 7cc7abfaa6b3215ec8519ca96e79e26b24b94736 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 14:29:37 +0200 Subject: [PATCH 05/28] Use httr2 instead of curl --- DESCRIPTION | 1 - R/ppm-sso-app.R | 27 ++---------------- R/ppm-sso.R | 76 ++++++++++++++++++++++++++++++++----------------- 3 files changed, 52 insertions(+), 52 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index aeceb45..665b20c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -29,7 +29,6 @@ Suggests: debugme, desc, fs, - httr2, keyring, openssl, pillar, diff --git a/R/ppm-sso-app.R b/R/ppm-sso-app.R index e852a55..351c0b6 100644 --- a/R/ppm-sso-app.R +++ b/R/ppm-sso-app.R @@ -21,29 +21,6 @@ ppm_sso_app <- function( app$locals$audience <- audience app$locals$scope <- scope - 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 = jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE) - ) - } - # Bearer-token check used by ppm_sso_can_authenticate(): any token passes. app$get("/", function(req, res) { res$set_status(200L)$send("ok") @@ -65,7 +42,7 @@ ppm_sso_app <- function( audience = app$locals$audience ) - upstream <- post_form( + upstream <- ppm_sso_post_form( paste0("https://", app$locals$auth0_domain, "/oauth/device/code"), payload ) @@ -115,7 +92,7 @@ ppm_sso_app <- function( )) } - upstream <- post_form( + upstream <- ppm_sso_post_form( paste0("https://", app$locals$auth0_domain, "/oauth/token"), list( grant_type = "urn:ietf:params:oauth:grant-type:device_code", diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 183ac7e..6e3daa2 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -2,6 +2,29 @@ ppm_sso_data <- new.env(parent = emptyenv()) ppm_sso_data$name <- "ppm" ppm_sso_data$viable <- FALSE +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 = jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE) + ) +} + ppm_sso_init <- function(url = NULL) { url <- url %||% Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) if (!is_string(url)) { @@ -82,14 +105,10 @@ ppm_sso_get_existing_token <- function() { } ppm_sso_can_authenticate <- function(token) { - req <- httr2::request(ppm_sso_data$ppm_url) - req <- httr2::req_auth_bearer_token(req, token) - # Handle errors manually - req <- httr2::req_error(req, is_error = function(resp) FALSE) - - resp <- httr2::req_perform(req) - - status <- httr2::resp_status(resp) + h <- curl::new_handle() + curl::handle_setheaders(h, "Authorization" = paste("Bearer", token)) + resp <- curl::curl_fetch_memory(ppm_sso_data$ppm_url, handle = h) + status <- resp$status_code status < 500 && status != 401 && status != 403 } @@ -119,9 +138,15 @@ ppm_sso_device_flow <- function() { code_challenge_method = "S256", code_challenge = challenge ) - init_req <- httr2::request(init_url) - init_req <- httr2::req_body_form(init_req, !!!payload) - init_resp_body <- httr2::resp_body_json(httr2::req_perform(init_req)) + 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 @@ -160,11 +185,16 @@ ppm_sso_identity_to_ppm_token <- function(identity_token) { subject_token_type = "urn:ietf:params:oauth:token-type:id_token" ) - req <- httr2::request(url) - req <- httr2::req_body_form(req, !!!payload) - resp <- httr2::req_perform(req) + 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 <- httr2::resp_body_json(resp) + token_data <- resp$body if (is.null(token_data$access_token)) { stop("Failed to exchange identity token for PPM token.") } @@ -261,19 +291,13 @@ ppm_sso_complete_device_auth = function( ) while (as.numeric(Sys.time() - start_time) < expires_in) { - req <- httr2::request(url) - req <- httr2::req_body_form(req, !!!payload) - # Handle errors manually - req <- httr2::req_error(req, is_error = function(resp) FALSE) - resp <- httr2::req_perform(req) - - status <- httr2::resp_status(resp) + resp <- ppm_sso_post_form(url, payload) + status <- resp$status if (status == 200) { - return(httr2::resp_body_json(resp)) + return(resp$body) } else if (status == 400) { - error_data <- httr2::resp_body_json(resp) - error_code <- error_data$error + error_code <- resp$body$error if (error_code == "access_denied") { stop("Access denied by user.") } @@ -282,7 +306,7 @@ ppm_sso_complete_device_auth = function( } # For "authorization_pending" or "slow_down", just wait and retry. } else { - httr2::resp_check_status(resp) + stop("Device authorization failed (HTTP ", status, ").") } Sys.sleep(interval) From 3179a85b2661689a7f0a2a3dff13c388ee979eac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Fri, 8 May 2026 15:04:02 +0200 Subject: [PATCH 06/28] Avoid openssl dependency --- DESCRIPTION | 1 - R/ppm-sso-app.R | 2 +- R/ppm-sso.R | 16 +++++++--- src/init.c | 2 ++ src/pkgcache.h | 2 ++ src/rand.c | 85 +++++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 102 insertions(+), 6 deletions(-) create mode 100644 src/rand.c diff --git a/DESCRIPTION b/DESCRIPTION index 665b20c..a03611b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -30,7 +30,6 @@ Suggests: desc, fs, keyring, - openssl, pillar, pingr, RcppTOML, diff --git a/R/ppm-sso-app.R b/R/ppm-sso-app.R index 351c0b6..79b2f78 100644 --- a/R/ppm-sso-app.R +++ b/R/ppm-sso-app.R @@ -84,7 +84,7 @@ ppm_sso_app <- function( envir = app$locals$challenges, inherits = FALSE ) - actual <- ppm_sso_base64url_encode(openssl::sha256(charToRaw(verifier))) + actual <- ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) if (!identical(expected, actual)) { return(res$set_status(400L)$send_json( auto_unbox = TRUE, diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 6e3daa2..a7eb13f 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -263,18 +263,26 @@ ppm_sso_write_token_to_file <- function(token) { } ppm_sso_base64url_encode <- function(x) { - encoded <- openssl::base64_encode(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(openssl::rand_bytes(32)) + ppm_sso_base64url_encode(.Call(pkgcache_rand_bytes, 32L)) } ppm_sso_new_pkce_challenge <- function(verifier) { - hash <- openssl::sha256(charToRaw(verifier)) - ppm_sso_base64url_encode(hash) + ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) } ppm_sso_complete_device_auth = function( diff --git a/src/init.c b/src/init.c index 97944f8..9334b0a 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 de0922f..05c0a16 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 0000000..f3b67e8 --- /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; +} From 170b36e58cf138a8fcaa86b73efb4f9cb910fbd1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 11 May 2026 11:56:36 +0200 Subject: [PATCH 07/28] Refactor PPM SSO Remove the global env completely, hidden state is not great. pkgcache already caches the HTTP headers, anyway. --- DESCRIPTION | 6 +- R/auth.R | 2 +- R/ppm-sso.R | 238 ++++++++++++++-------------------- tests/testthat/test-ppm-sso.R | 1 + 4 files changed, 103 insertions(+), 144 deletions(-) create mode 100644 tests/testthat/test-ppm-sso.R diff --git a/DESCRIPTION b/DESCRIPTION index a03611b..7efdc94 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,6 +23,8 @@ Imports: processx (>= 3.3.0.9001), R6, tools, + ts, + tstoml, utils Suggests: covr, @@ -32,7 +34,6 @@ Suggests: keyring, pillar, pingr, - RcppTOML, rprojroot, sessioninfo, spelling, @@ -40,6 +41,9 @@ Suggests: webfakes (>= 1.1.5), withr, zip +Remotes: + r-lib/ts, + gaborcsardi/tstoml Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 Config/usethis/last-upkeep: 2025-04-30 diff --git a/R/auth.R b/R/auth.R index bd6511f..bab42ff 100644 --- a/R/auth.R +++ b/R/auth.R @@ -480,7 +480,7 @@ repo_auth_sso <- function(repourl, username) { return(NULL) } - token <- try_catch_null(ppm_sso_login(service = repourl)) + token <- try_catch_null(ppm_sso_auth(repourl)) token } diff --git a/R/ppm-sso.R b/R/ppm-sso.R index a7eb13f..6a2ce45 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -1,6 +1,42 @@ -ppm_sso_data <- new.env(parent = emptyenv()) -ppm_sso_data$name <- "ppm" -ppm_sso_data$viable <- FALSE +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) + ppm_token +} + +ppm_sso_auth <- function(repo) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + if (is.na(ppm_url)) { + stop( + "Please set the PACKAGEMANAGER_ADDRESS environment variable to ", + "the URL of your RStudio Package Manager instance." + ) + } + + 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, + ")." + ) + } + + ppm_sso_get_existing_token(ppm_url, valid = TRUE) %||% ppm_sso_login(ppm_url) +} ppm_sso_post_form <- function(url, payload) { payload <- payload[!vapply(payload, is.null, logical(1))] @@ -25,91 +61,27 @@ ppm_sso_post_form <- function(url, payload) { ) } -ppm_sso_init <- function(url = NULL) { - url <- url %||% Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) - if (!is_string(url)) { - stop( - "Please set the PACKAGEMANAGER_ADDRESS environment variable to ", - "the URL of your RStudio Package Manager instance." - ) - } - - parsed_url <- regmatches( - url, - regexec("^(?:https?://)?([^/]+)", url) - )[[1]] - if (length(parsed_url) < 2) { - stop("Invalid Package Manager URL: ", url) - } - - ppm_sso_data$ppm_url <- url - ppm_sso_data$service_name <- parsed_url[2] - ppm_sso_data$token_file_path <- file.path( +ppm_sso_token_path <- function() { + file.path( path.expand("~"), ".ppm", "tokens.toml" ) - ppm_sso_data$viable <- TRUE } -ppm_sso_login <- function(service = NULL) { - service <- service %||% - ppm_sso_data$ppm_url %||% - Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) - if (!ppm_sso_data$viable) { - ppm_sso_init() - } - - if (!ppm_are_requirements_valid(service)) { - stop( - "Package Manager SSO is not properly configured. Please ensure that ", - "the PACKAGEMANAGER_ADDRESS environment variable is set to the URL of ", - "your Posit Package Manager instance." - ) - } - - existing_token <- ppm_sso_get_existing_token() - if (!is.null(existing_token) && ppm_sso_can_authenticate(existing_token)) { - return(existing_token) - } - - identity_token <- ppm_sso_get_identity_token_from_file() %||% - ppm_sso_device_flow() - ppm_token <- ppm_sso_identity_to_ppm_token(identity_token) - ppm_sso_write_token_to_file(ppm_token) - - ppm_token -} - -ppm_are_requirements_valid <- function(service) { - is_string(ppm_sso_data$ppm_url) && startsWith(service, ppm_sso_data$ppm_url) -} - -ppm_sso_get_existing_token <- function() { - if (!file.exists(ppm_sso_data$token_file_path)) { - return(NULL) - } - tryCatch( - { - tokens_data <- RcppTOML::parseTOML(ppm_sso_data$token_file_path) - for (conn in tokens_data$connection) { - if (identical(conn$url, ppm_sso_data$ppm_url)) { - return(conn$token) +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("connection", TRUE)]]) { + if (identical(conn$url, ppm_url)) { + if (valid && !ppm_sso_can_authenticate(ppm_url, conn$token)) { + return(NULL) } + return(conn$token) } - }, - error = function(e) { - NULL } - ) -} - -ppm_sso_can_authenticate <- function(token) { - h <- curl::new_handle() - curl::handle_setheaders(h, "Authorization" = paste("Bearer", token)) - resp <- curl::curl_fetch_memory(ppm_sso_data$ppm_url, handle = h) - status <- resp$status_code - status < 500 && status != 401 && status != 403 + }) } ppm_sso_get_identity_token_from_file <- function() { @@ -117,23 +89,17 @@ ppm_sso_get_identity_token_from_file <- function() { if (is.na(token_file)) { return(NULL) } - - tryCatch( - { - trimws(readLines(token_file, n = 1, warn = FALSE)) - }, - error = function(e) { - NULL - } - ) + try_catch_null({ + trimws(readLines(token_file, n = 1, warn = FALSE)) + }) } -ppm_sso_device_flow <- function() { +ppm_sso_device_flow <- function(ppm_url) { verifier <- ppm_sso_new_pkce_verifier() challenge <- ppm_sso_new_pkce_challenge(verifier) # 1. Initiate Device Auth - init_url <- paste0(ppm_sso_data$ppm_url, "/__api__/device") + init_url <- paste0(ppm_url, "/__api__/device") payload <- list( code_challenge_method = "S256", code_challenge = challenge @@ -164,6 +130,7 @@ ppm_sso_device_flow <- function() { # 2. Poll for token token_resp_body <- ppm_sso_complete_device_auth( + ppm_url, init_resp_body$device_code, verifier, init_resp_body$interval %||% 5, @@ -177,8 +144,16 @@ ppm_sso_device_flow <- function() { token_resp_body$id_token } -ppm_sso_identity_to_ppm_token <- function(identity_token) { - url <- paste0(ppm_sso_data$ppm_url, "/__api__/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, @@ -202,64 +177,42 @@ ppm_sso_identity_to_ppm_token <- function(identity_token) { token_data$access_token } -ppm_sso_write_token_to_file <- function(token) { - dir.create( - dirname(ppm_sso_data$token_file_path), - showWarnings = FALSE, - recursive = TRUE - ) - - new_connection <- list( - url = ppm_sso_data$ppm_url, +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( + url = ppm_url, token = token, method = "sso" ) - existing_data <- if (file.exists(ppm_sso_data$token_file_path)) { - tryCatch( - RcppTOML::parseTOML(ppm_sso_data$token_file_path), - error = function(e) { - list(connection = list()) - } + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- ts::ts_tree_unserialize( + ts::ts_tree_select(tokens, list("connection", TRUE, "url")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.null(tokens)) { + tokens <- tstoml::ts_parse_toml("") + tokens <- ts::ts_tree_insert(tokens, key = "connection", list(new_conn)) + } else if (!is.na(idx)) { + tokens <- ts::ts_tree_update( + ts::ts_tree_select(tokens, list("connection", idx, "token")), + new_conn$token ) } else { - list(connection = list()) - } - - # Find and update existing entry or add a new one - found <- FALSE - if ( - !is.null(existing_data$connection) && length(existing_data$connection) > 0 - ) { - for (i in seq_along(existing_data$connection)) { - if (identical(existing_data$connection[[i]]$url, ppm_sso_data$ppm_url)) { - existing_data$connection[[i]] <- new_connection - found <- TRUE - break - } - } - } - - if (!found) { - existing_data$connection <- c( - existing_data$connection, - list(new_connection) + tokens <- ts::ts_tree_insert( + ts::ts_tree_select(tokens, "connection"), + list(new_conn) ) } - # Manually construct TOML output - output_lines <- c() - for (conn in existing_data$connection) { - output_lines <- c( - output_lines, - "[[connection]]", - paste0("url = \"", conn$url, "\""), - paste0("token = \"", conn$token, "\""), - paste0("method = \"", conn$method, "\""), - "" - ) - } - writeLines(output_lines, ppm_sso_data$token_file_path) + ts::ts_tree_write(tokens, token_file_path) } ppm_sso_base64url_encode <- function(x) { @@ -286,12 +239,13 @@ ppm_sso_new_pkce_challenge <- function(verifier) { } ppm_sso_complete_device_auth = function( + ppm_url, device_code, verifier, interval, expires_in ) { - url <- paste0(ppm_sso_data$ppm_url, "/__api__/device_access") + url <- paste0(ppm_url, "/__api__/device_access") start_time <- Sys.time() payload <- list( device_code = device_code, diff --git a/tests/testthat/test-ppm-sso.R b/tests/testthat/test-ppm-sso.R new file mode 100644 index 0000000..942a628 --- /dev/null +++ b/tests/testthat/test-ppm-sso.R @@ -0,0 +1 @@ +test_that("ppm_sso_write_token_to_file", {}) From e2e03704e8cd7a0e1aee9575b6259ca1b8b210c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 11 May 2026 12:28:55 +0200 Subject: [PATCH 08/28] Fix tests for Bioconductor & PPM updates --- R/bioc.R | 22 ++++++++++++++------ R/onload.R | 1 + inst/fixtures/bioc-config.yaml | 19 +++++++++-------- tests/testthat/_snaps/platform.md | 24 ++++++---------------- tests/testthat/_snaps/ppm.md | 34 ++++++++++++++++--------------- tests/testthat/test-ppm.R | 3 +-- 6 files changed, 53 insertions(+), 50 deletions(-) diff --git a/R/bioc.R b/R/bioc.R index 0645af2..5e8015b 100644 --- a/R/bioc.R +++ b/R/bioc.R @@ -122,6 +122,7 @@ bioconductor <- local({ "4.2" = package_version("3.16"), "4.3" = package_version("3.18"), "4.4" = package_version("3.20"), + "4.5" = package_version("3.22"), NULL # Do not include R 4.5 <-> Bioc 3.21, because R 4.5 will use # Bioc 3.22 eventually. @@ -152,7 +153,9 @@ bioconductor <- local({ http_url <- sub("^https", "http", config_url()) new <- tryCatch(read_url(http_url), error = function(x) x) } - if (inherits(new, "error")) stop(new) + if (inherits(new, "error")) { + stop(new) + } yaml_config <<- new } @@ -160,7 +163,9 @@ bioconductor <- local({ } set_yaml_config <- function(text) { - if (length(text) == 1) text <- strsplit(text, "\n", fixed = TRUE)[[1]] + if (length(text) == 1) { + text <- strsplit(text, "\n", fixed = TRUE)[[1]] + } yaml_config <<- text } @@ -230,7 +235,9 @@ bioconductor <- local({ forget = FALSE ) { minor <- as.character(get_minor_r_version(r_version)) - if (minor %in% names(builtin_map)) return(builtin_map[[minor]]) + if (minor %in% names(builtin_map)) { + return(builtin_map[[minor]]) + } # If we are not in the map, then we need to look this up in # YAML data. It is possible that the current R version matches multiple @@ -251,7 +258,9 @@ bioconductor <- local({ mine <- rev(mine)[1] } } - if (!is.na(mine)) return(map$bioc_version[mine]) + if (!is.na(mine)) { + return(map$bioc_version[mine]) + } # If it is not even in the YAML, then it must be some very old # or very new version. If old, we fail. If new, we assume bioc-devel. @@ -281,8 +290,9 @@ bioconductor <- local({ BioCsoft = "{mirror}/packages/{bv}/bioc", BioCann = "{mirror}/packages/{bv}/data/annotation", BioCexp = "{mirror}/packages/{bv}/data/experiment", - BioCworkflows = if (bioc_version >= "3.7") - "{mirror}/packages/{bv}/workflows", + BioCworkflows = if (bioc_version >= "3.7") { + "{mirror}/packages/{bv}/workflows" + }, BioCextra = if (bioc_version <= "3.5") "{mirror}/packages/{bv}/extra", BioCbooks = if (bioc_version >= "3.12") "{mirror}/packages/{bv}/books" ) diff --git a/R/onload.R b/R/onload.R index 7d69377..01e4be3 100644 --- a/R/onload.R +++ b/R/onload.R @@ -254,6 +254,7 @@ pkgenv$ppm_distros_cached <- focal linux focal ubuntu 20.04 TRUE jammy linux jammy ubuntu 22.04 TRUE noble linux noble ubuntu 24.04 TRUE + resolute linux resolute ubuntu 26.04 TRUE buster linux buster debian 10 FALSE bullseye linux bullseye debian 11 TRUE bookworm linux bookworm debian 12 TRUE diff --git a/inst/fixtures/bioc-config.yaml b/inst/fixtures/bioc-config.yaml index b407aa5..b61c555 100644 --- a/inst/fixtures/bioc-config.yaml +++ b/inst/fixtures/bioc-config.yaml @@ -8,12 +8,12 @@ production_deploy_root: webadmin@master.bioconductor.org:/extra/www/bioc staging_dir: /loc/www/bioconductor-test-new ## CHANGE THIS WHEN WE RELEASE A VERSION: -release_version: "3.22" -r_version_associated_with_release: "4.5.0" +release_version: "3.23" +r_version_associated_with_release: "4.6.0" r_version_associated_with_devel: "4.6.0" ## CHANGE THIS WHEN WE RELEASE A VERSION: -devel_version: "3.23" +devel_version: "3.24" ## CHANGE THIS WHEN WE ADD A VERSION: ## This is the list of all versions for which we want to generate "new" @@ -24,26 +24,26 @@ devel_version: "3.23" ## let the no-longer-release version build one last time so package ## landing pages won't say "release version"): versions: -- "3.22" - "3.23" +- "3.24" ## CHANGE THIS (i.e., uncomment) as various parts of the new devel version ## become available. set to "[]" if none are available. devel_repos: - "bioc" - "data/experiment" -- "workflows" -- "data/annotation" +#- "workflows" +#- "data/annotation" ## CHANGE this when the build machines change: ## also, don't include machines that are not building yet (comment them out) active_release_builders: - linux: "nebbiolo2" + linux: "nebbiolo1" mac_monterey: "lconway" mac_ventura: "kjohnson3" # windows: "palomino8" active_devel_builders: - linux: "nebbiolo1" + linux: "nebbiolo2" # windows: "palomino7" # mac_monterey: "merida1" @@ -166,6 +166,7 @@ r_ver_for_bioc_ver: "3.21": "4.5" "3.22": "4.5" "3.23": "4.6" + "3.24": "4.6" # UPDATE THIS when we release a version release_dates: # old info from http://en.wikipedia.org/wiki/Bioconductor#Milestones "1.0": "1/5/2001" @@ -216,6 +217,7 @@ release_dates: # old info from http://en.wikipedia.org/wiki/Bioconductor#Milesto "3.20": "10/30/2024" "3.21": "04/16/2025" "3.22": "10/30/2025" + "3.23": "04/29/2026" release_last_built_dates: '2.0': 09/12/2007 '2.1': 04/09/2008 @@ -254,6 +256,7 @@ release_last_built_dates: '3.19': 10/18/2024 '3.20': 04/02/2025 '3.21': 10/16/2025 + '3.22': 04/08/2026 mirrors: - 0-Bioconductor: - institution: Bioconductor, automatic redirection to servers worldwide diff --git a/tests/testthat/_snaps/platform.md b/tests/testthat/_snaps/platform.md index 22cf39b..e0e16bf 100644 --- a/tests/testthat/_snaps/platform.md +++ b/tests/testthat/_snaps/platform.md @@ -59,19 +59,6 @@ Error in `get_package_dirs_for_platform()`: ! pkgcache does not support packages for R versions before R 3.2 ---- - - Code - get_all_package_dirs("windows", "2.15.0") - Condition - Error in `FUN()`: - ! pkgcache does not support packages for R versions before R 3.2 - Code - get_all_package_dirs("macos", "3.1.3") - Condition - Error in `FUN()`: - ! pkgcache does not support packages for R versions before R 3.2 - # current_r_platform_data_linux Code @@ -531,23 +518,24 @@ 39 3.19 4.4 out-of-date 40 3.20 4.4 out-of-date 41 3.21 4.5 out-of-date - 42 3.22 4.5 release - 43 3.23 4.6 devel - 44 3.23 4.7 future + 42 3.22 4.5 out-of-date + 43 3.23 4.6 release + 44 3.24 4.6 devel + 45 3.24 4.7 future # bioc_release_version, bioc_devel_version Code bioc_release_version(forget = TRUE) Output - [1] '3.22' + [1] '3.23' --- Code bioc_devel_version(forget = TRUE) Output - [1] '3.23' + [1] '3.24' # bioc_repos diff --git a/tests/testthat/_snaps/ppm.md b/tests/testthat/_snaps/ppm.md index ca6b58c..c17da0c 100644 --- a/tests/testthat/_snaps/ppm.md +++ b/tests/testthat/_snaps/ppm.md @@ -184,14 +184,15 @@ 25 focal linux focal ubuntu 20.04 TRUE 26 jammy linux jammy ubuntu 22.04 TRUE 27 noble linux noble ubuntu 24.04 TRUE - 28 buster linux buster debian 10 FALSE - 29 bullseye linux bullseye debian 11 TRUE - 30 bookworm linux bookworm debian 12 TRUE - 31 trixie linux trixie debian 13 TRUE - 32 windows windows windows all TRUE - 33 macos macos macos all TRUE - 34 manylinux_2_28 linux manylinux_2_28 centos 8 TRUE - 35 internal linux internal internal all TRUE + 28 resolute linux resolute ubuntu 26.04 TRUE + 29 buster linux buster debian 10 FALSE + 30 bullseye linux bullseye debian 11 TRUE + 31 bookworm linux bookworm debian 12 TRUE + 32 trixie linux trixie debian 13 TRUE + 33 windows windows windows all TRUE + 34 macos macos macos all TRUE + 35 manylinux_2_28 linux manylinux_2_28 centos 8 TRUE + 36 internal linux internal internal all TRUE platforms 1 centos-7 2 centos-8 @@ -220,12 +221,13 @@ 25 ubuntu-20.04 26 ubuntu-22.04 27 ubuntu-24.04 - 28 debian-10 - 29 debian-11 - 30 debian-12 - 31 debian-13 - 32 windows-all - 33 macos-all - 34 centos-8 - 35 internal-all + 28 ubuntu-26.04 + 29 debian-10 + 30 debian-11 + 31 debian-12 + 32 debian-13 + 33 windows-all + 34 macos-all + 35 centos-8 + 36 internal-all diff --git a/tests/testthat/test-ppm.R b/tests/testthat/test-ppm.R index 13099ee..8b663df 100644 --- a/tests/testthat/test-ppm.R +++ b/tests/testthat/test-ppm.R @@ -279,11 +279,10 @@ test_that("ppm_r_versions", { test_that("pkgenv$ppm_distros_cached is current", { skip_on_cran() - cached <- pkgenv$ppm_distros_cached current <- canonicalize_ppm_platforms( synchronise(async_get_ppm_status(forget = TRUE))$distros ) - expect_equal(cached, current) + expect_equal(pkgenv$ppm_distros_cached, current) expect_snapshot(current) }) From 81fd015b83faad288e75451909c910f04d43eb8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 11 May 2026 14:38:45 +0200 Subject: [PATCH 09/28] Fix snapshot test --- tests/testthat/_snaps/platform.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/tests/testthat/_snaps/platform.md b/tests/testthat/_snaps/platform.md index e0e16bf..30a4b70 100644 --- a/tests/testthat/_snaps/platform.md +++ b/tests/testthat/_snaps/platform.md @@ -59,6 +59,19 @@ Error in `get_package_dirs_for_platform()`: ! pkgcache does not support packages for R versions before R 3.2 +--- + + Code + get_all_package_dirs("windows", "2.15.0") + Condition + Error in `FUN()`: + ! pkgcache does not support packages for R versions before R 3.2 + Code + get_all_package_dirs("macos", "3.1.3") + Condition + Error in `FUN()`: + ! pkgcache does not support packages for R versions before R 3.2 + # current_r_platform_data_linux Code From f71a62c337878acae2ec6c6d8e2963ff7e9a01d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 11 May 2026 18:09:47 +0200 Subject: [PATCH 10/28] Fix snapshot tests --- tests/testthat/_snaps/platform.md | 2 +- tests/testthat/test-platform.R | 10 +++++++--- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/tests/testthat/_snaps/platform.md b/tests/testthat/_snaps/platform.md index 30a4b70..3c1ec33 100644 --- a/tests/testthat/_snaps/platform.md +++ b/tests/testthat/_snaps/platform.md @@ -59,7 +59,7 @@ Error in `get_package_dirs_for_platform()`: ! pkgcache does not support packages for R versions before R 3.2 ---- +# get_all_package_dirs 2 Code get_all_package_dirs("windows", "2.15.0") diff --git a/tests/testthat/test-platform.R b/tests/testthat/test-platform.R index fe2af20..6082f43 100644 --- a/tests/testthat/test-platform.R +++ b/tests/testthat/test-platform.R @@ -96,8 +96,10 @@ test_that("get_cran_extension", { ) }) -test_that("get_all_package_dirs", { - if (grepl("^aarch64-apple-", R.version$platform)) skip("M1") +test_that("get_all_package_dirs 2", { + if (grepl("^aarch64-apple-", R.version$platform)) { + skip("M1") + } d <- get_all_package_dirs(c("macos", "source"), "4.0.0") expect_true("x86_64-apple-darwin17.0" %in% d$platform) expect_true("source" %in% d$platform) @@ -128,7 +130,9 @@ test_that("current_r_platform_data_linux", { nlapply <- function(X, FUN, ...) { ret <- lapply(X, FUN, ...) - if (is.character(X) && is.null(names(ret))) names(ret) <- X + if (is.character(X) && is.null(names(ret))) { + names(ret) <- X + } ret } From 7ead6c2add9113136871956dc21534f5d68a2fa6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Tue, 12 May 2026 15:50:03 +0200 Subject: [PATCH 11/28] New webfakes app w/o auth0 --- R/ppm-sso-app.R | 126 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 125 insertions(+), 1 deletion(-) diff --git a/R/ppm-sso-app.R b/R/ppm-sso-app.R index 79b2f78..3761153 100644 --- a/R/ppm-sso-app.R +++ b/R/ppm-sso-app.R @@ -3,7 +3,7 @@ # 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_app <- function( +ppm_sso_auth0_app <- function( auth0_domain, client_id, audience = NULL, @@ -143,4 +143,128 @@ ppm_sso_app <- function( app } +ppm_sso_app <- function() { + 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" + ) + ) + }) + + 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 From 8d8c2318be91a221d2926396a208855d29ff7904 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Tue, 12 May 2026 22:32:15 +0200 Subject: [PATCH 12/28] PPM SSO improvements - ppm_sso_login() - ppm_sso_logout() - ppm_sso_status() - Some docs - Cache PPM SSO tokens separately from regular auth credential caching. This is because for "regular" auth (netrc, keyring) we can get a credential locally, so caching is less important and the cache is cleaned more often. - Improved UI. --- DESCRIPTION | 2 +- NAMESPACE | 5 + R/auth.R | 16 +- R/onload.R | 1 + R/ppm-sso.R | 347 +++++++++++++++++++++++++++++++++++++++++-- R/utils.R | 4 + man/ppm_sso_login.Rd | 65 ++++++++ 7 files changed, 420 insertions(+), 20 deletions(-) create mode 100644 man/ppm_sso_login.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 7efdc94..fc07eae 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -50,4 +50,4 @@ Config/usethis/last-upkeep: 2025-04-30 Encoding: UTF-8 Language: en-US Roxygen: list(markdown = TRUE, r6 = FALSE) -RoxygenNote: 7.3.2.9000 +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 6635a11..ff8464f 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/R/auth.R b/R/auth.R index bab42ff..e3cf891 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) { @@ -480,7 +480,17 @@ repo_auth_sso <- function(repourl, username) { return(NULL) } - token <- try_catch_null(ppm_sso_auth(repourl)) - + 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/onload.R b/R/onload.R index 01e4be3..1c679b4 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/ppm-sso.R b/R/ppm-sso.R index 6a2ce45..2eac6d9 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -1,15 +1,251 @@ -ppm_sso_login <- function( - ppm_url = Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) -) { +#' Posit Package Manager single sign-on (SSO) authentication +#' +#' @details +#' `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. +#' +#' ## 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") +#' )) +#' ``` +#' - 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. +#' +#' @return `ppm_sso_login()` returns the obtained token invisibly. +#' +#' @seealso +#' @export + +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) - ppm_token + + invisible(ppm_token) } -ppm_sso_auth <- function(repo) { +#' @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(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() + } + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- ts::ts_tree_unserialize( + ts::ts_tree_select(tokens, list("connection", TRUE, "url")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.na(idx)) { + return() + } + + tokens <- ts::ts_tree_delete( + ts::ts_tree_select(tokens, list("connection", idx)) + ) + + ts::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. +#' @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 (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 ", @@ -17,6 +253,17 @@ ppm_sso_auth <- function(repo) { ) } + 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) { @@ -35,7 +282,44 @@ ppm_sso_auth <- function(repo) { ) } - ppm_sso_get_existing_token(ppm_url, valid = TRUE) %||% ppm_sso_login(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) { @@ -120,13 +404,15 @@ ppm_sso_device_flow <- function(ppm_url) { stop("No verification URI found in device auth response.") } - message("\nPlease open the following URL in your browser:") - message(paste(" ", display_uri)) - message("\nAnd enter the following code when prompted:") - message(paste(" ", init_resp_body$user_code)) - message("\nWaiting for authorization...") - - try(utils::browseURL(display_uri), silent = TRUE) + cli::cli_rule("PPM SSO Login") + cli::cli_text("Login at {.url {display_uri}}") + cli::cli_text( + "and enter code {.emph {cli::col_magenta(init_resp_body$user_code)}} when prompted." + ) + if (interactive()) { + readline("Press ENTER to open in browser...") + utils::browseURL(display_uri) + } # 2. Poll for token token_resp_body <- ppm_sso_complete_device_auth( @@ -212,7 +498,19 @@ ppm_sso_write_token_to_file <- function(ppm_url, token) { ) } - ts::ts_tree_write(tokens, token_file_path) + 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) { @@ -252,26 +550,43 @@ ppm_sso_complete_device_auth = function( code_verifier = verifier ) + cli::cli_progress_bar( + format = "{cli::pb_spin} Waiting for browser." + ) 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) } 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 { - stop("Device authorization failed (HTTP ", status, ").") + cli::cli_progress_done() + cli::cli_alert_danger( + "Device authorization failed (HTTP {status})." + ) + stop("Device authorization failed.") } - Sys.sleep(interval) + deadline <- Sys.time() + interval + while (Sys.time() < deadline) { + Sys.sleep(.1) + cli::cli_progress_update() + } } stop("Device authorization timed out.") diff --git a/R/utils.R b/R/utils.R index ae0a111..e5787c4 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), ...) } diff --git a/man/ppm_sso_login.Rd b/man/ppm_sso_login.Rd new file mode 100644 index 0000000..546b8cb --- /dev/null +++ b/man/ppm_sso_login.Rd @@ -0,0 +1,65 @@ +% 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.} +} +\description{ +Posit Package Manager single sign-on (SSO) authentication +} +\details{ +\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. +\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{
}} +\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_logout()} removes the cached token, effectively logging you +out. + +\code{ppm_sso_status()} checks the status of your authentication, including +the path of the cached token and its expiration time. +} +\seealso{ +\url{https://docs.posit.co/rspm/admin/authentication/} +} From 3043656d410e508e1a0aad9da6661e887380aef2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Tue, 12 May 2026 23:13:43 +0200 Subject: [PATCH 13/28] Update pkgdown reference for ppm_sso* functions --- _pkgdown.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 5580059..de79e6f 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 From 864ab233d4834dea3e3308e8c43c2af316da64e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Tue, 12 May 2026 23:15:11 +0200 Subject: [PATCH 14/28] Fix spell check --- inst/WORDLIST | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/WORDLIST b/inst/WORDLIST index 44bd7d3..0f2516f 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -18,6 +18,7 @@ ROR RSPM RStudio SHA +SSO Solaris Sur UTF From 4e148dde6edc76eb223eab2a279e72085d7276e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Tue, 12 May 2026 23:16:03 +0200 Subject: [PATCH 15/28] Fix snapshot tests --- tests/testthat/_snaps/auth.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/tests/testthat/_snaps/auth.md b/tests/testthat/_snaps/auth.md index 546a4d5..356e2a1 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" @@ -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" From c1039a115f284c3ef899790f9b315b80f7672700 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 07:47:17 +0200 Subject: [PATCH 16/28] Do not suppress warnings from repo_add() These are messages about authentication. --- R/repo-set.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/repo-set.R b/R/repo-set.R index e423510..663643d 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) { From c76466a455bc6fe3a467a9a80e2229a2e141df17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 07:48:31 +0200 Subject: [PATCH 17/28] Better ppm_sso_status() w/x credentials --- R/ppm-sso.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 2eac6d9..40b03fd 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -57,11 +57,11 @@ ppm_sso_logout <- function() { ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) # remove from cache if there - try_catch_null(rm( + 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, @@ -71,7 +71,7 @@ ppm_sso_logout <- function() { token_file_path <- ppm_sso_token_path() if (!file.exists(token_file_path)) { - return() + return(invisible()) } tokens <- try_catch_null({ tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) @@ -83,7 +83,7 @@ ppm_sso_logout <- function() { }) if (is.na(idx)) { - return() + return(invisible()) } tokens <- ts::ts_tree_delete( @@ -201,7 +201,7 @@ format.ppm_sso_status <- function(x, ...) { cli::col_cyan(x) } url <- function(x) { - if (startsWith(x, "http")) { + if (!is.na(x) && startsWith(x, "http")) { cli::style_hyperlink(x, x) } else { x From 2e4772b29c813b3ce8ac3f7b91cf50ebebf82cf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 07:49:39 +0200 Subject: [PATCH 18/28] Update ppm sso token file keys Cf. https://github.com/r-lib/pak/pull/848#issuecomment-4432306571 --- R/ppm-sso.R | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 40b03fd..f4db86c 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -76,7 +76,7 @@ ppm_sso_logout <- function() { tokens <- try_catch_null({ tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) urls <- ts::ts_tree_unserialize( - ts::ts_tree_select(tokens, list("connection", TRUE, "url")) + ts::ts_tree_select(tokens, list("connections", TRUE, "address")) ) idx <- which(urls == ppm_url)[1] tokens @@ -87,7 +87,7 @@ ppm_sso_logout <- function() { } tokens <- ts::ts_tree_delete( - ts::ts_tree_select(tokens, list("connection", idx)) + ts::ts_tree_select(tokens, list("connections", idx)) ) ts::ts_tree_write(tokens, token_file_path) @@ -357,8 +357,8 @@ 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("connection", TRUE)]]) { - if (identical(conn$url, ppm_url)) { + 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) } @@ -469,15 +469,15 @@ ppm_sso_write_token_to_file <- function(ppm_url, token) { token_file_path <- ppm_sso_token_path() mkdirp(dirname(token_file_path)) new_conn <- list( - url = ppm_url, + address = ppm_url, token = token, - method = "sso" + auth_type = "sso" ) tokens <- try_catch_null({ tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) urls <- ts::ts_tree_unserialize( - ts::ts_tree_select(tokens, list("connection", TRUE, "url")) + ts::ts_tree_select(tokens, list("connections", TRUE, "address")) ) idx <- which(urls == ppm_url)[1] tokens @@ -485,15 +485,15 @@ ppm_sso_write_token_to_file <- function(ppm_url, token) { if (is.null(tokens)) { tokens <- tstoml::ts_parse_toml("") - tokens <- ts::ts_tree_insert(tokens, key = "connection", list(new_conn)) + tokens <- ts::ts_tree_insert(tokens, key = "connections", list(new_conn)) } else if (!is.na(idx)) { tokens <- ts::ts_tree_update( - ts::ts_tree_select(tokens, list("connection", idx, "token")), + ts::ts_tree_select(tokens, list("connections", idx, "token")), new_conn$token ) } else { tokens <- ts::ts_tree_insert( - ts::ts_tree_select(tokens, "connection"), + ts::ts_tree_select(tokens, "connections"), list(new_conn) ) } From d0668823a7690b94857250c6d6ca221204366d9f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 10:54:34 +0200 Subject: [PATCH 19/28] Refactor ppm_sso_device_flow() for pak So pak can call the different parts individually in another process. --- R/ppm-sso.R | 54 +++++++++++++++++++++++++++++------------------------ 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index f4db86c..501371c 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -378,7 +378,7 @@ ppm_sso_get_identity_token_from_file <- function() { }) } -ppm_sso_device_flow <- function(ppm_url) { +ppm_sso_device_flow_init <- function(ppm_url) { verifier <- ppm_sso_new_pkce_verifier() challenge <- ppm_sso_new_pkce_challenge(verifier) @@ -404,30 +404,37 @@ ppm_sso_device_flow <- function(ppm_url) { 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 {display_uri}}") + cli::cli_text("Login at {.url {init_result$display_uri}}") cli::cli_text( - "and enter code {.emph {cli::col_magenta(init_resp_body$user_code)}} when prompted." + "and enter code {.emph {cli::col_magenta(init_result$user_code)}} + when prompted." ) if (interactive()) { readline("Press ENTER to open in browser...") - utils::browseURL(display_uri) + utils::browseURL(init_result$display_uri) } +} - # 2. Poll for token - token_resp_body <- ppm_sso_complete_device_auth( - ppm_url, - init_resp_body$device_code, - verifier, - init_resp_body$interval %||% 5, - init_resp_body$expires_in %||% 300 - ) - - if (is.null(token_resp_body) || is.null(token_resp_body$id_token)) { +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_resp_body$id_token + token } ppm_sso_can_authenticate <- function(ppm_url, token) { @@ -536,13 +543,12 @@ ppm_sso_new_pkce_challenge <- function(verifier) { ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) } -ppm_sso_complete_device_auth = function( - ppm_url, - device_code, - verifier, - interval, - expires_in -) { +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( @@ -560,7 +566,7 @@ ppm_sso_complete_device_auth = function( if (status == 200) { cli::cli_progress_done() cli::cli_alert_success("Authorization successful.") - return(resp$body) + return(resp$body$id_token) } else if (status == 400) { error_code <- resp$body$error if (error_code == "access_denied") { From 03e327d6b216a0f20a063a22c5f2965470221457 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 11:43:10 +0200 Subject: [PATCH 20/28] PPM SSO: fix parsing response When the response is not JSON, typically when the status is not 200 or other known status. --- R/ppm-sso.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 501371c..d3c1f9f 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -341,7 +341,12 @@ ppm_sso_post_form <- function(url, payload) { resp <- curl::curl_fetch_memory(url, handle = h) list( status = resp$status_code, - body = jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE) + body = tryCatch( + jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE), + error = function(e) { + resp$content + } + ) ) } From 9fea7cfe4d06db7661886764b9f96cf771fd3ce7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 11:43:55 +0200 Subject: [PATCH 21/28] PPM SSO: improve messaging when called from pak --- R/ppm-sso.R | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index d3c1f9f..8d247bd 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -429,6 +429,10 @@ ppm_sso_device_flow_message <- function(ppm_url, init_result) { if (interactive()) { readline("Press ENTER to open in browser...") utils::browseURL(init_result$display_uri) + } else if (Sys.getenv("R_PKG_PKG_WORKER") == "true") { + # called from pak, make the UI slightly nicer. + # unfortunately we cannot interact with the user here + utils::browseURL(init_result$display_uri) } } @@ -561,9 +565,14 @@ ppm_sso_device_flow_complete <- function(ppm_url, init_result) { 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 @@ -600,5 +609,7 @@ ppm_sso_device_flow_complete <- function(ppm_url, init_result) { } } + cli::cli_progress_done() + cli::cli_alert_danger("Device authorization timed out.") stop("Device authorization timed out.") } From ecb7f93f9d2b1e248def5cd5a60bb87c08d35a74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 11:53:29 +0200 Subject: [PATCH 22/28] PPM SSO: fix browser open from pak --- R/ppm-sso.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 8d247bd..ec2f696 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -429,7 +429,7 @@ ppm_sso_device_flow_message <- function(ppm_url, init_result) { if (interactive()) { readline("Press ENTER to open in browser...") utils::browseURL(init_result$display_uri) - } else if (Sys.getenv("R_PKG_PKG_WORKER") == "true") { + } 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) From 7b0f2c432372ab8a8ea5dbfde143f05f5e6f6ef0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 12:10:19 +0200 Subject: [PATCH 23/28] Fix a redirected URL --- R/repo-set.R | 2 +- man/repo_get.Rd | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/repo-set.R b/R/repo-set.R index 663643d..28725a0 100644 --- a/R/repo-set.R +++ b/R/repo-set.R @@ -416,7 +416,7 @@ next_day <- function(x) { #' for details. #' * `MRAN@...` repository specifications now resolve to PPM, but note that #' PPM snapshots are only available from 2017-10-10. See more about this -#' at . +#' at . #' * All dates (or times) can be specified in the ISO 8601 format. #' * If PPM does not have a snapshot available for a date, the next #' available date is used. diff --git a/man/repo_get.Rd b/man/repo_get.Rd index 846ea6e..bfdefa1 100644 --- a/man/repo_get.Rd +++ b/man/repo_get.Rd @@ -134,7 +134,7 @@ Notes: for details. \item \code{MRAN@...} repository specifications now resolve to PPM, but note that PPM snapshots are only available from 2017-10-10. See more about this -at \url{https://posit.co/blog/migrating-from-mran-to-posit-package-manager/}. +at \url{https://posit.co/blog/migrating-from-mran-to-posit-package-manager}. \item All dates (or times) can be specified in the ISO 8601 format. \item If PPM does not have a snapshot available for a date, the next available date is used. @@ -159,7 +159,7 @@ with_repo(c(CRAN = "MRAN@2018-06-30"), summary(repo_status())) \dontshow{\}) # examplesIf} } \seealso{ -Other repository functions: +Other repository functions: \code{\link{repo_status}()} } \concept{repository functions} From 3ddf31347d4c3b7656f292eac2b630153ec70a6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 12:10:53 +0200 Subject: [PATCH 24/28] Docs for ppm_sso_status() --- R/ppm-sso.R | 19 +++++++++++++++++++ inst/WORDLIST | 2 ++ man/ppm_sso_login.Rd | 29 ++++++++++++++++++++++++++++- 3 files changed, 49 insertions(+), 1 deletion(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index ec2f696..701be0b 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -103,6 +103,25 @@ ppm_sso_logout <- function() { #' @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) { diff --git a/inst/WORDLIST b/inst/WORDLIST index 0f2516f..1d08957 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -13,6 +13,7 @@ Encodings FreeBSD MRAN PBC +POSIXct README ROR RSPM @@ -26,6 +27,7 @@ UUID archs async devel +difftime encodings funder html diff --git a/man/ppm_sso_login.Rd b/man/ppm_sso_login.Rd index 546b8cb..ff9235c 100644 --- a/man/ppm_sso_login.Rd +++ b/man/ppm_sso_login.Rd @@ -18,6 +18,33 @@ 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 } @@ -55,7 +82,7 @@ the login process directly. } \code{ppm_sso_logout()} removes the cached token, effectively logging you -out. +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. From 07b4dcfb08c2b6be3c7f0bf3a31bbdb9a4d2f670 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 12:25:12 +0200 Subject: [PATCH 25/28] PPM SSO docs examples --- R/ppm-sso.R | 10 ++++++++++ man/ppm_sso_login.Rd | 13 +++++++++++++ man/repo_get.Rd | 2 +- 3 files changed, 24 insertions(+), 1 deletion(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 701be0b..6d0d24d 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -34,6 +34,16 @@ #' #' @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_) diff --git a/man/ppm_sso_login.Rd b/man/ppm_sso_login.Rd index ff9235c..d9a58ac 100644 --- a/man/ppm_sso_login.Rd +++ b/man/ppm_sso_login.Rd @@ -87,6 +87,19 @@ 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/man/repo_get.Rd b/man/repo_get.Rd index bfdefa1..313f447 100644 --- a/man/repo_get.Rd +++ b/man/repo_get.Rd @@ -159,7 +159,7 @@ with_repo(c(CRAN = "MRAN@2018-06-30"), summary(repo_status())) \dontshow{\}) # examplesIf} } \seealso{ -Other repository functions: +Other repository functions: \code{\link{repo_status}()} } \concept{repository functions} From 542124b80b09d35e6aee5e56a974937600e429f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 14:02:17 +0200 Subject: [PATCH 26/28] Refine docs --- R/ppm-sso.R | 10 ++++++---- man/ppm_sso_login.Rd | 10 +++++++--- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 6d0d24d..2518577 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -1,10 +1,6 @@ #' Posit Package Manager single sign-on (SSO) authentication #' #' @details -#' `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. -#' #' ## 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 @@ -22,6 +18,8 @@ #' 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 @@ -30,6 +28,10 @@ #' - 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 diff --git a/man/ppm_sso_login.Rd b/man/ppm_sso_login.Rd index d9a58ac..4ebf46d 100644 --- a/man/ppm_sso_login.Rd +++ b/man/ppm_sso_login.Rd @@ -49,9 +49,6 @@ expired. Posit Package Manager single sign-on (SSO) authentication } \details{ -\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. \subsection{Set up SSO authentication:}{ \itemize{ \item Set the \code{PACKAGEMANAGER_ADDRESS} environment variable to the URL of @@ -71,6 +68,9 @@ instance. Include \verb{__token__} as the username in the URL. For example: 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 @@ -79,6 +79,10 @@ 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 From d9a5ad9f6b082d34ad9f44230542a6462538d66c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Wed, 13 May 2026 14:32:09 +0200 Subject: [PATCH 27/28] Fix adding first token to a token file --- R/ppm-sso.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 2518577..43e797a 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -538,6 +538,8 @@ ppm_sso_write_token_to_file <- function(ppm_url, token) { ts::ts_tree_select(tokens, list("connections", idx, "token")), new_conn$token ) + } else if (length(urls) == 0) { + tokens <- ts::ts_tree_insert(tokens, key = "connections", list(new_conn)) } else { tokens <- ts::ts_tree_insert( ts::ts_tree_select(tokens, "connections"), From 805c73114623c86b3fcf7dac30db312077c2625e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Sun, 17 May 2026 00:02:34 +0200 Subject: [PATCH 28/28] Some PPM SSO tests --- R/ppm-sso.R | 2 +- R/utils.R | 10 ++ tests/testthat/helper-mock.R | 4 +- tests/testthat/test-ppm-sso.R | 228 +++++++++++++++++++++++++++++++++- 4 files changed, 240 insertions(+), 4 deletions(-) diff --git a/R/ppm-sso.R b/R/ppm-sso.R index 43e797a..d9d6909 100644 --- a/R/ppm-sso.R +++ b/R/ppm-sso.R @@ -457,7 +457,7 @@ ppm_sso_device_flow_message <- function(ppm_url, init_result) { "and enter code {.emph {cli::col_magenta(init_result$user_code)}} when prompted." ) - if (interactive()) { + if (is_interactive()) { readline("Press ENTER to open in browser...") utils::browseURL(init_result$display_uri) } else if (isTRUE(getOption("pak.is_worker"))) { diff --git a/R/utils.R b/R/utils.R index e5787c4..9e09983 100644 --- a/R/utils.R +++ b/R/utils.R @@ -254,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/tests/testthat/helper-mock.R b/tests/testthat/helper-mock.R index 0e90b9d..33d8543 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-ppm-sso.R b/tests/testthat/test-ppm-sso.R index 942a628..62a4e22 100644 --- a/tests/testthat/test-ppm-sso.R +++ b/tests/testthat/test-ppm-sso.R @@ -1 +1,227 @@ -test_that("ppm_sso_write_token_to_file", {}) +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)) + ts::ts_tree_unserialize( + ts::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 <- ts::ts_tree_unserialize( + ts::ts_tree_select(tokens, list("connections", TRUE)) + ) + expect_equal( + conns, + list(list( + address = "https://ppm.example.com", + token = "tkn1", + auth_type = "sso" + )) + ) + expect_equal( + ts::ts_tree_unserialize(ts::ts_tree_select(tokens, "top_level"))[[1]], + "keep me" + ) + expect_equal( + ts::ts_tree_unserialize( + ts::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 <- ts::ts_tree_unserialize( + ts::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( + ts::ts_tree_unserialize(ts::ts_tree_select(tokens, "top_level"))[[1]], + "keep me" + ) + expect_equal( + ts::ts_tree_unserialize( + ts::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())) +})