diff --git a/lib_eio/unix/dune b/lib_eio/unix/dune index f36b5938e..63a0b99d0 100644 --- a/lib_eio/unix/dune +++ b/lib_eio/unix/dune @@ -1,4 +1,8 @@ (library (name eio_unix) (public_name eio.unix) + (foreign_stubs + (language c) + (include_dirs include) + (names fork_action)) (libraries eio unix threads mtime.clock.os)) diff --git a/lib_eio/unix/eio_unix.ml b/lib_eio/unix/eio_unix.ml index e8738048a..a078505e3 100644 --- a/lib_eio/unix/eio_unix.ml +++ b/lib_eio/unix/eio_unix.ml @@ -27,6 +27,8 @@ module Private = struct | Pipe : Eio.Switch.t -> ( * ) Effect.t module Rcfd = Rcfd + + module Fork_action = Fork_action end let await_readable fd = Effect.perform (Private.Await_readable fd) diff --git a/lib_eio/unix/eio_unix.mli b/lib_eio/unix/eio_unix.mli index 3cb022c49..491d33549 100644 --- a/lib_eio/unix/eio_unix.mli +++ b/lib_eio/unix/eio_unix.mli @@ -102,6 +102,8 @@ module Private : sig ( * ) Effect.t (** See {!pipe} *) module Rcfd = Rcfd + + module Fork_action = Fork_action end module Ctf = Ctf_unix diff --git a/lib_eio/unix/fork_action.c b/lib_eio/unix/fork_action.c new file mode 100644 index 000000000..5abe73b09 --- /dev/null +++ b/lib_eio/unix/fork_action.c @@ -0,0 +1,95 @@ +#include +#include +#include +#include +#include + +#include + +#include "fork_action.h" + +void eio_unix_run_fork_actions(int errors, value v_actions) { + int old_flags = fcntl(errors, F_GETFL, 0); + fcntl(errors, F_SETFL, old_flags & ~O_NONBLOCK); + while (Is_block(v_actions)) { + value v_action = Field(v_actions, 0); + fork_fn *action = (fork_fn *) Nativeint_val(Field(v_action, 0)); + action(errors, v_action); + v_actions = Field(v_actions, 1); + } + _exit(1); +} + +static void try_write_all(int fd, char *buf) { + int len = strlen(buf); + while (len > 0) { + int wrote = write(fd, buf, len); + + if (wrote <= 0) + return; + + buf += wrote; + len -= wrote; + } +} + +void eio_unix_fork_error(int fd, char *fn, char *buf) { + try_write_all(fd, fn); + try_write_all(fd, ": "); + try_write_all(fd, buf); +} + +static char **make_string_array(int errors, value v_array) { + int n = Wosize_val(v_array); + char **c = calloc(sizeof(char *), (n + 1)); + if (!c) { + eio_unix_fork_error(errors, "make_string_array", "out of memory"); + _exit(1); + } + for (int i = 0; i < n; i++) { + c[i] = (char *) String_val(Field(v_array, i)); + } + c[n] = NULL; + return c; +} + +static void action_execve(int errors, value v_config) { + value v_exe = Field(v_config, 1); + char **argv = make_string_array(errors, Field(v_config, 2)); + char **envp = make_string_array(errors, Field(v_config, 3)); + execve(String_val(v_exe), argv, envp); + eio_unix_fork_error(errors, "execve", strerror(errno)); + _exit(1); +} + +CAMLprim value eio_unix_fork_execve(value v_unit) { + return Val_fork_fn(action_execve); +} + +static void action_fchdir(int errors, value v_config) { + value v_fd = Field(v_config, 1); + int r; + r = fchdir(Int_val(v_fd)); + if (r != 0) { + eio_unix_fork_error(errors, "fchdir", strerror(errno)); + _exit(1); + } +} + +CAMLprim value eio_unix_fork_fchdir(value v_unit) { + return Val_fork_fn(action_fchdir); +} + +static void action_chdir(int errors, value v_config) { + value v_path = Field(v_config, 1); + int r; + r = chdir(String_val(v_path)); + if (r != 0) { + eio_unix_fork_error(errors, "chdir", strerror(errno)); + _exit(1); + } +} + +CAMLprim value eio_unix_fork_chdir(value v_unit) { + return Val_fork_fn(action_chdir); +} diff --git a/lib_eio/unix/fork_action.ml b/lib_eio/unix/fork_action.ml new file mode 100644 index 000000000..df09e93f0 --- /dev/null +++ b/lib_eio/unix/fork_action.ml @@ -0,0 +1,36 @@ +type c_action = Obj.t + +type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] + +(* A [fork_fn] is a C function that can be executed after forking. It cannot call OCaml code or + run the OCaml GC. It is passed a [Unix.file_descr] for errors and a pointer + to a [c_action]. On success it should write nothing to the error stream and + return 0. On error, it should write a message to the error FD and return a + non-zero value for the exit status (e.g. 1). *) +type fork_fn + +let rec with_actions actions fn = + match actions with + | [] -> fn [] + | { run } :: xs -> + run @@ fun c_action -> + with_actions xs @@ fun c_actions -> + fn (c_action :: c_actions) + +let err_closed op () = + Fmt.failwith "%s: FD is closed!" op + +external action_execve : unit -> fork_fn = "eio_unix_fork_execve" +let action_execve = action_execve () +let execve path ~argv ~env = { run = fun k -> k (Obj.repr (action_execve, path, argv, env)) } + +external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir" +let action_chdir = action_chdir () +let chdir path = { run = fun k -> k (Obj.repr (action_chdir, path)) } + +external action_fchdir : unit -> fork_fn = "eio_unix_fork_fchdir" +let action_fchdir = action_fchdir () +let fchdir fd = { + run = fun k -> + Rcfd.use ~if_closed:(err_closed "fchdir") fd @@ fun fd -> + k (Obj.repr (action_fchdir, fd)) } diff --git a/lib_eio/unix/fork_action.mli b/lib_eio/unix/fork_action.mli new file mode 100644 index 000000000..26ea4dc8b --- /dev/null +++ b/lib_eio/unix/fork_action.mli @@ -0,0 +1,40 @@ +(** Actions to perform after forking a child process. + + To spawn a child executable on Unix, the parent forks a copy of itself, + then has the child copy set up the environment for the new program and + execute it. + + However, we cannot run any OCaml code in the forked child process. This is + because `fork` only duplicates its own domain. To the child, it appears + that all other domains have stopped responding and if it tries to e.g. + perform a GC then the child process will hang. + + Therefore, the fork call and all child actions need to be written in C. + This module provides some support code for doing that. + Individual backends will wrap these actions with higher-level APIs and + can also add their own platform-specific actions *) + +type fork_fn +(** A C function, as defined in "include/fork_action.h". *) + +type c_action = Obj.t +(** An action to be performed in a child process after forking. + This must be a tuple whose first field is a [fork_fn]. *) + +type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed] +(** An action that calls [run k] in the parent process to create the C action. + [run] passes the action to [k], which forks the child and runs it. When [k] + returns, [run] can free any resources used. *) + +val with_actions : t list -> (c_action list -> 'a) -> 'a + +(** {2 Actions} *) + +val execve : string -> argv:string array -> env:string array -> t +(** See [execve(2)]. *) + +val chdir : string -> t +(** [chdir path] changes directory to [path]. *) + +val fchdir : Rcfd.t -> t +(** [fchdir fd] changes directory to [fd]. *) diff --git a/lib_eio/unix/include/fork_action.h b/lib_eio/unix/include/fork_action.h new file mode 100644 index 000000000..7f9627bdb --- /dev/null +++ b/lib_eio/unix/include/fork_action.h @@ -0,0 +1,22 @@ +#include +#include + +/* A function that runs in the forked child process. It must not run any OCaml code or invoke the GC. + * If the action fails then it writes an error message to the FD [errors] and calls [_exit]. + * v_args is the c_action tuple (where field 0 is the function itself). + */ +typedef void fork_fn(int errors, value v_args); + +Caml_inline value Val_fork_fn(fork_fn *fn) { + return caml_copy_nativeint((intnat) fn); +} + +/* Run each C action in the list [v_actions]. + * Sets [errors] to be blocking. Never returns. + */ +void eio_unix_run_fork_actions(int errors, value v_actions); + +/* Write "$fn: $msg" to fd. + * fd must be blocking. + * Ignores failure. */ +void eio_unix_fork_error(int fd, char *fn, char *msg); diff --git a/lib_eio_posix/children.ml b/lib_eio_posix/children.ml new file mode 100644 index 000000000..d5a12d139 --- /dev/null +++ b/lib_eio_posix/children.ml @@ -0,0 +1,88 @@ +(* Keep track of running child processes and notify their fiber when they exit. + After forking a child process, it gets registered in the global [db] along with a resolver + for the promise of its exit status. When we get a SIGCHLD signal, we reap all exited processes + and resolve their promises, waking whichever fibers are waiting for them. + + We have to be careful not to use a PID after [wait] reaps it, as the PID could have been reused by then. + + The signal handler can run in any domain or systhread, so we have to be careful about that too. + We can't defer the call to [wait] until we're running in an Eio domain as we don't know which domain + should handle it until [wait] gives as the process ID. We don't want to delegate to a particular domain + because it might be spinning doing CPU stuff for a long time. Instead, we try to take the lock in the + signal handler and do it there. If we can't get the lock then we just record that a wait is needed; + whoever holds the lock will soon release it and will do the reaping for us. + + Note that, since signal handlers are global, + this will interfere with any libraries trying to manage processes themselves. + + For systems with Process Descriptors we could skip all this nonsense and + just poll on the process's FD. e.g. using [pdfork] on FreeBSD or [CLONE_PIDFD] on Linux. *) + +open Eio.Std + +(* Each child process is registered in this table. + Must hold [lock] when accessing it. *) +let db : (int, Unix.process_status Promise.u) Hashtbl.t = Hashtbl.create 10 + +(* Set to [true] when we receive [SIGCHLD] and [false] before calling [wait]. *) +let need_wait = Atomic.make false + +(* [lock] must be held when spawning or reaping. Otherwise, this can happen: + + - We spawn process 100, adding it to [db]. + - It exits, sending us SIGCHLD. + - The signal handler calls [wait], reaping it. + - Another domain spawns another process 100 and adds it to [db], + overwriting the previous entry. + - The signal handler resumes, and gets the wrong entry. + + If [lock] is already locked when the SIGCHLD handler runs then it just leaves [need_wait = true] + (a signal handler can't wait on a mutex, since it may have interrupted the holder). + The unlocker needs to check [need_wait] after releasing the lock. *) +let lock = Mutex.create () + +(* [pid] has exited. Notify the waiter. Must hold [lock] when calling this. *) +let report_child_status pid status = + match Hashtbl.find_opt db pid with + | Some r -> + Hashtbl.remove db pid; + Promise.resolve r status + | None -> + (* Not one of ours. Not much we can do here. The spawner will probably get + an [ECHILD] error when they wait, which will do for the error. *) + () + +(* Must hold [lock] when calling this. *) +let rec reap () = + Atomic.set need_wait false; + match Unix.(waitpid [WNOHANG] (-1)) with + | 0, _ -> () (* Returned if there are children but none has exited yet. *) + | pid, status -> report_child_status pid status; reap () + | exception Unix.Unix_error (EINTR, _, _) -> reap () + | exception Unix.Unix_error (ECHILD, _, _) -> () (* Returned if there are no children at all. *) + +let rec reap_nonblocking () = + if Mutex.try_lock lock then ( + reap (); + Mutex.unlock lock; + if Atomic.get need_wait then reap_nonblocking () + ) (* else the unlocker will see [need_wait] and call us later *) + +let unlock () = + Mutex.unlock lock; + if Atomic.get need_wait then reap_nonblocking () + +(* Must hold [lock] when calling this. *) +let register pid = + assert (not (Hashtbl.mem db pid)); + let p, r = Promise.create () in + Hashtbl.add db pid r; + p + +let with_lock fn = + Mutex.lock lock; + Fun.protect fn ~finally:unlock + +let handle_sigchld () = + Atomic.set need_wait true; + reap_nonblocking () diff --git a/lib_eio_posix/children.mli b/lib_eio_posix/children.mli new file mode 100644 index 000000000..a8ead2276 --- /dev/null +++ b/lib_eio_posix/children.mli @@ -0,0 +1,14 @@ +(** Keep track of child processes and respond to SIGCHLD. *) + +val with_lock : (unit -> 'a) -> 'a +(** This must be held during the (fork, register) sequence + (so that we don't try to reap the process before it's registered), + and also when signalling a child process + (to ensure it isn't reaped at the same time). *) + +val register : int -> Unix.process_status Eio.Promise.t +(** [register pid] adds [pid] to the list of children and returns a promise for its exit status. + You must hold the lock while forking and then calling this. *) + +val handle_sigchld : unit -> unit +(** Call this on [SIGCHLD]. *) diff --git a/lib_eio_posix/domain_mgr.ml b/lib_eio_posix/domain_mgr.ml index a4a4a35bc..e442df6af 100644 --- a/lib_eio_posix/domain_mgr.ml +++ b/lib_eio_posix/domain_mgr.ml @@ -46,11 +46,7 @@ let run_event_loop fn x = ) | Eio_unix.Private.Pipe sw -> Some (fun k -> match - let unix_r, unix_w = Unix.pipe ~cloexec:true () in - let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in - let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in - Unix.set_nonblock unix_r; - Unix.set_nonblock unix_w; + let r, w = Low_level.pipe ~sw in let source = (Flow.of_fd r :> ) in let sink = (Flow.of_fd w :> ) in (source, sink) diff --git a/lib_eio_posix/dune b/lib_eio_posix/dune index 802633ce9..0131354a3 100644 --- a/lib_eio_posix/dune +++ b/lib_eio_posix/dune @@ -5,6 +5,7 @@ (foreign_stubs (language c) (flags :standard -D_LARGEFILE64_SOURCE) + (include_dirs ../lib_eio/unix/include) (names eio_posix_stubs)) (libraries eio eio.utils eio.unix fmt iomux)) diff --git a/lib_eio_posix/eio_posix.ml b/lib_eio_posix/eio_posix.ml index 7409ddf45..7015f76a3 100644 --- a/lib_eio_posix/eio_posix.ml +++ b/lib_eio_posix/eio_posix.ml @@ -33,6 +33,7 @@ type stdenv = < let run main = (* SIGPIPE makes no sense in a modern application. *) Sys.(set_signal sigpipe Signal_ignore); + Sys.(set_signal sigchld (Signal_handle (fun (_:int) -> Children.handle_sigchld ()))); let stdin = (Flow.of_fd Low_level.Fd.stdin :> ) in let stdout = (Flow.of_fd Low_level.Fd.stdout :> ) in let stderr = (Flow.of_fd Low_level.Fd.stderr :> ) in diff --git a/lib_eio_posix/eio_posix_stubs.c b/lib_eio_posix/eio_posix_stubs.c index e692d93ad..93a0f10c4 100644 --- a/lib_eio_posix/eio_posix_stubs.c +++ b/lib_eio_posix/eio_posix_stubs.c @@ -17,6 +17,8 @@ #include #include +#include "fork_action.h" + #ifdef ARCH_SIXTYFOUR #define Int63_val(v) Long_val(v) #else @@ -185,3 +187,17 @@ CAMLprim value caml_eio_posix_renameat(value v_old_fd, value v_old_path, value v if (ret == -1) uerror("renameat", v_old_path); CAMLreturn(Val_unit); } + +CAMLprim value caml_eio_posix_spawn(value v_errors, value v_actions) { + CAMLparam1(v_actions); + pid_t child_pid; + + child_pid = fork(); + if (child_pid == 0) { + eio_unix_run_fork_actions(Int_val(v_errors), v_actions); + } else if (child_pid < 0) { + uerror("fork", Nothing); + } + + CAMLreturn(Val_long(child_pid)); +} diff --git a/lib_eio_posix/fd.ml b/lib_eio_posix/fd.ml index e7ec8d63a..8a7b19fd1 100644 --- a/lib_eio_posix/fd.ml +++ b/lib_eio_posix/fd.ml @@ -16,6 +16,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_exn op t f = diff --git a/lib_eio_posix/fd.mli b/lib_eio_posix/fd.mli index 1192a8691..0fb961fd7 100644 --- a/lib_eio_posix/fd.mli +++ b/lib_eio_posix/fd.mli @@ -38,6 +38,10 @@ val to_unix : [`Peek | `Take] -> t -> Unix.file_descr [to_unix `Peek t] returns the wrapped FD directly. You must ensure that it is not closed while using it. *) +val to_rcfd : t -> Eio_unix.Private.Rcfd.t +(** Get the underlying ref-counted FD. + Note: you must not close this directly, as that will not remove the hook. *) + type has_fd = < fd : t > (** Resources that have FDs are sub-types of [has_fd]. *) diff --git a/lib_eio_posix/low_level.ml b/lib_eio_posix/low_level.ml index 791efcf79..e950f3be7 100644 --- a/lib_eio_posix/low_level.ml +++ b/lib_eio_posix/low_level.ml @@ -198,3 +198,80 @@ let rename ?old_dir old_path ?new_dir new_path = with_dirfd "rename-old" old_dir @@ fun old_dir -> with_dirfd "rename-new" new_dir @@ fun new_dir -> eio_renameat old_dir old_path new_dir new_path + +let pipe ~sw = + let unix_r, unix_w = Unix.pipe ~cloexec:true () in + let r = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_r in + let w = Fd.of_unix ~sw ~blocking:false ~close_unix:true unix_w in + Unix.set_nonblock unix_r; + Unix.set_nonblock unix_w; + r, w + +module Process = struct + type t = { + pid : int; + 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 = Bytes.create 256 in + match read fd buf 0 (Bytes.length buf) with + | 0 -> "" + | n -> Bytes.sub_string buf 0 n ^ read_response fd + + let with_pipe fn = + Switch.run @@ fun sw -> + let r, w = pipe ~sw in + fn r w + + let signal t signal = + (* The lock here ensures we don't signal the PID after reaping it. *) + Children.with_lock @@ fun () -> + if not (Promise.is_resolved t.exit_status) then ( + Unix.kill t.pid signal + ) + + external eio_spawn : Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> int = "caml_eio_posix_spawn" + + 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 t = + (* We take the lock to ensure that the signal handler won't reap the + process before we've registered it. *) + Children.with_lock (fun () -> + let pid = + Fd.use_exn "errors-w" errors_w @@ fun errors_w -> + eio_spawn errors_w c_actions + in + Fd.close errors_w; + { pid; exit_status = Children.register pid } + ) + in + let hook = Switch.on_release_cancellable sw (fun () -> signal t Sys.sigkill) in + (* Removing the hook must be done from our own domain, not from the signal handler, + so fork a fiber to deal with that. If the switch gets cancelled then this won't + run, but then the [on_release] handler will run the hook soon anyway. *) + Fiber.fork_daemon ~sw (fun () -> + ignore (Promise.await t.exit_status : Unix.process_status); + Switch.remove_hook hook; + `Stop_daemon + ); + (* 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 diff --git a/lib_eio_posix/low_level.mli b/lib_eio_posix/low_level.mli index 30f2a94c7..512c166cc 100644 --- a/lib_eio_posix/low_level.mli +++ b/lib_eio_posix/low_level.mli @@ -50,6 +50,8 @@ val writev : Fd.t -> Cstruct.t array -> int val preadv : file_offset:Optint.Int63.t -> Fd.t -> Cstruct.t array -> int val pwritev : file_offset:Optint.Int63.t -> Fd.t -> Cstruct.t array -> int +val pipe : sw:Switch.t -> Fd.t * Fd.t + module Open_flags : sig type t @@ -72,3 +74,43 @@ end val openat : ?dirfd:Fd.t -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> Fd.t (** Note: the returned FD is always non-blocking and close-on-exec. *) + +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 diff --git a/lib_eio_posix/test/spawn.md b/lib_eio_posix/test/spawn.md new file mode 100644 index 000000000..528a627eb --- /dev/null +++ b/lib_eio_posix/test/spawn.md @@ -0,0 +1,131 @@ +```ocaml +# #require "eio_posix";; +``` + +```ocaml +open Eio.Std + +module Process = Eio_posix.Low_level.Process +``` + +## Spawning processes + +Setting environment variables: + +```ocaml +# Eio_posix.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_posix.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_posix.run @@ fun _env -> + Switch.run @@ fun sw -> + let root = Eio_posix.Low_level.openat ~sw ~mode:0 "/" Eio_posix.Low_level.Open_flags.(rdonly + 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_posix.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_posix.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_posix.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_posix.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 = () +``` diff --git a/tests/signal.md b/tests/signal.md index b06136907..0d1b5567d 100644 --- a/tests/signal.md +++ b/tests/signal.md @@ -26,12 +26,15 @@ Prove we can catch sigint: Unix.kill ppid Sys.sigint; Unix._exit 0 | child_pid -> - let wait () = - let pid, status = Unix.waitpid [] child_pid in - assert (pid = child_pid); - assert (status = (Unix.WEXITED 0)) + let rec wait () = + match Unix.waitpid [] child_pid with + | pid, status -> + assert (pid = child_pid); + assert (status = (Unix.WEXITED 0)) + | exception Unix.Unix_error (EINTR, _, _) -> wait () + | exception Unix.Unix_error (ECHILD, _, _) -> () (* Hack until we have a cross-platform process API *) in - try wait () with Unix.Unix_error (Unix.EINTR, _, _) -> wait () + wait () ); Sys.set_signal Sys.sigint old;; +interrupted!