diff --git a/DESCRIPTION b/DESCRIPTION index af155a8..fc07eae 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,6 +23,8 @@ Imports: processx (>= 3.3.0.9001), R6, tools, + ts, + tstoml, utils Suggests: covr, @@ -39,10 +41,13 @@ 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 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 c096dd3..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) { @@ -199,10 +199,18 @@ repo_auth_headers <- function( error = NULL ) - pwd <- repo_auth_netrc(parsed_url$host, parsed_url$username) + pwd <- repo_auth_sso(parsed_url$repourl, parsed_url$username) if (!is.null(pwd)) { res$auth_domain <- parsed_url$host - res$source <- paste0(".netrc") + res$source <- "SSO" + } + + if (is.null(pwd)) { + pwd <- repo_auth_netrc(parsed_url$host, parsed_url$username) + if (!is.null(pwd)) { + res$auth_domain <- parsed_url$host + res$source <- paste0(".netrc") + } } if (is.null(pwd) && !requireNamespace("keyring", quietly = TRUE)) { @@ -461,3 +469,28 @@ repo_auth_netrc <- function(host, username) { NULL } + +repo_auth_sso <- function(repourl, username) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + if (is.na(ppm_url)) { + return(NULL) + } + + if (!startsWith(repourl, ppm_url)) { + return(NULL) + } + + token <- tryCatch( + ppm_sso_auth(repourl), + error = function(e) { + cli::cli_alert_warning( + "PPM SSO authentication failed for repo {.url {repourl}}: {conditionMessage(e)}" + ) + cli::cli_alert_info( + "Try calling {.code ppm_sso_login()} directly." + ) + NULL + } + ) + token +} diff --git a/R/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-app.R b/R/ppm-sso-app.R new file mode 100644 index 0000000..3761153 --- /dev/null +++ b/R/ppm-sso-app.R @@ -0,0 +1,270 @@ +# nocov start + +# Fake PPM server that proxies to Auth0, for testing ppm_sso_device_flow(). +# Auth0 device flow does not use PKCE, so we verify the PKCE challenge +# locally and forward only the device_code to Auth0's /oauth/token. +ppm_sso_auth0_app <- function( + auth0_domain, + client_id, + audience = NULL, + scope = "openid profile email" +) { + app <- webfakes::new_app() + + app$use("logger" = webfakes::mw_log()) + app$use("urlencoded body parser" = webfakes::mw_urlencoded()) + app$use("json body parser" = webfakes::mw_json()) + + app$locals$challenges <- new.env(parent = emptyenv()) + app$locals$auth0_domain <- auth0_domain + app$locals$client_id <- client_id + app$locals$audience <- audience + app$locals$scope <- scope + + # Bearer-token check used by ppm_sso_can_authenticate(): any token passes. + app$get("/", function(req, res) { + res$set_status(200L)$send("ok") + }) + + app$post("/__api__/device", function(req, res) { + challenge <- req$form$code_challenge + method <- req$form$code_challenge_method %||% "S256" + if (!identical(method, "S256")) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_challenge_method") + )) + } + + payload <- list( + client_id = app$locals$client_id, + scope = app$locals$scope, + audience = app$locals$audience + ) + + upstream <- ppm_sso_post_form( + paste0("https://", app$locals$auth0_domain, "/oauth/device/code"), + payload + ) + + if (upstream$status >= 400L) { + return(res$set_status(upstream$status)$send_json( + auto_unbox = TRUE, + upstream$body + )) + } + + assign(upstream$body$device_code, challenge, envir = app$locals$challenges) + + res$send_json( + auto_unbox = TRUE, + list( + device_code = upstream$body$device_code, + user_code = upstream$body$user_code, + verification_uri = upstream$body$verification_uri, + verification_uri_complete = upstream$body$verification_uri_complete, + expires_in = upstream$body$expires_in, + interval = upstream$body$interval %||% 5L + ) + ) + }) + + app$post("/__api__/device_access", function(req, res) { + device_code <- req$form$device_code + verifier <- req$form$code_verifier + + if (!exists(device_code, envir = app$locals$challenges, inherits = FALSE)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "expired_token") + )) + } + expected <- get( + device_code, + envir = app$locals$challenges, + inherits = FALSE + ) + actual <- ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) + if (!identical(expected, actual)) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "invalid_grant") + )) + } + + upstream <- ppm_sso_post_form( + paste0("https://", app$locals$auth0_domain, "/oauth/token"), + list( + grant_type = "urn:ietf:params:oauth:grant-type:device_code", + device_code = device_code, + client_id = app$locals$client_id + ) + ) + + if (upstream$status == 200L) { + rm(list = device_code, envir = app$locals$challenges) + return(res$send_json( + auto_unbox = TRUE, + list(id_token = upstream$body$id_token) + )) + } + + # Auth0 returns 403 for authorization_pending / slow_down; the PPM client + # only treats 400 as a soft pending state, so translate the status. + res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = upstream$body$error %||% "unknown_error") + ) + }) + + # Trivial token exchange: echo subject_token back as access_token. + app$post("/__api__/token", function(req, res) { + if ( + !identical( + req$form$grant_type, + "urn:ietf:params:oauth:grant-type:token-exchange" + ) + ) { + return(res$set_status(400L)$send_json( + auto_unbox = TRUE, + list(error = "unsupported_grant_type") + )) + } + res$send_json( + auto_unbox = TRUE, + list( + access_token = req$form$subject_token, + token_type = "Bearer", + issued_token_type = "urn:ietf:params:oauth:token-type:access_token" + ) + ) + }) + + 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 diff --git a/R/ppm-sso.R b/R/ppm-sso.R new file mode 100644 index 0000000..d9d6909 --- /dev/null +++ b/R/ppm-sso.R @@ -0,0 +1,648 @@ +#' Posit Package Manager single sign-on (SSO) authentication +#' +#' @details +#' ## Set up SSO authentication: +#' - Set the `PACKAGEMANAGER_ADDRESS` environment variable to the URL of +#' your RStudio Package Manager instance. For example, add this line to +#' your `.Renviron` file: +#' ``` +#' PACKAGEMANAGER_ADDRESS=https:// +#' ``` +#' Alternatively, you can also set it in your shell profile on Unix, +#' or in the System or User environment variables on Windows. +#' - Set `options(repos)` to include a repository from your Package Manager +#' instance. Include `__token__` as the username in the URL. For example: +#' ``` +#' options(repos = c( +#' PPM = "https://__token__@/", +#' getOption("repos") +#' )) +#' ``` +#' You probably want to add this to your `.Rprofile` file, so that it is +#' set in every R session. +#' - Call [repo_get()] to trigger authentication and caching of the token. +#' You should be prompted to log in via your browser, and the obtained +#' token will be cached for future use. Call [ppm_sso_status()] to check +#' the status of your authentication, including the path of the cached +#' token and its expiration time. +#' - Alternatively, you can call `ppm_sso_login()` directly to trigger +#' the login process directly. +#' +#' `ppm_sso_login()` initiates the SSO login process. You should be +#' prompted to log in via your browser, and the obtained token will be +#' cached for future use. +#' +#' @return `ppm_sso_login()` returns the obtained token invisibly. +#' +#' @seealso +#' @export +#' @examplesIf FALSE +#' Sys.setenv(PACKAGEMANAGER_ADDRESS = "https://") +#' options(repos = c( +#' PPM = "https://__token__@/", +#' getOption("repos") +#' )) +#' ppm_sso_login() +#' ppm_sso_status() +#' ppm_sso_status(connect = TRUE) +#' ppm_sso_logout() + +ppm_sso_login <- function() { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + + identity_token <- ppm_sso_get_identity_token_from_file() %||% + ppm_sso_device_flow(ppm_url) + ppm_token <- ppm_sso_identity_to_ppm_token(ppm_url, identity_token) + ppm_sso_write_token_to_file(ppm_url, ppm_token) + + invisible(ppm_token) +} + +#' @rdname ppm_sso_login +#' @details +#' `ppm_sso_logout()` removes the cached token, effectively logging you +#' out. If there is no cached token, it does nothing. +#' @return `ppm_sso_logout()` does not return anything. +#' @export + +ppm_sso_logout <- function() { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + + # remove from cache if there + try_catch_null(suppressWarnings(rm( + list = ppm_url, + envir = pkgenv$ppm_sso_cache, + inherits = FALSE + ))) + parsed <- parse_url(ppm_url) + try_catch_null(suppressWarnings(rm( + list = parsed$host, + envir = pkgenv$credentials, + inherits = FALSE + ))) + + token_file_path <- ppm_sso_token_path() + if (!file.exists(token_file_path)) { + return(invisible()) + } + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- ts::ts_tree_unserialize( + ts::ts_tree_select(tokens, list("connections", TRUE, "address")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.na(idx)) { + return(invisible()) + } + + tokens <- ts::ts_tree_delete( + ts::ts_tree_select(tokens, list("connections", 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. +#' @return `ppm_sso_status()` returns a list with the following components: +#' - `ppm_url`: The URL of the Package Manager instance. +#' - `token_file`: The path of the cached token file. +#' - `token`: The cached token (partially masked for display) or `NA` if +#' no token is found locally. +#' - `valid`: `TRUE` if the token is valid (only if `connect = TRUE`), +#' `FALSE` if invalid, or `NA` if not checked. +#' - `issuer`: The issuer of the token, or `NA` if not available. +#' - `subject`: The subject of the token, or `NA` if not available. +#' - `audience`: The audience of the token, or `NA` if not available. +#' - `issued_at`: The issue time of the token as a POSIXct object, or `NA` +#' if not available. +#' - `expires_at`: The expiration time of the token as a POSIXct object, +#' or `NA` if not available. +#' - `expired`: `TRUE` if the token is expired, `FALSE` if not expired, +#' or `NA` if expiration time is not available. +#' - `expires_in`: The time until expiration as a difftime object, or +#' `NA` if expiration time is not available or the token is already +#' expired. +#' @export + +ppm_sso_status <- function(connect = FALSE) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + ppm_sso_check_url(ppm_url) + token <- ppm_sso_get_cached_token(ppm_url, alive = TRUE) %||% + ppm_sso_get_existing_token(ppm_url, valid = FALSE) + + jwt <- token %&&% jwt_split(token) + iat <- .POSIXct(jwt$payload$iat %||% NA_real_) + exp <- .POSIXct(jwt$payload$exp %||% NA_real_) + now <- Sys.time() + auth <- if (connect) { + token %&&% + try_catch_null(ppm_sso_can_authenticate(ppm_url, token)) %||% + FALSE + } else { + NA + } + + structure( + list( + ppm_url = ppm_url, + token_file = ppm_sso_token_path(), + token = token %||% NA_character_, + valid = auth, + issuer = jwt$payload$iss %||% NA_character_, + subject = jwt$payload$sub %||% NA_character_, + audience = jwt$payload$aud %||% NA_character_, + issued_at = iat, + expires_at = exp, + expired = exp < now, + expires_in = if (!is.na(exp) && now < exp) { + exp - now + } else { + as.difftime(NA_real_, units = "secs") + } + ), + class = "ppm_sso_status" + ) +} + +jwt_split <- function(jwt) { + input <- strsplit(jwt, ".", fixed = TRUE)[[1]] + stopifnot(length(input) %in% c(2, 3)) + header <- jsonlite::fromJSON(rawToChar(ppm_sso_base64url_decode(input[1]))) + if (length(header$typ)) { + stopifnot(toupper(header$typ) == "JWT") + } + if (is.na(input[3])) { + input[3] = "" + } + sig <- ppm_sso_base64url_decode(input[3]) + payload <- jsonlite::fromJSON(rawToChar(ppm_sso_base64url_decode(input[2]))) + data <- charToRaw(paste(input[1:2], collapse = ".")) + if (!grepl("^none|EdDSA|[HRE]S(256|384|512)$", header$alg)) { + stop("Invalid algorithm: ", header$alg) + } + if (grepl(".S\\d\\d\\d", header$alg)) { + type <- match.arg(substring(header$alg, 1, 1), c("HMAC", "RSA", "ECDSA")) + keysize <- as.numeric(substring(header$alg, 3)) + } else { + type <- header$alg + keysize = NULL + } + list( + type = type, + keysize = keysize, + data = data, + sig = sig, + payload = payload, + header = header + ) +} + +#' @export + +print.ppm_sso_status <- function(x, ...) { + writeLines(format(x, ...)) + invisible(x) +} + +#' @export + +format.ppm_sso_status <- function(x, ...) { + token <- if (!is.na(x$token)) { + paste0( + substr(x$token, 1, 3), + "...", + substr(x$token, nchar(x$token) - 3, nchar(x$token)) + ) + } else { + NA_character_ + } + key <- function(x) { + cli::col_cyan(x) + } + url <- function(x) { + if (!is.na(x) && startsWith(x, "http")) { + cli::style_hyperlink(x, x) + } else { + x + } + } + tick <- function(x, invert = FALSE) { + txt <- if (isTRUE(x)) { + "yes" + } else if (isFALSE(x)) { + "no" + } else { + "?" + } + if (invert) { + x <- !x + } + if (isTRUE(x)) { + cli::col_green(txt) + } else if (isFALSE(x)) { + cli::col_magenta(txt) + } else { + txt + } + } + ein <- if (is.na(x$expires_in)) "-" else format_time$pretty_dt(x$expires_in) + c( + cli::rule("PPM SSO Status"), + paste(key("PPM URL: "), url(x$ppm_url)), + paste(key("Token file: "), x$token_file), + paste(key("Token: "), token), + paste(key("Valid: "), tick(x$valid)), + paste(key("Issuer: "), url(x$issuer)), + paste(key("Subject: "), x$subject), + paste(key("Audience: "), x$audience), + paste(key("Issued at: "), x$issued_at), + paste(key("Expires at: "), x$expires_at), + paste(key("Expired: "), tick(x$expired, invert = TRUE)), + paste(key("Expires in: "), ein), + NULL + ) +} + + +ppm_sso_check_url <- function(ppm_url) { + if (is.na(ppm_url)) { + stop( + "Please set the PACKAGEMANAGER_ADDRESS environment variable to ", + "the URL of your RStudio Package Manager instance." + ) + } + + if (is.na(parse_url(ppm_url)$host)) { + stop( + "The PACKAGEMANAGER_ADDRESS environment variable must be a valid URL, ", + "but got: ", + ppm_url + ) + } +} + +ppm_sso_auth <- function(repo) { + ppm_url <- Sys.getenv("PACKAGEMANAGER_ADDRESS", NA_character_) + parsed <- tryCatch( + parse_url(repo), + error = function(e) { + stop("Failed to parse repository URL: ", repo) + } + ) + repo_host <- paste0(parsed$protocol, "://", parsed$host) + if (repo_host != ppm_url) { + stop( + "The repository URL (", + repo_host, + ") does not match the configured ", + "Package Manager URL (", + ppm_url, + ")." + ) + } + + token <- ppm_sso_get_cached_token(ppm_url, alive = TRUE) %||% + ppm_sso_get_existing_token(ppm_url, valid = TRUE) %||% + ppm_sso_login() + + pkgenv$ppm_sso_cache[[ppm_url]] <- token + + token +} + +ppm_sso_get_cached_token <- function(ppm_url, alive = TRUE) { + token <- pkgenv$ppm_sso_cache[[ppm_url]] + + # no token in cache + if (is.null(token)) { + return(NULL) + } + + # no need to test if token is live + if (!alive) { + return(token) + } + + # no expiration date + jwt <- jwt_split(token) + exp <- jwt$payload$exp + if (is.null(exp)) { + return(token) + } + + # check if token is still valid + if (.POSIXct(exp) > Sys.time()) { + return(token) + } + + # not valid any more, remove from cache + pkgenv$ppm_sso_cache[[ppm_url]] <- NULL + + NULL +} + +ppm_sso_post_form <- function(url, payload) { + payload <- payload[!vapply(payload, is.null, logical(1))] + body <- paste( + paste0( + curl::curl_escape(names(payload)), + "=", + curl::curl_escape(unlist(payload, use.names = FALSE)) + ), + collapse = "&" + ) + h <- curl::new_handle() + curl::handle_setheaders( + h, + "Content-Type" = "application/x-www-form-urlencoded" + ) + curl::handle_setopt(h, post = TRUE, postfields = body) + resp <- curl::curl_fetch_memory(url, handle = h) + list( + status = resp$status_code, + body = tryCatch( + jsonlite::fromJSON(rawToChar(resp$content), simplifyVector = FALSE), + error = function(e) { + resp$content + } + ) + ) +} + +ppm_sso_token_path <- function() { + file.path( + path.expand("~"), + ".ppm", + "tokens.toml" + ) +} + +ppm_sso_get_existing_token <- function(ppm_url, valid = TRUE) { + path <- ppm_sso_token_path() + try_catch_null({ + ts_tokens <- suppressWarnings(tstoml::ts_read_toml(path)) + for (conn in ts_tokens[[list("connections", TRUE)]]) { + if (identical(conn$address, ppm_url)) { + if (valid && !ppm_sso_can_authenticate(ppm_url, conn$token)) { + return(NULL) + } + return(conn$token) + } + } + }) +} + +ppm_sso_get_identity_token_from_file <- function() { + token_file <- Sys.getenv("PACKAGEMANAGER_IDENTITY_TOKEN_FILE", unset = NA) + if (is.na(token_file)) { + return(NULL) + } + try_catch_null({ + trimws(readLines(token_file, n = 1, warn = FALSE)) + }) +} + +ppm_sso_device_flow_init <- function(ppm_url) { + verifier <- ppm_sso_new_pkce_verifier() + challenge <- ppm_sso_new_pkce_challenge(verifier) + + # 1. Initiate Device Auth + init_url <- paste0(ppm_url, "/__api__/device") + payload <- list( + code_challenge_method = "S256", + code_challenge = challenge + ) + init_resp <- ppm_sso_post_form(init_url, payload) + if (init_resp$status >= 400) { + stop( + "Failed to initiate device authorization (HTTP ", + init_resp$status, + ")." + ) + } + init_resp_body <- init_resp$body + + display_uri <- init_resp_body$verification_uri_complete %||% + init_resp_body$verification_uri + if (is.null(display_uri)) { + stop("No verification URI found in device auth response.") + } + + list( + verifier = verifier, + display_uri = display_uri, + user_code = init_resp_body$user_code, + device_code = init_resp_body$device_code, + expires_in = init_resp_body$expires_in, + interval = init_resp_body$interval + ) +} + +ppm_sso_device_flow_message <- function(ppm_url, init_result) { + cli::cli_rule("PPM SSO Login") + cli::cli_text("Login at {.url {init_result$display_uri}}") + cli::cli_text( + "and enter code {.emph {cli::col_magenta(init_result$user_code)}} + when prompted." + ) + if (is_interactive()) { + readline("Press ENTER to open in browser...") + utils::browseURL(init_result$display_uri) + } else if (isTRUE(getOption("pak.is_worker"))) { + # called from pak, make the UI slightly nicer. + # unfortunately we cannot interact with the user here + utils::browseURL(init_result$display_uri) + } +} + +ppm_sso_device_flow <- function(ppm_url) { + init_result <- ppm_sso_device_flow_init(ppm_url) + ppm_sso_device_flow_message(ppm_url, init_result) + token <- ppm_sso_device_flow_complete(ppm_url, init_result) + if (is.null(token)) { + stop("Failed to complete device authorization or obtain identity token.") + } + token +} + +ppm_sso_can_authenticate <- function(ppm_url, token) { + h <- curl::new_handle() + curl::handle_setheaders(h, "Authorization" = paste("Bearer", token)) + resp <- curl::curl_fetch_memory(ppm_url, handle = h) + status <- resp$status_code + status < 500 && status != 401 && status != 403 +} + +ppm_sso_identity_to_ppm_token <- function(ppm_url, identity_token) { + url <- paste0(ppm_url, "/__api__/token") + payload <- list( + grant_type = "urn:ietf:params:oauth:grant-type:token-exchange", + subject_token = identity_token, + subject_token_type = "urn:ietf:params:oauth:token-type:id_token" + ) + + resp <- ppm_sso_post_form(url, payload) + if (resp$status >= 400) { + stop( + "Failed to exchange identity token for PPM token (HTTP ", + resp$status, + ")." + ) + } + + token_data <- resp$body + if (is.null(token_data$access_token)) { + stop("Failed to exchange identity token for PPM token.") + } + + token_data$access_token +} + +ppm_sso_write_token_to_file <- function(ppm_url, token) { + # this is more difficult than it should be because TOML is unable + # to represent an empty array of tables + token_file_path <- ppm_sso_token_path() + mkdirp(dirname(token_file_path)) + new_conn <- list( + address = ppm_url, + token = token, + auth_type = "sso" + ) + + tokens <- try_catch_null({ + tokens <- suppressWarnings(tstoml::ts_read_toml(token_file_path)) + urls <- ts::ts_tree_unserialize( + ts::ts_tree_select(tokens, list("connections", TRUE, "address")) + ) + idx <- which(urls == ppm_url)[1] + tokens + }) + + if (is.null(tokens)) { + tokens <- tstoml::ts_parse_toml("") + tokens <- 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("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"), + list(new_conn) + ) + } + + bytes <- as.raw(tokens) + file.create(token_file_path) + Sys.chmod(token_file_path, "600") + writeBin(bytes, token_file_path) +} + +ppm_sso_base64url_decode <- function(x) { + # Add padding if missing + padding_needed <- (4 - nchar(x) %% 4) %% 4 + x <- paste0(x, strrep("=", padding_needed)) + # Replace URL-safe characters + x <- gsub("-", "+", gsub("_", "/", x)) + processx::base64_decode(x) +} + +ppm_sso_base64url_encode <- function(x) { + encoded <- processx::base64_encode(x) + # Make it URL-safe + gsub("\\+", "-", gsub("\\/", "_", gsub("=+$", "", encoded))) +} + +ppm_sso_hex_to_raw <- function(s) { + n <- nchar(s) + as.raw(strtoi(substring(s, seq(1L, n, 2L), seq(2L, n, 2L)), 16L)) +} + +ppm_sso_sha256_raw <- function(x) { + ppm_sso_hex_to_raw(cli::hash_sha256(x)) +} + +ppm_sso_new_pkce_verifier <- function() { + ppm_sso_base64url_encode(.Call(pkgcache_rand_bytes, 32L)) +} + +ppm_sso_new_pkce_challenge <- function(verifier) { + ppm_sso_base64url_encode(ppm_sso_sha256_raw(verifier)) +} + +ppm_sso_device_flow_complete <- function(ppm_url, init_result) { + device_code <- init_result$device_code + verifier <- init_result$verifier + interval <- init_result$interval %||% 5 + expires_in <- init_result$expires_in %||% 300 + + url <- paste0(ppm_url, "/__api__/device_access") + start_time <- Sys.time() + payload <- list( + device_code = device_code, + code_verifier = verifier + ) + + # PPM might not respond until the user completes auth, so show this + oldopt <- options(cli.progress_show_after = 0) + on.exit(options(oldopt), add = TRUE) + cli::cli_progress_bar( + format = "{cli::pb_spin} Waiting for browser." + ) + cli::cli_progress_update() + + while (as.numeric(Sys.time() - start_time) < expires_in) { + resp <- ppm_sso_post_form(url, payload) + status <- resp$status + + if (status == 200) { + cli::cli_progress_done() + cli::cli_alert_success("Authorization successful.") + return(resp$body$id_token) + } else if (status == 400) { + error_code <- resp$body$error + if (error_code == "access_denied") { + cli::cli_progress_done() + cli::cli_alert_danger("Authorization denied by user.") + stop("Access denied by user.") + } + if (error_code == "expired_token") { + cli::cli_progress_done() + cli::cli_alert_danger("Device authorization request expired.") + stop("Device authorization request expired.") + } + # For "authorization_pending" or "slow_down", just wait and retry. + } else { + cli::cli_progress_done() + cli::cli_alert_danger( + "Device authorization failed (HTTP {status})." + ) + stop("Device authorization failed.") + } + + deadline <- Sys.time() + interval + while (Sys.time() < deadline) { + Sys.sleep(.1) + cli::cli_progress_update() + } + } + + cli::cli_progress_done() + cli::cli_alert_danger("Device authorization timed out.") + stop("Device authorization timed out.") +} diff --git a/R/repo-set.R b/R/repo-set.R index e423510..28725a0 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) { @@ -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/R/utils.R b/R/utils.R index ae0a111..9e09983 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,6 +2,10 @@ repoman_data <- new.env(parent = emptyenv()) `%||%` <- function(l, r) if (is.null(l)) r else l +`%&&%` <- function(l, r) if (is.null(l)) NULL else r + +isFALSE <- function(x) is.logical(x) && length(x) == 1L && !is.na(x) && !x + vcapply <- function(X, FUN, ...) { vapply(X, FUN, FUN.VALUE = character(1), ...) } @@ -250,3 +254,13 @@ is_rcmd_check <- function() { random_key <- function() { basename(tempfile()) } + +is_interactive <- function() { + if (isTRUE(getOption("rlib.interactive"))) { + TRUE + } else if (isFALSE(getOption("rlib.interactive"))) { + FALSE + } else { + interactive() + } +} diff --git a/_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 diff --git a/inst/WORDLIST b/inst/WORDLIST index 44bd7d3..1d08957 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -13,11 +13,13 @@ Encodings FreeBSD MRAN PBC +POSIXct README ROR RSPM RStudio SHA +SSO Solaris Sur UTF @@ -25,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 new file mode 100644 index 0000000..4ebf46d --- /dev/null +++ b/man/ppm_sso_login.Rd @@ -0,0 +1,109 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ppm-sso.R +\name{ppm_sso_login} +\alias{ppm_sso_login} +\alias{ppm_sso_logout} +\alias{ppm_sso_status} +\title{Posit Package Manager single sign-on (SSO) authentication} +\usage{ +ppm_sso_login() + +ppm_sso_logout() + +ppm_sso_status(connect = FALSE) +} +\arguments{ +\item{connect}{If \code{TRUE}, also checks if the token is valid by making a test +request to the Package Manager instance. This requires an active internet +connection and may take a few seconds. If \code{FALSE}, only checks if a +token is cached and not expired.} +} +\value{ +\code{ppm_sso_login()} returns the obtained token invisibly. + +\code{ppm_sso_logout()} does not return anything. + +\code{ppm_sso_status()} returns a list with the following components: +\itemize{ +\item \code{ppm_url}: The URL of the Package Manager instance. +\item \code{token_file}: The path of the cached token file. +\item \code{token}: The cached token (partially masked for display) or \code{NA} if +no token is found locally. +\item \code{valid}: \code{TRUE} if the token is valid (only if \code{connect = TRUE}), +\code{FALSE} if invalid, or \code{NA} if not checked. +\item \code{issuer}: The issuer of the token, or \code{NA} if not available. +\item \code{subject}: The subject of the token, or \code{NA} if not available. +\item \code{audience}: The audience of the token, or \code{NA} if not available. +\item \code{issued_at}: The issue time of the token as a POSIXct object, or \code{NA} +if not available. +\item \code{expires_at}: The expiration time of the token as a POSIXct object, +or \code{NA} if not available. +\item \code{expired}: \code{TRUE} if the token is expired, \code{FALSE} if not expired, +or \code{NA} if expiration time is not available. +\item \code{expires_in}: The time until expiration as a difftime object, or +\code{NA} if expiration time is not available or the token is already +expired. +} +} +\description{ +Posit Package Manager single sign-on (SSO) authentication +} +\details{ +\subsection{Set up SSO authentication:}{ +\itemize{ +\item Set the \code{PACKAGEMANAGER_ADDRESS} environment variable to the URL of +your RStudio Package Manager instance. For example, add this line to +your \code{.Renviron} file: + +\if{html}{\out{
}}\preformatted{PACKAGEMANAGER_ADDRESS=https:// +}\if{html}{\out{
}} + +Alternatively, you can also set it in your shell profile on Unix, +or in the System or User environment variables on Windows. +\item Set \code{options(repos)} to include a repository from your Package Manager +instance. Include \verb{__token__} as the username in the URL. For example: + +\if{html}{\out{
}}\preformatted{options(repos = c( + PPM = "https://__token__@/", + getOption("repos") +)) +}\if{html}{\out{
}} + +You probably want to add this to your \code{.Rprofile} file, so that it is +set in every R session. +\item Call \code{\link[=repo_get]{repo_get()}} to trigger authentication and caching of the token. +You should be prompted to log in via your browser, and the obtained +token will be cached for future use. Call \code{\link[=ppm_sso_status]{ppm_sso_status()}} to check +the status of your authentication, including the path of the cached +token and its expiration time. +\item Alternatively, you can call \code{ppm_sso_login()} directly to trigger +the login process directly. +} + +\code{ppm_sso_login()} initiates the SSO login process. You should be +prompted to log in via your browser, and the obtained token will be +cached for future use. +} + +\code{ppm_sso_logout()} removes the cached token, effectively logging you +out. If there is no cached token, it does nothing. + +\code{ppm_sso_status()} checks the status of your authentication, including +the path of the cached token and its expiration time. +} +\examples{ +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} +Sys.setenv(PACKAGEMANAGER_ADDRESS = "https://") +options(repos = c( + PPM = "https://__token__@/", + getOption("repos") +)) +ppm_sso_login() +ppm_sso_status() +ppm_sso_status(connect = TRUE) +ppm_sso_logout() +\dontshow{\}) # examplesIf} +} +\seealso{ +\url{https://docs.posit.co/rspm/admin/authentication/} +} diff --git a/man/repo_get.Rd b/man/repo_get.Rd index 846ea6e..313f447 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. 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; +} 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" 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/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-platform.R b/tests/testthat/test-platform.R index 4e9ad32..6082f43 100644 --- a/tests/testthat/test-platform.R +++ b/tests/testthat/test-platform.R @@ -96,7 +96,7 @@ test_that("get_cran_extension", { ) }) -test_that("get_all_package_dirs", { +test_that("get_all_package_dirs 2", { if (grepl("^aarch64-apple-", R.version$platform)) { skip("M1") } diff --git a/tests/testthat/test-ppm-sso.R b/tests/testthat/test-ppm-sso.R new file mode 100644 index 0000000..62a4e22 --- /dev/null +++ b/tests/testthat/test-ppm-sso.R @@ -0,0 +1,227 @@ +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())) +})