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

The wait for the agent socket was in front of the accept loop

Browse Source 
[merged_serve] waited up to ten seconds for the program to bind agent.sock
before it started [accept_loop]. The listening socket was already up, so an
editor connected fine and then heard nothing: every first request of every
session cost the whole wait when the program calls (agent/start ...) late —
sand.flan starts it after rl/init-window returns — or never.

Nothing the editor asks needs that socket. In one process a delivery is a
call into flan_agent.c, not a connect, and the two-process daemon has already
waited for the bind in [two_process] and fails if it never comes. What the
wait was for is the sentence a program with no agent deserves, and a sentence
does not have to be in front of the loop to be said. So it is a deadline the
session passes ([agent_check]) rather than a wait it does: read from the
accept loop between connections and from [serve] before each request, because
an editor holds one connection for a whole session and the loop is not
cycling while it is attached. No thread, for the reason lib/dune gives about
what the merged link does to this library's dependencies.

Delivery stays honest either way. A program that links no agent at all
refuses through [over_socket]'s ENOENT, as before. One that has the agent but
has not started it takes the module into the ring and is answered with a note
that promises the poll and not a frame: a program with no (agent/poll) in it
never installs this, and "at its next frame boundary" would be the reply that
makes a redefinition look applied when it is not. C-x C-e's five-second
timeout gets the same distinction instead of asking whether a program that
has not got to its loop yet is calling the poll in it.

And the note a parked program's delivery carries is now said once per park.
A finished program is parked, so re-evaluating while a run's output is on the
screen repeated a paragraph on every C-c C-c. The first delivery of each park
explains itself; the rest say the one line that is the claim. [rerun] clears
the flag as well as [eval] does, so a new park is a new reader.
This commit is contained in:
Joseph Ferano 2026-09-20 18:07:33 +07:00
parent dc39631db7
commit 89481cf8ec
4 changed files with 467 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

184
lib/dev.ml
View File

@ -52,6 +52,18 @@ type t = {
The merged build keeps fd 1 open across runs now and is asked instead —
see [liveness] and [Program.state]. *)
mutable finished : bool;
(* When to start saying that the program has not bound [agent] — and [None]
once it has, or once that has been said. The merged session arms it and
nothing gates on it: see [agent_check] for why this is a clock a reply
passes rather than a wait the session does before it serves anything. *)
mutable agent_watch : float option;
(* Whether the long note about a delivery to a parked program has been said
for *this* park. A finished program is parked, so re-evaluating while one
is on the screen says it on every C-c C-c; the explanation is worth one
reading and not twenty. Cleared whenever the program is seen running
again ([eval]) and when a re-run is accepted ([rerun]), so the next park
is a new one and gets the whole sentence. *)
mutable park_noted : bool;
}
(* The program's stdout is a pipe into this process, so that an editor can see
@ -106,6 +118,48 @@ let await ?(ms = 5000) f =
in
go ms
(* Whether the program has bound the socket it receives modules on.
Cheap enough to ask on every reply — one [stat] — and asked rather than
remembered because the answer moves in one direction at a moment this side
does not get to see: [agent/start] runs on the program's own thread. *)
let agent_bound t = Sys.file_exists t.agent
(* And the clock that says so out loud, once.
This used to be a [await ~ms:10000] in [merged_serve], *before* the accept
loop was started — so a program that called [agent/start] late, or not at
all, cost every editor request up to ten seconds of silence at the start of
a session. The wait was never what made the editor protocol work: nothing
the editor asks needs the program's socket, because in one process the
compiler reaches the agent by calling it ([Agent.request]), and the
two-process daemon has already waited for the bind in [two_process] and
fails if it never comes. What the wait was for is the *sentence* — a
program with no [(agent/start ...)] in it should say so rather than look
idle — and a sentence does not need to be in front of the loop to be said.
So it is a deadline the session passes rather than a wait it does. Checked
from the accept loop between connections and from [serve] before each
request, which are the two places this thread can be: an editor holds one
connection for a whole session, so the loop is not cycling while it is
attached, and the request is then the only tick there is. The cost of that
is the warning landing on the first request after the deadline rather than
on the deadline itself; the alternative is a thread, and [lib/dune] has a
comment about what the merged link does to a library that grows one. *)
let agent_check t =
match t.agent_watch with
| None -> ()
| Some deadline ->
if agent_bound t then t.agent_watch <- None
else if Unix.gettimeofday () >= deadline then begin
(* Said once. A program that is never going to start an agent would
otherwise repeat this on every keystroke's worth of polling. *)
t.agent_watch <- None;
Printf.eprintf
"flan dev: the program is not listening on %s — does it call \
(agent/start ...)?\n%!" t.agent
end
(* ── Asking the agent ──────────────────────────────────────────────── *)
(* One line out, one line back. The agent is not a protocol and must not become
@ -687,6 +741,59 @@ let refusal ~parked reply =
one was not taken, so send it again after that run"
else "the program refused the module: " ^ reply
(* What a taken module still has to say about itself. The delivery succeeded —
the agent dlopened it and published it to its ring — so this is never a
refusal; it is the difference between "queued" and "running", which is a
difference only the program can close and only at a moment of its choosing.
Three of them, in the order of how far the module is from being live:
A PARKED program has finished [main] and is asleep in [flan_merged_park].
Its ring is drained by the park's own poll when it is woken and by the next
run's frame boundaries, so the module lands no later than that run — and an
expression evaluated in the meantime takes it first, because the poll that
runs a thunk installs whatever is queued ahead of it. That is the whole
sentence, and it is worth reading once. It is not worth reading on every
C-c C-c, and a finished program is parked, so every redefinition while a
run's output is still on the screen used to repeat it. [park_noted] is what
makes the second one a line instead of a paragraph; the rule is per park,
not per session, because the reader of a *new* park may not be the reader
of the last one.
A RUNNING program that has not bound its agent socket has not called
[(agent/start ...)] yet — it may be about to, ahead of a window that is
still being created, or it may have no such call at all. Either way the
module is in the ring and the ring is drained by [(agent/poll)], so what
can honestly be promised is the poll and not a frame: a program with no
poll in it never installs this, and saying "at its next frame boundary"
would be the reply that made a redefinition look applied when it was not.
A RUNNING program that has bound it needs no note: the reply already says
queued, and the frame boundary is the next one it reaches. *)
let install_note t ~parked =
if parked then begin
let first = not t.park_noted in
t.park_noted <- true;
[ ":note "
^ Wire.quote
(if first then
"queued; the program is parked, so this installs no later than \
its next run rather than at its next frame boundary — an \
expression evaluated in the meantime takes it first, because \
the poll that runs a thunk installs whatever is queued ahead \
of it"
else "queued; installs no later than the parked program's next run")
]
end
else if not (agent_bound t) then
[ ":note "
^ Wire.quote
"queued, but the program has not called (agent/start ...) yet, so \
this installs when it next reaches an (agent/poll) — and not at \
all if it never does"
]
else []
(* [pause], when given, is the position of the form to stop at — §9. It rides
beside the code rather than in it, and the reply echoes it back so an editor
marks the buffer only for a mark the session actually applied.
@ -706,6 +813,12 @@ let refusal ~parked reply =
let eval t ~code ~origin ~pause =
let now = liveness t in
let parked_now = now = Parked in
(* A park that is over takes its note with it: the long sentence below is
said once per park, and this is where a new one starts being possible.
Written on every eval rather than on the transition, because there is no
transition to hook — the program parks itself on its own thread and this
side finds out by asking. *)
if not parked_now then t.park_noted <- false;
(* What the session was before the form was checked, and every failure below
puts it back. [Session.eval] commits as soon as the check succeeds, which
is two fallible steps too early: the build can fail and the agent can
@ -779,15 +892,7 @@ let eval t ~code ~origin ~pause =
| Some (l, c) ->
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
| None -> [])
@ (if parked_now then
[ ":note "
^ Wire.quote
"queued; the program is parked, so this installs no \
later than its next run rather than at its next \
frame boundary — an expression evaluated in the \
meantime takes it first, because the poll that runs \
a thunk installs whatever is queued ahead of it" ]
else []))
@ install_note t ~parked:parked_now)
| reply -> refused (refusal ~parked:parked_now reply)
| exception Unix.Unix_error (e, _, _) ->
refused
@ -968,6 +1073,21 @@ let eval_expr t ~code ~origin ~pause =
program is parked, so nothing is competing with it: the \
thunk is most likely stopped on a condition inside the \
break loop, which restart or abort answers"
(* And a third cause, which is the one a session now reaches
early enough to hit: the program has not bound its agent
socket, so it is still ahead of its own [(agent/start ...)]
— inside whatever it does first, a window being created —
and asking whether it calls [(agent/poll)] would send the
reader to look at a loop it has not got to yet. Said only
where it is a fact about *this* program: the socket is
missing, which is a stat, not a guess. *)
else if not (agent_bound t) then
error
"the program has not called (agent/start ...) yet, so \
nothing has run the expression. It is queued and will run \
at the program's first (agent/poll); this reply cannot \
carry its value, so evaluate it again once the program is \
up"
else
error
"the program did not reach a frame boundary; is it calling \
@ -2574,6 +2694,12 @@ let rerun t =
| Live | Parked ->
(match Program.rerun () with
| Ok () ->
(* The park this session was explaining is over, so the park after it
gets the explanation again — see [install_note]. Cleared here as
well as in [eval] because a run can start and finish with nothing
evaluated in between, and the next park would otherwise inherit a
flag set by the last one. *)
t.park_noted <- false;
(* Taken is not always started, and the one case where it is not needs
saying rather than a mechanism. A thunk evaluated against the park
can stop in the break loop, and the parked thread is then inside that
@ -3357,6 +3483,10 @@ let serve t fd =
let rec go () =
match Wire.recv fd with
| src ->
(* One of the two places the agent clock is read — see [agent_check].
An attached editor keeps this loop, and not the accept loop, running
for the whole of a session. *)
agent_check t;
(* Parsed once, and the verb taken out of it before anything that can
fail: [close] has to be honoured even when the handler for it did not
return normally, and a tuple whose two halves are [Wire.string_field]
@ -3508,6 +3638,9 @@ let accept_loop ?grace t ls =
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 () =
(* The other place the agent clock is read: between connections, which is
where a session with no editor attached spends its time. *)
agent_check t;
match liveness t with
| Gone -> ()
| (Live | Parked) as live ->
@ -3634,7 +3767,8 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
let t =
{ session; child = Some child; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false }
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false }
in
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -4384,7 +4518,8 @@ let merged_setup () =
let t =
{ session; child = None; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false }
host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false }
in
ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -4422,15 +4557,24 @@ let merged_serve () =
| None -> prerr_endline "flan dev: serve was called before setup"; exit 1
| Some (t, ls, sock) ->
(* The agent is bound by the program on the main thread, which only starts
once [merged_setup] has returned — so unlike the daemon, this waits
*after* it is already serving. An editor connecting in the meantime is
answered; only a delivery needs the agent. A program that never calls
[agent/start] is a warning rather than a failure now, because the thing
the daemon would have killed for it is this process. *)
if not (await ~ms:10000 (fun () -> Sys.file_exists t.agent)) then
Printf.eprintf
"flan dev: the program is not listening on %s — does it call \
(agent/start ...)?\n%!" t.agent;
once [merged_setup] has returned. So this does not wait for it: it arms
the clock that eventually says it never came, and serves.
That was the bug. The wait used to be here, in front of [accept_loop],
so the listening socket was up — an editor connected fine — and nothing
answered until the program bound its own socket or ten seconds ran out.
A program that calls [(agent/start ...)] after something slow (a window
being created) or never at all made that the cost of the *first* thing
anybody asked the session, every session. Nothing the editor asks needs
the program's socket — in one process a delivery is a call, not a
connect — so the wait was gating the whole protocol on a fact only the
agent's own verbs care about.
A program that never calls [agent/start] is still a warning rather than
a failure, because the thing the daemon would have killed for it is
this process. See [agent_check] for where the sentence is said now, and
[eval] for what a delivery to such a program honestly reports. *)
t.agent_watch <- Some (Unix.gettimeofday () +. 10.);
(match accept_loop t ls with
| () -> ()
| exception e ->

36
test/programs/dev-lateagent.flan Normal file
View File

@ -0,0 +1,36 @@
;;;; A program that does call (agent/start ...) — but only after something
;;;; slow, which is the shape a real one has.
;;;;
;;;; sand.flan opens a window first and starts the agent afterwards, so on a
;;;; machine where window setup takes a while the socket appears seconds into
;;;; the run. [merged_serve] used to wait up to ten seconds for that socket
;;;; *before* starting its accept loop, so those seconds were charged to the
;;;; first thing the editor asked, every session. This fixture is that delay
;;;; with the window taken out: a sleep, then the agent, then an ordinary
;;;; poll loop.
;;;;
;;;; Two claims are checked against it in test_dev.ml: the session answers
;;;; while the sleep is still running, and a redefinition sent during the
;;;; sleep is installed once the program is up.
(import agent "vendor:agent")
(defvar frames i64)
(defn step [] i64 7)
(defn tick [] i64
(set frames (+ frames 1))
frames)
(defn main [] i32
;; Long enough for a test to connect, ask something and evaluate inside it,
;; and short enough that the rest of the test is not waiting on it.
(sleep-seconds 3.0)
(agent/start "/tmp/flan-dev-lateagent-fallback.sock")
;; dev-chatty.flan's count, for its reason: the test ends the session when
;; it is done, and a program that ran out of frames first would fail for
;; the wrong reason.
(dotimes [i 24000]
(tick)
(agent/wait 1))
0)

21
test/programs/dev-parknote.flan Normal file
View File

@ -0,0 +1,21 @@
;;;; A program that parks the moment it is up: an agent, a line of output and
;;;; a return from main.
;;;;
;;;; Every other fixture here has to be driven to its park through the run it
;;;; was written for. What the note test needs is the park itself, repeatedly
;;;; and cheaply — a redefinition sent to a parked program is answered with an
;;;; explanation of what "queued" means for one, and the claim under test is
;;;; that the explanation is given once per park rather than once per
;;;; keystroke. So the run is as short as a run can be, and [rerun] gets it
;;;; back to a fresh park in one op.
(import agent "vendor:agent")
(defvar runs i64)
(defn step [] i64 7)
(defn main [] i32
(agent/start "/tmp/flan-dev-parknote-fallback.sock")
(set runs (+ runs 1))
(print runs) (println "")
0)

271
test/test_dev.ml
View File

@ -3660,17 +3660,25 @@ let () =
without an agent into a session that dies at startup, silently, because
no test would have noticed.
So what is asserted is the policy and not the sentence: the session is
still answering after the wait ran out. The warning text is checked
second, as the evidence that this is the branch that produced it and
not some other path that happened to work.
So what is asserted is the policy and not the sentence: the session
answers. The warning text is checked second, as the evidence that this
is the branch that produced it and not some other path that happened to
work.
The block costs the full ten seconds of [merged_serve]'s [await]
([lib/dev.ml]) and there is no way to spend less: [accept_loop] is not
reached until the wait expires, so the reply cannot arrive sooner.
Shortening it would mean a timeout override in [lib/dev.ml] that exists
for the test and for nothing else, which is a worse trade than ten
seconds in a suite that already takes minutes. *)
WHEN it answers is asserted too, and that is the newer half. The wait
for the agent socket used to sit in front of [accept_loop], so this
[describe] could not arrive until the ten seconds had run out — the
block's cost, and every real session's first keystroke. The wait is a
deadline the session passes now ([Dev.agent_check]), so the reply comes
back immediately and the sentence is said later, by the accept loop,
once the deadline is behind it. The second half is what still costs ten
seconds here: a warning about a program that is never going to start an
agent cannot honestly be said before waiting for one.
[describe] and not a cheaper op on purpose: it is what
[emacs/flan.el] sends straight after [flan--open] (flan.el:646) and
what its poll sends after that, so this is the stall a person would
actually have felt. *)
let nsock = tmp "noagent.sock" and nlog = tmp "noagent.log" in
(try Sys.remove nsock with Sys_error _ -> ());
(* Its own stderr, unlike every other daemon here: the warning is the
@ -3706,11 +3714,12 @@ let () =
if Sys.file_exists (nhost "s") then
fail "flan dev --llvm left an x86 listing at %s" (nhost "s");
let nc = connect nsock in
(* Blocks for the whole of [merged_serve]'s wait, by construction. The
exception arm is not defensive: a session that adopted the daemon's
policy would exit here, and the connection would come back ECONNRESET
rather than with a status. Reported by name because an uncaught
[Unix_error] out of a test binary says nothing about which test. *)
(* The exception arm is not defensive: a session that adopted the
daemon's policy would exit here, and the connection would come back
ECONNRESET rather than with a status. Reported by name because an
uncaught [Unix_error] out of a test binary says nothing about which
test. *)
let nt0 = Unix.gettimeofday () in
(match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with
| r when status r = "ok" -> ()
| r ->
@ -3720,22 +3729,43 @@ let () =
fail
"a program without (agent/start ...) ended the session instead of \
drawing a warning: %s" (Printexc.to_string e));
(try
ignore (Wire.send nc "(:op \"close\")");
ignore (Wire.recv nc)
with _ -> ());
let ndt = Unix.gettimeofday () -. nt0 in
(* Two seconds, against a stall that was ten and a reply that is a
fraction of one. The threshold is loose on purpose: what is being
held is "the session does not wait for the program's socket before
answering", and a number close to the real cost would fail on a
loaded machine for a reason that has nothing to do with the wait. *)
if ndt > 2. then
fail
"the first editor request waited %.1fs on a program without \
(agent/start ...); the accept loop is gated on the agent again"
ndt;
(* Dropped rather than closed with [(:op "close")], and the difference
is the rest of this row: [close] ends the session, the process
[_exit]s, and the deadline below would be waited out by nobody. A
dropped connection leaves the accept loop cycling, which is where
the sentence is said from. *)
(try Unix.close nc with Unix.Unix_error _ -> ())
end;
(* And the sentence, which arrives after the deadline rather than before
the loop. Awaited with the daemon still alive — the accept loop is what
says it, so killing first would be testing that a dead process does not
print. Generous against the ten-second deadline for the reason the
threshold above is loose. *)
let nlog_says () =
contains_sub
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "")
"does it call (agent/start ...)?"
in
ignore (await ~ms:30000 nlog_says);
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ());
let nlog_text =
try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> ""
in
if not (contains_sub nlog_text "does it call (agent/start ...)?") then
if not (nlog_says ()) then
fail
"a program without (agent/start ...) drew no warning from flan dev:\n%s"
nlog_text;
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "");
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ nsock; nlog ];
@ -4984,6 +5014,197 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ csock; cout ];
(* ══ The agent socket is not the editor protocol ══════════════════
Two daemons of their own, both about what a session owes an editor
before the program has bound the socket it receives modules on. The
row above about a program with *no* [(agent/start ...)] is the other
half of the same claim and lives where it always did. *)
(* ── A program that starts its agent late ──────────────────────────
The shape a real one has: sand.flan opens a window and starts the
agent afterwards, so the socket appears seconds into the run. The
merged session used to wait up to ten seconds for it *before* running
its accept loop, which charged those seconds to the first thing the
editor asked. Two claims, and the second is what stops the first from
being bought with a lie: the session answers during the delay, and a
redefinition sent during it is really installed once the program is
up. *)
let lsock = tmp "lateagent.sock" and lout = tmp "lateagent.out" in
(try Sys.remove lsock with Sys_error _ -> ());
let lfd =
Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let lpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-lateagent.flan"; "-s"; lsock |]
Unix.stdin lfd Unix.stderr
in
Unix.close lfd;
if not (listening ~pid:lpid lsock) then begin
fail "the late-agent daemon %s (%S)" !listen_why
(In_channel.with_open_bin lout In_channel.input_all);
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let lc = connect lsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* The program sleeps for three seconds before [agent/start], so this is
asked inside the delay. Two seconds is the threshold for the reason
the agentless row gives: the reply is a fraction of one and the bug
was ten, so anything in between is a loaded machine rather than a
regression. *)
let lt0 = Unix.gettimeofday () in
let r = request lc "(:op \"describe\")" in
let ldt = Unix.gettimeofday () -. lt0 in
if status r <> "ok" then
fail "a program whose agent starts late was not described: %s" (said r);
if ldt > 2. then
fail
"the first editor request waited %.1fs on a program whose agent \
starts late; the accept loop is gated on the agent again" ldt;
(* And the delivery, also inside the delay. It is taken — in one process
the agent's ring is reachable whether or not the program has bound a
socket — and the note says what "queued" means for a program that has
not got to its poll yet. Asserted because the alternative was the
reply this whole area exists to prevent: an "ok" that reads as
installed. *)
let r =
request lc
"(:op \"eval\" :code \"(defn step [] i64 9)\" :file \
\"programs/dev-lateagent.flan\")"
in
if status r <> "ok" then
fail "a redefinition sent before (agent/start ...): %s" (said r)
else begin
let note = Option.value ~default:"" (Wire.string_field r "note") in
if not (contains_sub note "(agent/start ...)") then
fail
"a redefinition delivered before the program's agent was up said \
nothing about it: %S" note
end;
(* The claim the note makes, checked against the program rather than
against the reply: once the sleep is over and the program is polling,
the body that was queued is the one that runs. [await] because the
moment the agent comes up is the program's to choose, and each
[eval-expr] already waits five seconds of its own. *)
let answered = ref "" in
let installed () =
let r =
request lc
"(:op \"eval-expr\" :code \"(step)\" :file \
\"programs/dev-lateagent.flan\")"
in
answered := Option.value ~default:(said r) (Wire.string_field r "value");
!answered = "9"
in
if not (await ~ms:20000 installed) then
fail
"a redefinition queued before (agent/start ...) never installed: \
(step) answered %S" !answered;
(try
ignore (Wire.send lc "(:op \"close\")");
ignore (Wire.recv lc)
with _ -> ());
(try Unix.close lc with Unix.Unix_error _ -> ());
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock; lout ];
(* ── The parked note, once per park ────────────────────────────────
A finished program is parked, so re-evaluating while a run's output is
still on the screen is the commonest thing there is — and it used to
repeat a paragraph about what "queued" means for a park on every one.
The explanation is kept for the first delivery of each park and
shortened after it, which is a claim with two halves: the second note
is smaller than the first, and a *new* park gets the long one back.
The second half is why [rerun] clears the flag as well as [eval]: a run
can start and finish with nothing evaluated in between. *)
let psock = tmp "parknote.sock" and pout = tmp "parknote.out" in
(try Sys.remove psock with Sys_error _ -> ());
let pfd =
Unix.openfile pout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let ppid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-parknote.flan"; "-s"; psock |]
Unix.stdin pfd Unix.stderr
in
Unix.close pfd;
if not (listening ~pid:ppid psock) then begin
fail "the park-note daemon %s (%S)" !listen_why
(In_channel.with_open_bin pout In_channel.input_all);
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let pc = connect psock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let parked () =
match Wire.field (request pc "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let redefine n =
let r =
request pc
(Printf.sprintf
"(:op \"eval\" :code \"(defn step [] i64 %d)\" :file \
\"programs/dev-parknote.flan\")" n)
in
if status r <> "ok" then begin
fail "a redefinition of a parked program: %s" (said r); ""
end
else Option.value ~default:"" (Wire.string_field r "note")
in
(* [main] returns as soon as it has printed, so this is a wait on the
park rather than on anything this test does. *)
if not (await parked) then
fail "the park-note program never parked"
else begin
let first = redefine 1 in
let second = redefine 2 in
(* The long one by what it explains and not by its length: the
sentence about an expression taking the module first is the part
that is worth reading once. *)
if not (contains_sub first "an expression evaluated in the meantime") then
fail "the first delivery to a park did not explain itself: %S" first;
if second = "" then
fail "the second delivery to a park said nothing at all"
else if String.length second >= String.length first then
fail
"the second delivery to the same park repeated the explanation: \
%S" second;
(* Still true, and that is the point of shortening rather than
dropping it: what the reader is told is smaller, not different. *)
if not (contains_sub second "next run") then
fail "the short park note stopped saying when it installs: %S" second;
(* A new park is a new reader. [rerun] sends the program round [main]
again and it parks straight away, with nothing evaluated in
between — which is the case [eval]'s own clearing cannot reach. *)
let r = request pc "(:op \"rerun\")" in
if status r <> "ok" then fail "the park-note rerun: %s" (said r)
else if not (await parked) then
fail "the park-note program never parked a second time"
else begin
let again = redefine 3 in
if not (contains_sub again "an expression evaluated in the meantime")
then
fail "a second park did not get the explanation back: %S" again
end
end;
(try
ignore (Wire.send pc "(:op \"close\")");
ignore (Wire.recv pc)
with _ -> ());
(try Unix.close pc with Unix.Unix_error _ -> ());
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ psock; pout ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
Test_support.report ~label:"dev" ()