Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
40 kB · 1027 lines
OCaml
at main
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028(* The checks of one land (Checking): which results are reused, which checks run, a lock on the notes ref, the answers the ending waits for, and what the checks say together. *)
module M = Merge_queueopen Mq_fixture
let build = M.Check.v (M.Check.name "build") (M.Check.Command "make")let test = M.Check.v (M.Check.name "test") (M.Check.Command "make test")let config c = M.Build_config.v ~platform:"p" clet key = M.Key.of_tree (tree "t")let later s = Option.get (Ptime.add_span now (Ptime.Span.of_int_s s))
let note ?(attempt = 1) ?(machine = "build-host") (c : M.Check.t) result = Result.get_ok (M.Note.v ~result ~check:c.name ~tree:(M.Key.tree key) ~attempt ~config:(config c) ~rules:(hash "r") ~machine:(M.Host.v machine) ~mode:M.Note.Self ~confined:None ~seconds:(M.Duration.of_seconds 2) ~at:now ())
let held = { M.Settle.lock = M.Settle.Ref M.Ref_name.notes; path = Fpath.v "/src/.git/refs/notes/mq-checks.lock"; holds = None; }
let request ?(checks = [ build ]) ?(notes = []) ?notes_lock ?(retry = false) ?(logs = []) ?(leftovers = []) ?(slots = 1) ?(prerequisites = []) ?(estimates = M.Order.estimates []) ?(confinement = M.Confinement.Confined M.Confinement.Seatbelt) () = { M.Checking.checks; key; notes; scripts = []; logs; notes_lock; retry; mode = M.Note.Self; machine = M.Host.v "laptop"; platform = "p"; rules = hash "r"; commit = hash "c"; target = M.Branch.v "main"; target_tip = hash "m"; check_wall = 600; grace = 30; slot_wait = 7200; slots; estimates; job = M.Branch.v "feature"; serve = false; leftovers; confinement; prerequisites; }
let ended ?(digest = String.make 64 'a') ?(failures = M.Failures.empty) ?said n attempt status : M.Checking.event = Run ( M.Check.name n, Ended { phases = None; failures; attempt; status; seconds = 2.; log = Some (Fmt.kstr Fpath.v "/log-%s-%d" n attempt); digest = Some digest; said; build = None; } )
let recorded n : M.Checking.event = Recorded (M.Check.name n)
let slot n : M.Checking.event = Run (M.Check.name n, Slot_taken { attempt = 1; at = now })
let ending t = match M.Checking.ending t with | Some e -> Fmt.str "%a" M.Checking.pp_ending e | None -> "none"
let pp_ending_of = function | M.Checking.Passed c -> "passed: " ^ c | Red { detail; log; _ } -> Fmt.str "red: %s (%a)" detail Fmt.(option ~none:(any "no log") Fpath.pp) log | Base_red { detail; _ } -> "base red: " ^ detail | Stuck { detail; _ } -> "stuck: " ^ detail | Unavailable why -> "unavailable: " ^ why | Busy why -> "busy: " ^ why | Withdrawn -> "withdrawn" | Drained why -> "drained: " ^ why
let said t = match M.Checking.ending t with Some e -> pp_ending_of e | None -> "none"
let starts actions = List.filter_map (function | M.Checking.Run (n, M.Check_run.Start { attempt; _ }) -> Fmt.kstr Option.some "%a %d" M.Check.pp_name n attempt | _ -> None) actions
let feed t events = drive M.Checking.incoming t events
(* doc/machines.md: "A tree already checked costs a lookup", and an outcome that ran nothing "names where its results came from". *)let test_reused () = let t, actions = M.Checking.v (request ~notes:[ note build M.Check.Passed ] ()) ~now in Alcotest.(check (list string)) "nothing runs" [] (starts actions); Alcotest.(check string) "said" "passed: checks reused from build-host" (said t); let t, actions = M.Checking.v (request ~retry:true ~notes:[ note build M.Check.Passed ] ()) ~now in Alcotest.(check (list string)) "--retry runs it" [ "build 1" ] (starts actions); Alcotest.(check string) "not ended" "none" (ending t)
let journaled actions = List.filter_map (function | M.Checking.Journal (M.Event.Reused r) -> Fmt.kstr Option.some "%a %s %s %ds %s" M.Check.pp_name r.check (M.Check.string_of_result r.result) (M.Host.to_string r.machine) r.seconds (M.Tree.to_hex (M.Key.tree r.key)) | _ -> None) actions
(* A verdict taken from a stored result is a fact of its own, journaled with the run it reuses: a pass, and the newest run of a stored red. *)let test_reuse_journaled () = let tree = M.Tree.to_hex (M.Key.tree key) in let _, actions = M.Checking.v (request ~checks:[ build; test ] ~notes:[ note build M.Check.Passed ] ()) ~now in Alcotest.(check (list string)) "a pass reused" [ "build passed build-host 2s " ^ tree ] (journaled actions); let _, actions = M.Checking.v (request ~notes: [ note build M.Check.Failed; note ~attempt:2 ~machine:"ci" build M.Check.Failed; ] ()) ~now in Alcotest.(check (list string)) "a stored red" [ "build failed ci 2s " ^ tree ] (journaled actions); let _, actions = M.Checking.v (request ~retry:true ~notes:[ note build M.Check.Passed ] ()) ~now in Alcotest.(check (list string)) "--retry reuses nothing" [] (journaled actions)
(* doc/machines.md: a confirmed red is "stored and printed again by every land of that tree", with the log of the run that recorded it while it is on this machine. *)let test_stored_red () = let t, actions = M.Checking.v (request ~notes: [ note build M.Check.Failed; note ~attempt:2 build M.Check.Failed ] ~logs: [ (M.Check.name "build", 1, Fpath.v "/one"); (M.Check.name "build", 2, Fpath.v "/two"); ] ()) ~now in Alcotest.(check (list string)) "nothing runs" [] (starts actions); Alcotest.(check string) "said" "red: check build failed, recorded 2026-09-21T14:13:20Z (/two)" (said t)
(* Checking: a lock on the notes ref that holds mq's own append on the ref's value is stale and removed before the first run; any other lock ends the checks stuck before any runs. *)let test_notes_lock () = let lock ?(message = "mq: a check result\n\nmq1 ...\n") ?(on_tip = true) ?(commit = true) () = { M.Checking.held; append = (if commit then Some { message; on_tip } else None); } in let t, actions = M.Checking.v (request ~notes_lock:(lock ()) ()) ~now in (match actions with | M.Checking.Remove_lock h :: _ -> Alcotest.(check string) "the lock removed first" "/src/.git/refs/notes/mq-checks.lock" (Fpath.to_string h.path) | _ -> Alcotest.fail "no removal first"); Alcotest.(check (list string)) "then the run" [ "build 1" ] (starts actions); Alcotest.(check string) "not ended" "none" (ending t); let stuck name l = let t, actions = M.Checking.v (request ~notes_lock:l ()) ~now in Alcotest.(check int) (name ^ ": no action") 0 (List.length actions); Alcotest.(check string) name "stuck: /src/.git/refs/notes/mq-checks.lock is held by another process, \ or was left by one that died" (said t) in stuck "git notes' own append" (lock ~message:"Notes added by 'git notes append'\n" ()); stuck "an append on another value" (lock ~on_tip:false ()); stuck "a lock that holds no commit" (lock ~commit:false ()); Alcotest.(check bool) "stale" true (M.Checking.stale (lock ())); Alcotest.(check bool) "a message that only starts the same" false (M.Checking.stale (lock ~message:"mq: a check result, by hand\n" ()))
(* Checking: "The checks end once every note they asked for is answered"; "A result that could not be recorded after all is said in the outcome, and the checks go on". *)let test_answers () = let t, _ = M.Checking.v (request ()) ~now in let t, actions = feed t [ ended "build" 1 (M.Check_run.Exited 0) ] in Alcotest.(check int) "one note asked" 1 (List.length (List.filter (function M.Checking.Note _ -> true | _ -> false) actions)); Alcotest.(check string) "waits for its answer" "none" (ending t); let t', _ = feed t [ recorded "build" ] in Alcotest.(check string) "recorded" "passed: checks build (0s wall, 2s of runs)" (said t'); let t', _ = feed t [ Not_recorded (M.Check.name "build", "refs/notes/mq-checks is held") ] in Alcotest.(check string) "not recorded" "passed: checks build (0s wall, 2s of runs); the result of check build was \ not recorded: refs/notes/mq-checks is held" (said t'); let t, _ = M.Checking.v (request ()) ~now in let t, actions = feed t [ ended ~digest:"bad" "build" 1 (M.Check_run.Exited 0) ] in Alcotest.(check int) "a line that cannot be written: no note" 0 (List.length (List.filter (function M.Checking.Note _ -> true | _ -> false) actions)); Alcotest.(check string) "and it is said" "passed: checks build (0s wall, 2s of runs); the result of check build was \ not recorded: log digest \"bad\" is not a SHA-256" (said t)
let notes actions = List.filter_map (function | M.Checking.Note { note; _ } -> Some (M.Check.string_of_name note.check) | _ -> None) actions
let stops actions = List.filter_map (function | M.Checking.Run (n, M.Check_run.Stop _) -> Some (M.Check.string_of_name n) | _ -> None) actions
(* Checking: with one build slot, the checks of a land run one after the other in the order the branch lists them (doc/runs.md: "the sum of its checks with one slot"), and a failure is rerun once, at once, before the next check starts (doc/design.md, "Check_run"); a confirmed red ends no check, and the checks after it still run to their verdicts (doc/runs.md: "every check of a land runs to its verdict"). *)let test_one_after_another_and_red () = let t, actions = M.Checking.v (request ~checks:[ build; test ] ()) ~now in Alcotest.(check (list string)) "build starts" [ "build 1" ] (starts actions); let t, actions = feed t [ ended "build" 1 (M.Check_run.Exited 0); recorded "build" ] in Alcotest.(check (list string)) "then test" [ "test 1" ] (starts actions); Alcotest.(check string) "test runs" "none" (ending t); let t, _ = feed t [ ended "test" 1 (M.Check_run.Exited 0); recorded "test" ] in Alcotest.(check string) "both ran" "passed: checks build test (0s wall, 4s of runs)" (said t); let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = feed t [ ended "build" 1 (M.Check_run.Exited 1) ] in Alcotest.(check (list string)) "the failure is rerun at once, test waits" [ "build 2" ] (starts actions); let t, actions = feed t [ ended "build" 2 (M.Check_run.Exited 1) ] in Alcotest.(check (list string)) "test still starts after the red" [ "test 1" ] (starts actions); Alcotest.(check (list string)) "nothing to stop" [] (stops actions); Alcotest.(check (list string)) "build's second run is recorded" [ "build" ] (notes actions); let t, _ = feed t [ recorded "build"; recorded "build" ] in Alcotest.(check string) "test runs to its verdict" "none" (ending t); let t, _ = feed t [ ended "test" 1 (M.Check_run.Exited 0); recorded "test" ] in Alcotest.(check string) "red" "red: check build failed with exit code 1; check test passed (/log-build-2)" (said t)
(* A red names the check whose log it carries: the first red in the order the branch lists them, whichever ended first, so the progress lines, the journal and the outcome say the same check. *)let test_red_names_its_check () = let check_of t = match M.Checking.ending t with | Some (M.Checking.Red { check; log; _ }) -> Fmt.str "%a (%a)" M.Check.pp_name check Fmt.(option ~none:(any "no log") Fpath.pp) log | _ -> "not red" in let t, _ = M.Checking.v (request ~checks:[ build; test ] ~slots:2 ()) ~now in let t, _ = feed t [ ended "test" 1 (M.Check_run.Exited 1); ended "test" 2 (M.Check_run.Exited 1); ended "build" 1 (M.Check_run.Exited 1); ended "build" 2 (M.Check_run.Exited 1); recorded "test"; recorded "test"; recorded "build"; recorded "build"; ] in Alcotest.(check string) "listed first, not ended first" "build (/log-build-2)" (check_of t); let t, _ = M.Checking.v (request ~checks:[ build ] ~notes: [ note build M.Check.Failed; note ~attempt:2 build M.Check.Failed ] ~logs:[ (M.Check.name "build", 2, Fpath.v "/b") ] ()) ~now in Alcotest.(check string) "a stored red" "build (/b)" (check_of t)
(* A flake does not end the checks: the next check starts once the rerun passed. *)let test_flake_then_next () = let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, _ = feed t [ ended "build" 1 (M.Check_run.Exited 1) ] in let _, actions = feed t [ ended "build" 2 (M.Check_run.Exited 0) ] in Alcotest.(check (list string)) "then test" [ "test 1" ] (starts actions)
(* Checking: "a check stuck at its wall, or one that could not run, ends them stuck"; after Cancelled, no run starts. *)let test_stuck_and_cancelled () = let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, _ = feed t [ slot "build" ] in let t, stop = match M.Checking.timer t ~now:(later 600) with | Ok r -> r | Error e -> Alcotest.failf "%a" M.Machine.pp_error e in Alcotest.(check (list string)) "the wall stops it" [ "build" ] (stops stop); Alcotest.(check (list string)) "test never starts" [] (starts stop); let t, actions = feed t [ ended "build" 1 M.Check_run.Stopped; recorded "build" ] in Alcotest.(check (list string)) "still none" [] (starts actions); Alcotest.(check string) "stuck" "stuck: check build reached its wall (bounds.check_wall, 600s)" (said t); let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = feed t [ Cancelled "the target moved" ] in Alcotest.(check (list string)) "the run under way is stopped" [ "build" ] (stops actions); Alcotest.(check string) "withdrawn" "withdrawn" (said t); let t, actions = feed t [ ended "build" 1 M.Check_run.Stopped ] in Alcotest.(check (list string)) "no run starts" [] (starts actions); Alcotest.(check string) "still withdrawn" "withdrawn" (said t)
(* machine.mli, Now: a failed action cancels the actions after it in its list, and their answers reach the checks as failures too. They say nothing the first did not: the checks end unavailable for the first failure's reason, never for "cancelled". *)let test_failed_then_cancelled () = let leftover = "the check worktree /pool/.check/4.suite a killed run left: Permission \ denied" in let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = feed t [ Failed leftover; Failed "cancelled"; Failed "cancelled" ] in Alcotest.(check (list string)) "the run under way is stopped" [ "build" ] (stops actions); let t, _ = feed t [ ended "build" 1 M.Check_run.Stopped ] in Alcotest.(check string) "the first failure's reason" ("unavailable: " ^ leftover) (said t)
(* Checking: the run ends at the next boundary (doc/runs.md). A drain lets the run under way go on to its verdict, recorded as any, starts no other check, and the checks end drained once the note is answered; a run still waiting for a build slot is stopped, as it has not started; with nothing left to drop, the checks end with their verdict. *)let test_drain () = let t, actions = M.Checking.v (request ~checks:[ build; test ] ()) ~now in Alcotest.(check (list string)) "build starts" [ "build 1" ] (starts actions); let t, actions = feed t [ slot "build"; Drain "an upgrade" ] in Alcotest.(check (list string)) "the run under way goes on" [] (stops actions); let t, actions = feed t [ ended "build" 1 (M.Check_run.Exited 0) ] in Alcotest.(check (list string)) "test never starts" [] (starts actions); Alcotest.(check (list string)) "build is recorded" [ "build" ] (notes actions); Alcotest.(check string) "the note first" "none" (ending t); let t, _ = feed t [ recorded "build" ] in Alcotest.(check string) "drained" "drained: an upgrade" (said t); let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = feed t [ Drain "an upgrade" ] in Alcotest.(check (list string)) "a run waiting for a slot is stopped" [ "build" ] (stops actions); let t, actions = feed t [ ended "build" 1 M.Check_run.Stopped ] in Alcotest.(check (list string)) "and none starts" [] (starts actions); Alcotest.(check string) "drained" "drained: an upgrade" (said t); let t, _ = M.Checking.v (request ~checks:[ build ] ()) ~now in let t, _ = feed t [ slot "build"; Drain "an upgrade"; ended "build" 1 (M.Check_run.Exited 0); recorded "build"; ] in Alcotest.(check bool) "every check started: its verdict" true (Astring.String.is_prefix ~affix:"passed" (said t))
(* doc/outcomes.md: an outcome names its cause. A check that could not start says why, in the words of what refused it, and one a signal ended says which. *)let test_could_not_run () = let why = "the build slot's ticket directory /src/.git/mq/slots.tickets could not be \ made: Permission denied" in let t, _ = M.Checking.v (request ~checks:[ build ] ()) ~now in let t, _ = feed t [ ended "build" 1 (M.Check_run.Not_started why); recorded "build" ] in Alcotest.(check string) "not started" ("stuck: check build could not run: " ^ why) (said t); let t, _ = M.Checking.v (request ~checks:[ build ] ()) ~now in let t, _ = feed t [ slot "build"; ended "build" 1 (M.Check_run.Signaled Sys.sigkill); recorded "build"; ] in Alcotest.(check string) "signaled" "stuck: check build was ended by SIGKILL" (said t)
(* doc/commands.md, the check record: one that could not run carries the reason its land's outcome prints, so a reader of the journal alone can tell why; one that ran carries none. *)let test_could_not_run_journaled () = let why = "generation /pool/.deps/d/c: /pool/.deps/d/.lock is held by process 42" in let reasons actions = List.filter_map (function | M.Checking.Journal (M.Event.Check c) -> Fmt.kstr Option.some "%s %s" (M.Check.string_of_result c.result) (Option.value c.reason ~default:"no reason") | _ -> None) actions in let run events = let t, _ = M.Checking.v (request ~checks:[ build ] ()) ~now in reasons (snd (feed t events)) in Alcotest.(check (list string)) "not started" [ "error could not run: " ^ why ] (run [ ended "build" 1 (M.Check_run.Not_started why) ]); Alcotest.(check (list string)) "signaled" [ "error was ended by SIGKILL" ] (run [ slot "build"; ended "build" 1 (M.Check_run.Signaled Sys.sigkill) ]); Alcotest.(check (list string)) "passed" [ "passed no reason" ] (run [ slot "build"; ended "build" 1 (M.Check_run.Exited 0) ]); Alcotest.(check (list string)) "failed" [ "failed no reason" ] (run [ slot "build"; ended "build" 1 (M.Check_run.Exited 1) ])
(* doc/runs.md: "A check that other builds starve leaves its land queued, never needs_work, and a sound change is not blamed for a busy machine": the checks end busy once the starved wait's stop has answered, and the next check never starts. *)let test_starved () = let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = match M.Checking.timer t ~now:(later 7200) with | Ok r -> r | Error e -> Alcotest.failf "%a" M.Machine.pp_error e in Alcotest.(check (list string)) "build's wait is stopped" [ "build" ] (stops actions); Alcotest.(check (list string)) "test never starts" [] (starts actions); Alcotest.(check (list string)) "nothing is recorded" [] (notes actions); Alcotest.(check string) "the stop is not answered yet" "none" (ending t); Alcotest.(check bool) "not idle" false (M.Checking.idle t); let t, _ = feed t [ ended "build" 1 M.Check_run.Stopped ] in Alcotest.(check bool) "idle" true (M.Checking.idle t); Alcotest.(check string) "busy" "busy: check build waited for a build slot (bounds.wait_wall, 7200s by \ default)" (said t)
(* Checking: "once the ending is decided, no run is under way and none starts". A check that could not run ends the checks stuck, and the check after it never starts. *)let test_stopped_answers () = let why = "checkout: unsafe tree path \"fixtures/intel-rapl:0\"" in let t, _ = M.Checking.v (request ~checks:[ build; test ] ()) ~now in let t, actions = feed t [ ended "build" 1 (M.Check_run.Not_started why); recorded "build" ] in Alcotest.(check (list string)) "test never starts" [] (starts actions); Alcotest.(check bool) "idle" true (M.Checking.idle t); Alcotest.(check string) "stuck" ("stuck: check build could not run: " ^ why) (said t)
(* Checking: the check worktrees a killed run left are removed before any run starts, whatever the stored results decide. *)let test_leftovers () = let left = [ Fpath.v "/pool/.check/a-build-1"; Fpath.v "/pool/.check/b-test-2" ] in let removals actions = List.filter_map (function | M.Checking.Remove_worktree p -> Some (Fpath.to_string p) | _ -> None) actions in let _, actions = M.Checking.v (request ~leftovers:left ()) ~now in Alcotest.(check (list string)) "both removed" [ "/pool/.check/a-build-1"; "/pool/.check/b-test-2" ] (removals actions); (match actions with | M.Checking.Remove_worktree _ :: M.Checking.Remove_worktree _ :: _ -> () | _ -> Alcotest.fail "the removals come first"); let _, actions = M.Checking.v (request ~leftovers:left ~notes:[ note build M.Check.Passed ] ()) ~now in Alcotest.(check int) "with every result reused too" 2 (List.length (removals actions))
(* doc/trust.md, "How a check is confined": each result says whether its check ran confined, and a red its confinement caused names what was denied. *)let test_confinement () = let nested = M.Confinement.Unconfined M.Confinement.Nested in let _, actions = M.Checking.v (request ~confinement:nested ()) ~now in Alcotest.(check (list string)) "unconfined, it runs" [ "build 1" ] (starts actions); let confined confinement = let t, _ = M.Checking.v (request ~confinement ()) ~now in let _, actions = feed t [ ended "build" 1 (M.Check_run.Exited 0) ] in List.filter_map (function | M.Checking.Note { note; _ } -> Some (M.Confinement.field (match note.confined with | Some m -> M.Confinement.Confined m | None -> nested)) | _ -> None) actions in Alcotest.(check (list string)) "a confined run's note" [ "seatbelt" ] (confined (M.Confinement.Confined M.Confinement.Seatbelt)); Alcotest.(check (list string)) "an unconfined run's note" [ "no" ] (confined nested); let what = "sh: /src/.git/x: Operation not permitted" in let t, _ = M.Checking.v (request ()) ~now in let t, _ = feed t [ ended "build" 1 (M.Check_run.Denied { code = 1; what }); ended "build" 2 (M.Check_run.Denied { code = 1; what }); recorded "build"; recorded "build"; ] in Alcotest.(check string) "a denied red" ("red: check build failed with exit code 1, denied: " ^ what ^ " (/log-build-2)") (said t)
(* A red gives the run's own exit status, as a CI runner does ("Process completed with exit code 2"), and quotes the last line the run wrote as the run's words: a script whose last line is "exit 0" must not read as a run that exited 0. The status is the last run's, whose log the red carries. *)let test_red_exit_code () = let t, _ = M.Checking.v (request ()) ~now in let t, _ = feed t [ ended ~said:"exit 0" "build" 1 (M.Check_run.Exited 1); ended ~said:"exit 0" "build" 2 (M.Check_run.Exited 2); recorded "build"; recorded "build"; ] in Alcotest.(check string) "the status, and the run's words" "red: check build failed with exit code 2, last line \"exit 0\" \ (/log-build-2)" (said t)
(* A red whose run marked its failures is named by them, the count and the first, never by the line the run wrote after them nor by its exit code (doc/outcomes.md). *)let test_red_marked () = let failures = List.fold_left (fun t l -> M.Failures.add t ~offset:0 l) M.Failures.empty [ "::error file=a.mli,line=12::E400 no module doc comment"; "::error file=b.ml::E405 no doc comment"; ] in let last = "lint-touched: merlint over 4 files: 2.7 s" in let t, _ = M.Checking.v (request ()) ~now in let t, _ = feed t [ ended ~failures ~said:last "build" 1 (M.Check_run.Exited 2); ended ~failures ~said:last "build" 2 (M.Check_run.Exited 2); recorded "build"; recorded "build"; ] in Alcotest.(check string) "the marked failures" "red: check build failed: 2 failures, first a.mli:12: E400 no module doc \ comment (/log-build-2)" (said t)
(* The checks of a land as a clock sees them: each check runs for its own seconds once started and exits with the status its attempt is given; every note is answered at once. [phase] is the instant, in seconds from the first start, the ending is decided, every start with its instant, and every stop with its instant. *)type timed = { seconds : int; codes : int list }
let phase ~slots checks = let at s = later s in let spec n = match List.assoc_opt n checks with | Some x -> x | None -> Alcotest.failf "no check %s" n in let defs = List.map (fun (n, _) -> M.Check.v (M.Check.name n) (M.Check.Command n)) checks in let started = ref [] and stopped = ref [] in (* The runs under way: name, attempt, the instant they end. *) let live = ref [] in let feed_at t now (events : M.Checking.event list) = List.fold_left (fun (t, acc) e -> match M.Checking.incoming t ~now e with | Ok (t, actions) -> (t, acc @ actions) | Error err -> Alcotest.failf "%a" M.Machine.pp_error err) (t, []) events in let rec settle t clock actions = let t = List.fold_left (fun t (a : M.Checking.action) -> match a with | Run (n, Start { attempt; _ }) -> let n = M.Check.string_of_name n in started := (n, attempt, clock) :: !started; live := (n, attempt, clock + (spec n).seconds) :: !live; t | Run (n, Stop { attempt; _ }) -> let n = M.Check.string_of_name n in stopped := (n, clock) :: !stopped; live := List.filter (fun (n', a', _) -> not (n = n' && attempt = a')) !live; fst (feed_at t (at clock) [ Run ( M.Check.name n, Ended { phases = None; failures = M.Failures.empty; attempt; status = Stopped; seconds = 0.; log = None; digest = None; said = None; build = None; } ); ]) | Note { note; _ } -> fst (feed_at t (at clock) [ Recorded note.check ]) | Run (_, Hold _) | Journal _ | Remove_lock _ | Remove_worktree _ | Prepare _ -> t) t actions in match M.Checking.ending t with | Some e -> (clock, pp_ending_of e) | None -> ( match List.sort (fun (_, _, a) (_, _, b) -> Int.compare a b) !live with | [] -> Alcotest.fail "no run under way and no ending" | (n, attempt, ends) :: _ -> live := List.filter (fun (n', a', _) -> not (n = n' && attempt = a')) !live; let code = List.nth (spec n).codes (attempt - 1) in let t, actions = feed_at t (at ends) [ Run ( M.Check.name n, Ended { phases = None; failures = M.Failures.empty; attempt; status = Exited code; seconds = float_of_int (spec n).seconds; log = None; digest = Some (String.make 64 'a'); said = None; build = None; } ); ] in settle t ends actions) in let t, actions = M.Checking.v (request ~checks:defs ~slots ()) ~now in let ends, said = settle t 0 actions in let show l = List.rev_map (fun (n, a, c) -> Fmt.str "%s %d at %d" n a c) l in ( ends, said, show !started, List.rev_map (fun (n, c) -> Fmt.str "%s at %d" n c) !stopped )
(* doc/runs.md: a land's checks run side by side, as many at once as the repository has build slots ([mq.slots]), in the order the branch lists them, so its check phase takes the longest check where the slots allow it, and the sum of its checks with one slot. Seconds coprime to each other, so no sum of some checks equals another check. The outcome gives that phase's wall, from checking to the last check's end, and beside it the time of the runs, summed (doc/outcomes.md, "landed"). *)let test_side_by_side () = let checks = [ ("build", { seconds = 7; codes = [ 0 ] }); ("test", { seconds = 11; codes = [ 0 ] }); ("lint", { seconds = 5; codes = [ 0 ] }); ] in let case ~slots ~ends ~starts = let e, said, s, stops = phase ~slots checks in let name = Fmt.str "%d slots" slots in Alcotest.(check string) (name ^ ": passed") (Fmt.str "passed: checks build test lint (%a wall, 23s of runs)" M.Duration.pp (M.Duration.of_seconds ends)) said; Alcotest.(check int) (name ^ ": the check phase ends") ends e; Alcotest.(check (list string)) (name ^ ": the starts") starts s; Alcotest.(check (list string)) (name ^ ": nothing stopped") [] stops in case ~slots:1 ~ends:23 ~starts:[ "build 1 at 0"; "test 1 at 7"; "lint 1 at 18" ]; case ~slots:2 ~ends:12 ~starts:[ "build 1 at 0"; "test 1 at 0"; "lint 1 at 7" ]; case ~slots:3 ~ends:11 ~starts:[ "build 1 at 0"; "test 1 at 0"; "lint 1 at 0" ]; case ~slots:6 ~ends:11 ~starts:[ "build 1 at 0"; "test 1 at 0"; "lint 1 at 0" ]
(* doc/runs.md: every check of a land runs to its verdict. Side by side, the confirmed red of the shortest check stops none of the others: each runs to its own verdict, a check not started yet still starts once a slot is free, and the ending, decided once the last of them ends, names the red and every pass. *)let test_red_stops_none () = let build = ("build", { seconds = 13; codes = [ 0 ] }) and test = ("test", { seconds = 17; codes = [ 0 ] }) and lint = ("lint", { seconds = 3; codes = [ 1; 1 ] }) and doc = ("doc", { seconds = 19; codes = [ 0 ] }) in let e, said, starts, stops = phase ~slots:3 [ build; test; lint ] in Alcotest.(check string) "one red and two passes" "red: check lint failed with exit code 1; checks build test passed (no log)" said; Alcotest.(check int) "at the longest check's end" 17 e; Alcotest.(check (list string)) "the starts" [ "build 1 at 0"; "test 1 at 0"; "lint 1 at 0"; "lint 2 at 3" ] starts; Alcotest.(check (list string)) "nothing stopped" [] stops; let e, said, starts, stops = phase ~slots:3 [ build; test; lint; doc ] in Alcotest.(check string) "one red and three passes" "red: check lint failed with exit code 1; checks build test doc passed (no \ log)" said; Alcotest.(check int) "at the last check's end" 25 e; Alcotest.(check (list string)) "the check not started yet takes the red's slot" [ "build 1 at 0"; "test 1 at 0"; "lint 1 at 0"; "lint 2 at 3"; "doc 1 at 6"; ] starts; Alcotest.(check (list string)) "still nothing stopped" [] stops
(* The checks of a land share the dependency generations the locks of its tree name (doc/commands.md, "What a check reads"): those are ensured once, before any check starts, and a check never waits on another's lock of one. A failure to make them is one outcome for the land, never a check that could not run. *)let lint = M.Check.v (M.Check.name "lint") (M.Check.Command "make lint")
let generation = Result.get_ok (M.Generation.v ~pool:(Fpath.v "/pool") ~name:"vendor" ~commit:(hash "dep"))
let prepares actions = List.filter_map (function | M.Checking.Prepare { commit; generations } -> Fmt.kstr (fun s -> Some s) "%s %a" (M.Commit.short commit) Fmt.(list ~sep:sp (using M.Generation.path Fpath.pp)) generations | _ -> None) actions
let three = request ~checks:[ build; test; lint ] ~slots:3
let test_prerequisites_first () = let t, first = M.Checking.v (three ~prerequisites:[ generation ] ()) ~now in Alcotest.(check (list string)) "prepared once, for the tree's commit" [ Fmt.str "%s %a" (M.Commit.short (hash "c")) Fpath.pp (M.Generation.path generation); ] (prepares first); Alcotest.(check (list string)) "no check before it" [] (starts first); Alcotest.(check string) "not ended" "none" (ending t); let t, ready = feed t [ M.Checking.Prepared ] in Alcotest.(check (list string)) "then side by side" [ "build 1"; "test 1"; "lint 1" ] (starts ready); let t, rest = feed t (List.concat_map (fun n -> [ slot n; ended n 1 (M.Check_run.Exited 0); recorded n ]) [ "build"; "test"; "lint" ]) in Alcotest.(check (list string)) "never prepared again" [] (prepares (ready @ rest)); Alcotest.(check string) "passed" "passed: checks build test lint (0s wall, 6s of runs)" (said t); let _, none = M.Checking.v (three ()) ~now in Alcotest.(check (list string)) "nothing to prepare" [] (prepares none); Alcotest.(check (list string)) "at once without" [ "build 1"; "test 1"; "lint 1" ] (starts none)
let test_unprepared () = let why = "/pool/.deps/vendor: No space left on device" in let t, first = M.Checking.v (three ~prerequisites:[ generation ] ()) ~now in let t, rest = feed t [ M.Checking.Unprepared (`Msg why) ] in Alcotest.(check (list string)) "no check ran" [] (starts (first @ rest)); Alcotest.(check string) "one outcome" ("stuck: the dependency generations could not be prepared: " ^ why) (said t)
(* A generation's lease held past its wait says nothing of the tree: the checks end busy, which keeps the land queued, and none starts. *)let test_unprepared_busy () = let why = "generation /pool/.deps/vendor/931d84caac82: lock is held" in let t, first = M.Checking.v (three ~prerequisites:[ generation ] ()) ~now in let t, rest = feed t [ M.Checking.Unprepared (`Busy why) ] in Alcotest.(check (list string)) "no check ran" [] (starts (first @ rest)); Alcotest.(check string) "busy" ("busy: the dependency generations could not be prepared: " ^ why) (said t)
(* Murmuration-SRJF within a job (Vijayakumar, Madhavapeddy and Kalyvianaki, SoCC 2024, section 4.2; Order.v): a land's checks start shortest estimate first, whatever the order the branch lists them in. Build is estimated at 300 s, test at 30 s and lint at 2 s, listed build, test, lint. *)let test_shortest_first () = let estimates = M.Order.estimates [ (build.name, 300_000); (test.name, 30_000); (lint.name, 2_000) ] in let checks = [ build; test; lint ] in let t, actions = M.Checking.v (request ~checks ~slots:1 ~estimates ()) ~now in Alcotest.(check (list string)) "one slot: lint starts first" [ "lint 1" ] (starts actions); let t, actions = feed t [ ended "lint" 1 (M.Check_run.Exited 0); recorded "lint" ] in Alcotest.(check (list string)) "then test" [ "test 1" ] (starts actions); let _, actions = feed t [ ended "test" 1 (M.Check_run.Exited 0); recorded "test" ] in Alcotest.(check (list string)) "then build" [ "build 1" ] (starts actions); let _, actions = M.Checking.v (request ~checks ~slots:3 ~estimates ()) ~now in Alcotest.(check (list string)) "three slots: all start, shortest first" [ "lint 1"; "test 1"; "build 1" ] (starts actions)
let suite = ( "checking", [ Alcotest.test_case "a pass is reused, unless --retry" `Quick test_reused; Alcotest.test_case "a reuse is journaled" `Quick test_reuse_journaled; Alcotest.test_case "a stored red is printed again" `Quick test_stored_red; Alcotest.test_case "a lock on the notes ref" `Quick test_notes_lock; Alcotest.test_case "the ending waits for every answer" `Quick test_answers; Alcotest.test_case "one after another, past a red" `Quick test_one_after_another_and_red; Alcotest.test_case "a red names its check" `Quick test_red_names_its_check; Alcotest.test_case "a flake, then the next check" `Quick test_flake_then_next; Alcotest.test_case "stuck, and cancelled" `Quick test_stuck_and_cancelled; Alcotest.test_case "a failure, then the cancelled after it" `Quick test_failed_then_cancelled; Alcotest.test_case "drained at the next boundary" `Quick test_drain; Alcotest.test_case "a check that could not run says why" `Quick test_could_not_run; Alcotest.test_case "a check that could not run journals why" `Quick test_could_not_run_journaled; Alcotest.test_case "starved of a build slot" `Quick test_starved; Alcotest.test_case "a check that could not run ends them" `Quick test_stopped_answers; Alcotest.test_case "a killed run's check worktrees" `Quick test_leftovers; Alcotest.test_case "confined, or not" `Quick test_confinement; Alcotest.test_case "a red gives its exit code and quotes its run" `Quick test_red_exit_code; Alcotest.test_case "a red is named by what its run marked" `Quick test_red_marked; Alcotest.test_case "side by side, bounded by the slots" `Quick test_side_by_side; Alcotest.test_case "a red stops none of the others" `Quick test_red_stops_none; Alcotest.test_case "the shared generations first, once" `Quick test_prerequisites_first; Alcotest.test_case "the shared generations unprepared" `Quick test_unprepared; Alcotest.test_case "unprepared for a held lease is busy" `Quick test_unprepared_busy; Alcotest.test_case "a land's checks start shortest first" `Quick test_shortest_first; ] )