Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
7.6 kB · 229 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230module M = Merge_queue
let src = Logs.Src.create "merge-queue.queue-read" ~doc:"A run's queue reads"
module Log = (val Logs.src_log src : Logs.LOG)
let ( let* ) = Result.bindlet tail_segments = 2
let collect f xs = List.fold_right (fun x acc -> let* acc = acc in let* y = f x in Ok (match y with Some y -> y :: acc | None -> acc)) xs (Ok [])
let unreadable r e = Fmt.error "%a holds a record this mq cannot read: %a" M.Ref_name.pp r M.Record.pp_error e
let pin_of repo (r, id) = match r with | M.Ref_name.Queue _ -> ( let* tag = Repo.record_at repo r id in match M.Entry.of_tag tag with | Ok entry -> Ok (Some { M.Status.entry; queued = tag.date }) | Error e -> unreadable r e) | _ -> Ok None
let intent_of repo (r, id) = match r with | M.Ref_name.Intent name -> ( let* tag = Repo.record_at repo r id in match M.Intent.of_tag ~name tag with | Ok intent -> Ok (Some intent) | Error e -> unreadable r e) | _ -> Ok None
(* Who holds the run lock, read from the lock: a held lock is the run its file names first, and a free one leaves the names of runs that were killed, since a run that ends empties the file. *)let holder (p : Perform.t) names = match names with | [] -> M.Status.Free | first :: _ when Run_lock.taken ~fs:p.fs (Repo.mq_dir p.repo) -> Running first | all -> Killed all
let journal_tail (p : Perform.t) = Journal.tail p.journal ~segments:tail_segments
(* One reading's point reads of Git, each taken once: a branch's tip and its log, keyed by the branch's name, and the commits one tip has that another lacks, keyed by the pair. *)type reading = { p : Perform.t; tips : (string, M.Commit.t option) Hashtbl.t; logs : (string, Repo.entry list) Hashtbl.t; counts : (string * string, int) Hashtbl.t;}
let reading ?(tips = []) p = let t = Hashtbl.create 16 in List.iter (fun (b, c) -> Hashtbl.replace t (M.Branch.to_string b) c) tips; { p; tips = t; logs = Hashtbl.create 16; counts = Hashtbl.create 16 }
let once table key read = match Hashtbl.find_opt table key with | Some v -> v | None -> let v = read () in Hashtbl.replace table key v; v
let tip r b = once r.tips (M.Branch.to_string b) (fun () -> Repo.read_ref r.p.repo (M.Ref_name.branch b))
let reflog r b = once r.logs (M.Branch.to_string b) (fun () -> Repo.reflog r.p.repo (M.Ref_name.branch b))
(* The commits [head] has that [base] lacks. *)let beyond r base ~head = once r.counts (M.Commit.to_hex base, M.Commit.to_hex head) (fun () -> Repo.beyond r.p.repo [ base ] ~head)
let standing r ~target ~source = { M.Status.behind = beyond r target ~head:source; ahead = beyond r source ~head:target; }
(* When [b] last moved, from its reflog. *)let last_move r b = match reflog r b with | (e : Repo.entry) :: _ -> Ptime.of_float_s (Int64.to_float e.date) | [] -> None
let newer a b = match (a, b) with | Some x, Some y -> Some (if Ptime.compare x y >= 0 then x else y) | (Some _ as x), None | None, x -> x
(* When the edge was last served: its newest land the journal's tail records, else the target's last move (schedule.mli). *)let served r ~source ~target events = match M.Schedule.served ~source ~target events with | Some _ as at -> at | None -> last_move r target
(* How [b] last moved, as its log's newest line says. *)let mover r b = match reflog r b with | (e : Repo.entry) :: _ when e.message <> "" -> Some e.message | _ -> None
(* Whether [source] holds the originals of commits [target] holds as replays, read from its landing records or, once they expired, from the copies themselves, when the two have diverged (schedule.mli). *)let replayed (p : Perform.t) ~source ~target ~tip ~target_tip = let copy () = match Repo.copy p.repo ~source:tip ~target:target_tip with | Ok c -> c | Error (`Msg m) -> Log.warn (fun l -> l "the copies of %a's commits on %a cannot be read: %s" M.Branch.pp source M.Branch.pp target m); None in M.Schedule.replayed ~holds:(Repo.is_ancestor p.repo) ~copy ~target ~tip ~target_tip (List.filter_map Result.to_option (Perform.landings p source) |> List.map (fun (l : M.Land.landed) -> l.landing))
let edges ?reading:r (p : Perform.t) rules events = let r = match r with Some r -> r | None -> reading p in List.map (fun (source, target, every) -> let source_tip = tip r source and target_tip = tip r target in let behind, ahead = match (target_tip, source_tip) with | Some target, Some source -> let s = standing r ~target ~source in (s.behind, s.ahead) | _ -> (0, 0) in { M.Schedule.source; target; every; behind; ahead; served = served r ~source ~target events; tip = source_tip; target_tip; mover = mover r target; reported = (match (source_tip, target_tip) with | Some tip, Some target_tip -> M.Schedule.reported ~source ~target ~tip ~target_tip events | _ -> false); red = M.Schedule.red ~source ~target events; moved = newer (last_move r target) (last_move r p.local.rules); replayed = (match (source_tip, target_tip) with | Some tip, Some target_tip when behind > 0 && ahead > 0 -> replayed p ~source ~target ~tip ~target_tip | _ -> None); }) (M.Schedule.edges rules)
(* The worktrees mq handed out to [names], each the path its hand-out record names: one listing of the hand-out refs, then each record of a branch of [names]. *)let handed_out (p : Perform.t) names = let wanted b = List.exists (M.Branch.equal b) names in List.filter_map (fun (r : M.Ref_name.t) -> match r with | Worktree (b, serial) when wanted b -> ( match Repo.read_record p.repo r with | Ok (Some tag) -> ( match M.Handout.of_tag ~serial tag with | Ok h -> Some (b, h.path) | Error _ -> None) | Ok None | Error _ -> None) | _ -> None) (Repo.ref_names p.repo M.Ref_name.Prefix.worktree_all)
let worktrees (p : Perform.t) = function | [] -> Ok [] | names -> let ( let* ) = Result.bind in let main = Repo.top p.repo in let* main_on = Repo.working_on p.repo main in let candidates = handed_out p names in let rec find b = function | [] -> Ok None | (b', path) :: rest when M.Branch.equal b b' -> let* on = Repo.working_on p.repo path in if Option.equal M.Branch.equal on (Some b) then Ok (Some path) else find b rest | _ :: rest -> find b rest in List.fold_right (fun b acc -> let* acc = acc in if Option.equal M.Branch.equal main_on (Some b) then Ok ((b, main) :: acc) else let* path = find b candidates in Ok (match path with Some path -> (b, path) :: acc | None -> acc)) names (Ok [])
let queue (p : Perform.t) = let* refs = Repo.snapshot p.repo M.Ref_name.Prefix.[ queue; intent ] in let* pins = collect (pin_of p.repo) refs in let* intents = collect (intent_of p.repo) refs in let tail = journal_tail p in Ok { M.Status.pins; intents; holder = holder p (Run_lock.names ~fs:p.fs (Repo.mq_dir p.repo)); events = List.map (fun (r : Journal.record) -> r.event) tail.records; }