PPM SSO Auth

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

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)

R/auth.R

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

R/onload.R

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

R/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