diff --git a/NEWS.md b/NEWS.md index 2cd1ca5..fcc6dae 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,13 @@ # rstudioapi (development version) +* The IPC transport used by background jobs to call back into RStudio has + been hardened. Newer RStudio versions check the shared secret before + deserializing a request, responses are written atomically and matched to + their request, and the secret is removed from the job's environment when + rstudioapi loads, so processes spawned by a job no longer inherit the + ability to call into the IDE. Older versions of RStudio continue to use the + previous transport. + # rstudioapi 0.19.0 * `getDelegatedAzureToken()` gains an `as` argument. With `as = "AzureToken"`, diff --git a/R/remote.R b/R/remote.R index af5ad60..232971a 100644 --- a/R/remote.R +++ b/R/remote.R @@ -1,4 +1,3 @@ - #' Detect RStudio Jobs #' #' Use this function to detect whether RStudio is running an R "job". @@ -34,17 +33,102 @@ isWorkbenchJob <- function() { identical(Sys.getenv("RSTUDIO_WORKBENCH_JOB"), "1") } +# IPC with the parent RStudio session +# +# When RStudio launches an R process (e.g. a background job), it hands the +# process a request path, a response path and a shared secret via environment +# variables. rstudioapi calls made from that process are serialized into a +# request file; RStudio picks the request up while polling the job, evaluates +# the call, and writes a response file. +# +# RStudio advertises the newest request format it accepts through the +# RSTUDIOAPI_IPC_VERSION environment variable: +# +# - Version 1 (unset): the request is a single RDS payload containing both the +# secret and the call, and the response is the bare result. +# +# - Version 2: the request is a plain-text ticket (magic line, then +# 'key=value' lines for version, secret and id) and the call is written to a +# sibling '.payload' file. RStudio checks the secret before +# deserializing anything, and the response is list(id, value) or +# list(id, error), so a stale response can be told apart from the real one. +# +# The shared secret is moved out of the environment into an R option when the +# package loads (see .onLoad), so processes spawned by the job can't use it to +# call back into the IDE. The request and response paths stay put, since they +# only identify the job and other packages use them to detect jobs. + +ipcSecret <- function() { + secret <- getOption("rstudioapi.ipc.secret", default = NA) + if (is.na(secret)) + secret <- Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA) + secret +} + +ipcVersion <- function() { + version <- Sys.getenv("RSTUDIOAPI_IPC_VERSION", unset = "1") + version <- suppressWarnings(as.integer(version)) + if (is.na(version)) 1L else version +} + +ipcRequestId <- function() { + # tempfile() gives us a unique token without touching the user's RNG + basename(tempfile(paste0("rstudioapi-", Sys.getpid(), "-"))) +} + +# Write 'writer(path)' output into a sibling temporary file, then rename it +# into place, so the reader never observes a partially-written file. +ipcWriteAtomic <- function(path, writer) { + tmp <- tempfile(tmpdir = dirname(path)) + on.exit(unlink(tmp), add = TRUE) + writer(tmp) + if (!file.rename(tmp, path)) + stop("failed to write rstudioapi IPC file '", path, "'") + invisible(path) +} + +# Poll until 'responseFile' holds a response that 'accept' is happy with, or +# the timeout elapses. Unreadable or rejected responses are discarded and the +# poll continues, so a half-written or stale file never masquerades as ours. +ipcAwaitResponse <- function(responseFile, accept) { + + # in theory we'd just do a blocking read but there isn't really a good + # way to do this in a cross-platform way without additional dependencies + now <- Sys.time() + timeout <- getOption("rstudioapi.remote.timeout", default = 10) + repeat { + + if (file.exists(responseFile)) { + response <- tryCatch(readRDS(responseFile), error = function(e) NULL) + if (!is.null(response) && accept(response)) + return(response) + if (!is.null(response)) + unlink(responseFile) + } + + diff <- difftime(Sys.time(), now, units = "secs") + if (diff > timeout) + stop("RStudio did not respond to rstudioapi IPC request") + + Sys.sleep(0.1) + + } + +} + callRemote <- function(call, frame) { # check for active request / response requestFile <- Sys.getenv("RSTUDIOAPI_IPC_REQUESTS_FILE", unset = NA) responseFile <- Sys.getenv("RSTUDIOAPI_IPC_RESPONSE_FILE", unset = NA) - secret <- Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA) - if (is.na(requestFile) || is.na(responseFile) || is.na(secret)) + if (is.na(requestFile) || is.na(responseFile)) stop("internal error: callRemote() called without remote connection") - - # clean up on exit - on.exit(unlink(c(requestFile, responseFile)), add = TRUE) + + secret <- ipcSecret() + if (is.na(secret)) { + stop("this R process has no rstudioapi IPC credentials; only the R ", + "process launched by RStudio itself can call back into the IDE") + } # remove srcrefs (un-needed for serialization here) attr(call, "srcref") <- NULL @@ -62,35 +146,59 @@ callRemote <- function(call, frame) { call <- as.call(c(callFun, args)) - # write to tempfile and rename, to ensure atomicity - data <- list(secret = secret, call = call) - tmp <- tempfile(tmpdir = dirname(requestFile)) - saveRDS(data, file = tmp) - file.rename(tmp, requestFile) + if (ipcVersion() >= 2L) + callRemoteV2(call, requestFile, responseFile, secret) + else + callRemoteV1(call, requestFile, responseFile, secret) - # loop until response is ready (poll) - # in theory we'd just do a blocking read but there isn't really a good - # way to do this in a cross-platform way without additional dependencies - now <- Sys.time() - timeout <- getOption("rstudioapi.remote.timeout", default = 10) - repeat { +} - # check for response - if (file.exists(responseFile)) - break +callRemoteV2 <- function(call, requestFile, responseFile, secret) { - # check for lack of response - diff <- difftime(Sys.time(), now, units = "secs") - if (diff > timeout) - stop("RStudio did not respond to rstudioapi IPC request") + id <- ipcRequestId() + payloadFile <- paste(requestFile, "payload", sep = ".") + on.exit(unlink(c(requestFile, payloadFile, responseFile)), add = TRUE) - # wait a bit - Sys.sleep(0.1) + # the payload goes first and the ticket last: RStudio only looks for the + # ticket, so a complete ticket implies a complete payload + ipcWriteAtomic(payloadFile, function(path) { + saveRDS(call, file = path) + }) - } + ticket <- c( + "rstudioapi-ipc", + "version=2", + paste0("secret=", secret), + paste0("id=", id) + ) + + ipcWriteAtomic(requestFile, function(path) { + writeLines(ticket, con = path) + }) + + response <- ipcAwaitResponse(responseFile, function(response) { + is.list(response) && identical(response$id, id) + }) + + if ("error" %in% names(response)) + stop(response$error) + + response$value + +} + +callRemoteV1 <- function(call, requestFile, responseFile, secret) { + + on.exit(unlink(c(requestFile, responseFile)), add = TRUE) + + data <- list(secret = secret, call = call) + ipcWriteAtomic(requestFile, function(path) { + saveRDS(data, file = path) + }) - # read response - response <- readRDS(responseFile) + # older RStudio versions write the response in place, so accept whatever + # readRDS() manages to read and retry while the file is being written + response <- ipcAwaitResponse(responseFile, function(response) TRUE) if (inherits(response, "error")) stop(response) diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 0000000..2e733f5 --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,11 @@ +.onLoad <- function(libname, pkgname) { + + # take the IPC secret out of the environment, so that processes spawned by + # an RStudio job don't inherit the ability to call back into the IDE + secret <- Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA) + if (!is.na(secret)) { + options(rstudioapi.ipc.secret = secret) + Sys.unsetenv("RSTUDIOAPI_IPC_SHARED_SECRET") + } + +} diff --git a/tests/testthat/test-remote.R b/tests/testthat/test-remote.R new file mode 100644 index 0000000..0e2b6ec --- /dev/null +++ b/tests/testthat/test-remote.R @@ -0,0 +1,179 @@ + +# Simulates the RStudio side of the IPC transport in a separate R process: +# waits for a request, answers it with 'responder', and exits. Returns the +# path to a file the server writes its own diagnostics to. +startFakeServer <- function(requestFile, responseFile, secret, version, error = FALSE) { + + script <- tempfile("rstudioapi-fake-server-", fileext = ".R") + log <- tempfile("rstudioapi-fake-server-", fileext = ".log") + + code <- substitute({ + + deadline <- Sys.time() + 20 + while (!file.exists(requestFile) && Sys.time() < deadline) + Sys.sleep(0.05) + + if (version >= 2) { + ticket <- readLines(requestFile) + fields <- strsplit(ticket[-1], "=", fixed = TRUE) + ticket <- setNames( + vapply(fields, `[[`, 2L, FUN.VALUE = ""), + vapply(fields, `[[`, 1L, FUN.VALUE = "") + ) + call <- readRDS(paste(requestFile, "payload", sep = ".")) + ok <- identical(ticket[["secret"]], secret) + response <- if (error) + list(id = ticket[["id"]], error = simpleError("boom")) + else + list(id = ticket[["id"]], value = list(ok = ok, call = call)) + } else { + data <- readRDS(requestFile) + ok <- identical(data[["secret"]], secret) + response <- list(ok = ok, call = data[["call"]]) + } + + # write in place (not atomically), as older RStudio versions do, so the + # client must tolerate reading a partially-written file + saveRDS(response, file = responseFile) + writeLines("done", log) + + }, list( + requestFile = requestFile, + responseFile = responseFile, + secret = secret, + version = version, + error = error, + log = log + )) + + writeLines(deparse(code), script) + rscript <- file.path(R.home("bin"), "Rscript") + system2(rscript, shQuote(script), wait = FALSE, stdout = FALSE, stderr = FALSE) + + log + +} + +withIpcEnvironment <- function(version, secret, expr) { + + dir <- tempfile("rstudioapi-ipc-") + dir.create(dir) + on.exit(unlink(dir, recursive = TRUE), add = TRUE) + + requestFile <- file.path(dir, "requests.rds") + responseFile <- file.path(dir, "response.rds") + + old <- Sys.getenv( + c("RSTUDIOAPI_IPC_REQUESTS_FILE", "RSTUDIOAPI_IPC_RESPONSE_FILE", "RSTUDIOAPI_IPC_VERSION"), + unset = NA + ) + on.exit({ + for (name in names(old)) { + if (is.na(old[[name]])) Sys.unsetenv(name) else do.call(Sys.setenv, as.list(old[name])) + } + }, add = TRUE) + + Sys.setenv( + RSTUDIOAPI_IPC_REQUESTS_FILE = requestFile, + RSTUDIOAPI_IPC_RESPONSE_FILE = responseFile + ) + if (version >= 2) Sys.setenv(RSTUDIOAPI_IPC_VERSION = version) else Sys.unsetenv("RSTUDIOAPI_IPC_VERSION") + + oldOptions <- options(rstudioapi.ipc.secret = secret, rstudioapi.remote.timeout = 15) + on.exit(options(oldOptions), add = TRUE) + + expr(requestFile, responseFile) + +} + +test_that("version 2 requests are written as a ticket plus payload and matched by id", { + + withIpcEnvironment(2L, "s3cret", function(requestFile, responseFile) { + + startFakeServer(requestFile, responseFile, "s3cret", 2L) + + # a stale response from an earlier request must be ignored, not returned + saveRDS(list(id = "stale", value = "stale"), responseFile) + + result <- callRemote(quote(versionInfo(1, x = "two")), environment()) + expect_true(result$ok) + expect_identical(result$call, quote(rstudioapi::versionInfo(1, x = "two"))) + + # the transport cleans up after itself + expect_false(file.exists(requestFile)) + expect_false(file.exists(paste(requestFile, "payload", sep = "."))) + expect_false(file.exists(responseFile)) + + }) + +}) + +test_that("version 1 requests are used when RStudio doesn't advertise a newer protocol", { + + withIpcEnvironment(1L, "s3cret", function(requestFile, responseFile) { + + startFakeServer(requestFile, responseFile, "s3cret", 1L) + + result <- callRemote(quote(rstudioapi::versionInfo()), environment()) + expect_true(result$ok) + expect_identical(result$call, quote(rstudioapi::versionInfo())) + expect_false(file.exists(requestFile)) + expect_false(file.exists(responseFile)) + + }) + +}) + +test_that("version 2 errors from RStudio are re-raised in the client", { + + withIpcEnvironment(2L, "s3cret", function(requestFile, responseFile) { + startFakeServer(requestFile, responseFile, "s3cret", 2L, error = TRUE) + expect_error(callRemote(quote(versionInfo()), environment()), "boom") + }) + +}) + +test_that("callRemote() times out when RStudio doesn't answer", { + + withIpcEnvironment(2L, "s3cret", function(requestFile, responseFile) { + options(rstudioapi.remote.timeout = 0.5) + expect_error( + callRemote(quote(versionInfo()), environment()), + "did not respond" + ) + }) + +}) + +test_that("callRemote() refuses to run without a secret", { + + withIpcEnvironment(2L, NA, function(requestFile, responseFile) { + old <- Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA) + on.exit(if (is.na(old)) Sys.unsetenv("RSTUDIOAPI_IPC_SHARED_SECRET") else Sys.setenv(RSTUDIOAPI_IPC_SHARED_SECRET = old)) + Sys.unsetenv("RSTUDIOAPI_IPC_SHARED_SECRET") + + expect_error( + callRemote(quote(versionInfo()), environment()), + "no rstudioapi IPC credentials" + ) + }) + +}) + +test_that(".onLoad() moves the IPC secret out of the environment", { + + old <- Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA) + oldOptions <- options(rstudioapi.ipc.secret = NULL) + on.exit({ + options(oldOptions) + if (is.na(old)) Sys.unsetenv("RSTUDIOAPI_IPC_SHARED_SECRET") else Sys.setenv(RSTUDIOAPI_IPC_SHARED_SECRET = old) + }, add = TRUE) + + Sys.setenv(RSTUDIOAPI_IPC_SHARED_SECRET = "s3cret") + .onLoad(NULL, "rstudioapi") + + expect_identical(Sys.getenv("RSTUDIOAPI_IPC_SHARED_SECRET", unset = NA), NA_character_) + expect_identical(getOption("rstudioapi.ipc.secret"), "s3cret") + expect_identical(ipcSecret(), "s3cret") + +})