Kill with grace

DESCRIPTION

@@ -31,12 +31,13 @@ Suggests:
     curl,
     debugme,
     parallel,
+    pkgload,
     rlang (>= 1.0.2),
     testthat (>= 3.0.0),
     webfakes,
     withr
 Encoding: UTF-8
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)
 Config/testthat/edition: 3
 Config/Needs/website: tidyverse/tidytemplate

NEWS.md

@@ -1,5 +1,10 @@
 # processx (development version)
 
+* The `grace` argument of the `kill()` method is now active on Unix
+  platforms. processx first tries to kill with `SIGTERM` with a
+  timeout of `grace` seconds. After the timeout, `SIGKILL` is sent as
+  before.
+
 # processx 3.8.1
 
 * On Unixes, R processes created by callr now feature a `SIGTERM`

R/assertions.R

@@ -27,6 +27,14 @@ on_failure(is_flag) <- function(call, env) {
   paste0(deparse(call$x), " is not a flag (length 1 logical)")
 }
 
+is_numeric_scalar <- function(x) {
+  is.numeric(x) && length(x) == 1 && !is.na(x)
+}
+
+on_failure(is_numeric_scalar) <- function(call, env) {
+  paste0(deparse(call$x), " is not a length 1 number")
+}
+
 is_integerish_scalar <- function(x) {
   is.numeric(x) && length(x) == 1 && !is.na(x) && round(x) == x
 }

R/initialize.R

@@ -25,10 +25,10 @@
 process_initialize <- function(self, private, command, args,
                                stdin, stdout, stderr, pty, pty_options,
                                connections, poll_connection, env, cleanup,
-                               cleanup_tree, wd, echo_cmd, supervise,
-                               windows_verbatim_args, windows_hide_window,
-                               windows_detached_process, encoding,
-                               post_process) {
+                               cleanup_tree, cleanup_grace, wd, echo_cmd,
+                               supervise, windows_verbatim_args,
+                               windows_hide_window, windows_detached_process,
+                               encoding, post_process) {
 
   "!DEBUG process_initialize `command`"
 
@@ -45,6 +45,7 @@ process_initialize <- function(self, private, command, args,
     is.null(env) || is_env_vector(env),
     is_flag(cleanup),
     is_flag(cleanup_tree),
+    is_numeric_scalar(cleanup_grace),
     is_string_or_null(wd),
     is_flag(echo_cmd),
     is_flag(windows_verbatim_args),
@@ -99,6 +100,7 @@ process_initialize <- function(self, private, command, args,
   private$args <- args
   private$cleanup <- cleanup
   private$cleanup_tree <- cleanup_tree
+  private$cleanup_grace <- cleanup_grace
   private$wd <- wd
   private$pstdin <- stdin
   private$pstdout <- stdout
@@ -139,7 +141,7 @@ process_initialize <- function(self, private, command, args,
     c_processx_exec,
     command, c(command, args), pty, pty_options,
     connections, env, windows_verbatim_args, windows_hide_window,
-    windows_detached_process, private, cleanup, wd, encoding,
+    windows_detached_process, private, cleanup, cleanup_grace, wd, encoding,
     paste0("PROCESSX_", private$tree_id, "=YES")
   )
 

R/process.R

@@ -184,6 +184,10 @@ process <- R6::R6Class(
     #'   object is garbage collected.
     #' @param cleanup_tree Whether to kill the process and its child
     #'   process tree when the `process` object is garbage collected.
+    #' @param cleanup_grace Grace period between `SIGTERM` and `SIGKILL`.
+    #'   Only has an effect on Unix platforms. Set to 0 to terminate abruptly
+    #'   with `SIGKILL` only. Currently defaults to 0 until we implement
+    #'   a better approach on session quit.
     #' @param wd Working directory of the process. It must exist.
     #'   If `NULL`, then the current working directory is used.
     #' @param echo_cmd Whether to print the command to the screen before
@@ -212,17 +216,17 @@ process <- R6::R6Class(
     initialize = function(command = NULL, args = character(),
       stdin = NULL, stdout = NULL, stderr = NULL, pty = FALSE,
       pty_options = list(), connections = list(), poll_connection = NULL,
-      env = NULL, cleanup = TRUE, cleanup_tree = FALSE, wd = NULL,
-      echo_cmd = FALSE, supervise = FALSE, windows_verbatim_args = FALSE,
-      windows_hide_window = FALSE, windows_detached_process = !cleanup,
-      encoding = "",  post_process = NULL)
+      env = NULL, cleanup = TRUE, cleanup_tree = FALSE, cleanup_grace = 0.0,
+      wd = NULL, echo_cmd = FALSE, supervise = FALSE,
+      windows_verbatim_args = FALSE, windows_hide_window = FALSE,
+      windows_detached_process = !cleanup, encoding = "",  post_process = NULL)
 
       process_initialize(self, private, command, args, stdin,
                          stdout, stderr, pty, pty_options, connections,
-                         poll_connection, env, cleanup, cleanup_tree, wd,
-                         echo_cmd, supervise, windows_verbatim_args,
-                         windows_hide_window, windows_detached_process,
-                         encoding, post_process),
+                         poll_connection, env, cleanup, cleanup_tree,
+                         cleanup_grace, wd, echo_cmd, supervise,
+                         windows_verbatim_args, windows_hide_window,
+                         windows_detached_process, encoding, post_process),
 
     #' @description
     #' Cleanup method that is called when the `process` object is garbage
@@ -650,6 +654,7 @@ process <- R6::R6Class(
     args = NULL,          # Save 'args' argument here
     cleanup = NULL,       # cleanup argument
     cleanup_tree = NULL,  # cleanup_tree argument
+    cleanup_grace = NULL, # cleanup_grace argument
     stdin = NULL,         # stdin argument or stream
     stdout = NULL,        # stdout argument or stream
     stderr = NULL,        # stderr argument or stream
@@ -737,7 +742,8 @@ process_interrupt <- function(self, private) {
 
 process_kill <- function(self, private, grace, close_connections) {
   "!DEBUG process_kill '`private$get_short_name()`', pid `self$get_pid()`"
-  ret <- chain_call(c_processx_kill, private$status, as.numeric(grace),
+
+  ret <- chain_clean_call(c_processx_kill, private$status, as.numeric(grace),
                       private$get_short_name())
   if (close_connections) private$close_connections()
   ret

R/run.R

@@ -123,6 +123,7 @@
 #'   both streams in UTF-8 currently.
 #' @param cleanup_tree Whether to clean up the child process tree after
 #'   the process has finished.
+#' @param cleanup_grace Passed to `kill()` or `kill_tree()` on cleanup.
 #' @param ... Extra arguments are passed to `process$new()`, see
 #'   [process]. Note that you cannot pass `stout` or `stderr` here,
 #'   because they are used internally by `run()`. You can use the
@@ -162,7 +163,7 @@ run <- function(
   stderr_line_callback = NULL, stderr_callback = NULL,
   stderr_to_stdout = FALSE, env = NULL,
   windows_verbatim_args = FALSE, windows_hide_window = FALSE,
-  encoding = "", cleanup_tree = FALSE, ...) {
+  encoding = "", cleanup_tree = FALSE, cleanup_grace = 0.1, ...) {
 
   assert_that(is_flag(error_on_status))
   assert_that(is_time_interval(timeout))
@@ -176,6 +177,7 @@ run <- function(
   assert_that(is.null(stdout_callback) || is.function(stdout_callback))
   assert_that(is.null(stderr_callback) || is.function(stderr_callback))
   assert_that(is_flag(cleanup_tree))
+  assert_that(is_numeric_scalar(cleanup_grace))
   assert_that(is_flag(stderr_to_stdout))
   ## The rest is checked by process$new()
   "!DEBUG run() Checked arguments"
@@ -195,9 +197,9 @@ run <- function(
 
   ## We make sure that the process is eliminated
   if (cleanup_tree) {
-    on.exit(pr$kill_tree(), add = TRUE)
+    defer(pr$kill_tree(grace = cleanup_grace))
   } else {
-    on.exit(pr$kill(), add = TRUE)
+    defer(pr$kill(grace = cleanup_grace))
   }
 
   ## If echo, then we need to create our own callbacks.
@@ -238,7 +240,7 @@ run <- function(
         resenv$errbuf$push(pr$read_error())
         resenv$errbuf$read()
       }
-      tryCatch(pr$kill(), error = function(e) NULL)
+      tryCatch(pr$kill(grace = cleanup_grace), error = function(e) NULL)
       signalCondition(new_process_interrupt_cond(
         list(
           interrupt = TRUE, stderr = err, stdout = out,

R/utils.R

@@ -300,3 +300,24 @@ 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)
 }
+
+rimraf <- function(...) {
+  x <- file.path(...)
+  if ("~" %in% x) stop("Cowardly refusing to delete `~`")
+  unlink(x, recursive = TRUE, force = TRUE)
+}
+
+get_test_lib <- function(lib) {
+  if (pkgload::is_dev_package("processx")) {
+    path <- "src"
+  } else {
+    path <- paste0('libs', .Platform$r_arch)
+  }
+
+  system.file(
+    package = "processx",
+    path,
+    "test",
+    paste0(lib, .Platform$dynlib.ext)
+  )
+}

src/Makevars

@@ -8,7 +8,8 @@ OBJECTS = init.o poll.o errors.o processx-connection.o   \
 
 .PHONY: all clean
 
-all: tools/px tools/sock supervisor/supervisor client$(SHLIB_EXT) $(SHLIB)
+all: tools/px tools/sock supervisor/supervisor client$(SHLIB_EXT) $(SHLIB) \
+     test/sigtermignore$(SHLIB_EXT)
 
 tools/px: tools/px.c
 	$(CC) $(CFLAGS) $(LDFLAGS) -Wall tools/px.c -o tools/px
@@ -30,6 +31,9 @@ client$(SHLIB_EXT): $(CLIENT_OBJECTS)
 	    patchelf --remove-needed libR.so client$(SHLIB_EXT); \
 	fi
 
+test/sigtermignore$(SHLIB_EXT): test/sigtermignore.o
+	$(SHLIB_LINK) -o test/sigtermignore$(SHLIB_EXT) test/sigtermignore.o
+
 clean:
 	rm -rf $(SHLIB) $(OBJECTS) $(CLIENT_OBJECTS)		\
 	    supervisor/supervisor supervisor/supervisor.dSYM 	\

src/init.c

@@ -15,7 +15,7 @@ SEXP processx__set_boot_time(SEXP);
 
 static const R_CallMethodDef callMethods[]  = {
   CLEANCALL_METHOD_RECORD,
-  { "processx_exec",               (DL_FUNC) &processx_exec,              14 },
+  { "processx_exec",               (DL_FUNC) &processx_exec,              15 },
   { "processx_wait",               (DL_FUNC) &processx_wait,               3 },
   { "processx_is_alive",           (DL_FUNC) &processx_is_alive,           2 },
   { "processx_get_exit_status",    (DL_FUNC) &processx_get_exit_status,    2 },

src/install.libs.R

@@ -18,3 +18,8 @@ file.copy(files, dest, overwrite = TRUE)
 if (file.exists("symbols.rds")) {
   file.copy("symbols.rds", dest, overwrite = TRUE)
 }
+
+test_files <- Sys.glob(paste0("test/*", SHLIB_EXT))
+test_dest <- file.path(dest, "test")
+dir.create(test_dest, recursive = TRUE, showWarnings = FALSE)
+file.copy(test_files, test_dest, overwrite = TRUE)

src/processx.h

@@ -45,8 +45,8 @@ extern "C" {
 SEXP processx_exec(SEXP command, SEXP args, SEXP pty, SEXP pty_options,
 		   SEXP connections, SEXP env, SEXP windows_verbatim_args,
 		   SEXP windows_hide_window, SEXP windows_detached_process,
-		   SEXP private_, SEXP cleanup, SEXP wd, SEXP encoding,
-		   SEXP tree_id);
+		   SEXP private_, SEXP cleanup, SEXP cleanup_signal,
+                   SEXP wd, SEXP encoding, SEXP tree_id);
 SEXP processx_wait(SEXP status, SEXP timeout, SEXP name);
 SEXP processx_is_alive(SEXP status, SEXP name);
 SEXP processx_get_exit_status(SEXP status, SEXP name);

src/test/sigtermignore.c

@@ -0,0 +1,11 @@
+#ifndef _WIN32
+
+#include <Rinternals.h>
+#include <R_ext/Rdynload.h>
+#include <signal.h>
+
+void R_init_sigtermignore(DllInfo *dll) {
+  signal(SIGTERM, SIG_IGN);
+}
+
+#endif

src/unix/processx-unix.h

@@ -23,6 +23,8 @@ typedef struct processx_handle_s {
   int fd2;			/* readable */
   int waitpipe[2];		/* use it for wait() with timeout */
   int cleanup;
+  int cleanup_signal;
+  double cleanup_grace;
   double create_time;
   processx_connection_t *pipes[3];
   int ptyfd;
@@ -36,7 +38,12 @@ void processx__sigchld_callback(int sig, siginfo_t *info, void *ctx);
 void processx__setup_sigchld(void);
 void processx__remove_sigchld(void);
 void processx__block_sigchld(void);
+void processx__block_sigchld_save(sigset_t *old);
 void processx__unblock_sigchld(void);
+void processx__procmask_set(sigset_t *set);
+
+int c_processx_wait(processx_handle_t *handle, int timeout, const char *name);
+int c_processx_kill(SEXP status, double grace, SEXP name);
 
 void processx__finalizer(SEXP status);