Safer cleanup on SIGTERM

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)
+}

src/client.c

@@ -240,10 +240,27 @@ SEXP processx_base64_decode(SEXP array);
 #include <string.h>
 #include <signal.h>
 
+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

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")
+}

tests/testthat/test-process.R

@@ -75,25 +75,44 @@ 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())
     writeLines(tempdir(), file)
   }
 
   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))
+})