JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A test's flan dev daemon ends with its harness, a daemon whose socket is gone exits, agent sockets are removed with their program, and killing *flan* asks first.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 14:15:25 +07:00
commit 3cc8ca9cbb
11 changed files with 558 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
emacs/flan.el
View File

@ -900,6 +900,62 @@ It builds the program first, which for a cold project is most of this."
(message "flan dev: the daemon exited (%s); see %s"
(string-trim (or event "")) flan-daemon-buffer))))
(defun flan--close-daemon ()
"Ask the daemon this Emacs started to end, and give it a moment to.
For `kill-buffer-hook' on its buffer and for `kill-emacs-hook': either
deletes the process outright, and a daemon killed that way never runs its
own cleanup -- its socket, its temporary directory, and under
--two-process the program it started. `close' is its own way out. Never
signals, so the kill that called it always goes ahead."
(let ((proc flan--daemon)
(sock flan--daemon-socket))
(when (and (process-live-p proc) sock)
(if (and (process-live-p flan--connection)
(equal flan--socket sock))
;; Connected to it: `flan-quit' is exactly this, with its state
;; cleared as well.
(ignore-errors (flan-quit))
;; Not connected, or connected to another session: a connection of
;; its own, so the other session is left alone.
(ignore-errors
(let ((c (make-network-process
:name "flan-close" :family 'local
:service (flan--short-socket sock)
:coding 'binary :noquery t)))
(unwind-protect
(progn
(flan--send c '(:op "close"))
(let ((deadline (+ (float-time) 2)))
(while (and (process-live-p proc)
(< (float-time) deadline))
(accept-process-output proc 0.05))))
(delete-process c))))))))
(add-hook 'kill-emacs-hook #'flan--close-daemon)
(defun flan--daemon-of-this-buffer-p ()
"Whether the live daemon this Emacs started writes to the current buffer."
(and (process-live-p flan--daemon)
(eq (process-buffer flan--daemon) (current-buffer))))
(defun flan--query-kill-daemon ()
"Ask before killing the buffer of a live daemon, as CIDER does for nREPL.
For `kill-buffer-query-functions'. A yes clears the process's own query,
so Emacs does not ask a second time, and `flan--kill-daemon-buffer' then
stops the daemon cleanly."
(or (not (flan--daemon-of-this-buffer-p))
(when (y-or-n-p
(format "flan dev is running %s; stop it and kill the buffer? "
(file-name-nondirectory
(or flan--file flan--daemon-socket "the program"))))
(set-process-query-on-exit-flag flan--daemon nil)
t)))
(defun flan--kill-daemon-buffer ()
"Stop the daemon cleanly when its buffer is killed; see `flan--close-daemon'."
(when (flan--daemon-of-this-buffer-p)
(flan--close-daemon)))
(defun flan--start-daemon (file socket)
"Start `flan dev' on FILE listening on SOCKET, and return the process."
(let* ((buf (get-buffer-create flan-daemon-buffer))
@ -947,13 +1003,19 @@ It builds the program first, which for a cold project is most of this."
;; program runs, and `compilation-mode' would claim it as the output of
;; one finished command — killing the process on a `recompile', among
;; other things it has no business doing to a live session.
(flan--daemon-buffer-setup))
(flan--daemon-buffer-setup)
;; Killing this buffer deletes its process, so the kill asks first and
;; then tells the daemon to close.
(add-hook 'kill-buffer-query-functions #'flan--query-kill-daemon nil t)
(add-hook 'kill-buffer-hook #'flan--kill-daemon-buffer nil t))
(make-process
:name "flan-daemon" :buffer buf
:command args
;; The daemon writes its ready line and the program's stderr to stderr,
;; and both belong in the same buffer in the order they happened.
:connection-type 'pipe :noquery t
;; No :noquery: exiting Emacs with a session running asks once, through
;; the usual list of live processes, and `kill-emacs-hook' then closes it.
:connection-type 'pipe
:sentinel #'flan--daemon-sentinel)))
(defun flan--connect-when-ready (socket proc)

58
emacs/test-flan.el
View File

@ -1597,7 +1597,63 @@ already rely on it — so nothing here is a stand-in for the real thing."
;; claim seen from the other side.
(test-flan--check "and takes its socket with it"
(not (file-exists-p socket2))))
(ignore-errors (delete-file socket2)))
(ignore-errors (delete-file socket2))
;; Killing the daemon's buffer asks first, as CIDER does, and a yes stops
;; the daemon the way `flan-quit' does rather than deleting the process:
;; the daemon, its program (--two-process, so it is a process of its own)
;; and the socket all go. A no leaves both the buffer and the daemon.
(let ((socket3 (concat socket "-killed-buffer"))
(asked 0)
(answer nil))
(ignore-errors (delete-file socket3))
(let ((flan-daemon-args (append flan-daemon-args '("--two-process"))))
(flan program socket3))
(let* ((proc flan--daemon)
(pid (process-id proc))
(kids (ignore-errors
(mapcar #'string-to-number
(split-string
(with-temp-buffer
(insert-file-contents
(format "/proc/%d/task/%d/children" pid pid))
(buffer-string))))))
(gone (lambda (p)
(let ((stat (format "/proc/%d/stat" p)))
(or (not (file-exists-p stat))
(with-temp-buffer
(insert-file-contents stat)
(re-search-forward ") \\(.\\)" nil t)
(equal (match-string 1) "Z")))))))
(cl-letf (((symbol-function 'y-or-n-p)
(lambda (&rest _) (setq asked (1+ asked)) answer)))
(test-flan--check "the daemon's program is a process of its own"
kids)
(setq answer nil)
(kill-buffer flan-daemon-buffer)
(test-flan--check "killing the daemon's buffer asks, and no keeps both"
(and (= asked 1)
(get-buffer flan-daemon-buffer)
(process-live-p proc)))
(setq answer t)
(kill-buffer flan-daemon-buffer)
(let ((deadline (+ (float-time) 5)))
(while (and (< (float-time) deadline)
(not (and (funcall gone pid)
(cl-every gone kids))))
(sleep-for 0.05)))
(test-flan--check "and yes stops the daemon and its program"
(and (= asked 2)
(not (get-buffer flan-daemon-buffer))
(null flan--daemon)
(funcall gone pid)
(cl-every gone kids)))
(test-flan--check "and removes its socket"
(not (file-exists-p socket3)))
(setq asked 0)
(with-temp-buffer
(test-flan--check "no daemon, no question"
(and (flan--query-kill-daemon) (= asked 0))))))))
;; ── One command, one session ──────────────────────────────────────────
;;

146
lib/dev.ml
View File

@ -5106,6 +5106,27 @@ let push_request p req op reply =
else p.watch_every <- None
| _ -> ()
(* A test harness that starts a daemon names itself in FLAN_DEV_HARNESS
(test/watchdog.ml), and the daemon dies with its parent and ends when the
harness has gone. The parent half is PR_SET_PDEATHSIG, armed in [start].
The harness half is for a daemon whose parent is not the harness — one an
Emacs under test started — and is read by [accept_loop] and [serve].
Opt-in only: a daemon an editor or a shell starts must outlive them, as it
always has. *)
let harness () =
match Sys.getenv_opt "FLAN_DEV_HARNESS" with
| Some s ->
(match int_of_string_opt (String.trim s) with
| Some p when p > 0 -> Some p
| _ -> None)
| None -> None
let alive pid =
match Unix.kill pid 0 with
| () -> true
| exception Unix.Unix_error (Unix.ESRCH, _, _) -> false
| exception Unix.Unix_error _ -> true
(* ── The loop ──────────────────────────────────────────────────────── *)
(* One connection at a time. An editor is one client, evaluations are
@ -5118,12 +5139,43 @@ let push_request p req op reply =
let serve t fd =
let p = { on = false; out_due = None; last_out = 0.; watch_every = None;
watch_due = 0.; pend = Buffer.create 4096; sent = 0 } in
(* Under a test harness only: an attached client is no proof the harness is
alive — an Emacs under test holds its connection after the test binary
that ran it is gone, and it is this daemon's parent, so PDEATHSIG does not
fire either. So the wait is capped at a second and the harness looked at
each time round. Not the socket: an attached editor can still reach this
daemon whatever happened to the file. *)
let harness_pid = harness () in
let harness_due = ref 0. in
let harness_gone () =
match harness_pid with
| None -> false
| Some pid ->
let now = Unix.gettimeofday () in
if now < !harness_due then false
else begin
harness_due := now +. 1.;
if alive pid then false
else begin
Printf.eprintf
"flan dev: this session is ending; the test harness that started \
it (pid %d) has exited\n%!" pid;
true
end
end
in
let cap wait =
match harness_pid with
| None -> wait
| Some _ -> if wait < 0. || wait > 1. then 1. else wait
in
(* Between requests: push what is due, then wait for a request, for the
program's output, or for the next push, whichever comes first. The pipe
is drained here whether or not this client takes pushes, which is the
liveness requirement [drain] describes, met while an editor is attached
as well as between editors. *)
let rec go () =
if harness_gone () then true else
match push_due p t fd (Unix.gettimeofday ()) with
| exception Unix.Unix_error _ -> false
| blocked ->
@ -5134,7 +5186,7 @@ let serve t fd =
let wfds, wait =
if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ())
in
(match Unix.select fds wfds [] wait with
(match Unix.select fds wfds [] (cap wait) with
| ready, _, _ ->
if List.mem t.stdout ready && not t.finished then begin
drain t;
@ -5282,6 +5334,60 @@ let client_grace () =
| None -> client_grace_default)
| None -> client_grace_default
(* ── Whether anything can still reach this session ─────────────────── *)
(* A daemon whose socket file has been deleted, or replaced by another daemon
binding the same path, can never be connected to again: an editor finds a
session only by that path. So the accept loop looks at the path about once a
second and ends the session, cleanly, when it no longer names the file this
daemon bound.
The identity is taken with [stat] on the path right after the bind, never
from the listening fd (a socket fd's inode is sockfs's, not the file's), and
the watch starts only in [accept_loop], after the bind — so a session still
building cannot trip it. [stat] takes a path up to PATH_MAX, so a socket
bound through /proc/self/fd because its path is past 107 bytes is looked at
by that long path directly; the short symlink an editor connects through is
not what is checked. Both daemon shapes bind in this process, so
--two-process watches the same file the merged build does. *)
type bound = { path : string; dev : int; ino : int }
let bound_at sock =
let path =
if Filename.is_relative sock then Filename.concat (Sys.getcwd ()) sock
else sock
in
match Unix.stat path with
| s -> Some { path; dev = s.Unix.st_dev; ino = s.Unix.st_ino }
| exception Unix.Unix_error _ -> None
let still_bound b =
match Unix.stat b.path with
| s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino
| exception Unix.Unix_error _ -> false
(* Why the session can no longer be reached, if it cannot. *)
let unreachable bound =
match bound with
| Some b when not (still_bound b) ->
Some
(Printf.sprintf "its socket %s was removed or replaced, so no editor can \
reach it" b.path)
| _ ->
match harness () with
| Some pid when not (alive pid) ->
Some (Printf.sprintf "the test harness that started it (pid %d) has exited"
pid)
| _ -> None
(* The socket file and its short symlink, removed on the way out only while
the path still names this daemon's socket: one that was replaced belongs to
the daemon that replaced it, and so does the symlink to it. *)
let release_socket bound sock ~unlink_short =
let mine = match bound with Some b -> still_bound b | None -> true in
if mine then (try Unix.unlink sock with Unix.Unix_error _ -> ());
if mine || not (Sys.file_exists sock) then unlink_short sock
(* [accept] would block past the program's own exit, so it is waited on with
a timeout and the child checked each time round: a daemon whose program has
finished has nothing left to do, and an editor waiting on it would wait
@ -5298,18 +5404,29 @@ let client_grace () =
hole: it reads the client, not the program, and all of an Emacs's windows
share the one [flan--connection], so closing one of them changes
nothing this loop can see. *)
let accept_loop ?grace t ls =
let accept_loop ?grace ?bound t ls =
let grace = match grace with Some g -> g | None -> client_grace () in
(* [served] arms the clock and [since] is when the last client let go — set
when [serve] returns rather than when [accept] fires, so a connection that
is held for an hour is an hour of the clock not running. *)
let served = ref false and since = ref (Unix.gettimeofday ()) in
let reach_due = ref 0. in
let cut_off () =
let now = Unix.gettimeofday () in
if now < !reach_due then None
else begin reach_due := now +. 1.; unreachable bound end
in
let rec go () =
(* The other place the agent clock is read: between connections, which is
where a session with no editor attached spends its time. *)
agent_check t;
match liveness t with
| Gone when t.relaunch = None -> ()
| _ when (match cut_off () with
| Some why ->
Printf.eprintf "flan dev: this session is ending; %s\n%!" why;
true
| None -> false) -> ()
| live ->
(* A --two-process child that has ended can be started again, so the
session waits as a parked one does, on the parked grace. *)
@ -5614,6 +5731,7 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
link_short_socket sock;
Wire.bind_socket ls sock;
let bound = bound_at sock in
Unix.listen ls 4;
Printf.eprintf "flan dev: %s ready on %s (%.0fms)\n%!" file sock
((Unix.gettimeofday () -. t0) *. 1000.);
@ -5625,9 +5743,8 @@ let two_process ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock (
| None -> ());
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.close t.stdout with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock)
(fun () -> accept_loop t ls);
release_socket bound sock ~unlink_short:unlink_short_socket)
(fun () -> accept_loop ?bound t ls);
(* Here only when the loop returned: an exception out of it has already
left through the [finally]. A child killed by a signal is the crash that
keeps the directory. *)
@ -6478,8 +6595,9 @@ let merged_setup () =
let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
link_short_socket sock;
Wire.bind_socket ls sock;
let bound = bound_at sock in
Unix.listen ls 4;
merged_state := Some (t, ls, sock);
merged_state := Some (t, ls, sock, bound);
Printf.eprintf "flan dev: %s ready on %s (%.0fms, one process)\n%!" file
sock ((Unix.gettimeofday () -. t0) *. 1000.)
with
@ -6508,7 +6626,7 @@ let merged_setup () =
let merged_serve () =
match !merged_state with
| None -> prerr_endline "flan dev: serve was called before setup"; exit 1
| Some (t, ls, sock) ->
| Some (t, ls, sock, bound) ->
(* The agent is bound by the program on the main thread, which only starts
once [merged_setup] has returned. So this does not wait for it: it arms
the clock that eventually says it never came, and serves.
@ -6529,15 +6647,14 @@ let merged_serve () =
[eval] for what a delivery to such a program honestly reports. *)
t.agent_watch <- Some (Unix.gettimeofday () +. 10.);
let clean =
match accept_loop t ls with
match accept_loop ?bound t ls with
| () -> true
| exception e ->
Printf.eprintf "flan dev: %s\n%!" (Printexc.to_string e);
false
in
(try Unix.close ls with Unix.Unix_error _ -> ());
(try Unix.unlink sock with Unix.Unix_error _ -> ());
unlink_short_socket sock;
release_socket bound sock ~unlink_short:unlink_short_socket;
(* The program is this process, so a program that crashed never gets here;
the one end that does and is not clean is the loop raising. *)
if clean then remove_session_dirs t;
@ -6615,6 +6732,15 @@ let start_merged ?(debug = false) ?(sanitize = false) ?(x86 = true) ~file ~sock
actually deleted. *)
let start ?(debug = false) ?(sanitize = false) ?(merged = true) ?(x86 = true)
~file ~sock () =
(* Under a test harness only (see [harness]): SIGKILL when the parent dies,
which the kernel keeps across the exec into a merged build. A parent that
died before this was armed is caught by asking whether the harness is
still there; one that is not the harness is left to [accept_loop]. *)
(match harness () with
| Some pid ->
Spawn.die_with_parent ();
if not (alive pid) then exit 1
| None -> ());
(* The sanitizers are LLVM passes, and the x86 backend's host is written
by hand with no pass run over it. The modules a session sends are not
instrumented on either backend; what is checked is the host and the

3
lib/spawn.ml
View File

@ -4,3 +4,6 @@ external dying : string -> string array -> int = "flan_spawn_dying"
(** The host number of an OCaml signal number. *)
external host_signal : int -> int = "flan_host_signal"
(** Ask for SIGKILL when this process's parent dies; nothing off Linux. *)
external die_with_parent : unit -> unit = "flan_die_with_parent"

12
lib/spawn_stubs.c
View File

@ -56,3 +56,15 @@ value flan_spawn_dying(value path, value argv) {
value flan_host_signal(value s) {
return Val_int(caml_convert_signal_number(Int_val(s)));
}
/* The same request made by this process for itself: SIGKILL when whatever is
* its parent now dies. Only `flan dev` under a test harness asks
* (FLAN_DEV_HARNESS, lib/dev.ml); the kernel keeps it across the exec into a
* merged build. */
value flan_die_with_parent(value unit) {
(void)unit;
#ifdef __linux__
prctl(PR_SET_PDEATHSIG, SIGKILL);
#endif
return Val_unit;
}

5
runtime/flan_rt.c
View File

@ -795,12 +795,17 @@ static void rt_flush_out(void) {
* The two functions are kept saying the same thing on purpose. They are the
* two ways a Flan program dies where it stands, and a difference between them
* would be a difference nobody could predict from the outside. */
/* Set by the dev agent once it has bound its own socket, to remove it: the
* [_exit] below skips the atexit handler that otherwise would. */
void (*flan_die_hook)(void);
static _Noreturn void rt_die(void) {
const char *sock;
rt_flush_out();
fflush(stderr);
sock = getenv("FLAN_DEV_SOCK");
if (sock != NULL && *sock != '\0') unlink(sock);
if (flan_die_hook != NULL) flan_die_hook();
_exit(134);
}

2
test/programs/agent-auto.flan
View File

@ -2,7 +2,7 @@
;;;;
;;;; Under [flan dev] it binds where the daemon said, exactly as the explicit
;;;; form did, and nothing here can tell the difference. Run on its own — which
;;;; is what test_agent.ml does with it — it picks a path under /tmp and prints
;;;; is what test_agent.ml does with it — it picks a path under TMPDIR and prints
;;;; it to stderr, and that printed line is the only way anything could connect.
;;;;
;;;; The second start is here to be a no-op. It answers 0 like the first, does

41
test/test_agent.ml
View File

@ -242,7 +242,11 @@ let () =
(* The shape is part of the claim: two programs started at once must not
choose the same file, and the pid alone would not separate two runs of
the same program in sequence. *)
let pid_part = Printf.sprintf "/tmp/flan-agent-%d-" apid in
(* Under TMPDIR, which the program inherited from this suite. *)
let pid_part =
Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-agent-%d-" apid)
in
if not (String.length apath > String.length pid_part
&& String.sub apath 0 (String.length pid_part) = pid_part)
then fail "the chosen path is not this process's: %S" apath;
@ -286,6 +290,41 @@ let () =
end
end
end;
(* ── The socket goes with a program ended by a signal ──────────────
SIGTERM runs no atexit, so the agent removes its socket from a handler
of its own and then dies of the signal as before. *)
let terr = tmp "term.err" in
let t1 = ofd (tmp "term.out") and t2 = ofd terr in
let tpid = Unix.create_process_env aexe [| aexe |] aenv Unix.stdin t1 t2 in
Unix.close t1;
Unix.close t2;
let tpath () =
let text = In_channel.with_open_bin terr In_channel.input_all in
List.find_map
(fun l ->
if String.starts_with ~prefix l then
Some (String.sub l (String.length prefix)
(String.length l - String.length prefix))
else None)
(String.split_on_char '\n' text)
in
(match
if await (fun () -> tpath () <> None) then tpath () else None
with
| None ->
fail "a program to be sent SIGTERM never announced its socket";
(try Unix.kill tpid Sys.sigkill with Unix.Unix_error _ -> ())
| Some p ->
ignore (await (fun () -> Sys.file_exists p));
Unix.kill tpid Sys.sigterm;
let _, st = Unix.waitpid [] tpid in
if st <> Unix.WSIGNALED Sys.sigterm then
fail "a program sent SIGTERM did not die of it";
if Sys.file_exists p then
fail "the socket outlived a program ended by SIGTERM: %S" p);
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ terr; tmp "term.out" ];
(* ── A path that cannot be bound ────────────────────────────────── *)
(* The same program again, told to listen somewhere that does not exist.

182
test/test_dev.ml
View File

@ -5923,6 +5923,14 @@ let () =
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
(* Past two of the daemon's socket checks with no editor attached:
a socket reached through its directory is still its own. *)
Unix.sleepf 2.5;
(match Unix.waitpid [ Unix.WNOHANG ] pid with
| 0, _ -> ()
| _ -> fail "a deep TMPDIR (%s): the daemon ended with its socket \
in place" shape
| exception Unix.Unix_error _ -> ());
let c = connect dsock in
let said r =
Option.value ~default:(status r) (Wire.string_field r "message")
@ -5958,6 +5966,180 @@ let () =
[ [||]; [| "--two-process" |] ];
Own_tmp.remove deep;
(* ── A daemon nothing can reach any more ends ──────────────────────
Three ways a session becomes unreachable, each in both shapes: the
process that started it is SIGKILLed (the daemon, and under
--two-process its program, die with it); the test harness named in
FLAN_DEV_HARNESS goes, though the daemon's own parent lives on (the
Emacs-started case); and its socket file is deleted. And one way it
does not: a socket left alone keeps the daemon running. *)
let gone pid =
match In_channel.with_open_bin (Printf.sprintf "/proc/%d/stat" pid)
In_channel.input_all with
| st ->
(match String.rindex_opt st ')' with
| Some i when i + 2 < String.length st -> st.[i + 2] = 'Z'
| _ -> false)
| exception Sys_error _ -> true
in
let children pid =
match In_channel.with_open_bin
(Printf.sprintf "/proc/%d/task/%d/children" pid pid)
In_channel.input_all with
| s -> List.filter_map int_of_string_opt (String.split_on_char ' ' (String.trim s))
| exception Sys_error _ -> []
in
let with_harness env =
Array.of_list
(env
@ List.filter
(fun v -> not (String.starts_with ~prefix:"FLAN_DEV_HARNESS=" v))
(Array.to_list (Unix.environment ())))
in
List.iter
(fun mode ->
let shape = if mode = [||] then "one process" else "--two-process" in
let argv s =
Array.append [| flan; "dev"; "programs/dev-pause.flan"; "-s"; s |] mode
in
(* The parent SIGKILLed. A harness process of its own, so that the
parent can be killed without killing this test. *)
let ksock = tmp "orphan-parent.sock" in
(try Sys.remove ksock with Sys_error _ -> ());
let rd, wr = Unix.pipe () in
(match Unix.fork () with
| 0 ->
Unix.close rd;
let d =
Unix.create_process flan (argv ksock) Unix.stdin Unix.stdout
Unix.stderr
in
let msg = string_of_int d ^ "\n" in
ignore (Unix.write_substring wr msg 0 (String.length msg));
Unix.close wr;
Unix.sleep 600;
Unix._exit 0
| h ->
Unix.close wr;
let ic = Unix.in_channel_of_descr rd in
let d = int_of_string (String.trim (input_line ic)) in
close_in ic;
if not (listening ~pid:d ksock) then
fail "a daemon under a harness (%s): %s" shape !listen_why;
let kids = children d in
if mode <> [||] && kids = [] then
fail "a daemon under a harness (%s): no program child found" shape;
Unix.kill h Sys.sigkill;
ignore (Unix.waitpid [] h);
if not (await ~ms:5000 (fun () -> gone d)) then begin
fail "a daemon (%s) outlived the process that started it" shape;
(try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ())
end;
List.iter
(fun k ->
if not (await ~ms:5000 (fun () -> gone k)) then begin
fail "a daemon's program (%s) outlived the daemon" shape;
(try Unix.kill k Sys.sigkill with Unix.Unix_error _ -> ())
end)
kids);
(try Sys.remove ksock with Sys_error _ -> ());
(* The harness gone, the parent alive. [sleep] stands in for it.
Twice: with no client, and with one connected and holding on, as
an Emacs under test does after the binary that ran it is gone. *)
List.iter
(fun held ->
let how = if held then "connected" else "idle" in
let hsock = tmp "orphan-harness.sock" in
(try Sys.remove hsock with Sys_error _ -> ());
let stand_in =
Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin
Unix.stdout Unix.stderr
in
let d =
Unix.create_process_env flan (argv hsock)
(with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ])
Unix.stdin Unix.stdout Unix.stderr
in
let client = ref None in
if not (listening ~pid:d hsock) then
fail "a daemon with a harness (%s, %s): %s" shape how !listen_why
else begin
if held then begin
let c = connect hsock in
client := Some c;
if status (request c "(:op \"describe\")") <> "ok" then
fail "a daemon with a harness (%s): describe failed" shape
end;
Unix.kill stand_in Sys.sigkill;
ignore (Unix.waitpid [] stand_in);
let ended =
await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] d with
| 0, _ -> false
| _ -> true)
in
if not ended then
fail "a daemon (%s, %s) outlived the test harness that \
started it" shape how
end;
(match !client with
| Some c -> (try Unix.close c with Unix.Unix_error _ -> ())
| None -> ());
(try Unix.kill stand_in Sys.sigkill with Unix.Unix_error _ -> ());
(try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] stand_in) with Unix.Unix_error _ -> ());
(try Sys.remove hsock with Sys_error _ -> ()))
[ false; true ];
(* The socket: kept, the daemon stays; deleted, it ends, cleanly. *)
let ssock = tmp "orphan-socket.sock" in
(try Sys.remove ssock with Sys_error _ -> ());
let d =
Unix.create_process flan (argv ssock) Unix.stdin Unix.stdout
Unix.stderr
in
if not (listening ~pid:d ssock) then
fail "a daemon whose socket goes (%s): %s" shape !listen_why
else begin
let kids = children d in
Unix.sleepf 2.5;
(match Unix.waitpid [ Unix.WNOHANG ] d with
| 0, _ -> ()
| _ -> fail "a daemon (%s) ended with its socket in place" shape);
Sys.remove ssock;
let st = ref None in
let ended =
await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] d with
| 0, _ -> false
| _, s -> st := Some s; true)
in
if not ended then
fail "a daemon (%s) outlived its deleted socket" shape
else begin
if !st <> Some (Unix.WEXITED 0) then
fail "a daemon (%s) whose socket was deleted did not end cleanly"
shape;
let dir =
Filename.concat (Filename.get_temp_dir_name ())
(Printf.sprintf "flan-dev-%d" d)
in
if Sys.file_exists dir then
fail "a daemon (%s) whose socket was deleted left %s" shape dir;
List.iter
(fun k ->
if not (await ~ms:5000 (fun () -> gone k)) then
fail "the program (%s) outlived its daemon's socket" shape)
kids
end
end;
(try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ()))
[ [||]; [| "--two-process" |] ];
(* ── Prelude functions shadowed live keep the prelude's own calls ──
[rand] and then [rand-int] redefined in a running program: the

4
test/watchdog.ml
View File

@ -76,6 +76,10 @@ let arm ?(seconds = 600) name =
label := name;
budget := seconds;
deadline := Unix.gettimeofday () +. float_of_int seconds;
(* Every [flan dev] this binary starts, directly or from an Emacs it runs,
dies with its parent and ends once this process is gone (lib/dev.ml,
[harness]), so a run killed partway leaves no daemon behind. *)
Unix.putenv "FLAN_DEV_HARNESS" (string_of_int (Unix.getpid ()));
backstop ()
(* [f] under a tighter alarm, with the backstop restored afterwards however

69
vendor/agent/flan_agent.c vendored
View File

@ -1023,28 +1023,55 @@ static int sock_dir_fd = -1;
/* A socket file outlives the process that bound it, and a stale one answers
* the next client with ECONNREFUSED — which reads like a program that is there
* and refusing rather than one that has gone. So the bind registers its own
* removal, and the three ways out of a program each unlink it:
* removal, and every way out of a program that runs any code unlinks it:
*
* ordinary exit this handler, via atexit
* break-loop abort die_now, by hand, because it takes _exit
* trap rt_die in flan_rt.c, through [flan_die_hook]
* orphaned child orphan_die, by hand, for the same reason
* fatal signal fatal_unlink: SIGTERM, SIGINT, SIGHUP, SIGQUIT and
* SIGABRT, while their disposition is still the default
*
* Outside a daemon that is the whole story, and the path is under /tmp where
* nothing else would ever reclaim it.
* Outside a daemon that is the whole story, and the path is under TMPDIR where
* nothing else would ever reclaim it. SIGKILL is the one end nothing survives.
*
* Under [flan dev] none of the three is how a session usually ends, and this
* is worth being exact about rather than claiming cover it does not give: the
* two-process daemon kills its child with SIGTERM, whose default disposition
* runs no atexit, and the merged session leaves by [Unix._exit 0]. So the
* socket there is left in the daemon's temp directory — which is itself never
* removed today. TODO.org, "The daemon leaves its temp directory behind": the
* session-end cleanup that item asks for takes the socket with it, and until
* it lands the socket outlives the session. Nothing below can fix that from
* here; a program that is killed does not get to tidy up. */
* Under [flan dev] the session's own end also covers it: the two-process
* daemon stops its child with SIGTERM, which [fatal_unlink] sees, and the
* merged session leaves by [Unix._exit 0] after removing its temp directory,
* the socket with it (lib/dev.ml, [remove_session_dirs]). */
static void unlink_bound_sock(void) {
if (bound_sock[0] != '\0') unlink(bound_sock);
}
extern void (*flan_die_hook)(void);
/* unlink and re-raise under the default disposition, so the process still
* ends by the signal it was sent: a parent waiting on it sees the same status
* as before. Both calls are async-signal-safe. */
static void fatal_unlink(int sig) {
if (bound_sock[0] != '\0') unlink(bound_sock);
signal(sig, SIG_DFL);
raise(sig);
}
/* Only a signal nobody has claimed: a program, or the runtime a merged build
* carries, that installed its own handler keeps it. Called after the bind. */
static void unlink_on_fatal_signals(void) {
static const int sigs[] = { SIGTERM, SIGINT, SIGHUP, SIGQUIT, SIGABRT };
size_t i;
for (i = 0; i < sizeof sigs / sizeof sigs[0]; i++) {
struct sigaction old, sa;
if (sigaction(sigs[i], NULL, &old) != 0) continue;
if ((old.sa_flags & SA_SIGINFO) != 0 || old.sa_handler != SIG_DFL) continue;
memset(&sa, 0, sizeof sa);
sa.sa_handler = fatal_unlink;
sigemptyset(&sa.sa_mask);
sa.sa_flags = SA_RESETHAND;
sigaction(sigs[i], &sa, NULL);
}
flan_die_hook = unlink_bound_sock;
}
/* Every way out of the break loop that is not a resume. [_exit] and not
* [exit], because this runs on the game thread while the listener thread may
* be inside [dlopen] holding the loader lock — and [exit] runs the atexit
@ -2786,6 +2813,7 @@ static int32_t start_on(const char *path) {
/* After the bind, because a program that is going to fail to listen should
fail on its own terms rather than arrange its death first. */
watch_the_daemon();
unlink_on_fatal_signals();
/* From here an unhandled error stops rather than dying. Installed with the
* socket and not before it: without a listener there is nobody to ask what
* to do, and stopping forever is worse than the abort it replaces. */
@ -2864,14 +2892,25 @@ int32_t flan_agent_start(const uint8_t *path, int64_t len) {
* silently reuses a file it may not own. stderr rather than stdout, so a
* program whose output is data stays data. */
int32_t flan_agent_start_auto(void) {
char path[sizeof(((struct sockaddr_un *)0)->sun_path)];
/* Room for a TMPDIR too deep for sun_path; [start_on] binds such a path
* through its directory. */
char path[4096];
struct timespec ts;
int32_t r;
const char *env = daemon_socket();
const char *dir = getenv("TMPDIR");
size_t dlen;
int n;
if (env != NULL) return start_on(env) < 0 ? -1 : 0;
/* TMPDIR, as everything else Flan makes on the fly: a test run's own
* directory, or a user's, is removed with it. /tmp when unset. */
if (dir == NULL || dir[0] != '/') dir = "/tmp";
dlen = strlen(dir);
while (dlen > 1 && dir[dlen - 1] == '/') dlen--;
if (clock_gettime(CLOCK_REALTIME, &ts) != 0) ts.tv_nsec = 0;
snprintf(path, sizeof path, "/tmp/flan-agent-%ld-%08lx.sock",
(long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL));
n = snprintf(path, sizeof path, "%.*s/flan-agent-%ld-%08lx.sock", (int)dlen,
dir, (long)getpid(), (unsigned long)(ts.tv_nsec & 0xffffffffL));
if (n < 0 || (size_t)n >= sizeof path) return -1;
r = start_on(path);
/* Only when this call is the one that bound: a second [(agent/start)] would
* otherwise print a path it did not bind and nothing is listening on. */