diff --git a/R/utils.R b/R/utils.R index 10da64eb..5a78f802 100644 --- a/R/utils.R +++ b/R/utils.R @@ -295,3 +295,8 @@ ends_with <- function(x, post) { l <- nchar(post) substr(x, nchar(x) - l + 1, nchar(x)) == post } + +defer <- function(expr, frame = parent.frame(), after = FALSE) { + thunk <- as.call(list(function() expr)) + do.call(on.exit, list(thunk, add = TRUE, after = after), envir = frame) +} diff --git a/src/client.c b/src/client.c index ad9db57e..dcf36c4f 100644 --- a/src/client.c +++ b/src/client.c @@ -240,10 +240,27 @@ SEXP processx_base64_decode(SEXP array); #include #include +static FILE *cleanup_file; +static int cleanup_fd; +static int needs_handler_cleanup = 0; + +// We want to clean up the temporary directory on SIGTERM. Since we +// can barely do anything safely from a signal handler, we set up a +// process ahead of time that is going to run `rm -rf tempdir` on +// termination. The process is waiting for an empty line that we send +// with the signal-async-safe function `write()`. + +static void term_handler(int n) { - // Need the cast and the +1 to ignore compiler warning about unused - // return value. - (void) (system("rm -rf \"$R_SESSION_TMPDIR\"") + 1); + // `fwrite()` is not async-safe. Need the cast to avoid + // `-Wunused-result` warning + (void) (write(cleanup_fd, "\n", 1) + 1); + + // `pclose()` is not async-safe. Just assume that the cleanup + // process is going to terminate naturally once it's finished the + // command. The file descriptors will be closed automatically on + // exit. This also allows us to exit faster. + // Continue signal raise(SIGTERM); } @@ -253,10 +270,25 @@ void install_term_handler(void) { return; } + // Ignore SIGTERM in cleanup process via inherited procmask + sigset_t mask; + sigemptyset(&mask); + sigaddset(&mask, SIGTERM); + + sigset_t old; + sigprocmask(SIG_BLOCK, &mask, &old); + + // FIXME: Is it a bit dangerous to use an envvar here? + cleanup_file = popen("read input && [ \"$input\" = \"\" ] && rm -rf \"$R_SESSION_TMPDIR\"", "w"); + cleanup_fd = fileno(cleanup_file); + needs_handler_cleanup = 1; + struct sigaction sig = {{ 0 }}; sig.sa_handler = term_handler; sig.sa_flags = SA_RESETHAND; sigaction(SIGTERM, &sig, NULL); + + sigprocmask(SIG_SETMASK, &old, NULL); } #endif // not _WIN32 diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 93caae0f..e541087c 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -150,3 +150,19 @@ scrub_srcref <- function(x) { } err$register_testthat_print() + +poll_until <- function(fn, interrupt = 0.2, timeout = 5) { + time <- Sys.time() + timeout <- time + timeout + + while (Sys.time() < timeout) { + if (fn()) { + expect_true(TRUE) + return() + } + Sys.sleep(interrupt) + } + + skip_on_cran() + stop("timeout") +} diff --git a/tests/testthat/test-process.R b/tests/testthat/test-process.R index ead69473..911ab483 100644 --- a/tests/testthat/test-process.R +++ b/tests/testthat/test-process.R @@ -75,10 +75,13 @@ test_that("R process is installed with a SIGTERM cleanup handler", { # Needs POSIX signal handling skip_on_os("windows") + n_children <- length(ps::ps_children()) + # Enabled case withr::local_envvar(c(PROCESSX_R_SIGTERM_CLEANUP = "true")) out <- tempfile() + defer(unlink(out, TRUE, TRUE)) fn <- function(file) { file.create(tempfile()) @@ -86,14 +89,30 @@ test_that("R process is installed with a SIGTERM cleanup handler", { } p <- callr::r_session$new() + h <- ps::ps_handle(p$get_pid()) p$run(fn, list(file = out)) p_temp_dir <- readLines(out) expect_true(dir.exists(p_temp_dir)) + # The cleanup process has been launched + expect_length(ps::ps_children(), n_children + 1) + p$signal(ps::signals()$SIGTERM) p$wait() - expect_false(dir.exists(p_temp_dir)) + + # We're no longer waiting for the cleanup process to finish so poll + # until finished + poll_until(function() !dir.exists(p_temp_dir)) + expect_length(ps::ps_children(), n_children) + + # The cleanup process is terminated on quit + p <- callr::r_session$new() + h <- ps::ps_handle(p$get_pid()) + + expect_length(ps::ps_children(), n_children + 1) + p$run(function() quit("no")) + expect_length(ps::ps_children(), n_children) # Disabled case withr::local_envvar(c(PROCESSX_R_SIGTERM_CLEANUP = NA_character_)) @@ -113,3 +132,99 @@ test_that("R process is installed with a SIGTERM cleanup handler", { # Was not cleaned up expect_true(dir.exists(p_temp_dir)) }) + +test_that("can kill process tree with SIGTERM", { + # https://github.com/r-lib/callr/pull/250 + skip_if_not_installed("callr", "3.7.3.9001") + + # Needs POSIX signal handling + skip_on_os("windows") + + withr::local_envvar(c(PROCESSX_R_SIGTERM_CLEANUP = "true")) + + out <- tempfile() + defer(unlink(out, TRUE, TRUE)) + file.create(out) + + fn <- function(recurse, local, file) { + p <- NULL + + if (recurse) { + p <- callr::r_session$new() + p$call( + sys.function(), + list(recurse - 1, local = FALSE, file = file) + ) + } + + if (!local) { + file.create(tempfile()) + cat(paste0(tempdir(), "\n"), file = file, append = TRUE) + + # Sleeping prevents the process to receive an EOF in + # `R_ReadConsole()` (which causes it to quit normally) + Sys.sleep(60) + } + + p + } + + N <- 5 + p <- fn(N, local = TRUE, file = out) + + pid <- p$get_pid() + id <- p$.__enclos_env__$private$tree_id + + temp_dirs <- NULL + + poll_until(function() { + temp_dirs <<- readLines(out) + length(temp_dirs) == N + }) + + ps <- ps::ps_find_tree(id) + + # Kill all ps-marked subprocesses, including the cleanup + # processes. These ignore SIGTERM but should exit quickly when their + # parent process is terminated. + for (p in ps) { + tools::pskill(ps::ps_pid(p)) + } + poll_until(function() { + !any(sapply(ps, function(p) ps::ps_is_running(p))) + }) + + expect_false(any(dir.exists(temp_dirs))) +}) + +test_that("can exit or sigkill parent of cleanup process", { + # https://github.com/r-lib/callr/pull/250 + skip_if_not_installed("callr", "3.7.3.9001") + + # Needs POSIX signal handling + skip_on_os("windows") + + withr::local_envvar(c(PROCESSX_R_SIGTERM_CLEANUP = "true")) + + p <- callr::r_session$new() + p_handle <- ps::ps_handle(p$get_pid()) + + ps <- ps::ps_children(p_handle) + expect_length(ps, 1) + cleanup_p <- ps[[1]] + + # Normal exit: The cleanup process gets an EOF on its stdin and exits + p$close() + poll_until(function() !ps::ps_is_running(cleanup_p)) + + p <- callr::r_session$new() + p_handle <- ps::ps_handle(p$get_pid()) + + ps <- ps::ps_children(p_handle) + expect_length(ps, 1) + cleanup_p <- ps[[1]] + + # SIGKILL: Also gets an EOF + tools::pskill(p$get_pid(), tools::SIGKILL) + poll_until(function() !ps::ps_is_running(cleanup_p)) +})