Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
50 kB · 1318 lines
OCaml
at main
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319open Merge_queue
(* doc/machines.md, "Offline first", and doc/commands.md, mq push: what goes where, what each remote takes, and the push's trace. *)
let now = Option.get (Ptime.of_date_time ((2026, 10, 1), ((12, 0, 0), 0)))let b = Branch.vlet c n = Commit.of_hash (Git.Hash.of_hex (String.make 40 n))
let rules src = match Rules.of_string src with | Ok r -> r | Error (`Msg m) -> Alcotest.failf "rules: %s" m
let edge = rules {|[branch.staging]checks = [][branch.main]takes = "staging"checks = []|}
let ctx = { Push.rules = edge; rules_branch = b "mq/config"; default_remote = Some "origin"; attest = false; dependencies = []; }
let local ?(push = Some "origin") ?(pull = Some "origin") name value = { Push.branch = b name; value; push_remote = push; pull_remote = pull }
let locals = [ local "fix" (c 'f') ~pull:None; local "main" (c '1'); local "mq/config" (c 'a'); local "staging" (c '2'); ]
let short (v : Commit.t) = String.sub (Git.Hash.to_hex (v :> Git.Hash.t)) 0 1
let names r = List.map (fun (remote, bs) -> ( remote, List.map (fun ((l : Push.local), v) -> Fmt.str "%a@%s" Branch.pp l.branch (short v)) bs )) r
let pp_outcome = Alcotest.testable Outcome.pp Outcome.equallet targets ?remote branches = Push.targets ctx { Push.remote; branches } locals
let refused_with ~exit ~affix = function | Ok _ -> Alcotest.fail "not refused" | Error (o : Outcome.t) -> Alcotest.(check int) (Outcome.first_line o) exit (Outcome.exit o); Alcotest.(check bool) (Fmt.str "%S in %S" affix (Outcome.first_line o)) true (Astring.String.is_infix ~affix (Outcome.first_line o))
let check_targets expected = function | Ok r -> Alcotest.(check (list (pair string (list string)))) "targets" expected (names r) | Error o -> Alcotest.failf "%a" Outcome.pp o
(* "With no BRANCH, every branch of the DAG and mq/config", sources first, so no remote holds a main its staging lacks. *)let test_every_branch () = check_targets [ ("origin", [ "mq/config@a"; "staging@2"; "main@1" ]) ] (targets [])
(* "mq push origin main also pushes the part of staging that main holds". *)let test_part_of_source () = check_targets [ ("origin", [ "staging@1"; "main@1" ]) ] (targets ~remote:"origin" [ b "main" ])
(* "A BRANCH outside the DAG is refused, the rules branch excepted: a work branch is pushed with Git", with exit 2 (the acceptance's mq push origin fix on a work branch). *)let test_work_branch () = let r = targets ~remote:"origin" [ b "fix" ] in refused_with ~exit:2 ~affix:"a work branch is pushed with Git" r; match r with | Error o -> Alcotest.(check (option string)) "next" (Some "git push origin fix") o.Outcome.next | Ok _ -> ()
(* "a branch of the DAG for which Git names no remote, when no REMOTE is given, is refused, naming the branch". *)let test_no_remote () = let locals = [ local "staging" (c '2') ~push:None ~pull:None ] in refused_with ~exit:2 ~affix:"Git names no remote for staging" (Push.targets ctx { remote = None; branches = [] } locals); check_targets [ ("origin", [ "staging@2" ]) ] (Push.targets ctx { remote = Some "origin"; branches = [] } locals); (* The rules branch goes where the DAG's branches go when Git names no remote for it, as mq init creates it. *) check_targets [ ("origin", [ "mq/config@a"; "staging@2" ]) ] (Push.targets ctx { remote = None; branches = [] } [ local "mq/config" (c 'a') ~push:None ~pull:None; local "staging" (c '2'); ])
(* A branch Git names no remote for is refused, and the refusal names the push to the remote Git would take (git-push(1), "remote"), when there is one. *)let test_no_remote_next () = let locals = [ local "staging" (c '2') ~push:None ~pull:None ] in let next default_remote = match Push.targets { ctx with default_remote } { remote = None; branches = [] } locals with | Ok _ -> Alcotest.fail "not refused" | Error o -> o.Outcome.next in Alcotest.(check (option string)) "a remote" (Some "mq push forge") (next (Some "forge")); Alcotest.(check (option string)) "none" None (next None)
(* mq status reads where mq push sends each branch from the same rule: Git's push remote, never the remote the branch is pulled from (git-config(1), "remote.pushDefault": it "overrides branch.<name>.remote"). *)let test_destination () = let locals = [ local "fix" (c 'f') ~push:(Some "fork") ~pull:None; local "main" (c '1') ~push:(Some "github") ~pull:(Some "origin"); local "mq/config" (c 'a') ~push:None ~pull:None; local "staging" (c '2') ~push:None ~pull:(Some "origin"); ] in let dest name = Push.destination ctx locals (b name) in Alcotest.(check (option string)) "main" (Some "github") (dest "main"); (* staging, the entry, has no push remote: it goes where the DAG's other branch goes, as mq push sends it. *) Alcotest.(check (option string)) "no push remote" (Some "github") (dest "staging"); Alcotest.(check (option string)) "a work branch" None (dest "fix"); Alcotest.(check (option string)) "not here" None (dest "full"); (* The rules branch goes where the DAG's branches go, as mq push sends it. *) Alcotest.(check (option string)) "the rules branch" (Some "github") (dest "mq/config"); Alcotest.(check string) "the remote-tracking branch" "github/main" (Ref_name.Tracking.to_string (Ref_name.Tracking.v ~remote:"github" (b "main")))
let facts ?(values = []) ?(seen = []) ?(tracking = []) ?(contains = []) ?(unpublished = []) ?evidence ?(evidence_held = true) ?(results = Push.Unchanged) ?(origins = Push.Unchanged) ?(diverged = []) ?(waiting = []) () = { Push.name = "origin"; seen_key = "origin"; url = "origin"; values; seen; tracking; contains; unpublished; evidence; evidence_held; results; origins; diverged; waiting; }
let plan f = Push.plan ctx ("origin", [ (local "staging" (c '2'), c '2') ]) f
let updates = function | Ok (p : Push.plan) -> List.map (fun (u : Push.update) -> Fmt.str "%a %s" Branch.pp u.branch (match u.expected with None -> "create" | Some e -> short e)) p.updates | Error o -> Alcotest.failf "%a" Outcome.pp o
(* "Each push carries the value it expects the remote to hold": a fast-forward from what the remote holds. *)let test_fast_forward () = Alcotest.(check (list string)) "updates" [ "staging 0" ] (updates (plan (facts ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2') ] ())))
(* doc/runs.md, "A move mq did not make": a branch of the DAG goes as far as mq's landings go. Catches a push that sends the local value whatever moved it, as a fast-import onto staging reached github on 2026-10-22. *)let test_as_far_as_landings () = let sent f = match plan f with | Ok (p : Push.plan) -> ( List.map (fun (u : Push.update) -> Fmt.str "%a %s" Branch.pp u.branch (short u.value)) p.updates, List.map (fun (b, (w : Push.waiting)) -> (Branch.to_string b, w.commits)) p.waiting ) | Error o -> Alcotest.failf "%a" Outcome.pp o in let moved newest = facts ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2'); (c '0', c '1'); (c '1', c '2') ] ~waiting:[ (b "staging", { Push.newest; commits = 1 }) ] () in Alcotest.(check (pair (list string) (list (pair string int)))) "to the newest landing" ([ "staging 1" ], [ ("staging", 1) ]) (sent (moved (Some (c '1')))); Alcotest.(check (pair (list string) (list (pair string int)))) "no landing above the remote's: nothing sent" ([], [ ("staging", 1) ]) (sent (moved None))
(* "When the remote has moved, it is refused and names mq pull": the agreed copy holds commits the local branch lacks, and nothing is sent. *)let test_remote_moved () = let r = plan (facts ~values:[ (b "staging", c '9') ] ()) in refused_with ~exit:2 ~affix:"origin/staging holds commits staging lacks" r; match r with | Error o -> Alcotest.(check (option string)) "next" (Some "mq pull origin") o.next | Ok _ -> ()
(* doc/machines.md, "Offline first": the entry, whose agreed copy holds commits it lacks only as ids, each held here as a copy or a lock commit a later lock supersedes, is published over them with a lease on what the remote holds; a branch that takes from another never is, nor a branch a person moved with Git, each refused naming the force-with-lease a person runs. *)let test_published_over () = let lacked ?(held = false) ?(superseded = false) n = { Push.commit = c n; held; superseded } in let diverged b ?(moved = false) ls = (b, { Push.lacked = ls; moved }) in let staging lacked = facts ~values:[ (b "staging", c '9') ] ~diverged:[ diverged (b "staging") lacked ] () in (match plan (staging [ lacked ~held:true '8'; lacked ~superseded:true '9' ]) with | Ok p -> Alcotest.(check (list string)) "over" [ "staging 9" ] (updates (Ok p)); Alcotest.(check (list string)) "replaced" [ "8"; "9" ] (List.concat_map (fun (o : Push.over) -> List.map (fun (l : Push.lacked) -> short l.commit) o.replaced) p.over) | Error o -> Alcotest.failf "%a" Outcome.pp o); let next r = match r with | Error (o : Outcome.t) -> o.next | Ok _ -> Alcotest.fail "sent" in let lease = Fmt.str "git push --force-with-lease=staging:%s origin staging" (String.make 40 '9') in let r = plan (staging [ lacked '9' ]) in refused_with ~exit:2 ~affix:"origin/staging holds commits staging lacks" r; Alcotest.(check (option string)) "a commit not held: a pull" (Some "mq pull origin") (next r); let r = plan (facts ~values:[ (b "staging", c '9') ] ~diverged:[ diverged (b "staging") ~moved:true [ lacked '9' ] ] ()) in refused_with ~exit:2 ~affix:"staging was moved with Git" r; Alcotest.(check (option string)) "a person's move" (Some lease) (next r); let main = Push.plan ctx ("origin", [ (local "main" (c '2'), c '2') ]) (facts ~values:[ (b "main", c '9') ] ~diverged:[ diverged (b "main") [ lacked ~held:true '9' ] ] ()) in refused_with ~exit:2 ~affix:"takes from another" main; Alcotest.(check (option string)) "main is never published over" (Fmt.kstr (fun s -> Some s) "git push --force-with-lease=main:%s origin main" (String.make 40 '9')) (next main)
(* doc/machines.md, "Dependencies across machines": a consumer branch whose lock names a dependency commit the dependency's remote-tracking paired branch lacks is published all the same, and listed for the report to name; mq stands between a person and Git nowhere. A fork's copy follows this machine whatever its lock names, and lists nothing. *)let test_unpublished_lock () = let unpublished = [ ( b "staging", { Push.path = Fpath.v "vendor/lib"; commit = c '7'; tracking = Ref_name.Tracking.v ~remote:"origin" (b "staging"); } ); ] in let lacked = function | Ok (p : Push.plan) -> List.map (fun (br, (u : Push.unpublished)) -> Fmt.str "%a %a %s" Branch.pp br Fpath.pp u.path (short u.commit)) p.lacked | Error o -> Alcotest.failf "%a" Outcome.pp o in let r = plan (facts ~unpublished ()) in (* Catches a push that refuses the lock again: it would be an Error. *) Alcotest.(check (list string)) "published" [ "staging create" ] (updates r); Alcotest.(check (list string)) "named" [ "staging vendor/lib 7" ] (lacked r); Alcotest.(check (list string)) "already there, named" [ "staging vendor/lib 7" ] (lacked (plan (facts ~unpublished ~values:[ (b "staging", c '2') ] ()))); let fork = ("origin", [ (local "staging" (c '2') ~pull:(Some "upstream"), c '2') ]) in let r = Push.plan ctx fork (facts ~unpublished ()) in Alcotest.(check (list string)) "a fork's copy" [ "staging create" ] (updates r); Alcotest.(check (list string)) "a fork's copy names none" [] (lacked r)
(* A branch the remote held when this machine last saw it, and holds no longer, is not created again; one it never held is created. What this machine last saw is its record under refs/mq/seen/, else the remote-tracking branch, as a pull reads it (Push.last_seen): a clone where mq has not pushed yet still sees the deletion. *)let test_deleted () = refused_with ~exit:2 ~affix:"staging was deleted on origin" (plan (facts ~seen:[ (b "staging", c '0') ] ())); refused_with ~exit:2 ~affix:"staging was deleted on origin" (plan (facts ~tracking:[ (b "staging", c '0') ] ())); Alcotest.(check (list string)) "never held" [ "staging create" ] (updates (plan (facts ())))
(* The remote at the local value already: nothing to send. *)let test_current () = match plan (facts ~values:[ (b "staging", c '2') ] ()) with | Ok p -> Alcotest.(check int) "updates" 0 (List.length p.updates); Alcotest.(check int) "current" 1 (List.length p.current) | Error o -> Alcotest.failf "%a" Outcome.pp o
(* "A fork's copy, which is not the agreed copy, follows this machine with a lease": against the value seen, not a fast-forward. *)let test_fork () = let remote = ("origin", [ (local "staging" (c '2') ~pull:(Some "upstream"), c '2') ]) in (match Push.plan ctx remote (facts ~values:[ (b "staging", c '7') ] ~seen:[ (b "staging", c '7') ] ()) with | Ok p -> Alcotest.(check bool) "not agreed" false p.agreed; Alcotest.(check (list string)) "lease" [ "staging 7" ] (updates (Ok p)) | Error o -> Alcotest.failf "%a" Outcome.pp o); refused_with ~exit:2 ~affix:"moved on origin since" (Push.plan ctx remote (facts ~values:[ (b "staging", c '8') ] ~seen:[ (b "staging", c '7') ] ()))
(* git push --set-upstream: a push that names REMOTE sets each branch it publishes there as the agreed copy, and that is pulled from no remote, up to track it; a branch with an upstream keeps it, a fork's copy is no agreed copy, and a push that names no REMOTE sets nothing up. *)let test_track () = let track ?(track = true) branches f = match Push.plan ~track ctx ("origin", branches) f with | Ok p -> List.map Branch.to_string p.track | Error o -> Alcotest.failf "%a" Outcome.pp o in let none = local "staging" (c '2') ~pull:None in Alcotest.(check (list string)) "no upstream" [ "staging" ] (track [ (none, c '2') ] (facts ())); Alcotest.(check (list string)) "already there" [ "staging" ] (track [ (none, c '2') ] (facts ~values:[ (b "staging", c '2') ] ())); Alcotest.(check (list string)) "no REMOTE named" [] (track ~track:false [ (none, c '2') ] (facts ())); Alcotest.(check (list string)) "an upstream kept" [ "staging" ] (track [ (none, c '2'); (local "main" (c '1'), c '1') ] (facts ())); Alcotest.(check (list string)) "a fork's copy" [] (track [ (none, c '2'); (local "main" (c '1') ~pull:(Some "upstream"), c '1') ] (facts ()))
let step t e = match Push.incoming t ~now e with | Ok r -> r | Error err -> Alcotest.failf "%a" Machine.pp_error err
(* A push takes no run lock: its first action is its read. *)let started request = let t, first = Push.v ctx request in (match first with | [ Push.Read_local ] -> () | _ -> Alcotest.fail "a push reads the local branches first"); (t, first)
(* The trace: the run hands the push its pass; it reads, sends, records, and reports what it published. *)let test_trace () = let t, acts = started { remote = Some "origin"; branches = [ b "staging" ] } in (match acts with [ Push.Read_local ] -> () | _ -> Alcotest.fail "read"); let t, acts = step t (Local_read locals) in (match acts with | [ Push.Read_remote { remote = "origin"; _ } ] -> () | _ -> Alcotest.fail "read the remote"); let t, acts = step t (Remote_read [ facts ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2') ] (); ]) in (match acts with [ Push.Push _ ] -> () | _ -> Alcotest.fail "push"); let t, acts = step t (Pushed { landings = 2 }) in (match acts with [ Push.Record _ ] -> () | _ -> Alcotest.fail "record"); let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "report" "published staging to origin: 2 landings" (Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report"
(* doc/commands.md, "Publication": the consumer's line tells each dependency's push the command made first, and each lock commit the dependency's remote still lacks with that push's outcome and its next command, run from the consumer. *)let test_dependency_notes () = let lib = Fpath.v "vendor/lib" and other = Fpath.v "vendor/other" in let refusal = Outcome.v ~branch:(b "staging") ~next:"mq pull origin" Outcome.Refused "origin/staging holds commits staging lacks: nothing moved" in let ctx = { ctx with dependencies = [ { Push.path = other; pushed = Ok (Report.v ~detail:"1 landing" Report.Published "staging to origin"); }; { Push.path = lib; pushed = Error refusal }; ]; } in let t, _ = Push.v ctx { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let unpublished = [ ( b "staging", { Push.path = lib; commit = c '7'; tracking = Ref_name.Tracking.v ~remote:"origin" (b "staging"); } ); ] in let t, _ = step t (Remote_read [ facts ~unpublished ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2') ] (); ]) in let t, _ = step t (Pushed { landings = 1 }) in let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "report" "published staging to origin: 1 landing; vendor/other published \ staging to origin first: 1 landing; staging's lock names vendor/lib's \ 777777777777, which vendor/lib's origin/staging lacks; vendor/lib's \ push: refused staging: origin/staging holds commits staging lacks: \ nothing moved; next: mq -C vendor/lib pull origin" (Fmt.str "%a" Report.pp r) | Some (Error o) -> Alcotest.failf "refused: %a" Outcome.pp o | None -> Alcotest.fail "no ending"
(* The branches whose locks the command reads: those it sends to their agreed copy, a fork's copy left out. *)let test_publishes () = let publishes locals = List.map (fun (br, v) -> Fmt.str "%a@%s" Branch.pp br (short v)) (Push.publishes ctx { remote = None; branches = [] } locals) in Alcotest.(check (list string)) "agreed" [ "mq/config@a"; "staging@2"; "main@1" ] (publishes locals); Alcotest.(check (list string)) "a fork's copy" [ "mq/config@a"; "main@1" ] (publishes [ local "mq/config" (c 'a'); local "staging" (c '2') ~push:(Some "fork") ~pull:(Some "upstream"); local "main" (c '1'); ]); Alcotest.(check int) "a refused call" 0 (List.length (Push.publishes ctx { remote = None; branches = [ b "fix" ] } locals))
let test_two_destinations_partial_refusal () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let first = facts () in let second = { first with url = "mirror"; seen_key = "origin/push/mirror" } in let t, actions = step t (Remote_read [ first; second ]) in (match actions with | [ Push.Push p ] -> Alcotest.(check string) "first URL" "origin" p.url | _ -> Alcotest.fail "first destination not planned"); let t, _ = step t (Pushed { landings = 1 }) in let t, actions = step t Recorded in (match actions with | [ Push.Push p ] -> Alcotest.(check string) "second URL" "mirror" p.url | _ -> Alcotest.fail "second destination not planned"); let t, _ = step t (Push_refused "denied") in let t, _ = step t Journalled in match Push.ending t with | Some (Error o) -> Alcotest.(check string) "partial move is stated" "origin took the push at origin, and mirror did not take it (origin \ refused the push (denied): earlier destinations moved)" o.detail | _ -> Alcotest.fail "no refusal"
let test_two_destinations_one_landing () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let first = facts () in let second = { first with url = "mirror"; seen_key = "origin/push/mirror" } in let t, _ = step t (Remote_read [ first; second ]) in let t, _ = step t (Pushed { landings = 1 }) in let t, _ = step t Recorded in let t, _ = step t (Pushed { landings = 1 }) in let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "one logical landing" "published staging to origin: 1 landing" (Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report"
(* What a push sets up is what it sent to a REMOTE it was given, once the remote took it, and the report says so: a branch that goes to the remote Git pushes it to, with no REMOTE, gets no upstream. *)let test_trace_track () = let locals = [ local "staging" (c '2') ~pull:None ] in let record remote = let t, _ = started { remote; branches = [] } in let t, _ = step t (Local_read locals) in let t, _ = step t (Remote_read [ facts () ]) in let t, acts = step t (Pushed { landings = 1 }) in let track = match acts with | [ Push.Record { track; _ } ] -> List.map Branch.to_string track | _ -> Alcotest.fail "record" in let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> (track, Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report" in Alcotest.(check (pair (list string) string)) "no REMOTE" ([], "published staging to origin: 1 landing") (record None); Alcotest.(check (pair (list string) string)) "REMOTE" ( [ "staging" ], "published staging to origin: 1 landing; staging now tracks origin" ) (record (Some "origin"))
(* "A branch of the DAG Git names no remote for goes where the DAG's entry goes" (doc/commands.md, mq push): an edge mq serves whose target mq created (run.space's walks, taking main) is published with the DAG, never refused for lack of a remote, and set up to track it as the push to REMOTE would. The rules branch, which mq init creates with no remote, goes there too and keeps its configuration. Before the fix, mq push and every scheduled sync refused walks, naming the push to origin. *)let test_edge_follows_entry () = let ctx = { ctx with rules = rules {|[branch.main]checks = [][branch.walks]takes = "main"checks = []|}; } in let locals = [ local "main" (c '1'); local "mq/config" (c 'a') ~push:None ~pull:None; local "walks" (c '1') ~push:None ~pull:None; ] in check_targets [ ("origin", [ "main@1"; "mq/config@a"; "walks@1" ]) ] (Push.targets ctx { remote = None; branches = [] } locals); Alcotest.(check (option string)) "where status reads walks is pushed" (Some "origin") (Push.destination ctx locals (b "walks")); (* With remote.pushDefault, Git's push remote of the entry, the edge goes there, not where the entry is pulled from. *) let pushed_default = [ local "main" (c '1') ~push:(Some "forge"); local "walks" (c '1') ~push:None ~pull:None; ] in check_targets [ ("forge", [ "main@1"; "walks@1" ]) ] (Push.targets ctx { remote = None; branches = [] } pushed_default); let t, _ = Push.v ctx { remote = None; branches = [] } in let t, _ = step t (Local_read locals) in let t, _ = step t (Remote_read [ facts () ]) in let t, acts = step t (Pushed { landings = 1 }) in let track = match acts with | [ Push.Record { track; _ } ] -> List.map Branch.to_string track | _ -> Alcotest.fail "record" in Alcotest.(check (list string)) "walks tracks origin" [ "walks" ] track; let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "the report" "published main, mq/config, walks to origin: 1 landing; walks now \ tracks origin" (Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report"
(* A remote with two push URLs takes the push at each, as git push --set-upstream sends to every remote.<name>.pushurl and records one upstream: the report names the upstream once. *)let test_two_destinations_track () = let t, _ = started { remote = Some "origin"; branches = [] } in let t, _ = step t (Local_read [ local "staging" (c '2') ~pull:None ]) in let first = facts () in let second = { first with url = "mirror"; seen_key = "origin/push/mirror" } in let t, _ = step t (Remote_read [ first; second ]) in let t, _ = step t (Pushed { landings = 1 }) in let t, _ = step t Recorded in let t, _ = step t (Pushed { landings = 1 }) in let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "one upstream" "published staging to origin: 1 landing; staging now tracks origin" (Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report"
(* An outside writer between the read and the push: the lease breaks, nothing moved, and the outcome names mq pull. *)let test_stale () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let t, _ = step t (Remote_read [ facts () ]) in let t, acts = step t (Stale { branch = b "staging"; held = Some (c '9') }) in (match acts with | [ Push.Journal (Event.Push_refused _) ] -> () | _ -> Alcotest.fail "only the refusal is recorded"); let t, _ = step t Journalled in match Push.ending t with | Some (Error o) -> Alcotest.check pp_outcome "outcome" (Outcome.v ~branch:(b "staging") ~next:"mq pull origin" Outcome.Refused "origin/staging moved during the push: nothing moved") o | _ -> Alcotest.fail "not refused"
(* A remote that cannot be reached ends the push unavailable (5), once the journal holds why: mq status names a landing the agreed copy lacks past its schedule with the reason its last push was not taken (doc/invariants.md, liveness 12), and a scheduled sync's push leaves nothing else behind it. It is no refused push. *)let test_unreachable () = let t, _ = started { remote = Some "origin"; branches = [] } in let t, _ = step t (Local_read locals) in let t, actions = step t (Unserved { remote = "origin"; error = `Unreachable "gone" }) in (match actions with | [ Push.Journal (Event.Push_unreachable { remote; reason }) ] -> Alcotest.(check (pair string string)) "the remote and why" ("origin", "gone") (remote, reason) | _ -> Alcotest.fail "no push-unreachable journaled"); Alcotest.(check bool) "waits for the journal" true (Push.ending t = None); let t, _ = step t Journalled in match Push.ending t with | Some (Error o) -> Alcotest.(check int) "exit" 5 (Outcome.exit o) | _ -> Alcotest.fail "not unavailable"
(* doc/trust.md, "Evidence": with a key, a push attests the landings it publishes to the agreed copy, then sends the evidence ref with the branches, in the same transaction. *)
let attesting = { ctx with attest = true }
let attest_started request = let t, _ = Push.v attesting request in t
let evidence_of = function | [ Push.Push p ] -> ( match p.evidence with | None -> "none" | Some e -> Fmt.str "%s %s" (match e.expected with None -> "create" | Some x -> short x) (short e.value)) | _ -> Alcotest.fail "not a push"
let test_attest_trace () = let t = attest_started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let t, acts = step t (Remote_read [ facts ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2') ] (); ]) in (match acts with | [ Push.Attest { updates = [ u ] } ] -> Alcotest.(check string) "the branch" "staging" (Branch.to_string u.branch); Alcotest.(check (option string)) "from the remote's value" (Some "0") (Option.map short u.expected); Alcotest.(check string) "to the local one" "2" (short u.value) | _ -> Alcotest.fail "attest the landings the push publishes"); let t, acts = step t (Attested { evidence = Some (c 'e'); attested = 2 }) in Alcotest.(check string) "the evidence ref, created" "create e" (evidence_of acts); let t, _ = step t (Pushed { landings = 2 }) in let t, _ = step t Recorded in match Push.ending t with | Some (Ok r) -> Alcotest.(check string) "report" "published staging to origin: 2 landings, 2 attested" (Fmt.str "%a" Report.pp r) | _ -> Alcotest.fail "no report"
(* Without a key, a push attests nothing and sends no evidence. *)let test_attest_off () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let _, acts = step t (Remote_read [ facts ~values:[ (b "staging", c '0') ] ~contains:[ (c '0', c '2') ] ~evidence:(c 'd') (); ]) in Alcotest.(check string) "no evidence" "none" (evidence_of acts)
let attested ?(remote = facts ()) evidence = let t = attest_started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let t, _ = step t (Remote_read [ remote ]) in step t (Attested { evidence; attested = 0 })
(* The evidence ref moves by fast-forward from the remote's value; a remote that holds it already takes nothing, and one that holds attestations this machine lacks refuses the push: merging several signers' evidence is not this machine's to do. *)let test_evidence_update () = Alcotest.(check string) "a fast-forward" "d e" (evidence_of (snd (attested ~remote:(facts ~evidence:(c 'd') ()) (Some (c 'e'))))); Alcotest.(check string) "already there" "none" (evidence_of (snd (attested ~remote:(facts ~evidence:(c 'e') ()) (Some (c 'e'))))); Alcotest.(check string) "none here" "none" (evidence_of (snd (attested ~remote:(facts ~evidence:(c 'd') ()) None))); let t, acts = attested ~remote:(facts ~evidence:(c 'd') ~evidence_held:false ()) (Some (c 'e')) in (match acts with | [ Push.Journal (Event.Push_refused _) ] -> () | _ -> Alcotest.fail "the refusal is recorded"); let t, _ = step t Journalled in match Push.ending t with | Some (Error o) -> Alcotest.(check int) "refused" 2 (Outcome.exit o); Alcotest.(check string) "detail" "origin holds evidence in refs/notes/mq-evidence that this machine \ lacks: nothing moved" o.detail | _ -> Alcotest.fail "not refused"
(* A fork's copy is no agreed copy: it is attested for and sent nothing. *)let test_attest_fork () = let fork = [ local "staging" (c '2') ~pull:(Some "upstream") ] in let t = attest_started { remote = Some "origin"; branches = [] } in let t, _ = step t (Local_read fork) in let t, acts = step t (Remote_read [ facts ~values:[ (b "staging", c '7') ] ~seen:[ (b "staging", c '7') ] (); ]) in (match acts with | [ Push.Attest { updates = [] } ] -> () | _ -> Alcotest.fail "nothing to attest"); let _, acts = step t (Attested { evidence = Some (c 'e'); attested = 0 }) in Alcotest.(check string) "no evidence" "none" (evidence_of acts)
(* A key that cannot sign refuses the push before anything is sent. *)let test_unattested () = let t = attest_started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let t, _ = step t (Remote_read [ facts () ]) in let t, acts = step t (Unattested "the key is unreadable") in (match acts with | [ Push.Journal (Event.Push_refused _) ] -> () | _ -> Alcotest.fail "the refusal is recorded"); let t, _ = step t Journalled in match Push.ending t with | Some (Error o) -> Alcotest.(check string) "detail" "the landings could not be attested: the key is unreadable: nothing \ moved" o.detail | _ -> Alcotest.fail "not refused"
let check_event_terminal_text prefix name visible event = let t, _ = Push.v ctx { remote = None; branches = [] } in match Push.incoming t ~now event with | Error (Machine.Unexpected { event = output; _ } as error) -> Mq_fixture.terminal_safe name output; Mq_fixture.terminal_safe name (Fmt.str "%a" Machine.pp_error error); Alcotest.(check string) name (prefix ^ visible) output | _ -> Alcotest.fail "the out-of-order push event was not diagnosed"
let test_refused_terminal_text () = List.iter (fun (name, raw, visible) -> check_event_terminal_text "refused: " name visible (Push.Push_refused raw)) Mq_fixture.outside_text
let test_unknown_terminal_text () = List.iter (fun (name, raw, visible) -> check_event_terminal_text "unknown: " name visible (Push.Push_unknown raw)) Mq_fixture.outside_text
(* doc/machines.md, "Dependencies across machines"; doc/invariants.md, 11: a consumer's push publishes first each dependency's paired branches whose agreed copy lacks a commit a lock names, each dependency's own dependencies before it, then the consumer's, whatever those ended in. A repository the walk pushed or is pushing is not pushed again, so one that links back ends the walk. Each dependency is read once per repository, its branches in the order the locks name them. *)let test_dependencies_first () = let p = Fpath.v in Alcotest.(check (list (pair string (list string)))) "one per repository" [ ("/a", [ "staging"; "main" ]); ("/b", [ "main" ]) ] (List.map (fun (l : Push.lacking) -> (Fpath.to_string l.top, List.map Branch.to_string l.branches)) (Push.lacking [ (p "vendor/a", p "/a", b "staging"); (p "vendor/a", p "/a", b "main"); (p "vendor/a", p "/a", b "staging"); (p "vendor/b", p "/b", b "main"); ])); let at = function None -> "here" | Some t -> Fpath.to_string t in let step = function | Push.Read_lacking { at = a; _ } -> "read " ^ at a | Push_from { at = a; dependencies; _ } -> Fmt.str "push %s after [%s]" (at a) (String.concat "; " (List.map (fun (d : Push.dependency) -> Fpath.to_string d.path) dependencies)) | Walked (Ok r) -> "walked " ^ r.subject | Walked (Error o) -> "walked " ^ Outcome.first_line o in let ok = Ok (Report.v Report.Published "done") in let trace = ref [] in let log (w, s) = trace := step s :: !trace; (w, s) in let w, _ = log (Push.walk ~remote:None [ b "staging" ]) in let w, _ = log (Push.answered w (Ok ( p "/c", [ (p "vendor/a", p "/a", b "staging"); (p "vendor/b", p "/b", b "staging"); ] ))) in let w, _ = log (Push.answered w (Ok ( p "/a", [ (p "vendor/b", p "/b", b "main"); (p "vendor/c", p "/c", b "staging"); ] ))) in let w, _ = log (Push.answered w (Ok (p "/b", []))) in let w, _ = log (Push.pushed w ok) in let w, _ = log (Push.pushed w ok) in let _, _ = log (Push.pushed w ok) in Alcotest.(check (list string)) "the order" [ "read here"; "read /a"; "read /b"; "push /b after []"; "push /a after [vendor/b]"; "push here after [vendor/a]"; "walked done"; ] (List.rev !trace); let w, _ = Push.walk ~remote:None [ b "staging" ] in Alcotest.(check string) "a lock that cannot be read" "push here after []" (step (snd (Push.answered w (Error (Outcome.v Outcome.Refused "unreadable")))))
let suite = ( "push", [ Alcotest.test_case "dependencies first" `Quick test_dependencies_first; Alcotest.test_case "refused diagnostics are terminal safe" `Quick test_refused_terminal_text; Alcotest.test_case "unknown diagnostics are terminal safe" `Quick test_unknown_terminal_text; Alcotest.test_case "every branch, sources first" `Quick test_every_branch; Alcotest.test_case "the part of a source a branch holds" `Quick test_part_of_source; Alcotest.test_case "a work branch is refused" `Quick test_work_branch; Alcotest.test_case "a branch with no remote is refused" `Quick test_no_remote; Alcotest.test_case "where each branch is pushed" `Quick test_destination; Alcotest.test_case "a fast-forward from the remote's value" `Quick test_fast_forward; Alcotest.test_case "a hand's move waits for its landing" `Quick test_as_far_as_landings; Alcotest.test_case "a remote that moved names mq pull" `Quick test_remote_moved; Alcotest.test_case "the entry published over commits it holds" `Quick test_published_over; Alcotest.test_case "a deleted branch is not created again" `Quick test_deleted; Alcotest.test_case "a branch already there" `Quick test_current; Alcotest.test_case "a lock no dependency's remote holds" `Quick test_unpublished_lock; Alcotest.test_case "a branch with no remote names the push" `Quick test_no_remote_next; Alcotest.test_case "a push to REMOTE sets the upstream" `Quick test_track; Alcotest.test_case "a fork follows with a lease" `Quick test_fork; Alcotest.test_case "the trace" `Quick test_trace; Alcotest.test_case "the dependencies' pushes, told" `Quick test_dependency_notes; Alcotest.test_case "the branches whose locks are read" `Quick test_publishes; Alcotest.test_case "two destinations, partial refusal" `Quick test_two_destinations_partial_refusal; Alcotest.test_case "two destinations, one landing" `Quick test_two_destinations_one_landing; Alcotest.test_case "the trace of a push that sets an upstream" `Quick test_trace_track; Alcotest.test_case "an edge's target goes where the entry goes" `Quick test_edge_follows_entry; Alcotest.test_case "two destinations, one upstream" `Quick test_two_destinations_track; Alcotest.test_case "a lease lost to an outside writer" `Quick test_stale; Alcotest.test_case "an unreachable remote" `Quick test_unreachable; Alcotest.test_case "the trace of an attesting push" `Quick test_attest_trace; Alcotest.test_case "no key, no evidence" `Quick test_attest_off; Alcotest.test_case "the evidence ref's update" `Quick test_evidence_update; Alcotest.test_case "a fork's copy takes no evidence" `Quick test_attest_fork; Alcotest.test_case "a key that cannot sign" `Quick test_unattested; ] )
let journal_fact ~remote ~branches ~reason t actions = Alcotest.(check bool) "refusal awaits its durable acknowledgement" true (Option.is_none (Push.ending t)); (match actions with | [ Push.Journal (Event.Push_refused fact) ] -> Alcotest.(check (option string)) "resolved remote" remote fact.remote; Alcotest.(check (list string)) "requested branches" branches (List.map Branch.to_string fact.branches); Alcotest.(check string) "outcome reason" reason fact.reason | _ -> Alcotest.fail "exactly one typed refusal journal action required"); let t, actions = step t Journalled in Alcotest.(check int) "nothing emitted after acknowledgement" 0 (List.length actions); (match Push.ending t with | Some (Error o) -> Alcotest.(check int) "refused exit" 2 (Outcome.exit o) | _ -> Alcotest.fail "no refused outcome"); let _, actions = step t Journalled in Alcotest.(check int) "duplicate acknowledgement emits no second fact" 0 (List.length actions)
let test_local_refusal_fact () = let t, _ = started { remote = Some "origin"; branches = [ b "fix" ] } in let t, actions = step t (Local_read locals) in journal_fact ~remote:(Some "origin") ~branches:[ "fix" ] ~reason:"fix is not a branch of the DAG: a work branch is pushed with Git" t actions
let test_default_remote_refusal_fact () = let t, _ = started { remote = None; branches = [ b "fix" ] } in let t, actions = step t (Local_read locals) in journal_fact ~remote:(Some "origin") ~branches:[ "fix" ] ~reason:"fix is not a branch of the DAG: a work branch is pushed with Git" t actions
let pushing () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let t, actions = step t (Remote_read [ facts () ]) in (match actions with | [ Push.Push _ ] -> () | _ -> Alcotest.fail "not pushing"); t
let test_remote_refusal_fact () = let t, actions = step (pushing ()) (Push_refused "policy") in journal_fact ~remote:(Some "origin") ~branches:[ "staging" ] ~reason:"origin refused the push (policy): nothing moved" t actions
let no_journal actions = Alcotest.(check int) "no typed refused-push fact" 0 (List.length (List.filter (function Push.Journal _ -> true | _ -> false) actions))
let test_unavailable_has_no_refusal () = let t, actions = step (pushing ()) (Unserved { remote = "origin"; error = `Unreachable "offline" }) in no_journal actions; match Push.ending t with | Some (Error o) -> Alcotest.(check int) "unavailable" 5 (Outcome.exit o) | _ -> Alcotest.fail "not unavailable"
(* A push whose answer did not arrive after it went out: the remote may hold it, so the outcome is unavailable, says so, and is no refused push. *)let test_unknown_is_not_a_refusal () = let t, actions = step (pushing ()) (Push_unknown "cut") in no_journal actions; match Push.ending t with | Some (Error o) -> Alcotest.(check int) "unavailable" 5 (Outcome.exit o); Alcotest.(check string) "says the remote may hold it" "origin may have taken the push, and its answer did not arrive (cut)" o.detail | _ -> Alcotest.fail "not unavailable"
let test_interrupted_has_no_refusal () = let t, actions = step (pushing ()) (Signalled Signal.Terminate) in no_journal actions; match Push.ending t with | Some (Error o) -> Alcotest.(check string) "interrupted" "interrupted" (Outcome.string_of_word o.word) | _ -> Alcotest.fail "not interrupted"
let test_success_has_no_refusal () = let t, actions = step (pushing ()) (Pushed { landings = 1 }) in no_journal actions; let t, actions = step t Recorded in no_journal actions; match Push.ending t with | Some (Ok _) -> () | _ -> Alcotest.fail "not successful"
let test_failed_refusal_write () = let t, _ = started { remote = Some "origin"; branches = [ b "fix" ] } in let t, actions = step t (Local_read locals) in let action = match actions with [ a ] -> a | _ -> Alcotest.fail "no journal action" in let t, actions = step t (Unanswered (action, Machine.Failed "disk full")) in no_journal actions; match Push.ending t with | Some (Error o) -> Alcotest.(check int) "a failed write is unavailable" 5 (Outcome.exit o); Alcotest.(check string) "the actual write failure" "the push refusal could not be recorded: disk full" o.detail | _ -> Alcotest.fail "not unavailable"
(* git push to a remote with several push URLs pushes to each in turn and goes on past one that refuses, then fails naming it (builtin/push.c, do_push: push_with_options for each URL, its errors counted, the push failed once every URL was tried). *)let two_urls () = let one = { (facts ()) with url = "/r/one.git"; seen_key = "origin/push/one" } in (one, { one with url = "/r/two.git"; seen_key = "origin/push/two" })
let pushing_two ?(one = Fun.id) () = let t, _ = started { remote = Some "origin"; branches = [ b "staging" ] } in let t, _ = step t (Local_read locals) in let first, second = two_urls () in step t (Remote_read [ one first; second ])
let next_url url = function | [ Push.Push p ] -> Alcotest.(check string) "the next push URL" url p.url | _ -> Alcotest.failf "%s is not pushed to" url
(* The first URL refuses the push: the second takes it, what it took is recorded, and the push is refused naming the first. *)let test_first_url_refuses () = let t, _ = pushing_two () in let t, actions = step t (Push_refused "denied") in next_url "/r/two.git" actions; let t, actions = step t (Pushed { landings = 1 }) in (match actions with | [ Push.Record { remote; _ } ] -> Alcotest.(check string) "what /r/two.git took" "/r/two.git" remote.url | _ -> Alcotest.fail "what /r/two.git took is not recorded"); let t, actions = step t Recorded in journal_fact ~remote:(Some "origin") ~branches:[ "staging" ] ~reason: "origin took the push at /r/two.git, and /r/one.git did not take it \ (origin refused the push (denied): nothing moved)" t actions
(* The first URL holds a commit staging lacks, so its read refuses the push: the second still takes it, and no checkpoint is sent, since the work is published there. *)let test_first_url_holds_more () = let t, actions = pushing_two ~one:(fun f -> { f with values = [ (b "staging", c '9') ] }) () in next_url "/r/two.git" actions; let t, _ = step t (Pushed { landings = 1 }) in let t, actions = step t Recorded in journal_fact ~remote:(Some "origin") ~branches:[ "staging" ] ~reason: "origin took the push at /r/two.git, and /r/one.git did not take it \ (origin/staging holds commits staging lacks: nothing moved)" t actions
(* The first URL's answer is lost: the second still takes the push, and the push ends unavailable, not refused, since the first may hold it. *)let test_first_url_answer_lost () = let t, _ = pushing_two () in let t, actions = step t (Push_unknown "reset") in next_url "/r/two.git" actions; let t, _ = step t (Pushed { landings = 1 }) in let t, actions = step t Recorded in no_journal actions; match Push.ending t with | Some (Error o) -> Alcotest.(check int) "unavailable" 5 (Outcome.exit o); Alcotest.(check string) "what each URL did" "origin took the push at /r/two.git, and /r/one.git did not take it \ (origin may have taken the push, and its answer did not arrive \ (reset))" o.detail | _ -> Alcotest.fail "not unavailable"
(* Both URLs refuse: each is tried and named. *)let test_every_url_refuses () = let t, _ = pushing_two () in let t, actions = step t (Push_refused "denied") in next_url "/r/two.git" actions; let t, actions = step t (Stale { branch = b "staging"; held = Some (c '9') }) in journal_fact ~remote:(Some "origin") ~branches:[ "staging" ] ~reason: "/r/one.git did not take the push (origin refused the push (denied): \ nothing moved), and /r/two.git did not take it (origin/staging moved \ during the push: nothing moved)" t actions
let refusal_suite = ( "push_refusal", [ Alcotest.test_case "local policy refusal is durable once" `Quick test_local_refusal_fact; Alcotest.test_case "a default remote is captured on local refusal" `Quick test_default_remote_refusal_fact; Alcotest.test_case "remote refusal is durable once" `Quick test_remote_refusal_fact; Alcotest.test_case "unavailable is not a refused push" `Quick test_unavailable_has_no_refusal; Alcotest.test_case "an unknown push is not a refused push" `Quick test_unknown_is_not_a_refusal; Alcotest.test_case "interrupted is not a refused push" `Quick test_interrupted_has_no_refusal; Alcotest.test_case "success is not a refused push" `Quick test_success_has_no_refusal; Alcotest.test_case "a failed journal write ends unavailable" `Quick test_failed_refusal_write; Alcotest.test_case "the first push URL refuses the push" `Quick test_first_url_refuses; Alcotest.test_case "the first push URL holds what is not here" `Quick test_first_url_holds_more; Alcotest.test_case "the first push URL's answer is lost" `Quick test_first_url_answer_lost; Alcotest.test_case "every push URL refuses the push" `Quick test_every_url_refuses; ] )