From 2752d5765505fd452ae2dae4579d5e196bda24e0 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 13:13:39 +0700 Subject: [PATCH 1/3] A dev daemon started by a test dies with it, a daemon whose socket is gone ends cleanly, the Emacs daemon buffer asks before it is killed and closes the session, and a program's agent socket lives under TMPDIR and goes on a trap or fatal signal. --- emacs/flan.el | 66 +++++++++++++- emacs/test-flan.el | 58 +++++++++++- lib/dev.ml | 112 +++++++++++++++++++++-- lib/spawn.ml | 3 + lib/spawn_stubs.c | 12 +++ runtime/flan_rt.c | 5 ++ test/programs/agent-auto.flan | 2 +- test/test_agent.ml | 41 ++++++++- test/test_dev.ml | 165 ++++++++++++++++++++++++++++++++++ test/watchdog.ml | 4 + vendor/agent/flan_agent.c | 56 ++++++++++-- 11 files changed, 504 insertions(+), 20 deletions(-) diff --git a/emacs/flan.el b/emacs/flan.el index b96b6eda..1ab1531b 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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) diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 7712e455..2b385227 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -1592,7 +1592,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 ────────────────────────────────────────── ;; diff --git a/lib/dev.ml b/lib/dev.ml index 4f078e5f..1157eccd 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -5282,6 +5282,80 @@ 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 + +(* 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]. 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 + +(* 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 +5372,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 +5699,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 +5711,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 +6563,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 +6594,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 +6615,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 +6700,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 diff --git a/lib/spawn.ml b/lib/spawn.ml index 85baac85..9c3f757d 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -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" diff --git a/lib/spawn_stubs.c b/lib/spawn_stubs.c index f8ab49a0..b4e67cfe 100644 --- a/lib/spawn_stubs.c +++ b/lib/spawn_stubs.c @@ -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; +} diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index d4f500d7..098a9724 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -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); } diff --git a/test/programs/agent-auto.flan b/test/programs/agent-auto.flan index ef624d4b..c1b159f8 100644 --- a/test/programs/agent-auto.flan +++ b/test/programs/agent-auto.flan @@ -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 diff --git a/test/test_agent.ml b/test/test_agent.ml index ecd63d4f..01ad672d 100644 --- a/test/test_agent.ml +++ b/test/test_agent.ml @@ -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. diff --git a/test/test_dev.ml b/test/test_dev.ml index be21fb4e..b0d74d17 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -5920,6 +5920,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") @@ -5955,6 +5963,163 @@ 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. *) + 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 + if not (listening ~pid:d hsock) then + fail "a daemon with a harness (%s): %s" shape !listen_why + else begin + 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) outlived the test harness that started it" shape + end; + (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 _ -> ()); + + (* 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 diff --git a/test/watchdog.ml b/test/watchdog.ml index 75beecbf..e4779d88 100644 --- a/test/watchdog.ml +++ b/test/watchdog.ml @@ -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 diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index e5c687f7..0ea62eb7 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -1023,14 +1023,17 @@ 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 @@ -1045,6 +1048,35 @@ 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 +2818,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 +2897,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. */ From 6170f50061c08b0f0cc3ccc98ac6bcf32c24caf4 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 13:17:05 +0700 Subject: [PATCH 2/3] The agent's comment on socket removal describes how a flan dev session removes it now. --- vendor/agent/flan_agent.c | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 0ea62eb7..38d60e2b 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -1035,15 +1035,10 @@ static int sock_dir_fd = -1; * 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); } From ed5b56f21240dffa265066197ee7e81fcb0c7a50 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Sat, 26 Sep 2026 14:05:29 +0700 Subject: [PATCH 3/3] A daemon under a test harness ends within a second or two of the harness going even while a client holds its connection. --- lib/dev.ml | 74 ++++++++++++++++++++++++++++++++------------- test/test_dev.ml | 79 +++++++++++++++++++++++++++++------------------- 2 files changed, 101 insertions(+), 52 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 1157eccd..6897d2a8 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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; @@ -5314,26 +5366,6 @@ let still_bound b = | s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino | exception Unix.Unix_error _ -> false -(* 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]. 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 - (* Why the session can no longer be reached, if it cannot. *) let unreachable bound = match bound with diff --git a/test/test_dev.ml b/test/test_dev.ml index b856d62e..268a9149 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6045,37 +6045,54 @@ let () = kids); (try Sys.remove ksock with Sys_error _ -> ()); - (* The harness gone, the parent alive. [sleep] stands in for it. *) - 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 - if not (listening ~pid:d hsock) then - fail "a daemon with a harness (%s): %s" shape !listen_why - else begin - 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) outlived the test harness that started it" shape - end; - (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 _ -> ()); + (* 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