Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
13 kB · 378 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379type lock = Ref of Ref_name.t | Packed_refs
let pp_lock ppf = function | Ref r -> Ref_name.pp ppf r | Packed_refs -> Fmt.string ppf "packed-refs"
type held = { lock : lock; path : Fpath.t; holds : Git.Hash.t option }type facts = { target : Commit.t option; contains : bool }type decision = Finish | Restart
(* doc/design.md, "Recovery": the target at the intent's new commit, or at a commit that contains it, is the landing having happened. That commit is the one move's, whichever land of it asks, so every land the move names finishes, or none does. *)let decide (intent : Intent.t) facts = if facts.contains || Option.equal Commit.equal facts.target (Some intent.move.next) then Finish else Restart
type request = { id : Record.id; intent : Intent.t; role : Tidy.role; decision : decision; resumed : bool;}
type deletion = { queued : Commit.t; landed : Commit.t }
type commit = { name : Branch.t; branch : deletion option; worktree : Fpath.t option; pin : Record.id option; intent : Record.id option;}
type event = | Released | Released_leaving of { paths : Fpath.t list } | Unswitched | Kept | Keep_taken of Landing.t option | Tidy of Tidy.event | Committed | Branch_kept of Tidy.event | Held of { lock : lock; path : Fpath.t } | Unanswered of action * Machine.unanswered
and action = | Release of Intent.t | Unswitch of Intent.t | Keep of { name : Branch.t; serial : int; landing : Landing.t } | Tidy of Tidy.action | Commit of commit
type report = { landing : Landing.t; serial : int; tidy : Tidy.report option; clauses : string list; standing : bool;}
type ending = | Finished of report | Restarted of { clauses : string list; standing : bool }
type step = | Releasing | Unswitching | Keeping | Tidying of Tidy.t | Committing of commit | Done of ending
type t = { request : request; step : step; serial : int; tidy : Tidy.report option; clauses : string list; (** Newest first. *) kept : bool; (** Whether the landing record is at its serial. *) keep_intent : bool; (** Whether the intent stays for the next run: a step it covers did not happen. *)}
let machine = "settle"let name t = t.request.intent.name
(* A landing record kept at a serial another record holds goes to the next one; past this many, it is said in the outcome instead. *)let serial_tries = 64
let landing t = let i = t.request.intent in Landing.v ~submission:i.submission ~tree:i.tree ~checks:i.checks ~name:i.name ~queued:i.queued ~target:i.move.target ~was:i.onto ~landed:i.landed ~commits:i.commits
let clause t c = { t with clauses = c :: t.clauses }
let pp_step ppf = function | Releasing -> Fmt.string ppf "releasing the move's locks" | Unswitching -> Fmt.string ppf "switching the checkouts back" | Keeping -> Fmt.string ppf "keeping the pre-replay tip" | Tidying _ -> Fmt.string ppf "tidying" | Committing _ -> Fmt.string ppf "settling the refs" | Done _ -> Fmt.string ppf "done"
let stage t = match t.step with | Tidying tidy -> Tidy.stage tidy | step -> Fmt.str "settle: %a" pp_step step
let pp ppf t = Fmt.pf ppf "settlement of %a: %a" Branch.pp (name t) pp_step t.step
let pp_action ppf = function | Release _ -> Fmt.string ppf "release the move's locks" | Unswitch _ -> Fmt.string ppf "switch the checkouts back" | Keep { serial; _ } -> Fmt.pf ppf "keep the pre-replay tip as %d" serial | Tidy a -> Tidy.pp_action ppf a | Commit c -> let some o s = Option.map (fun _ -> s) o in let what = List.filter_map Fun.id [ some c.branch (Fmt.str "delete %a" Branch.pp c.name); some c.pin "unpin"; some c.intent "clear the intent"; ] in Fmt.string ppf (match what with | [] -> "forget the hand-out" | _ -> String.concat ", " what)
let pp_event ppf = function | Released -> Fmt.string ppf "released" | Unswitched -> Fmt.string ppf "checkouts switched back" | Released_leaving { paths } -> Fmt.pf ppf "released, leaving %a" Fmt.(list ~sep:comma Fpath.pp) paths | Kept -> Fmt.string ppf "kept" | Keep_taken _ -> Fmt.string ppf "serial taken" | Tidy e -> Tidy.pp_event ppf e | Committed -> Fmt.string ppf "committed" | Branch_kept e -> Fmt.pf ppf "branch kept: %a" Tidy.pp_event e | Held { path; _ } -> Fmt.pf ppf "%a is held" Fpath.pp path | Unanswered (a, why) -> Fmt.pf ppf "%a: %a" pp_action a Machine.pp_unanswered why
let unexpected t e = Machine.unexpected machine ~state:(Fmt.str "%a" pp t) ~event:(Fmt.str "%a" pp_event e)
let finish t = let t = if t.keep_intent then clause t "the intent stays for the next run" else t in let ending = match t.request.decision with | Finish -> Finished { landing = landing t; serial = t.serial; tidy = t.tidy; clauses = List.rev t.clauses; standing = t.keep_intent; } | Restart -> Restarted { clauses = List.rev t.clauses; standing = t.keep_intent } in ({ t with step = Done ending }, [])
(* The settlement's refs, in one transaction: the branch's deletion when [branch]; once the tidy ran, the hand-out records of the worktree the intent records and the pin; and the intent, cleared once every step it covers happened, else left for the next run, which settles it again. *)let commit t ~branch ~tidied = let i = t.request.intent in { name = i.name; branch = (if branch then Some { queued = i.queued; landed = i.move.next } else None); worktree = (if tidied then i.worktree else None); pin = (if tidied then Some i.entry else None); intent = (if t.keep_intent then None else Some t.request.id); }
let commit_rest t ~tidied = let c = commit t ~branch:false ~tidied in match c with | { branch = None; worktree = None; pin = None; intent = None; _ } -> finish t | c -> ({ t with step = Committing c }, [ Commit c ])
(* The tidy goes on; the deletion of the branch it waits on is made with the rest of the settlement's refs. *)let tidying t tidy actions = let t = { t with step = Tidying tidy } in let actions = List.map (fun a : action -> Tidy a) actions in if Tidy.deleting tidy then (t, actions @ [ Commit (commit t ~branch:true ~tidied:true) ]) else (t, actions)
let keep t = ( { t with step = Keeping }, [ Keep { name = name t; serial = t.serial; landing = landing t } ] )
(* A replayed branch whose pre-replay commits no landing record keeps is left at them: deleting or moving it would make them unreachable. *)let tidy t = let i = t.request.intent in if (not t.kept) && not (Commit.equal i.queued i.landed) then (* Its pin stays too: the next land of the name answers from the target, which holds its changes. *) commit_rest ~tidied:false (clause t (Fmt.str "%a stays queued at its commits, which no landing record keeps" Branch.pp i.name)) else let tidy, actions = Tidy.v { name = i.name; queued = i.queued; landed = i.landed; target = i.move.target; role = t.request.role; keep_branch = i.keep_branch; resumed = t.request.resumed; pool = i.worktree; } in tidying t tidy actions
let main t = match t.request.decision with | Finish -> keep t | Restart when t.request.intent.checkouts <> [] -> ({ t with step = Unswitching }, [ Unswitch t.request.intent ]) | Restart -> commit_rest t ~tidied:false
let v request = let t = { request; step = Releasing; serial = request.intent.serial; tidy = None; clauses = []; kept = false; keep_intent = false; } in if request.resumed then (t, [ Release request.intent ]) else main t
let held_clause t path what = clause t (Fmt.str "%a is held, so %s" Fpath.pp path what)
let failed_clause t a why = clause t (Fmt.str "%a could not be done: %a" pp_action a Machine.pp_unanswered why)
(* A lock of the commit's transaction is held: nothing of it was made. *)let held_commit t (c : commit) path = let t = if Option.is_some c.intent then { t with keep_intent = true } else t in match c.pin with | Some _ -> held_clause t path (Branch.to_string (name t) ^ " stays queued") | None -> clause t (Fmt.str "%a is held" Fpath.pp path)
let on_tidy t ~now tidy te = match Tidy.incoming tidy ~now te with | Error _ as e -> e | Ok (tidy, actions) -> ( match Tidy.ending tidy with | None -> Ok (tidying t tidy actions) | Some report -> let t = { t with tidy = Some report } in let t = match report.kept with Some k -> clause t k | None -> t in (* The branch is deleted only with every other ref of the settlement, in its one transaction. *) if report.deleted then Ok (finish t) else let t, more = commit_rest t ~tidied:true in Ok (t, List.map (fun a : action -> Tidy a) actions @ more))
let incoming t ~now e = let nm = Branch.to_string (name t) in match (t.step, e) with | Releasing, Released -> Ok (main t) | Releasing, Released_leaving { paths } -> Ok (main (List.fold_left (fun t path -> clause t (Fmt.str "%a holds what the move did not write there, so it stays" Fpath.pp path)) t paths)) | Releasing, Unanswered ((Release _ as a), why) -> Ok (main { (failed_clause t a why) with keep_intent = true }) | Unswitching, Unswitched -> Ok (commit_rest t ~tidied:false) | Unswitching, Unanswered ((Unswitch _ as a), why) -> Ok (commit_rest ~tidied:false { (failed_clause t a why) with keep_intent = true }) | Keeping, Kept -> Ok (tidy { t with kept = true }) | Keeping, Keep_taken (Some l) when Landing.equal l (landing t) -> Ok (tidy { t with kept = true }) | Keeping, Keep_taken _ when t.serial < t.request.intent.serial + serial_tries -> Ok (keep { t with serial = t.serial + 1 }) | Keeping, Keep_taken _ -> Ok (tidy (clause t (Fmt.str "no serial under refs/mq/landed/ was free for %s" nm))) | Keeping, Held { path; _ } -> Ok (tidy { (held_clause t path "the commits before the replay are not kept") with keep_intent = true; }) | Keeping, Unanswered ((Keep _ as a), why) -> Ok (tidy { (failed_clause t a why) with keep_intent = true }) | Tidying tidy, Tidy te -> on_tidy t ~now tidy te | Tidying tidy, Unanswered (Tidy a, why) -> on_tidy t ~now tidy (Tidy.unanswered a why) | Tidying tidy, Committed when Tidy.deleting tidy -> on_tidy t ~now tidy Tidy.Branch_deleted | Tidying tidy, Branch_kept te when Tidy.deleting tidy -> on_tidy t ~now tidy te | Tidying tidy, Unanswered ((Commit _ as a), why) when Tidy.deleting tidy -> Ok (finish { (failed_clause t a why) with keep_intent = true }) | Committing _, Committed -> Ok (finish t) | Committing c, Held { path; _ } -> Ok (finish (held_commit t c path)) | Committing _, Unanswered ((Commit _ as a), why) -> Ok (finish { (failed_clause t a why) with keep_intent = true }) | Done _, _ -> Ok (t, []) | ( (Releasing | Unswitching | Keeping | Tidying _ | Committing _), ( Released | Released_leaving _ | Unswitched | Kept | Keep_taken _ | Tidy _ | Committed | Branch_kept _ | Held _ | Unanswered _ ) ) -> unexpected t e
let timer t ~now:_ = Ok (t, [])let next_timeout _ = Nonelet ending t = match t.step with Done e -> Some e | _ -> None
let task : action -> Machine.Task.t = function | Tidy a -> Machine.Task.under "tidy" (Tidy.task a) | Release _ | Unswitch _ | Keep _ | Commit _ -> Machine.Task.Now
let unanswered a why = Unanswered (a, why)let plural n one = if n = 1 then Fmt.str "1 %s" one else Fmt.str "%d %ss" n one
let recovered_outcome ~killed r = let l = r.landing in let detail = String.concat "; " (Fmt.str "%s, finished after a run that %s" (plural l.commits "commit") (if killed then "was killed" else "stopped before its end") :: r.clauses) in Outcome.v ~branch:l.name ~target:(Outcome.Into l.target) ~landed:true ~published:false ?worktree:(Option.bind r.tidy (fun (t : Tidy.report) -> t.worktree)) Outcome.Landed detail