Joseph Ferano
38a570bc7a
The bug review found: [start_on] claimed [started] at the top and every failure exit left it claimed. Under [flan dev] the constructor is the first caller and reports to nobody, so a path nothing could bind disarmed the program's own (agent/start ...) as well — it answered 0 with no socket, no listener and no hooks, where before this lane the explicit form answered -1. Success reported for nothing at all is worse than the error it replaced. So every way out that is not a listening socket unwinds: the fd is closed, a file the bind managed to make is unlinked, and [started] goes back to 0 so a later start is a real attempt. Pinned by running the zero-argument fixture with FLAN_AGENT_SOCKET pointing nowhere — constructor fails silently, main's own call then fails loudly, "cannot listen" and exit 1. Two arguments to (agent/start) are refused, which nothing held: the macro's [& args] cannot say "one at most", so what says it is the expansion splicing every argument into a function that declares one. The message names agent/start-at and carries the expanded-from note, and that is what the acceptance row asserts. And the reply a delivery gets when there is no agent in the process, which nothing held either. dev-noagent.flan parks, so it was never this case; dev-noagent-running.flan keeps running, and the answer is a refusal naming the socket that could not be reached — not install_note's "queued", which would promise a poll with nothing to drain. Which leaves that note unreachable in all three shapes rather than merely unpinned, worked through in FIX.org. FIX.org also now says what an exported FLAN_AGENT_SOCKET would do: start_on unlinks before it binds, so an agent-linked program started in that environment takes the path away from whoever bound it first.
783 lines
38 KiB
OCaml
783 lines
38 KiB
OCaml
(* The agent, end to end (NEXT.md, dev loop step 3).
|
|
|
|
test_reload.ml proves the primitive with a C harness driving it. This one
|
|
proves the thing the dev loop actually is: a program that is running its own
|
|
loop, a redefinition arriving over a socket while it runs, and the swap
|
|
becoming visible at a point the program chose.
|
|
|
|
The split the agent exists for is between two threads. [dlopen] relocates a
|
|
module and takes the loader lock — milliseconds, unbounded — so it happens
|
|
on the listener thread. [flan_reload_install] is one store per function, and
|
|
it must not land while a redefined function is on the stack, so it happens
|
|
on the game thread when it asks. Everything here is arranged to make that
|
|
observable rather than to make it fast. *)
|
|
|
|
open Flan
|
|
|
|
(* The watchdog first: a hang is the one failure mode that reports
|
|
nothing at all. See watchdog.ml. *)
|
|
let () = Watchdog.arm ~seconds:600 "test_agent"
|
|
|
|
(* The counter, the scratch paths, the poll and the connect are in
|
|
test_support.ml — the note there on why a retry is narrowed to
|
|
ECONNREFUSED is this file's own reasoning, moved with the code it explains.
|
|
|
|
Both budgets below are shorter than the shared defaults, and deliberately:
|
|
everything this file waits on is a program that has already been built and
|
|
launched, so three seconds is a wait for a bind rather than for a compile,
|
|
and the two the connect retries for are the width of the bind/listen race
|
|
itself. *)
|
|
let fail fmt = Test_support.fail fmt
|
|
let tmp name = Test_support.tmp "flan-agent-" name
|
|
let await ?(ms = 3000) f = Test_support.await ~ms f
|
|
|
|
let send path line =
|
|
let s = Test_support.connect ~ms:2000 path in
|
|
let msg = line ^ "\n" in
|
|
ignore (Unix.write_substring s msg 0 (String.length msg));
|
|
(* Read to EOF, not once: a reply arrives in several pieces, and closing
|
|
after the first one is what made the agent take SIGPIPE. *)
|
|
let buf = Bytes.create 512 in
|
|
let b = Buffer.create 512 in
|
|
let rec drain () =
|
|
match Unix.read s buf 0 512 with
|
|
| 0 -> ()
|
|
| n -> Buffer.add_subbytes b buf 0 n; drain ()
|
|
| exception Unix.Unix_error _ -> ()
|
|
in
|
|
drain ();
|
|
Unix.close s;
|
|
Buffer.contents b
|
|
|
|
let () =
|
|
match Sys.command "command -v clang > /dev/null 2>&1 && command -v llc > /dev/null 2>&1" with
|
|
| 0 ->
|
|
(* The session is the program the process is about to be built from. Going
|
|
through it rather than calling Emit directly is the point: it is what
|
|
knows [tick] is a name the host has, so the module binds to its cell as
|
|
a symbol instead of inventing a registry entry nobody publishes. *)
|
|
let t, l = Session.create ~file:"programs/agent.flan" () in
|
|
|
|
(* A dev build, because that is what has cells to install into and exports
|
|
them. The agent's own C and its -lpthread come from the package. *)
|
|
let dev = { Build.default with Build.dev = true } in
|
|
let exe = tmp "prog" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:l.Load.csrcs ~lflags:l.Load.lflags
|
|
t.Session.host ~out:exe);
|
|
|
|
(* And the same program without [--dev], which has to *link*. Its [main]
|
|
calls [agent/start], so the package is reached and its C comes with it
|
|
even through [Reach.link] — and that C refers to the dev runtime, so
|
|
leaving it out made this an undefined symbol at the link rather than a
|
|
missing flag. Nothing is run: with no cells the agent refuses every
|
|
module, and linking is the whole claim. *)
|
|
(match
|
|
let p, csrcs, lflags = Reach.link l t.Session.host in
|
|
Build.executable ~opts:Build.default ~csrcs ~lflags p
|
|
~out:(tmp "prog-release")
|
|
with
|
|
| _ -> ()
|
|
| exception Failure m -> fail "a release build of the agent: %s" m);
|
|
|
|
(* Two evaluations from the one session, which is the daemon's loop and
|
|
the thing no earlier test does. The first introduces a global the
|
|
process was never built with; the second only reads it, and can only
|
|
come back with 1007 if it found the storage the first one allocated
|
|
rather than a fresh zeroed copy of it. *)
|
|
let build_module src name =
|
|
let c = Session.eval t src in
|
|
let out = tmp name in
|
|
ignore (Build.shared ~opts:dev ~ir:c.Session.ir ~out ());
|
|
out
|
|
in
|
|
let so1 =
|
|
build_module
|
|
"(defvar acc i64) (defn tick [] i64 (set acc (+ acc 1000)) acc)"
|
|
"tick1.so"
|
|
in
|
|
let so2 =
|
|
build_module "(defn tick [] i64 (set acc (+ acc 7)) acc)" "tick2.so"
|
|
in
|
|
|
|
let sock = tmp "sock" in
|
|
let out = tmp "out" in
|
|
(try Sys.remove sock with Sys_error _ -> ());
|
|
let fd = Unix.openfile out [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let pid =
|
|
Unix.create_process exe [| exe; sock |] Unix.stdin fd Unix.stderr
|
|
in
|
|
Unix.close fd;
|
|
|
|
if not (await (fun () -> Sys.file_exists sock)) then begin
|
|
fail "the program never bound its socket";
|
|
(try Unix.kill pid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end else begin
|
|
(* Refusing junk comes first, while the program is still running: the
|
|
daemon is a separate process and can send anything, and a bad path
|
|
must not take down the program it was sent to. Nothing is queued by
|
|
it, so the program is still waiting afterwards. *)
|
|
let reply = send sock "/nonexistent/nope.so" in
|
|
if String.length reply < 4 || String.sub reply 0 4 <> "err " then
|
|
fail "a bad path was not refused: %S" reply;
|
|
|
|
(* "ok" means queued, not installed — the store happens on the other
|
|
thread, at a time this one does not choose. *)
|
|
let lines () =
|
|
let text = In_channel.with_open_bin out In_channel.input_all in
|
|
List.length (String.split_on_char '\n' text) - 1
|
|
in
|
|
let reply = send sock so1 in
|
|
if reply <> "ok\n" then fail "agent replied %S, wanted \"ok\\n\"" reply;
|
|
(* Wait for the program to have consumed the first module before sending
|
|
the second. Both at once is a legitimate thing for the agent to do —
|
|
one poll installs everything queued — but then only the last one is
|
|
ever observed and the sequencing is not what was tested. *)
|
|
if not (await (fun () -> lines () >= 2)) then
|
|
fail "the first reload was never installed";
|
|
let reply = send sock so2 in
|
|
if reply <> "ok\n" then fail "agent replied %S, wanted \"ok\\n\"" reply;
|
|
let _, status = Unix.waitpid [] pid in
|
|
let text = In_channel.with_open_bin out In_channel.input_all in
|
|
(* 1 from the original [tick]; 1000 from a body that did not exist when
|
|
the program started, over a global that did not either; 1007 from a
|
|
second body that only reads it. That last number is the whole point of
|
|
doing this twice — a registry that handed out fresh storage per module
|
|
would say 7. *)
|
|
if status <> Unix.WEXITED 0 || text <> "1\n1000\n1007\n" then
|
|
fail "agent reload\n got: %S (%s)\n wanted: %S" text
|
|
(match status with
|
|
| Unix.WEXITED c -> Printf.sprintf "exit %d" c
|
|
| Unix.WSIGNALED c -> Printf.sprintf "signal %d" c
|
|
| Unix.WSTOPPED c -> Printf.sprintf "stopped %d" c)
|
|
"1\n1000\n1007\n"
|
|
end;
|
|
|
|
(* ── (agent/start), with nothing named ──────────────────────────── *)
|
|
|
|
(* The zero-argument form, run with no daemon anywhere: no
|
|
FLAN_AGENT_SOCKET in the environment, so the program has to choose a
|
|
path itself and then say which one. The printed line is not a nicety
|
|
here — it is the only thing that makes the socket reachable, and
|
|
everything below it in this block is reached *through* that line rather
|
|
than through a path the test picked in advance. If the sentence ever
|
|
changes shape, the connect fails and this says so.
|
|
|
|
stderr and stdout are separate files on purpose. The program's numbers
|
|
are its output and the agent's line is not; a program whose stdout is
|
|
data would be corrupted by a sentence landing in it, and under [flan
|
|
dev] stdout is a pipe the editor reads. Asserting the transcript on fd 1
|
|
is exactly the claim that the line did not go there.
|
|
|
|
Three things are pinned at once, and they share a process because they
|
|
are the same startup: the path chosen and printed, the *second*
|
|
[(agent/start)] being a no-op rather than a second listener, and the
|
|
socket file being gone once the program exits. *)
|
|
let aout = tmp "auto.out" and aerr = tmp "auto.err" in
|
|
let at, al = Session.create ~file:"programs/agent-auto.flan" () in
|
|
let aexe = tmp "auto" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:al.Load.csrcs ~lflags:al.Load.lflags
|
|
at.Session.host ~out:aexe);
|
|
let aso = tmp "auto-tick.so" in
|
|
let ac = Session.eval at "(defn tick [] i64 1000)" in
|
|
ignore (Build.shared ~opts:dev ~ir:ac.Session.ir ~out:aso ());
|
|
(* The variable this suite sets for every other program here, taken back
|
|
out: with it set the zero-argument form binds where it says and prints
|
|
nothing, which is the daemon's case and not this one. *)
|
|
let aenv =
|
|
Array.of_list
|
|
(List.filter
|
|
(fun kv ->
|
|
not (String.length kv >= 18
|
|
&& String.sub kv 0 18 = "FLAN_AGENT_SOCKET="))
|
|
(Array.to_list (Unix.environment ())))
|
|
in
|
|
let ofd name =
|
|
Unix.openfile name [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
|
in
|
|
let a1 = ofd aout and a2 = ofd aerr in
|
|
let apid = Unix.create_process_env aexe [| aexe |] aenv Unix.stdin a1 a2 in
|
|
Unix.close a1;
|
|
Unix.close a2;
|
|
let said () = In_channel.with_open_bin aerr In_channel.input_all in
|
|
let prefix = "flan agent: listening on " in
|
|
let announced () =
|
|
List.filter
|
|
(fun l ->
|
|
String.length l > String.length prefix
|
|
&& String.sub l 0 (String.length prefix) = prefix)
|
|
(String.split_on_char '\n' (said ()))
|
|
in
|
|
if not (await (fun () -> announced () <> [])) then begin
|
|
fail "(agent/start) never said where it was listening: %S" (said ());
|
|
(try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let line = List.hd (announced ()) in
|
|
let apath =
|
|
String.sub line (String.length prefix)
|
|
(String.length line - String.length prefix)
|
|
in
|
|
(* The shape is part of the claim: two programs started at once must not
|
|
choose the same file, and the pid alone would not separate two runs of
|
|
the same program in sequence. *)
|
|
let pid_part = Printf.sprintf "/tmp/flan-agent-%d-" apid in
|
|
if not (String.length apath > String.length pid_part
|
|
&& String.sub apath 0 (String.length pid_part) = pid_part)
|
|
then fail "the chosen path is not this process's: %S" apath;
|
|
if not (Filename.check_suffix apath ".sock") then
|
|
fail "the chosen path is not a socket name: %S" apath;
|
|
if not (await (fun () -> Sys.file_exists apath)) then
|
|
fail "nothing was bound at the path that was printed: %S" apath
|
|
else begin
|
|
(* Reached only through the printed line. *)
|
|
let r = send apath aso in
|
|
if r <> "ok\n" then fail "the announced socket refused a module: %S" r;
|
|
let astatus = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] apid with
|
|
| 0, _ -> false
|
|
| _, s -> astatus := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill apid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "the program never took the delivery it was sent"
|
|
end
|
|
else begin
|
|
(* 0 is the second [(agent/start)] answering, and it is the whole of
|
|
the idempotence claim on this side: had it bound again, the
|
|
number would be the same but the socket the test is talking to
|
|
would be the older of two. The single announcement below is the
|
|
other half — one bind, one sentence. *)
|
|
let text = In_channel.with_open_bin aout In_channel.input_all in
|
|
if !astatus <> Unix.WEXITED 0 || text <> "0\n1\n1000\n" then
|
|
fail "(agent/start)\n got: %S\n wanted: %S" text
|
|
"0\n1\n1000\n";
|
|
if List.length (announced ()) <> 1 then
|
|
fail "a second (agent/start) announced a second socket: %S"
|
|
(said ());
|
|
(* And the file is gone. Nothing else removes it — there is no
|
|
daemon here and no directory that belongs to one — so this is the
|
|
program's own atexit and nothing else. *)
|
|
if Sys.file_exists apath then
|
|
fail "the socket outlived the program that bound it: %S" apath
|
|
end
|
|
end
|
|
end;
|
|
(* ── A path that cannot be bound ────────────────────────────────── *)
|
|
|
|
(* The same program again, told to listen somewhere that does not exist.
|
|
Two claims, and the second is the one that cost a bug.
|
|
|
|
It fails, and says so. [start_on] answers -1, the [if] in the fixture
|
|
takes its other arm, and the process ends 1 with "cannot listen" — which
|
|
is what the explicit form has always done for a path it could not bind.
|
|
|
|
And the *constructor* failing first does not disarm it. That is the
|
|
ordering here: FLAN_AGENT_SOCKET is set, so [auto_start] runs before
|
|
main, tries this path and fails — before any Flan code runs, with
|
|
nothing to report to. If a failed attempt latched [started], the
|
|
program's own [(agent/start)] would then answer 0 with no socket, no
|
|
listener and no hooks: success reported for nothing at all, which is
|
|
strictly worse than the error it replaced. The transcript below is that
|
|
not happening. *)
|
|
let bad = tmp "bad.out" in
|
|
let bfd' = ofd bad in
|
|
let benv =
|
|
Array.append aenv [| "FLAN_AGENT_SOCKET=/nonexistent-dir/agent.sock" |]
|
|
in
|
|
let bpid' = Unix.create_process_env aexe [| aexe |] benv Unix.stdin bfd' bfd' in
|
|
Unix.close bfd';
|
|
let bstat = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] bpid' with
|
|
| 0, _ -> false
|
|
| _, s -> bstat := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill bpid' Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "a program told to listen on an impossible path did not finish"
|
|
end
|
|
else begin
|
|
let text = In_channel.with_open_bin bad In_channel.input_all in
|
|
if !bstat <> Unix.WEXITED 1 || text <> "cannot listen\n" then
|
|
fail "an impossible socket path\n got: %S (%s)\n wanted: \
|
|
%S (exit 1)" text
|
|
(match !bstat with
|
|
| Unix.WEXITED c -> Printf.sprintf "exit %d" c
|
|
| Unix.WSIGNALED c -> Printf.sprintf "signal %d" c
|
|
| Unix.WSTOPPED c -> Printf.sprintf "stopped %d" c)
|
|
"cannot listen\n"
|
|
end;
|
|
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ aexe; aso; aout; aerr; bad ];
|
|
|
|
(* ── No (agent/start) at all ────────────────────────────────────── *)
|
|
|
|
(* The ceremony gone rather than shortened: this program says nothing about
|
|
the agent except that it installs what has arrived. The listener is the
|
|
package's constructor, and the condition it runs on is
|
|
FLAN_AGENT_SOCKET — which is exactly what the daemon sets, in both
|
|
shapes, before the program starts. Setting it here is therefore not a
|
|
test fixture standing in for the daemon; it is the same variable set the
|
|
same way, which is why this does not need a daemon to be the claim.
|
|
|
|
The two numbers are the split the agent exists for, and they are what
|
|
keeps this honest: a listener bound before main is still not an install.
|
|
1 is the body the program was built with, printed before anything could
|
|
have arrived; 1000 is a body that did not exist then, and it appears
|
|
only after the [wait] — the program's own frame boundary — which is the
|
|
half no constructor can do for it.
|
|
|
|
[Reach] is the limit, and the fixture's header says so: the package is
|
|
linked because the program calls into it. A program that called nothing
|
|
would not have this constructor in it to run. *)
|
|
let nsock = tmp "nostart.sock" and nout = tmp "nostart.out" in
|
|
(try Sys.remove nsock with Sys_error _ -> ());
|
|
let nt, nl = Session.create ~file:"programs/agent-nostart.flan" () in
|
|
let nexe = tmp "nostart" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:nl.Load.csrcs ~lflags:nl.Load.lflags
|
|
nt.Session.host ~out:nexe);
|
|
let nso = tmp "nostart-tick.so" in
|
|
let nc = Session.eval nt "(defn tick [] i64 1000)" in
|
|
ignore (Build.shared ~opts:dev ~ir:nc.Session.ir ~out:nso ());
|
|
let nenv =
|
|
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ nsock |]
|
|
in
|
|
let nfd =
|
|
Unix.openfile nout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
|
in
|
|
let npid = Unix.create_process_env nexe [| nexe |] nenv Unix.stdin nfd nfd in
|
|
Unix.close nfd;
|
|
if not (await (fun () -> Sys.file_exists nsock)) then begin
|
|
fail "a program with no (agent/start) never bound %s" nsock;
|
|
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let r = send nsock nso in
|
|
if r <> "ok\n" then
|
|
fail "the constructor's socket refused a module: %S" r;
|
|
let nstatus = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] npid with
|
|
| 0, _ -> false
|
|
| _, s -> nstatus := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "the redefinition never reached a program that never started an \
|
|
agent"
|
|
end
|
|
else begin
|
|
let text = In_channel.with_open_bin nout In_channel.input_all in
|
|
if !nstatus <> Unix.WEXITED 0 || text <> "1\n1000\n" then
|
|
fail "no (agent/start)\n got: %S\n wanted: %S" text
|
|
"1\n1000\n"
|
|
end
|
|
end;
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ nexe; nso; nsock; nout ];
|
|
|
|
(* ── The break loop, spec-conditions.md §2 ──────────────────────── *)
|
|
|
|
(* The claim is that an unhandled [error] stops rather than dying, and can
|
|
be resumed into a restart chosen from outside. A program that died would
|
|
exit 134 with no output; one that stopped and was never resumed would
|
|
hang and be killed by the timeout. Only a resume produces both numbers,
|
|
and they differ, so a loop that always took the same restart fails. *)
|
|
let bsock = tmp "break.sock" and bout = tmp "break.out" in
|
|
(try Sys.remove bsock with Sys_error _ -> ());
|
|
let bt, bl = Session.create ~file:"programs/break.flan" () in
|
|
let bexe = tmp "break" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:bl.Load.csrcs ~lflags:bl.Load.lflags
|
|
bt.Session.host ~out:bexe);
|
|
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let env =
|
|
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ bsock |]
|
|
in
|
|
let bpid =
|
|
Unix.create_process_env bexe [| bexe |] env Unix.stdin bfd bfd
|
|
in
|
|
Unix.close bfd;
|
|
if not (await (fun () -> Sys.file_exists bsock)) then
|
|
fail "the broken program never listened"
|
|
else begin
|
|
(* It has to be *stopped* before the restarts are knowable: the listener
|
|
refuses to walk a stack the game thread is still running on. *)
|
|
let listed = ref "" in
|
|
if not
|
|
(await (fun () ->
|
|
listed := send bsock "restarts";
|
|
!listed <> "" && not (String.length !listed >= 3
|
|
&& String.sub !listed 0 3 = "err")))
|
|
then fail "the program never reached the break loop: %S" !listed
|
|
else begin
|
|
(* Innermost first, and both on offer. *)
|
|
if !listed <> "0 + retry\n1 + use-placeholder\n.\n" then
|
|
fail "restarts on offer\n got: %S\n wanted: %S" !listed
|
|
"0 + retry\n1 + use-placeholder\n.\n";
|
|
(* A name nothing offers is refused *here*, before the reply. Answering
|
|
ok and discovering it on the game thread would report success for
|
|
something that cannot happen. *)
|
|
let bad = send bsock "restart nonesuch" in
|
|
if not (String.length bad >= 3 && String.sub bad 0 3 = "err") then
|
|
fail "a restart nobody offers was accepted: %S" bad;
|
|
ignore (send bsock "restart retry");
|
|
(* Wait for the *result* of that choice before making the next one.
|
|
Asking whether it is stopped is not enough: it is still stopped in
|
|
the first break until the resume lands, and a second choice sent
|
|
then would be taken by the first one — which passes the listing
|
|
check and then hangs, because the second break never gets an
|
|
answer. The printed 7 is the only proof the first resume happened. *)
|
|
let printed () =
|
|
let t = In_channel.with_open_bin bout In_channel.input_all in
|
|
List.exists (String.equal "7") (String.split_on_char '\n' t)
|
|
in
|
|
if not (await printed) then
|
|
fail "the first restart never produced its value"
|
|
else if not (await (fun () -> send bsock "restarts"
|
|
= "0 + retry\n1 + use-placeholder\n.\n"))
|
|
then fail "the program never stopped a second time"
|
|
else begin
|
|
ignore (send bsock "restart use-placeholder");
|
|
(* -- Taking a restart by index ------------------------------- *)
|
|
|
|
(* The third break is inside a [restart-case] whose name the frame
|
|
below it also offers. Both are listed; §4's by-name walk can only
|
|
ever reach the first. So this takes the *second*, and 900 is a
|
|
value nothing else in the program can produce — the assertion on
|
|
the output at the end is what makes this test about shadowing
|
|
rather than about a reply. *)
|
|
let printed2 () =
|
|
let t = In_channel.with_open_bin bout In_channel.input_all in
|
|
List.exists (String.equal "-1") (String.split_on_char '\n' t)
|
|
in
|
|
if not (await printed2) then
|
|
fail "the second restart never produced its value"
|
|
else if not (await (fun () -> send bsock "restarts"
|
|
= "0 + retry\n1 + retry\n.\n"))
|
|
then fail "the program never stopped on the shadowed pair"
|
|
else begin
|
|
(* Out of range is refused before the reply, like a bad name. *)
|
|
let oob = send bsock "restart-at 7" in
|
|
if not (String.length oob >= 3 && String.sub oob 0 3 = "err") then
|
|
fail "an index nothing offers was accepted: %S" oob;
|
|
(* The name rides along as a receipt, not as the lookup: an index
|
|
whose name has moved is refused rather than silently taken,
|
|
which is the same failure by-name lookup had. *)
|
|
let drift = send bsock "restart-at 1 use-placeholder" in
|
|
if not (String.length drift >= 3 && String.sub drift 0 3 = "err")
|
|
then fail "an index whose name had drifted was accepted: %S" drift;
|
|
ignore (send bsock "restart-at 1 retry")
|
|
end
|
|
end
|
|
end
|
|
end;
|
|
let bstatus = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] bpid with
|
|
| 0, _ -> false
|
|
| _, s -> bstatus := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "the program never resumed out of the break loop"
|
|
end
|
|
else begin
|
|
let text = In_channel.with_open_bin bout In_channel.input_all in
|
|
let want = "7\n-1\n900\n" in
|
|
let got =
|
|
String.concat "\n"
|
|
(List.filter
|
|
(fun l -> l <> "" && not (String.length l >= 5 && String.sub l 0 5 = "flan:")
|
|
&& not (String.length l >= 2 && String.sub l 0 2 = " "))
|
|
(String.split_on_char '\n' text))
|
|
in
|
|
if !bstatus <> Unix.WEXITED 0 || got ^ "\n" <> want then
|
|
fail "break loop transcript\n got: %S\n wanted: %S" got want
|
|
end;
|
|
|
|
(* ── The job ring, and what a full one does ─────────────────────── *)
|
|
|
|
(* Two claims, one program. A module the agent refuses because it carries
|
|
no installer is *closed* rather than leaked; and a ring with no room
|
|
refuses the module instead of overwriting the slot the game thread is
|
|
reading.
|
|
|
|
The program blocks on stdin until the test has finished filling the
|
|
ring, so neither claim is a race against how fast sixty-five
|
|
connections are served. *)
|
|
let qsock = tmp "queue.sock" and qout = tmp "queue.out" in
|
|
(try Sys.remove qsock with Sys_error _ -> ());
|
|
let qt, ql = Session.create ~file:"programs/agent-queue.flan" () in
|
|
let qexe = tmp "queue" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:ql.Load.csrcs ~lflags:ql.Load.lflags
|
|
qt.Session.host ~out:qexe);
|
|
(* One module, sent many times. dlopen keys on the path, so this is the
|
|
same relocation over and over — what is being counted is publishes, and
|
|
building sixty-five of them would measure llc instead. *)
|
|
let qso = tmp "queue-tick.so" in
|
|
let qc = Session.eval qt "(defn tick [] i64 (set ticks (+ ticks 1)) ticks)" in
|
|
ignore (Build.shared ~opts:dev ~ir:qc.Session.ir ~out:qso ());
|
|
let noinstall = tmp "noinstall.so" in
|
|
let cc =
|
|
Printf.sprintf "clang -shared -fPIC -o %s noinstall.c 2>/dev/null"
|
|
(Filename.quote noinstall)
|
|
in
|
|
if Sys.command cc <> 0 then fail "could not build noinstall.so"
|
|
else begin
|
|
(* Close-on-exec, or the child inherits the write end and its own stdin
|
|
never reaches end of file: the program would sit in its last read
|
|
waiting for a byte only it could send. The read end is dup'd onto fd 0
|
|
by [create_process], which clears the flag on the copy. *)
|
|
let rfd, wfd = Unix.pipe ~cloexec:true () in
|
|
let qfd =
|
|
Unix.openfile qout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
|
|
in
|
|
let qpid = Unix.create_process qexe [| qexe; qsock |] rfd qfd qfd in
|
|
Unix.close qfd;
|
|
Unix.close rfd;
|
|
let qtext () = In_channel.with_open_bin qout In_channel.input_all in
|
|
let has needle =
|
|
let t = qtext () in
|
|
List.exists (String.equal needle) (String.split_on_char '\n' t)
|
|
in
|
|
if not (await (fun () -> Sys.file_exists qsock && has "ready")) then begin
|
|
fail "the queue program never bound its socket";
|
|
(try Unix.kill qpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
(* A module with no installer. The refusal was always there; what is
|
|
new is that the handle is closed, and the destructor saying so
|
|
*while the program is still running* is the only way to see it —
|
|
at exit the loader would run it either way. *)
|
|
let r = send qsock noinstall in
|
|
if r <> "err no flan_reload_install\n" then
|
|
fail "a module with no installer: %S" r;
|
|
if not (await (fun () -> has "unloaded")) then
|
|
fail "the refused module was not closed: %S" (qtext ());
|
|
|
|
(* QUEUE slots, then one more. The one more is refused, at the sender,
|
|
with a reason — the old code took it, wrote it over slot 0, and
|
|
said ok. *)
|
|
let queue_size = 64 in
|
|
let bad = ref "" in
|
|
for _ = 1 to queue_size do
|
|
let r = send qsock qso in
|
|
if r <> "ok\n" && !bad = "" then bad := r
|
|
done;
|
|
if !bad <> "" then fail "a module that fitted was refused: %S" !bad;
|
|
let full = send qsock qso in
|
|
if full <> "err reload queue full; the program is not calling agent/poll\n"
|
|
then fail "a full ring did not refuse: %S" full;
|
|
|
|
(* Let it poll. Every slot the ring kept is installed here, so the
|
|
number is how many survived — 64, not 65 and not some torn count. *)
|
|
ignore (Unix.write wfd (Bytes.of_string "\n") 0 1);
|
|
if not (await (fun () -> has "64")) then
|
|
fail "the ring never drained: %S" (qtext ())
|
|
else begin
|
|
(* ── The 4K result cap ───────────────────────────────────────
|
|
|
|
NEXT.md names this buffer twice as having no coverage at all,
|
|
because it is on the agent's path and so needs a socket. There is
|
|
a socket here. The value is a 5000-byte string literal, which is
|
|
longer than anything [emit] will keep, so what comes back is the
|
|
clamp and the ellipsis [result_end] puts there to say it clamped
|
|
— and it comes back through the seqlock's copy rather than off a
|
|
borrowed pointer. *)
|
|
let long = String.make 5000 'x' in
|
|
let ec = Session.eval_expr qt ("\"" ^ long ^ "\"") in
|
|
let eso = tmp "queue-eval.so" in
|
|
ignore (Build.shared ~opts:dev ~ir:ec.Session.ir ~out:eso ());
|
|
|
|
(* ── A stopped-only job that reaches a running program ────────
|
|
|
|
The [reg at] TOCTOU, pinned at the one place it can be pinned
|
|
deterministically. In the daemon it is a race: [inspect] by
|
|
address checks that the program is stopped, spends a third of a
|
|
second building a thunk with that address baked in, and a
|
|
[restart] landing in the window resumes the game thread before
|
|
the thunk runs. Reproducing *that* means winning a race against
|
|
llc. What the fix actually turns on does not need the race at
|
|
all — a job tagged stopped-only, arriving at a frame boundary
|
|
with no break in force, must be dropped — and this program is
|
|
never stopped, so "no break in force" is not something to arrange.
|
|
|
|
It is also the A/B, in one program at one moment, which is why it
|
|
sits beside the eval module rather than in a block of its own.
|
|
Two jobs are queued back to back: the same [tick] module the ring
|
|
above installed sixty-four times, now sent stopped-only, and the
|
|
eval module sent plainly. The program polls once and prints how
|
|
many it installed. One. Without the flag it is two, and the two
|
|
deliveries differ in nothing but the word in front of the path. *)
|
|
let refusals_before = send qsock "refusals" in
|
|
let s = send qsock ("stopped-only " ^ qso) in
|
|
if s <> "ok\n" then
|
|
fail "a stopped-only module was not queued: %S" s;
|
|
|
|
let r = send qsock eso in
|
|
if r <> "ok\n" then fail "the eval module was not queued: %S" r;
|
|
ignore (Unix.write wfd (Bytes.of_string "\n") 0 1);
|
|
if not (await (fun () -> has "1")) then
|
|
fail "the eval thunk never ran: %S" (qtext ())
|
|
else begin
|
|
let reply = send qsock "result" in
|
|
match String.index_opt reply '\n' with
|
|
| None -> fail "no result header: %S" reply
|
|
| Some i ->
|
|
let hdr = String.sub reply 0 i in
|
|
let body =
|
|
String.sub reply (i + 1) (String.length reply - i - 1)
|
|
in
|
|
(* Exactly the cap, ellipsis included: [result_end] makes room
|
|
for it rather than assuming there is any. *)
|
|
if String.length body <> 4096 then
|
|
fail "the 4K result cap: %d bytes back, header %S"
|
|
(String.length body) hdr;
|
|
let tail n = if String.length body < n then body
|
|
else String.sub body (String.length body - n) n in
|
|
let head n = if String.length body < n then body
|
|
else String.sub body 0 n in
|
|
if tail 3 <> "..." then
|
|
fail "a clamped result did not say so: %S" (tail 8);
|
|
if head 2 <> "\"x" then
|
|
fail "the result is not the value that was rendered: %S"
|
|
(head 8)
|
|
end;
|
|
(* And the program says so, because a job that vanishes quietly is
|
|
the same lie the ring's dropped-oldest was. The count is what the
|
|
daemon compares either side of a delivery; the sentence is what it
|
|
puts in front of the person, and it lives here so that there is
|
|
one copy of it. *)
|
|
let refusals_after = send qsock "refusals" in
|
|
let count r =
|
|
match String.index_opt r '\n' with
|
|
| None -> None
|
|
| Some i -> int_of_string_opt (String.sub r 0 i)
|
|
in
|
|
(match (count refusals_before, count refusals_after) with
|
|
| Some b, Some a when a = b + 1 -> ()
|
|
| _ ->
|
|
fail "a dropped stopped-only job was not counted: %S then %S"
|
|
refusals_before refusals_after);
|
|
let wanted =
|
|
"the program resumed while this inspection was being built — \
|
|
stop it again and re-ask"
|
|
in
|
|
(match String.index_opt refusals_after '\n' with
|
|
| Some i
|
|
when String.trim
|
|
(String.sub refusals_after (i + 1)
|
|
(String.length refusals_after - i - 1))
|
|
= wanted -> ()
|
|
| _ ->
|
|
fail "the refusal does not say why: %S" refusals_after);
|
|
(try Sys.remove eso with Sys_error _ -> ())
|
|
end;
|
|
Unix.close wfd;
|
|
let qstatus = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] qpid with
|
|
| 0, _ -> false
|
|
| _, s -> qstatus := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill qpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "the queue program never finished"
|
|
end
|
|
else begin
|
|
let got =
|
|
String.concat "\n"
|
|
(List.filter (fun l -> l <> "")
|
|
(String.split_on_char '\n' (qtext ())))
|
|
in
|
|
if !qstatus <> Unix.WEXITED 0 || got <> "ready\nunloaded\n64\n1" then
|
|
fail "job ring\n got: %S\n wanted: %S" got
|
|
"ready\nunloaded\n64\n1"
|
|
end
|
|
end
|
|
end;
|
|
|
|
(* ── condition_name[128] ────────────────────────────────────────── *)
|
|
|
|
(* The other named buffer with no coverage at all, and it needs a socket
|
|
for the same reason: nothing but [status] ever reads it. The condition
|
|
class is 198 characters, so what comes back is the 127 that fit and a
|
|
terminator — a clamp, not an overrun, and now measured rather than
|
|
read. Aborting out of it also pins that the break loop's way out is
|
|
still exit status 134 now that it takes it with _exit. *)
|
|
let lsock = tmp "long.sock" and lout = tmp "long.out" in
|
|
(try Sys.remove lsock with Sys_error _ -> ());
|
|
let lt, ll = Session.create ~file:"programs/agent-longname.flan" () in
|
|
let lexe = tmp "long" in
|
|
ignore
|
|
(Build.executable ~opts:dev ~csrcs:ll.Load.csrcs ~lflags:ll.Load.lflags
|
|
lt.Session.host ~out:lexe);
|
|
let lfd = Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
|
let lenv =
|
|
Array.append (Unix.environment ()) [| "FLAN_AGENT_SOCKET=" ^ lsock |]
|
|
in
|
|
let lpid = Unix.create_process_env lexe [| lexe |] lenv Unix.stdin lfd lfd in
|
|
Unix.close lfd;
|
|
let stopped = ref "" in
|
|
if not
|
|
(await (fun () ->
|
|
Sys.file_exists lsock
|
|
&& (stopped := send lsock "status";
|
|
String.length !stopped > 8
|
|
&& String.sub !stopped 0 8 = "stopped ")))
|
|
then begin
|
|
fail "the long-named condition never stopped: %S" !stopped;
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
|
|
end
|
|
else begin
|
|
let got = String.trim (String.sub !stopped 8 (String.length !stopped - 8)) in
|
|
if String.length got <> 127 then
|
|
fail "condition_name clamps at 127: got %d characters"
|
|
(String.length got);
|
|
if String.length got >= 7 && String.sub got 0 7 <> "Missing" then
|
|
fail "the clamped name is not the condition's: %S" got;
|
|
ignore (send lsock "abort");
|
|
let lstatus = ref (Unix.WEXITED 0) in
|
|
let reaped =
|
|
await ~ms:5000 (fun () ->
|
|
match Unix.waitpid [ Unix.WNOHANG ] lpid with
|
|
| 0, _ -> false
|
|
| _, s -> lstatus := s; true)
|
|
in
|
|
if not reaped then begin
|
|
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
|
|
fail "abort did not end the program"
|
|
end
|
|
else if !lstatus <> Unix.WEXITED 134 then
|
|
fail "abort left status %s, wanted exit 134"
|
|
(match !lstatus with
|
|
| Unix.WEXITED c -> Printf.sprintf "exit %d" c
|
|
| Unix.WSIGNALED c -> Printf.sprintf "signal %d" c
|
|
| Unix.WSTOPPED c -> Printf.sprintf "stopped %d" c)
|
|
(* The other way out, and the one that skips atexit on purpose: [abort]
|
|
leaves by [_exit] so that it cannot hang on the loader lock, and the
|
|
socket is therefore unlinked by hand there. A file left here would
|
|
answer the next client with ECONNREFUSED — a program that is there
|
|
and refusing, rather than one that died. *)
|
|
else if Sys.file_exists lsock then
|
|
fail "abort left the agent socket behind: %S" lsock
|
|
end;
|
|
|
|
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
|
|
[ exe; so1; so2; sock; out; bsock; bout; bexe; qexe; qso; qsock; qout;
|
|
noinstall; lexe; lsock; lout ];
|
|
Test_support.report ~label:"agent" ()
|
|
| _ -> print_endline "agent: skipped (no clang or llc on PATH)"
|