Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
3.2 kB · 92 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293module M = Merge_queueopen Command
(* The fetch before the lock, the reconciliation under it. *)module Run = M.Run.Make (M.Pull)module Run_loop = Loop.Make (Run) (Perform_run.Make (M.Pull) (Perform_pull))
let reconcile (q : queue) context request ~wait_wall = Eio.Switch.run @@ fun sw -> let now = Clock.now q.perform.clock in let run = run_name q.perform.caller ~now in let p = { q.perform with sw; run = Some run } in let machine, actions = Run.v ~run ~mode:M.Note.Self ~wait_wall ~now (M.Pull.v context request) in let machine = Run_loop.run ~clock:p.clock p machine actions in match Run.ending machine with | Some e -> e | None -> raise (Defect "mq pull ended with no outcome")
let args name = { Command_land.name = Some name; onto = None; dry_run = false; retry = false; keep_branch = false; no_wait = false; wait_for = None; resolve = Some false; expedite = None; }
let became (q : queue) name = List.find_map (function | Ok (l : M.Land.landed) -> Some l.landing.landed | Error _ -> None) (Perform.landings q.perform name)
(* A landing that did not land again: its commits under its own name, as they were on this machine, unless a branch has taken it since. *)let restore (q : queue) (r : M.Pull.replay) = match Repo.set_ref q.perform.repo (M.Ref_name.branch r.name) ~expected:None (Some r.was) ~reflog:"mq pull: returned" ~now:(Clock.now q.perform.clock) with | Ok () -> Some r.name | Error _ -> None
let replay q ~in_check loaded (r : M.Pull.replay) = match Command_land.land_branch q ~in_check (args r.name) r.name loaded with | M.Land.Ended o -> Perform.announce (M.Outcome.first_line o); if o.word = M.Outcome.Landed then Ok (r, o, became q r.name, None) else Ok (r, o, None, restore q r) | M.Land.Left_queued s -> Error s | M.Land.Yielded _ -> raise (Defect "a replayed landing yielded to a run's end") | M.Land.Offered _ -> raise (Defect "a replayed landing was offered to the resolver")
let replays q ~in_check loaded ?named ~remote ~pulled rs = let rec go acc = function | [] -> Error (M.Pull.summary ?named ~remote ~pulled (List.rev acc)) | r :: rest -> ( match replay q ~in_check loaded r with | Ok x -> go (x :: acc) rest | Error _ -> Error (M.Pull.interrupted (r :: rest))) in match go [] rs with | Error o when o.word = M.Outcome.Landed -> Error o | r -> r
let run ctx ~remote ~no_wait = with_queue ~writes:true ctx (fun q -> initialised q @@ fun ((rules, _) as loaded) -> let context = { M.Pull.rules; rules_branch = q.perform.local.rules; scheduler = false; } in let wait_wall = M.Duration.of_seconds rules.M.Rules.bounds.wait_wall in match reconcile q context { remote; no_wait } ~wait_wall with | M.Pull.Stopped o -> Error o | Reconciled { report; replays = []; _ } -> Ok report | Reconciled { report; replays = rs; remotes; pulled } -> replays q ~in_check:(Command_land.in_check ctx) loaded ?named:report.detail ~remote:remotes ~pulled rs)