Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
17 kB · 492 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493type hooks = { dir : Check.place; own : Fpath.t; existing : string option; calls_mq : bool;}
type past = Never | Ran of Commit.t option
(* A landing into the rules branch reads the rules it moved the branch to: its notes name the rules it replaced, which a repair was judged under. *)let last_rules ~rules_branch events = let newest best ((at, _) as read) = match best with | Some (b, _) when Ptime.compare b at >= 0 -> best | _ -> Some read in List.fold_left (fun best (e : Event.t) -> match e.kind with | Landed (_, l) when Branch.equal l.target rules_branch -> newest best (e.time, l.landed) | Landed (_, l) -> List.fold_left (fun best (n : Note.t) -> newest best (n.at, n.rules)) best l.checks | _ -> best) None events |> Option.map snd
let gone ?branch ~rules_branch = function | Some c -> Outcome.v ?branch ~next:(Fmt.str "git branch %a %a" Branch.pp rules_branch Commit.pp c) Outcome.Refused (Fmt.str "%a is gone; the rules last read here were at %a" Branch.pp rules_branch Commit.pp c) | None -> Outcome.v ?branch ~next:"mq init" Outcome.Refused (Fmt.str "%a is gone, though mq has run here, and no note names the rules \ last read here" Branch.pp rules_branch)
type facts = { head : Branch.t option; born : bool; head_remote : string option; rules_branch : Branch.t; local : (Commit.t * string) option; remotes : (string * (Commit.t * string) option) list; hook : bool; files : string list; makefile_check : bool; root : Fpath.t; hooks : hooks; mq : Fpath.t; past : past option;}
(* Dune's root rule: a dune-workspace, then a dune-project, marks a project's root. *)let dune_roots = [ "dune-workspace"; "dune-project" ]
let detect f = let has n = List.mem n f.files in let command c = Some (Check.v (Check.name "build") (Check.Command c)) in if f.hook then Some (Check.v (Check.name "pre-commit") (Check.Hook Check.Commit)) else if List.exists has dune_roots then command "dune build @check" else if has "Cargo.toml" then command "cargo check" else if has "go.mod" then command "go vet ./..." else if has "Makefile" && f.makefile_check then command "make check" else None
let pull_remote f = match f.head_remote with | Some "." -> None | Some r -> Some r | None -> Some "origin"
let hook_line ~mq = let mq = Shell.word (Fpath.to_string mq) in Fmt.str "test -x %s && %s hook reference-transaction \"$@\" >/dev/null 2>&1 || :" mq mq
let marker = "# mq init wrote this hook."
(* Git runs the hook at every phase of every transaction. mq hook acts on a probe of mq init or mq doctor, in any phase, and on a branch a committed transaction moved (Registration.woken), so the script reads Git's lines ("<old> SP <new> SP <ref>", githooks(5)) with the shell's own read, starts no process for any other transaction, and hands mq the lines it read. *)let hook_filter = {|input=act=while read -r old new ref || [ -n "$old" ]; do input="$input$old $new $ref" case "$1:$ref" in *:refs/mq/probe/*) act=1 ;; committed:refs/heads/*) [ "$old" = "$new" ] || act=1 ;; esacdone[ -n "$act" ] || exit 0exec <<EOF$inputEOF|}
let hook_script ~mq = Fmt.str "#!/bin/sh\n\ %s It tells mq that a ref moved, and never refuses the update.\n\ %s%s\n" marker hook_filter (hook_line ~mq)
let ours contents = String.starts_with ~prefix:("#!/bin/sh\n" ^ marker) contentslet only_line = "# mq: this hook only tells mq that a ref moved."
(* A line of the hook that holds the declaration and nothing more but blanks: a hook saved with CRLF ends of line still carries it. *)let only_mq contents = ours contents || List.exists (fun l -> String.equal (String.trim l) only_line) (String.split_on_char '\n' contents)
let clone_directory url = let strip_suffix suffix s = if String.ends_with ~suffix s then String.sub s 0 (String.length s - String.length suffix) else s in let rec strip_slashes s = if String.ends_with ~suffix:"/" s then strip_slashes (String.sub s 0 (String.length s - 1)) else s in let s = strip_slashes (String.trim url) in let s = strip_slashes (strip_suffix "/.git" s) in let s = strip_suffix ".git" s in let after c s = match String.rindex_opt s c with | Some i -> String.sub s (i + 1) (String.length s - i - 1) | None -> s in let base = after ':' (after '/' s) in match Fpath.of_string base with | Ok d when Fpath.is_seg base && (not (Fpath.is_rel_seg base)) && base <> "" -> Ok d | _ -> Fmt.error_msg "%S names no directory to clone into" url
(* {1 The machine} *)
type event = | Read of facts | Answered of (string * (Commit.t * string) option) list | Unreachable of { remote : string; why : string } | Unsupported of { remote : string; why : string } | Untrusted of { remote : string; why : string } | Created of Commit.t | Create_raced | Adopted | Tracked of Branch.t option | Hook_installed | Hook_raced | Signalled of Signal.t | Unanswered of action * Machine.unanswered
and action = | Read_facts | Ask of { remotes : string list; branch : Branch.t } | Create_rules of { branch : Branch.t; content : string; message : string; reflog : string; } | Adopt of { branch : Branch.t; remote : string; commit : Commit.t } | Track of { branch : Branch.t; remote : string } | Install_hook of { path : Fpath.t; content : string; replacing : string option; }
type hook_plan = | Install of { path : Fpath.t; content : string; replacing : string option } | Installed | Calls_mq of Fpath.t | Not_ours of { why : string; path : Fpath.t }
let hook_name = "reference-transaction"
let hook_plan (hooks : hooks) ~mq = let content = hook_script ~mq in let theirs why path = if hooks.calls_mq then Calls_mq path else Not_ours { why; path } in match hooks.dir with | Check.On_machine d when Fpath.equal d hooks.own -> ( let path = Fpath.(d / hook_name) in match hooks.existing with | None -> Install { path; content; replacing = None } | Some s when String.equal s content -> Installed | Some s when ours s -> Install { path; content; replacing = Some s } | Some _ -> theirs "the repository has one of its own" path) | Check.In_tree d -> theirs (Fmt.str "core.hooksPath names %a, in the work tree" Fpath.pp d) Fpath.(d / hook_name) | Check.On_machine d -> theirs (Fmt.str "core.hooksPath names %a" Fpath.pp d) Fpath.(d / hook_name)
let pp_hook ~mq ppf = function | Calls_mq path -> Fmt.pf ppf "the reference-transaction hook is installed: %a calls mq" Fpath.pp path | Not_ours { why; path } -> Fmt.pf ppf "the reference-transaction hook is not installed: %s; add this line to \ %a: %s" why Fpath.pp path (hook_line ~mq) | Installed -> Fmt.string ppf "the reference-transaction hook is installed" | Install _ -> Fmt.string ppf "the reference-transaction hook is not installed"
(* Where the rules in force come from. A remote's copy is adopted whether its rules load or not, the reason they do not in [Error]. *)type source = | Unchanged of Rules.t | Create of Rules.t | Adopt_from of { remote : string; commit : Commit.t; rules : (Rules.t, string) result; }
type plan = { facts : facts; source : source; hook : hook_plan; tracked : Branch.t list; (** The branches created, tracking the remote's. *)}
type phase = | Reading | Asking of facts | Writing of { plan : plan; pending : action list } | Done of (Report.t, Outcome.t) result
type ending = (Report.t, Outcome.t) resulttype t = { phase : phase; fetch : bool }
let machine = "init"let v ?(fetch = true) () = ({ phase = Reading; fetch }, [ Read_facts ])
let pp ppf t = Fmt.pf ppf "init: %s" (match t.phase with | Reading -> "reading" | Asking _ -> "asking the remotes" | Writing _ -> "writing" | Done _ -> "done")
let pp_event ppf = function | Read _ -> Fmt.string ppf "facts read" | Answered _ -> Fmt.string ppf "the remotes answered" | Unreachable { remote; _ } -> Fmt.pf ppf "%s did not answer" remote | Unsupported { remote; _ } -> Fmt.pf ppf "%s is not reachable by mq" remote | Untrusted { remote; _ } -> Fmt.pf ppf "the SSH session to %s was refused" remote | Created h -> Fmt.pf ppf "rules created at %s" (Commit.to_hex h) | Create_raced -> Fmt.string ppf "rules created by another hand" | Adopted -> Fmt.string ppf "rules adopted" | Tracked (Some b) -> Fmt.pf ppf "%a created" Branch.pp b | Tracked None -> Fmt.string ppf "nothing to create" | Hook_installed -> Fmt.string ppf "hook installed" | Hook_raced -> Fmt.string ppf "a hook appeared meanwhile" | Signalled sg -> Fmt.pf ppf "signalled %a" Signal.pp sg | Unanswered (_, why) -> Fmt.pf ppf "unanswered: %a" Machine.pp_unanswered why
let pp_action ppf = function | Read_facts -> Fmt.string ppf "read the facts" | Ask { remotes; branch } -> Fmt.pf ppf "ask %a for %a" Fmt.(list ~sep:(any ", ") string) remotes Branch.pp branch | Create_rules { branch; _ } -> Fmt.pf ppf "create %a" Branch.pp branch | Adopt { branch; remote; _ } -> Fmt.pf ppf "adopt %s/%a" remote Branch.pp branch | Track { branch; remote } -> Fmt.pf ppf "set %a up from %s/%a" Branch.pp branch remote Branch.pp branch | Install_hook { path; _ } -> Fmt.pf ppf "install %a" Fpath.pp path
let unexpected t e = Machine.unexpected machine ~state:(Fmt.str "%a" pp t) ~event:(Fmt.str "%a" pp_event e)
let finish o = Ok (Done o, [])
(* The ending of a cause mq doctor reports with its remedy. *)let err_diagnosed fmt = Fmt.kstr (fun d -> Error (Outcome.diagnosed d)) fmtlet unavailable detail = finish (Error (Outcome.v Outcome.Unavailable detail))
let refused ?next detail = finish (Error (Outcome.v ?next Outcome.Refused detail))
let report plan rules = let hook = match plan.hook with | (Calls_mq _ | Not_ours _) as h -> Fmt.str "; %a" (pp_hook ~mq:plan.facts.mq) h | Install _ | Installed -> "" in let branch = plan.facts.rules_branch in match plan.source with | Unchanged _ -> Report.v ~detail:("already set up, " ^ Rules.summary rules ^ hook) Report.Unchanged (Branch.to_string branch) | Create _ -> Report.v ~detail:(Rules.summary rules ^ hook) Report.Created (Branch.to_string branch) | Adopt_from { remote; _ } -> let tracked = Report.tracking ~remote (List.map Branch.to_string plan.tracked) |> Option.fold ~none:"" ~some:(fun c -> "; " ^ c) in Report.v ~detail:(Rules.summary rules ^ tracked ^ hook) Report.Adopted (Fmt.str "%s/%a" remote Branch.pp branch)
(* The writes of a plan, in order: the rules, with each branch of the DAG an adopted remote holds set up from it, then the hook. *)let writes plan = let f = plan.facts in let rules = match plan.source with | Unchanged _ -> [] | Create rules -> let head = Option.value f.head ~default:f.rules_branch in [ Create_rules { branch = f.rules_branch; content = Rules.to_string rules; message = Fmt.str "mq init: the rules, with the DAG %a" Branch.pp head; reflog = "mq init: created"; }; ] | Adopt_from { remote; commit; rules } -> (* Rules that do not load name no branch to set up. *) let named = match rules with Ok r -> Rules.literals r | Error _ -> [] in Adopt { branch = f.rules_branch; remote; commit } :: List.filter_map (fun branch -> if Branch.equal branch f.rules_branch then None else Some (Track { branch; remote })) named in let hook = match plan.hook with | Install { path; content; replacing } -> [ Install_hook { path; content; replacing } ] | Installed | Calls_mq _ | Not_ours _ -> [] in rules @ hook
(* Rules adopted that do not load end the call with the doctor's next, which names the land into the rules branch that fixes them. *)let ending plan = match plan.source with | Unchanged rules | Create rules | Adopt_from { rules = Ok rules; _ } -> Ok (report plan rules) | Adopt_from { remote; rules = Error why; _ } -> err_diagnosed "adopted %s/%a, whose rules do not load: %s" remote Branch.pp plan.facts.rules_branch why
let next plan pending = match pending with | [] -> finish (ending plan) | a :: rest -> Ok (Writing { plan; pending = rest }, [ a ])
let planned f source = let plan = { facts = f; source; hook = hook_plan f.hooks ~mq:f.mq; tracked = [] } in next plan (writes plan)
let decide f = let load (commit, content) = let file = Fmt.str "mq.toml at %a" Commit.pp commit in Result.map_error (fun (`Msg m) -> m) (Rules.of_string ~file content) in let remote = Option.bind (pull_remote f) (fun r -> Option.map (fun c -> (r, c)) (Option.join (List.assoc_opt r f.remotes))) in match (f.local, remote) with | Some local, _ -> ( match load local with | Ok rules -> planned f (Unchanged rules) | Error why -> finish (err_diagnosed "%a holds rules that do not load: %s" Branch.pp f.rules_branch why)) | None, Some (r, ((commit, _) as copy)) -> planned f (Adopt_from { remote = r; commit; rules = load copy }) | None, None -> ( match (f.past, f.head) with | Some (Ran (Some _ as last)), _ -> finish (Error (gone ~rules_branch:f.rules_branch last)) | _, None -> refused "HEAD names no branch, so the rules have no branch to name" | _, Some head when not f.born -> Fmt.kstr (refused ~next:"git commit") "%a has no commit yet" Branch.pp head | _, Some head -> planned f (Create (Rules.initial head (detect f))))
(* With no rules here, every remote is asked for its copy before any is created: a clone of one branch has no remote-tracking copy to read. Without fetching, the remote-tracking copies Git already holds decide. *)let ask ~fetch f = match (fetch, f.local, f.remotes) with | true, None, (_ :: _ as remotes) -> Ok ( Asking f, [ Ask { remotes = List.map fst remotes; branch = f.rules_branch } ] ) | _ -> decide f
let step t e = match (t.phase, e) with | Reading, Read f -> ask ~fetch:t.fetch f | Asking f, Answered copies -> decide { f with remotes = copies } | Asking f, Unreachable { remote; why } -> Fmt.kstr unavailable "%s did not answer for %a, so no rules are created beside its own: %s; \ mq init --no-fetch decides on the copies Git holds here" remote Branch.pp f.rules_branch why | Asking f, (Unsupported { remote; why } | Untrusted { remote; why }) -> Fmt.kstr refused "%s: %s, so no rules are created beside its own %a" remote why Branch.pp f.rules_branch | Writing { plan; pending }, (Created _ | Adopted | Hook_installed) -> next plan pending | Writing { plan; pending }, Tracked b -> next { plan with tracked = plan.tracked @ Option.to_list b } pending | Writing _, Create_raced -> Ok (Reading, [ Read_facts ]) | Writing { plan; pending }, Hook_raced -> let path = match plan.hook with | Install { path; _ } -> path | Installed | Calls_mq _ | Not_ours _ -> Fpath.(plan.facts.hooks.own / hook_name) in next { plan with hook = Not_ours { why = "the repository has one of its own"; path }; } pending | Done _, _ -> Ok (t.phase, []) | _, Signalled _ -> finish (Error (Outcome.v Outcome.Interrupted "interrupted")) | _, Unanswered (_, why) -> Fmt.kstr unavailable "%a" Machine.pp_unanswered why | ( (Reading | Asking _ | Writing _), ( Read _ | Answered _ | Unreachable _ | Unsupported _ | Untrusted _ | Created _ | Create_raced | Adopted | Tracked _ | Hook_installed | Hook_raced ) ) -> unexpected t e
let incoming t ~now:_ e = Result.map (fun (phase, actions) -> ({ t with phase }, actions)) (step t e)
let ending t = match t.phase with Done r -> Some r | _ -> Nonelet timer t ~now:_ = Ok (t, [])let next_timeout (_ : t) = Nonelet task (_ : action) = Machine.Task.Nowlet unanswered a why = Unanswered (a, why)let signal s = Signalled s