From d9ce1baa530fd099ccc58750a86f745276b4df4b Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 19:42:23 +0700 Subject: [PATCH] Take the abort, and refuse a name that is two requests Every check of `abort' so far was of it being refused while the program runs. The accepted path -- the one that ends a program -- was code that had never run and answered `ok'. So the break block breaks its program once more, by installing a `step' that errors into the loop that calls it, and takes the exit: the daemon owns the program's lifetime, so no `close' is sent and the daemon coming down on its own is the assertion. And `restart' refuses a name with a control character in it. The agent's contract is one line per request; a newline in a name is a second request smuggled into the first. `completing-read' with require-match cannot produce one, but the guarantee belongs to the end holding the socket, and an editor is not the only thing that can speak to it. --- lib/dev.ml | 7 +++++++ test/test_dev.ml | 37 +++++++++++++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 2 deletions(-) diff --git a/lib/dev.ml b/lib/dev.ml index 013ef9b..7ec16d6 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -410,6 +410,13 @@ let break t = find it stopped, and re-open the prompt it had just answered. *) let choose t ~name = if not (alive t) then error "the program exited; restart flan dev" + else if String.exists (fun c -> Char.code c < 32 || Char.code c = 127) name then + (* The agent's contract is one line per request. A name carrying a newline + would be a second request smuggled into the first, and the guarantee is + this end's to keep: [completing-read] cannot produce one, but the daemon + is what holds the socket and an editor is not the only thing that can + speak to it. *) + error "a restart name cannot contain a control character" else match ask t ("restart " ^ name) with | reply when String.trim reply = "ok" -> diff --git a/test/test_dev.ml b/test/test_dev.ml index 9138d3d..2b5a8fa 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -371,9 +371,42 @@ let () = (Option.value ~default:(status r) (Wire.string_field r "message")) end end; - ignore (ask "(:op \"close\")"); + (* ...and the other way out. Every check above is of an abort being + *refused*; the accepted path is the one that must not be left as code + that has never run, because it is the one that ends a program. Break + it once more — the daemon's own program calls [step] every time round + its loop, so a body that errors stops it — and take the exit. *) + (match + ask + "(:op \"eval\" :code \"(defn step [] i64 (restart-case (do (error (Missing {:id 9})) 0) (use-placeholder [] -1)))\" :file \"/tmp/buf.flan\")" + with + | r when status r <> "ok" -> + fail "installing a body that errors: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + | _ -> + if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then + fail "the program never stopped on the body that errors" + else begin + let r = ask "(:op \"abort\")" in + if status r <> "ok" then + fail "abort was refused by a stopped program: %s" + (Option.value ~default:"" (Wire.string_field r "message")) + end); Unix.close c; - ignore (Unix.waitpid [] bpid) + (* No [close] op: an abort ends the program, and the daemon owns the + program's lifetime, so it comes down on its own. A daemon still + running here would be one waiting on a socket nobody will use. *) + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] bpid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + fail "the daemon outlived the program it aborted"; + (try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] bpid) with Unix.Unix_error _ -> ()) + end end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out; bsock; bout ];