eio_linux: add subprocess support

Co-authored-by: Patrick Ferris <[email protected]>

lib_eio_linux/dune

@@ -9,5 +9,6 @@
  (foreign_stubs
   (language c)
   (flags :standard -D_LARGEFILE64_SOURCE)
+  (include_dirs ../lib_eio/unix/include)
   (names eio_stubs))
  (libraries eio eio.utils eio.unix uring logs fmt))

lib_eio_linux/eio_linux.mli

@@ -248,4 +248,46 @@ module Low_level : sig
   (** [getaddrinfo host] returns a list of IP addresses for [host]. [host] is either a domain name or
       an ipaddress. *)
 
+  (** {1 Processes} *)
+
+  module Process : sig
+    type t
+    (** A child process. *)
+
+    (** Setup actions to perform in the child process. *)
+    module Fork_action : sig
+      type t = Eio_unix.Private.Fork_action.t
+
+      val execve : string -> argv:string array -> env:string array -> t
+      (** See execve(2).
+          This replaces the current executable,
+          so it only makes sense as the last action to be performed. *)
+
+      val chdir : string -> t
+      (** [chdir path] changes directory to [path]. *)
+
+      val fchdir : FD.t -> t
+      (** [fchdir dir] changes directory to [dir]. *)
+    end
+
+    val spawn : sw:Switch.t -> Fork_action.t list -> t
+    (** [spawn ~sw actions] forks a child process, which executes [actions].
+        The last action should be {!Fork_action.execve}.
+
+        You will typically want to do [Promise.await (exit_status child)] after this.
+
+        @param sw The child will be sent {!Sys.sigkill} if [sw] finishes. *)
+
+    val signal : t -> int -> unit
+    (** [signal t x] sends signal [x] to [t].
+
+        This is similar to doing [Unix.kill t.pid x],
+        except that it ensures no signal is sent after [t] has been reaped. *)
+
+    val pid : t -> int
+
+    val exit_status : t -> Unix.process_status Promise.t
+    (** [exit_status t] is a promise for the process's exit status. *)
+  end
+
 end

lib_eio_linux/eio_stubs.c

@@ -1,3 +1,6 @@
+#define _GNU_SOURCE
+#include <linux/sched.h>
+
 #include <sys/stat.h>
 #include <sys/types.h>
 #include <sys/eventfd.h>
@@ -7,8 +10,11 @@
 #include <errno.h>
 #include <dirent.h>
 #include <fcntl.h>
+#include <signal.h>
 #include <unistd.h>
 
+// We need caml_convert_signal_number
+#define CAML_INTERNALS
 
 #include <caml/mlvalues.h>
 #include <caml/memory.h>
@@ -17,6 +23,8 @@
 #include <caml/unixsupport.h>
 #include <caml/bigarray.h>
 
+#include "fork_action.h"
+
 // Make sure we have enough space for at least one entry.
 #define DIRENT_BUF_SIZE (PATH_MAX + sizeof(struct dirent64))
 
@@ -99,3 +107,43 @@ CAMLprim value caml_eio_getdents(value v_fd) {
 
   CAMLreturn(result);
 }
+
+static int pidfd_send_signal(int pidfd, int sig, siginfo_t *info, unsigned int flags) {
+  return syscall(SYS_pidfd_send_signal, pidfd, sig, info, flags);
+}
+
+CAMLprim value caml_eio_pidfd_send_signal(value v_pidfd, value v_signal) {
+  CAMLparam0();
+  int res;
+
+  res = pidfd_send_signal(Int_val(v_pidfd), caml_convert_signal_number(Int_val(v_signal)), NULL, 0);
+  if (res == -1) uerror("pidfd_send_signal", Nothing);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value caml_eio_clone3(value v_errors, value v_actions) {
+  CAMLparam1(v_actions);
+  CAMLlocal1(v_result);
+  pid_t child_pid;
+  int pidfd = -1;		/* Is automatically close-on-exec */
+  struct clone_args cl_args = {
+    .flags = CLONE_PIDFD,
+    .pidfd = (uint64_t) &pidfd,
+    .exit_signal = SIGCHLD,	/* Needed for wait4 to work if we exit before exec */
+    .stack = (uint64_t) NULL,	/* Use copy-on-write parent stack */
+    .stack_size = 0,
+  };
+
+  child_pid = syscall(SYS_clone3, &cl_args, sizeof(struct clone_args));
+  if (child_pid == 0) {
+    eio_unix_run_fork_actions(Int_val(v_errors), v_actions);
+  } else if (child_pid < 0) {
+    uerror("clone3", Nothing);
+  }
+
+  v_result = caml_alloc_tuple(2);
+  Store_field(v_result, 0, Val_long(child_pid));
+  Store_field(v_result, 1, Val_int(pidfd));
+
+  CAMLreturn(v_result);
+}

lib_eio_linux/fd.ml

@@ -10,6 +10,8 @@ type t = {
   mutable release_hook : Eio.Switch.hook;     (* Use this on close to remove switch's [on_release] hook. *)
 }
 
+let to_rcfd t = t.fd
+
 let err_closed op = Invalid_argument (op ^ ": file descriptor used after calling close!")
 
 let use t f ~if_closed = Rcfd.use t.fd f ~if_closed

lib_eio_linux/low_level.ml

@@ -441,3 +441,84 @@ let pipe ~sw =
   Unix.set_nonblock unix_r;
   Unix.set_nonblock unix_w;
   (r, w)
+
+let with_pipe fn =
+  Switch.run @@ fun sw ->
+  let r, w = pipe ~sw in
+  fn r w
+
+module Process = struct
+  module Rcfd = Eio_unix.Private.Rcfd
+
+  external eio_spawn :
+    Unix.file_descr ->
+    Eio_unix.Private.Fork_action.c_action list ->
+    int * Unix.file_descr = "caml_eio_clone3"
+
+  external pidfd_send_signal : Unix.file_descr -> int -> unit = "caml_eio_pidfd_send_signal"
+
+  type t = {
+    pid : int;
+    pid_fd : Fd.t;
+    exit_status : Unix.process_status Promise.t;
+  }
+
+  let exit_status t = t.exit_status
+  let pid t = t.pid
+
+  module Fork_action = struct
+    type t = Eio_unix.Private.Fork_action.t
+
+    let fchdir fd = Eio_unix.Private.Fork_action.fchdir (Fd.to_rcfd fd)
+    let chdir = Eio_unix.Private.Fork_action.chdir
+    let execve = Eio_unix.Private.Fork_action.execve
+  end
+
+  (* Read a (typically short) error message from a child process. *)
+  let rec read_response fd =
+    let buf = Cstruct.create 256 in
+    match readv fd [buf] with
+    | len -> Cstruct.to_string buf ~len ^ read_response fd
+    | exception End_of_file -> ""
+
+  let signal t signum =
+    Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd ->
+    pidfd_send_signal pid_fd signum
+
+  let rec waitpid pid =
+    match Unix.waitpid [] pid with
+    | p, status -> assert (p = pid); status
+    | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid
+
+  let spawn ~sw actions =
+    with_pipe @@ fun errors_r errors_w ->
+    Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions ->
+    Switch.check sw;
+    let exit_status, set_exit_status = Promise.create () in
+    let t =
+      Fd.use_exn "errors-w" errors_w @@ fun errors_w ->
+      let pid, pid_fd = eio_spawn errors_w c_actions in
+      let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in
+      { pid; pid_fd; exit_status }
+    in
+    Fd.close errors_w;
+    Fiber.fork_daemon ~sw (fun () ->
+        let cleanup () =
+          Fd.close t.pid_fd;
+          Promise.resolve set_exit_status (waitpid t.pid);
+          `Stop_daemon
+        in
+        match await_readable t.pid_fd with
+        | () -> Eio.Cancel.protect cleanup
+        | exception Eio.Cancel.Cancelled _ ->
+          Eio.Cancel.protect (fun () ->
+              signal t Sys.sigkill;
+              await_readable t.pid_fd;
+              cleanup ()
+            )
+      );
+    (* Check for errors starting the process. *)
+    match read_response errors_r with
+    | "" -> t                       (* Success! Execing the child closed [errors_w] and we got EOF. *)
+    | err -> failwith err
+end

lib_eio_linux/tests/spawn.md

@@ -0,0 +1,138 @@
+```ocaml
+# #require "eio_linux";;
+```
+
+```ocaml
+open Eio.Std
+
+module Process = Eio_linux.Low_level.Process
+```
+
+## Spawning processes
+
+Setting environment variables:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let child = Process.spawn ~sw Process.Fork_action.[
+    execve "/usr/bin/env"
+      ~argv:[| "env" |]
+      ~env:[| "FOO=bar" |];
+  ] in
+  Promise.await (Process.exit_status child);;
+FOO=bar
+- : Unix.process_status = Unix.WEXITED 0
+```
+
+Changing directory:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let child = Process.spawn ~sw Process.Fork_action.[
+    chdir "/";
+    execve "/usr/bin/env"
+      ~argv:[| "env"; "pwd" |]
+      ~env:(Unix.environment ())
+  ] in
+  Promise.await (Process.exit_status child);;
+/
+- : Unix.process_status = Unix.WEXITED 0
+```
+
+Changing directory using a file descriptor:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let root =
+    Eio_linux.Low_level.openat2 ~sw "/"
+      ~seekable:false
+      ~access:`R
+      ~perm:0
+      ~resolve:Uring.Resolve.empty
+      ~flags:Uring.Open_flags.(cloexec + path + directory)
+  in
+  let child = Process.spawn ~sw Process.Fork_action.[
+    fchdir root;
+    execve "/usr/bin/env"
+      ~argv:[| "env"; "pwd" |]
+      ~env:(Unix.environment ())
+  ] in
+  Promise.await (Process.exit_status child);;
+/
+- : Unix.process_status = Unix.WEXITED 0
+```
+
+Exit status:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let child = Process.spawn ~sw Process.Fork_action.[
+    execve "/usr/bin/env"
+      ~argv:[| "env"; "false" |]
+      ~env:(Unix.environment ())
+  ] in
+  Promise.await (Process.exit_status child);;
+- : Unix.process_status = Unix.WEXITED 1
+```
+
+Failure starting child:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  try
+    let _child =
+      Process.spawn ~sw Process.Fork_action.[
+        chdir "/idontexist";
+        execve "/usr/bin/env"
+          ~argv:[| "env"; "pwd" |]
+          ~env:(Unix.environment ())
+      ]
+    in
+    assert false
+  with Failure ex ->
+    String.sub ex 0 7
+- : string = "chdir: "
+```
+
+Signalling a running child:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let child =
+    Process.spawn ~sw Process.Fork_action.[
+      execve "/usr/bin/env"
+        ~argv:[| "env"; "sleep"; "1000" |]
+        ~env:(Unix.environment ())
+    ]
+  in
+  Process.signal child Sys.sigkill;
+  match Promise.await (Process.exit_status child) with
+  | Unix.WSIGNALED x when x = Sys.sigkill -> traceln "Child got SIGKILL"
+  | _ -> assert false;;
++Child got SIGKILL
+- : unit = ()
+```
+
+Signalling an exited child does nothing:
+
+```ocaml
+# Eio_linux.run @@ fun _env ->
+  Switch.run @@ fun sw ->
+  let child =
+    Process.spawn ~sw Process.Fork_action.[
+      execve "/usr/bin/env"
+        ~argv:[| "env" |]
+        ~env:[| "FOO=bar" |];
+    ]
+  in
+  ignore (Promise.await (Process.exit_status child) : Unix.process_status);
+  Process.signal child Sys.sigkill;;
+FOO=bar
+- : unit = ()
+```