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

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

test/test_dev.ml

@@ -6045,7 +6045,12 @@ let () =
               kids);
          (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.
+            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 =
@@ -6057,9 +6062,16 @@ let () =
                   (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" shape !listen_why
+                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 =
@@ -6069,13 +6081,18 @@ let () =
                     | _ -> true)
                 in
                 if not ended then
-             fail "a daemon (%s) outlived the test harness that started it" shape
+                  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 _ -> ());
+              (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