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
| _ -> ()
(* 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

79
test/test_dev.ml
View File

@ -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