Merge: a daemon whose editor is gone reaps itself

FIX.org

@@ -309,5 +309,17 @@ Ten bug lanes and three demolitions, all on dev-loop and verified together:
   two-process child, armed in the agent, with a spawn-SIGKILL-reap test.
   Found in passing: the eight orphans split 4/4 — four are MERGED daemons
   whose editor vanished, a separate defect (accept_loop has no client
-  liveness), recorded here, not fixed. The eight are still alive and the
-  author decides their fate.
+  liveness), recorded here. The eight are still alive and the author decides
+  their fate.
+- That second defect is now fixed too. accept_loop keeps a grace since the
+  last client let go of the socket, and ends the session when it runs out.
+  The connection is per session and not per request — Emacs holds one
+  make-network-process for the whole of flan-dev and every deliberate
+  teardown sends [close] first — so an editor left open and idle is an editor
+  still attached, and the clock cannot run under it. Armed only after a first
+  client has connected, so a headless daemon waiting for one is untouched.
+  Two graces: 5 minutes parked, 30 minutes live, because a parked program is
+  invisible (which is why four piled up) and a live one is a window somebody
+  may be watching. FLAN_DEV_CLIENT_GRACE overrides in seconds; non-positive
+  turns it off. Six unit rows on the decision and one end-to-end daemon whose
+  client drops without a [close].

lib/dev.ml

@@ -2933,11 +2933,70 @@ let ignore_sigpipe () =
   try Sys.set_signal Sys.sigpipe Sys.Signal_ignore
   with Invalid_argument _ -> ()
 
+(* ── Whether the editor is ever coming back ────────────────────────── *)
+
+(* The loop below used to have exactly one way out that anybody ever took:
+   [close], which Emacs sends when it is quitting on purpose. An editor that is
+   *killed* — SIGKILL, a crash, a laptop that slept and came back to a dead X
+   session — sends nothing, and the daemon went on accepting connections that
+   nobody was ever going to make. Four of the eight orphans found on the
+   author's machine were exactly that, and FIX.org recorded it as a defect the
+   PDEATHSIG work does not touch: that kills a *child* when the daemon dies,
+   and this is a *daemon* whose client died.
+
+   What makes this answerable without a new protocol is that the connection is
+   per session and not per request. [emacs/flan-dev.el] opens one
+   [make-network-process] in [flan-dev--open], keeps it in
+   [flan-dev--connection], and reopens only when the process is dead; every
+   site that tears it down deliberately sends [close] first. [serve] mirrors
+   that shape — it loops on the one fd until EOF — so while an editor is
+   attached this loop is not even cycling. An editor left open and idle
+   overnight is therefore *attached* overnight, and the grace below can never
+   accumulate under it. That is structural, not a number chosen to outlast
+   human patience, and it is why no PID handshake and no heartbeat op is
+   needed: holding the socket open is the heartbeat, and a client that only
+   ever polls — or one that has [flan-dev-poll-interval] set to nil and polls
+   never — is indistinguishable from any other attached client.
+
+   So the signal is client *absence*, and the only absence this is allowed to
+   read as death is one that follows a client having been there: [served]. A
+   daemon started in a terminal while its author goes off to open an editor is
+   not an orphan, and arming before the first connection would quietly change
+   what [flan dev] means for anyone running it headless.
+
+   Two graces rather than one, and the argument is visibility rather than
+   work. A parked program has no window and no thread doing anything; it is
+   invisible, which is precisely why four of them piled up unnoticed. A live
+   one is a game on somebody's screen, and ending it out from under them is a
+   loss they cannot undo — and one they can avoid by closing the window
+   themselves, which parks it and starts the shorter clock. A non-positive
+   grace turns the whole thing off, for a daemon that is meant to outlive every
+   client it will ever have. *)
+let client_grace_default = 300.
+
+(* Split out from the loop for the reason [liveness_of] was: the loop needs a
+   real session and a real socket, so the decision inside it is otherwise only
+   reachable through a case that takes a compile. *)
+let orphan_grace ~grace = function
+  | Live -> grace *. 6.
+  | Parked | Gone -> grace
+
+let orphaned ~grace ~served ~idle live =
+  grace > 0. && served && idle >= orphan_grace ~grace live
+
+let client_grace () =
+  match Sys.getenv_opt "FLAN_DEV_CLIENT_GRACE" with
+  | Some s ->
+    (match float_of_string_opt (String.trim s) with
+     | Some f -> f
+     | None -> client_grace_default)
+  | None -> client_grace_default
+
 (* [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
    forever. In the merged build the loop ends the only way it can — the process
-   does, on [close].
+   does, on [close] or on the grace above running out.
 
    [Gone] and nothing narrower, and this is the one place where getting the
    three states the wrong way round is fatal rather than merely confusing. A
@@ -2945,23 +3004,45 @@ let ignore_sigpipe () =
    ask over this socket; stopping the loop when it parked would shut the
    listener, return from [merged_serve], and [_exit] the process — closing a
    window would kill the session, which is the bug this whole change exists to
-   remove, reintroduced one line further out. *)
-let accept_loop t ls =
+   remove, reintroduced one line further out. The grace does not reopen that
+   hole: it reads the client, not the program, and all of an Emacs's windows
+   share the one [flan-dev--connection], so closing one of them changes
+   nothing this loop can see. *)
+let accept_loop ?grace 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 rec go () =
-    if liveness t <> Gone then
-      (* The program's pipe is in the same select as the listening socket: it
-         has to be drained whether or not an editor is asking for anything. *)
-      match Unix.select [ ls; t.stdout ] [] [] 0.2 with
-      | [], _, _ -> go ()
-      | ready, _, _ when not (List.mem ls ready) -> drain t; go ()
-      | _ ->
-        (match Unix.accept ls with
-         | fd, _ ->
-           let closed = serve t fd in
-           (try Unix.close fd with Unix.Unix_error _ -> ());
-           if not closed then go ()
-         | exception Unix.Unix_error (Unix.EINTR, _, _) -> go ())
-      | exception Unix.Unix_error (Unix.EINTR, _, _) -> go ()
+    match liveness t with
+    | Gone -> ()
+    | (Live | Parked) as live ->
+      let idle = Unix.gettimeofday () -. !since in
+      if orphaned ~grace ~served:!served ~idle live then
+        (* The measured gap and not the threshold it crossed: the threshold is
+           a constant a reader can look up, and the gap is the observation the
+           decision was made on. *)
+        Printf.eprintf
+          "flan dev: no editor has been connected for %.0fs, so this session \
+           is ending; its client is gone\n%!"
+          idle
+      else
+        (* The program's pipe is in the same select as the listening socket: it
+           has to be drained whether or not an editor is asking for anything. *)
+        match Unix.select [ ls; t.stdout ] [] [] 0.2 with
+        | [], _, _ -> go ()
+        | ready, _, _ when not (List.mem ls ready) -> drain t; go ()
+        | _ ->
+          (match Unix.accept ls with
+           | fd, _ ->
+             served := true;
+             let closed = serve t fd in
+             (try Unix.close fd with Unix.Unix_error _ -> ());
+             since := Unix.gettimeofday ();
+             if not closed then go ()
+           | exception Unix.Unix_error (Unix.EINTR, _, _) -> go ())
+        | exception Unix.Unix_error (Unix.EINTR, _, _) -> go ()
   in
   go ()
 
@@ -3761,9 +3842,10 @@ let merged_serve () =
        Printf.eprintf "flan dev: %s\n%!" (Printexc.to_string e));
     (try Unix.close ls with Unix.Unix_error _ -> ());
     (try Unix.unlink sock with Unix.Unix_error _ -> ());
-    (* [close] from the editor ends the session, and in one process that means
-       the program too — which is what the daemon did by killing its child.
-       [_exit] for the loader-lock reason the break loop gives. *)
+    (* [close] from the editor ends the session, and so now does an editor that
+       stopped being there; in one process either means the program too — which
+       is what the daemon did by killing its child. [_exit] for the loader-lock
+       reason the break loop gives. *)
     flush_all ();
     Unix._exit 0
 

test/test_dev.ml

@@ -120,6 +120,36 @@ let () =
     (Dev.liveness_of ~child_alive:None ~finished:false ~program:Program.Absent)
     Dev.Live
 
+(* ── When an absent editor counts as a dead one ─────────────────────── *)
+
+(* Split out of [accept_loop] for the same reason as the three-way above: the
+   loop needs a session and a bound socket, so reaching the decision otherwise
+   costs a compile. The end-to-end case at the bottom of this file proves a
+   daemon really does exit; these are the four ways it must not. *)
+let () =
+  let case name got want = if got <> want then fail "orphaned: %s" name in
+  case "a daemon no client has ever reached is not an orphan, however long"
+    (Dev.orphaned ~grace:1. ~served:false ~idle:10_000. Dev.Parked)
+    false;
+  case "a client that let go a moment ago is coming back"
+    (Dev.orphaned ~grace:60. ~served:true ~idle:1. Dev.Parked)
+    false;
+  case "a parked program whose client is long gone is an orphan"
+    (Dev.orphaned ~grace:60. ~served:true ~idle:61. Dev.Parked)
+    true;
+  (* The longer clock: a running program is a window somebody may be looking
+     at, so the same idle gap that ends a parked session does not end this
+     one. *)
+  case "a live program gets the longer grace"
+    (Dev.orphaned ~grace:60. ~served:true ~idle:61. Dev.Live)
+    false;
+  case "but not an unbounded one"
+    (Dev.orphaned ~grace:60. ~served:true ~idle:361. Dev.Live)
+    true;
+  case "a non-positive grace is off"
+    (Dev.orphaned ~grace:0. ~served:true ~idle:10_000. Dev.Parked)
+    false
+
 let rec connect ?(ms = 5000) path =
   let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
   match Unix.connect s (Unix.ADDR_UNIX path) with
@@ -3938,6 +3968,73 @@ let () =
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ xsock2; xout2; msock; mout ];
 
+    (* ── A daemon whose editor was killed ─────────────────────────────── *)
+
+    (* The defect FIX.org recorded and PDEATHSIG does not reach: an editor that
+       quits *politely* sends [close] and the daemon ends, but one that is
+       killed sends nothing, and before this the loop went on accepting for
+       ever. So the whole test is the missing goodbye — the connection is
+       dropped without a [close] on it, which is all a SIGKILLed Emacs leaves
+       behind, and what has to happen next is the daemon reaping itself.
+
+       [FLAN_DEV_CLIENT_GRACE] is here so this can be seconds instead of
+       minutes. It is a parameter rather than a constant for exactly this: a
+       default short enough to test would be one that fires on a person, and a
+       default long enough for a person is one no suite can wait out. *)
+    let gsock = tmp "gone.sock" and gout = tmp "gone.out" in
+    (try Sys.remove gsock with Sys_error _ -> ());
+    let gfd =
+      Unix.openfile gout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
+    in
+    let gpid =
+      Unix.create_process_env flan
+        [| flan; "dev"; "programs/dev-loop.flan"; "-s"; gsock |]
+        (Array.append (Unix.environment ()) [| "FLAN_DEV_CLIENT_GRACE=0.2" |])
+        Unix.stdin gfd Unix.stderr
+    in
+    Unix.close gfd;
+    if not (listening ~pid:gpid gsock) then begin
+      fail "the orphan-grace daemon %s" !listen_why;
+      (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ())
+    end
+    else begin
+      let reaped () =
+        match Unix.waitpid [ Unix.WNOHANG ] gpid with
+        | 0, _ -> false
+        | _ -> true
+        | exception Unix.Unix_error _ -> true
+      in
+      let c = connect gsock in
+      let r = request c "(:op \"describe\")" in
+      if status r <> "ok" then fail "the orphan-grace daemon: %s" (status r);
+      (* Still there while a client is holding the socket, which is the half
+         that keeps an editor left open overnight alive. Three seconds against
+         a program that is running, so the threshold in force is the longer one
+         — 6 × 0.2s — and the wait is past it with room to spare; a hold
+         shorter than that would pass whether or not the clock ran under an
+         attached client, and would pin nothing.
+
+         It cannot fail today, and that is the point of keeping it: the reason
+         an attached client is safe is structural, [serve] sitting in
+         [Wire.recv] while the accept loop is not cycling at all. This is the
+         guard for the refactor that serves a connection off the accept path
+         and turns a structural guarantee back into an arithmetic one. *)
+      ignore (await ~ms:3000 reaped);
+      if reaped () then
+        fail "the daemon ended while a client was still connected to it";
+      (* The kill, spelled as the kernel spells it: the fd goes away and
+         nothing is sent. *)
+      (try Unix.close c with Unix.Unix_error _ -> ());
+      if not (await ~ms:20000 reaped) then begin
+        fail "the daemon outlived its client: nothing ended it %s"
+          (In_channel.with_open_bin gout In_channel.input_all);
+        (try Unix.kill gpid Sys.sigkill with Unix.Unix_error _ -> ());
+        (try ignore (Unix.waitpid [] gpid) with Unix.Unix_error _ -> ())
+      end
+    end;
+    List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
+      [ gsock; gout ];
+
     List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
       [ sock; out; bsock; bout ];
     if !failures = 0 then print_endline "dev: all tests passed"