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

A daemon under a test harness ends within a second or two of the harness going even while a client holds its connection.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 14:05:29 +07:00
parent 3134246511
commit ed5b56f212
2 changed files with 101 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
lib/dev.ml
View File

@ -5106,6 +5106,27 @@ let push_request p req op reply =
else p.watch_every <- None 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 ──────────────────────────────────────────────────────── *) (* ── The loop ──────────────────────────────────────────────────────── *)
(* One connection at a time. An editor is one client, evaluations are (* 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 serve t fd =
let p = { on = false; out_due = None; last_out = 0.; watch_every = None; let p = { on = false; out_due = None; last_out = 0.; watch_every = None;
watch_due = 0.; pend = Buffer.create 4096; sent = 0 } in 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 (* 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 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 is drained here whether or not this client takes pushes, which is the
liveness requirement [drain] describes, met while an editor is attached liveness requirement [drain] describes, met while an editor is attached
as well as between editors. *) as well as between editors. *)
let rec go () = let rec go () =
if harness_gone () then true else
match push_due p t fd (Unix.gettimeofday ()) with match push_due p t fd (Unix.gettimeofday ()) with
| exception Unix.Unix_error _ -> false | exception Unix.Unix_error _ -> false
| blocked -> | blocked ->
@ -5134,7 +5186,7 @@ let serve t fd =
let wfds, wait = let wfds, wait =
if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ()) if blocked then [ fd ], -1. else [], push_wait p (Unix.gettimeofday ())
in in
(match Unix.select fds wfds [] wait with (match Unix.select fds wfds [] (cap wait) with
| ready, _, _ -> | ready, _, _ ->
if List.mem t.stdout ready && not t.finished then begin if List.mem t.stdout ready && not t.finished then begin
drain t; drain t;
@ -5314,26 +5366,6 @@ let still_bound b =
| s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino | s -> s.Unix.st_dev = b.dev && s.Unix.st_ino = b.ino
| exception Unix.Unix_error _ -> false | 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. *) (* Why the session can no longer be reached, if it cannot. *)
let unreachable bound = let unreachable bound =
match bound with match bound with

79
test/test_dev.ml
View File

@ -6045,37 +6045,54 @@ let () =
kids); kids);
(try Sys.remove ksock with Sys_error _ -> ()); (try Sys.remove ksock with Sys_error _ -> ());
(* The harness gone, the parent alive. [sleep] stands in for it. *) (* The harness gone, the parent alive. [sleep] stands in for it.
let hsock = tmp "orphan-harness.sock" in Twice: with no client, and with one connected and holding on, as
(try Sys.remove hsock with Sys_error _ -> ()); an Emacs under test does after the binary that ran it is gone. *)
let stand_in = List.iter
Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin (fun held ->
Unix.stdout Unix.stderr let how = if held then "connected" else "idle" in
in let hsock = tmp "orphan-harness.sock" in
let d = (try Sys.remove hsock with Sys_error _ -> ());
Unix.create_process_env flan (argv hsock) let stand_in =
(with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ]) Unix.create_process "sleep" [| "sleep"; "600" |] Unix.stdin
Unix.stdin Unix.stdout Unix.stderr Unix.stdout Unix.stderr
in in
if not (listening ~pid:d hsock) then let d =
fail "a daemon with a harness (%s): %s" shape !listen_why Unix.create_process_env flan (argv hsock)
else begin (with_harness [ "FLAN_DEV_HARNESS=" ^ string_of_int stand_in ])
Unix.kill stand_in Sys.sigkill; Unix.stdin Unix.stdout Unix.stderr
ignore (Unix.waitpid [] stand_in); in
let ended = let client = ref None in
await ~ms:5000 (fun () -> if not (listening ~pid:d hsock) then
match Unix.waitpid [ Unix.WNOHANG ] d with fail "a daemon with a harness (%s, %s): %s" shape how !listen_why
| 0, _ -> false else begin
| _ -> true) if held then begin
in let c = connect hsock in
if not ended then client := Some c;
fail "a daemon (%s) outlived the test harness that started it" shape if status (request c "(:op \"describe\")") <> "ok" then
end; fail "a daemon with a harness (%s): describe failed" shape
(try Unix.kill stand_in Sys.sigkill with Unix.Unix_error _ -> ()); end;
(try Unix.kill d Sys.sigkill with Unix.Unix_error _ -> ()); Unix.kill stand_in Sys.sigkill;
(try ignore (Unix.waitpid [] d) with Unix.Unix_error _ -> ()); ignore (Unix.waitpid [] stand_in);
(try ignore (Unix.waitpid [] stand_in) with Unix.Unix_error _ -> ()); let ended =
(try Sys.remove hsock with Sys_error _ -> ()); 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. *) (* The socket: kept, the daemon stays; deleted, it ends, cleanly. *)
let ssock = tmp "orphan-socket.sock" in let ssock = tmp "orphan-socket.sock" in