76270eac0d
Ten test binaries share a directory and had shared nothing in it but watchdog.ml. Everything else each one needed it wrote out again: the failure counter and its FAIL line, the three-line report tail, a poll, a socket connect, the wait for a [flan dev] daemon to bind, a substring search, and the Load -> Check -> Reach.link front half of a compile. [listening] was the clearest case. Three copies, byte for byte apart from one comment, and two of them said in that comment that they were kept separate because "these three files have no module between them". That was not true when it was written: watchdog.ml was already named in the same (modules ...) stanzas. test_support.ml is the second such module, wired the same way, and those two sentences go with the copies they were explaining. test_repl.ml's [quote] was Wire.quote character for character, in a file that already links Wire and already names Wire.quote in a comment about what the case below it is checking. It is Wire.quote now. One real behaviour change, and it is a fix. [connect] existed twice over with different retries: the agent's narrowed to ECONNREFUSED with a comment saying why -- the socket file appears at bind, a moment before listen -- while dev's and repl's retried any Unix_error, which meant an ENOENT or an EACCES was retried to the full timeout before raising something the reader still had to interpret. The shared one takes the narrow version. Every caller connects to a socket [listening] has already seen on disk, so the race it does catch is the only one left. The rest is left where it is, on purpose. The three output-capturing [run]s differ in what they wrap -- a pid suffix, a sanitizer environment, a valgrind invocation -- and are not the same function. The report tails in test_repl, test_web and the two sweep binaries print different things for different reasons. The per-file scratch prefixes are the feature that keeps two suites running at once from unlinking each other's sockets, so the shared helper takes the prefix rather than choosing one. And the [match Sys.command "command -v clang ..."] probes stay as they are: their skip lines are output this suite pins. bin/main.ml has the compile pipeline written out twice more. Left alone -- this was a test/-scoped change and bin/ should not be reaching into a test module -- and noted in FIX.org as what it actually needs, which is the pipeline moving into lib/. dune test: exit 0, and its output is the same line for line once the temp-directory hash and the millisecond counts are normalised.
545 lines
26 KiB
OCaml
545 lines
26 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;
|
|
|
|
(* ── 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)
|
|
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)"
|