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 1/6] 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 2/6] 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 3/6] 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 4/6] 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 5/6] 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 6/6] 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; +}