(* The agent, end to end (TODO.org, "The dev loop, step 3: the agent installs at a frame boundary"). 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 (* A [restarts] reply with each row cut at its first tab: the index, the flag and the name, which is what most checks below are about. *) let names_only reply = String.concat "\n" (List.map (fun l -> match String.index_opt l '\t' with | Some i -> String.sub l 0 i | None -> l) (String.split_on_char '\n' reply)) 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 (* The pair the daemon sets: the path, and the pid it is meant for. This test binary is the parent of every program it starts, which is the --two-process shape. *) let daemon_env path = let me = string_of_int (Unix.getpid ()) in [| "FLAN_AGENT_SOCKET=" ^ path; "FLAN_AGENT_OWNER=" ^ me; "FLAN_DEV_PARENT=" ^ me |] 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 "(defonce 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 -> Test_support.signal_name c | Unix.WSTOPPED c -> "stopped on " ^ Test_support.signal_name 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 (daemon_env "/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 -> Test_support.signal_name c | Unix.WSTOPPED c -> "stopped on " ^ Test_support.signal_name c) "cannot listen\n" end; (* ── The variable inherited by a process the daemon did not start ── *) (* A shell opened from inside a [flan dev] program carries its FLAN_AGENT_SOCKET, and so does anything run from that shell. Binding unlinks the path first, so honouring it there would take the session's socket from its program. FLAN_AGENT_OWNER names the process the daemon launched; pid 1 is neither this program nor its parent, so the variable is not this program's, and it picks and announces a path of its own as if nothing were set. The file standing in for the session's socket has to still be the same file afterwards. *) let inherited ~shape ~owner = let stolen = tmp "stolen.sock" and serr = tmp "stolen.err" in Out_channel.with_open_bin stolen (fun oc -> output_string oc "the session's"); let senv = Array.append aenv [| "FLAN_AGENT_SOCKET=" ^ stolen; "FLAN_AGENT_OWNER=" ^ owner |] in let s1 = ofd (tmp "stolen.out") and s2 = ofd serr in let spid = Unix.create_process_env aexe [| aexe |] senv Unix.stdin s1 s2 in Unix.close s1; Unix.close s2; let prefix = "flan agent: listening on " in let sannounced () = let text = In_channel.with_open_bin serr In_channel.input_all in List.find_map (fun l -> if String.length l > String.length prefix && String.sub l 0 (String.length prefix) = prefix then Some (String.sub l (String.length prefix) (String.length l - String.length prefix)) else None) (String.split_on_char '\n' text) in (match if await (fun () -> sannounced () <> None) then sannounced () else None with | None -> fail "%s: a program with someone else's FLAN_AGENT_SOCKET announced no \ socket of its own" shape; (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()) | Some p -> if p = stolen then fail "%s: the inherited path was bound: %S" shape p; if not (await (fun () -> Sys.file_exists p)) then fail "%s: nothing was bound at the announced %S" shape p else ignore (send p aso); let reaped = await ~ms:5000 (fun () -> match Unix.waitpid [ Unix.WNOHANG ] spid with | 0, _ -> false | _ -> true) in if not reaped then begin (try Unix.kill spid Sys.sigkill with Unix.Unix_error _ -> ()); fail "%s: the program with an inherited variable never finished" shape end); (match In_channel.with_open_bin stolen In_channel.input_all with | "the session's" -> () | _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was replaced" shape | exception Sys_error _ -> fail "%s: the inherited FLAN_AGENT_SOCKET's file was removed" shape); List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ stolen; serr; tmp "stolen.out" ] in (* Nobody's pid. *) inherited ~shape:"an owner that is not this process" ~owner:"1"; (* A merged build's owner is the program itself, so a process the program starts has the owner as its parent; with no FLAN_DEV_PARENT naming it, that is not the --two-process shape and the socket is not its. Here the test binary stands in for the program. *) inherited ~shape:"a child of a merged program" ~owner:(string_of_int (Unix.getpid ())); 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 ()) (daemon_env 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 ()) (daemon_env 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. *) (* After each name, tab-separated: the parameter count, their spelling, where the clause is written, and its :report sentence — empty for [retry], which wrote none. *) let want = "0 + retry\t0\t()\tprograms/break.flan:15:5\t\n\ 1 + use-placeholder\t0\t()\tprograms/break.flan:14:5\t\ Answer -1 for the missing value\n.\n" in if !listed <> want then fail "restarts on offer\n got: %S\n wanted: %S" !listed want; (* 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 () -> names_only (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 () -> names_only (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"); if not (await (fun () -> names_only (send bsock "restarts") = "0 + keep\n.\n")) then fail "a handler-case's own restart was listed: %S" (send bsock "restarts") else ignore (send bsock "restart-at 0 keep") 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\n42\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 ─────────────────────────────────────── TODO.org, "The 4K result cap is not a transport buffer and stays", names this buffer 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 ()) (daemon_env 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 -> Test_support.signal_name c | Unix.WSTOPPED c -> "stopped on " ^ Test_support.signal_name 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 ]; (* ── The snapshot's caps and the choice handoff, from inside ──────── *) (* agent_hooks.c is the entry point and drives the break loop through [flan_agent_break_poll_hook], on the stopped thread, so each case below is one fixed interleaving rather than a race against the loop's 2ms sleep. One process per mode: each ends with a restart stack the next would inherit. *) let ht, hl = Session.create ~file:"programs/agent-hooks.flan" () in let hexe = tmp "hooks" in ignore (Build.executable ~opts:dev ~csrcs:("agent_hooks.c" :: hl.Load.csrcs) ~lflags:hl.Load.lflags ht.Session.host ~out:hexe); let hook_mode m = let o = tmp ("hooks-" ^ m ^ ".out") and e = tmp ("hooks-" ^ m ^ ".err") and s = tmp ("hooks-" ^ m ^ ".sock") in let code = Sys.command (Printf.sprintf "%s %s %s > %s 2> %s" (Filename.quote hexe) m (Filename.quote s) (Filename.quote o) (Filename.quote e)) in let out = In_channel.with_open_bin o In_channel.input_all in let err = In_channel.with_open_bin e In_channel.input_all in List.iter (fun p -> try Sys.remove p with Sys_error _ -> ()) [ o; e; s ]; (code, out, err) in let contains s sub = let n = String.length sub in let rec go i = i + n <= String.length s && (String.sub s i n = sub || go (i + 1)) in go 0 in (* SNAP_MAX. 71 restarts on the stack, 64 listed, every listed one whole, and the terminal saying how many were left out. Taking index 5 lands in the frame five levels up from the one that erred, which returns 5: the indices of a truncated list still name the frames they say. *) let code, out, err = hook_mode "snapmax" in let want = "listed 64\nnames 5..5\ntake ok\nreturned 5\n" in if code <> 0 || out <> want then fail "a break with more restarts than the snapshot holds\n got: %S (exit %d, err %S)\n wanted: %S" out code err want; if not (contains err "... and 7 more, not listed") then fail "the break did not say how many restarts it left out: %S" err; (* SNAP_NAMES. 31 restarts whose names are 200 bytes each: twenty fit in 4096 bytes with their terminators, the twenty-first does not, and no name is cut short to squeeze it in. *) let code, out, err = hook_mode "snapnames" in let want = "listed 20\nnames 200..200\ntake ok\nreturned 19\n" in if code <> 0 || out <> want then fail "a break whose restart names outgrow the snapshot\n got: %S (exit %d, err %S)\n wanted: %S" out code err want; if not (contains err "... and 11 more, not listed") then fail "the break did not say how many long-named restarts it left out: %S" err; (* A choice made against the outer break, then a break nested on top of it before the outer one looks. The inner break turns past it five times and resumes only on its own choice, into its own frame; index 1 read without its generation would have sent it to outer-b. The last two lines are the outer break needing to be asked again, because the choice slot is one slot — TODO.org, "A choice made at an outer break is lost to a nested one". *) let code, out, err = hook_mode "stale" in let want = "outer choice ok\nstatus stopped Inner\ninner choice ok\ninner turns 5\n\ inner resumed into inner\nouter re-asked 1\nouter resumed into outer-a\n" in if code <> 0 || out <> want then fail "a choice addressed to an outer break, met by a nested one\n got: %S (exit %d, err %S)\n wanted: %S" out code err want; (* A restart accepted with an inspector read queued behind it, and a second asked for after. Neither runs in the break being left: the break takes the restart without draining the ring, the queued job is dropped at the next poll, and the late one is refused at the door. *) let code, out, err = hook_mode "resuming" in let want = "queued ok\ntake ok\nlate err the program is resuming: a restart was taken\n\ returned 0\ndropped 1\n" in if code <> 0 || out <> want then fail "a restart accepted with a read queued behind it\n got: %S (exit %d, err %S)\n wanted: %S" out code err want; (try Sys.remove hexe with Sys_error _ -> ()); Test_support.report ~label:"agent" () | _ -> print_endline "agent: skipped (no clang or llc on PATH)"