Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
23 kB · 755 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756type branch_rule = { pattern : Branch.Pattern.t; checks : Check.name list; takes : Branch.t option; every : Duration.t option; report : bool;}
type bounds = { check_wall : int; check_grace : int; wait_wall : int; run_start : int; resolve_wall : int option; hook_wall : int; remote_bytes : int;}
type resolve = { command : string option; default : [ `Auto | `Stop ] }
type t = { name : Branch.t option; checks : Check.t list; branches : branch_rule list; entry : Branch.t option; bounds : bounds; resolve : resolve; expedite_per_day : int option; hook : string option; cone : string option;}
let default_bounds = { check_wall = 3600; check_grace = 30; wait_wall = 7200; run_start = 300; resolve_wall = None; hook_wall = 30; remote_bytes = 17179869184; }
type bound = Check_wall | Check_grace | Wait_wall | Run_start | Hook_wall
let pp_bound ppf (b, v) = let d = default_bounds in let key, default = match b with | Check_wall -> ("check_wall", d.check_wall) | Check_grace -> ("check_grace", d.check_grace) | Wait_wall -> ("wait_wall", d.wait_wall) | Run_start -> ("run_start", d.run_start) | Hook_wall -> ("hook_wall", d.hook_wall) in Fmt.pf ppf "bounds.%s, %ds%s" key v (if v = default then " by default" else "")
let err fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmtlet ( let* ) = Result.bind
let rec all f = function | [] -> Ok [] | x :: rest -> let* y = f x in let* ys = all f rest in Ok (y :: ys)
(* {1 Reading TOML values} *)
module V = Toml.Value
let members where = function | V.Table (members, _) -> Ok (List.map (fun ((k, _), v) -> (k, v)) members) | _ -> err "%s is not a table" where
let only where allowed members = match List.find_opt (fun (k, _) -> not (List.mem k allowed)) members with | Some (k, _) -> err "%s has no key %S (it takes %s)" where k (String.concat ", " allowed) | None -> Ok ()
let string where = function | V.String (s, _) -> Ok s | _ -> err "%s is not a string" where
let bool where = function | V.Bool (b, _) -> Ok b | _ -> err "%s is not a boolean" where
let int where = function | V.Int (n, _) when Int64.compare n 0L > 0 && Int64.compare n 0x3fffffffL <= 0 -> Ok (Int64.to_int n) | _ -> err "%s is not a positive integer" where
(* A count of bytes: a positive integer as wide as the platform holds. *)let bytes where = function | V.Int (n, _) when Int64.compare n 0L > 0 && Int64.compare n (Int64.of_int max_int) <= 0 -> Ok (Int64.to_int n) | _ -> err "%s is not a positive count of bytes" where
let strings where = function | V.Array (vs, _) -> all (string where) vs | _ -> err "%s is not an array of strings" where
let find k members = List.assoc_opt k members
let opt where k f members = match find k members with | None -> Ok None | Some v -> Result.map Option.some (f (where ^ "." ^ k) v)
let msg where = Result.map_error (fun (`Msg m) -> `Msg (where ^ ": " ^ m))
(* {1 Sections} *)
let definition_of where cname command = match (command, Check.hook_of_name cname) with | Some c, None -> Ok (Check.Command c) | None, Some h -> Ok (Check.Hook h) | Some _, Some _ -> err "%s is a Git hook, which runs its own script and takes no command" where | None, None -> err "%s has no command" where
let paths where k members = let* l = opt where k strings members in let* l = all (fun g -> msg (where ^ "." ^ k) (Confinement.grant_of_string g)) (Option.value ~default:[] l) in Ok (Some l)
let grants_of where members = let* read = paths where "read" members in let* write = paths where "write" members in let* network = opt where "network" bool members in Ok { Check.read = Option.value ~default:[] read; write = Option.value ~default:[] write; network = Option.value ~default:false network; }
let check_section (name, v) = let where = "check." ^ name in let* members = members where v in let* () = only where [ "command"; "read"; "write"; "network"; "wall" ] members in let* cname = msg where (Check.name_of_string name) in let* () = if Check.equal_name cname Check.rules.name then err "%s is mq's own check, which a land into the rules branch runs, and \ takes no section" where else Ok () in let* command = opt where "command" string members in let* definition = definition_of where cname command in let* grants = grants_of where members in let* wall = opt where "wall" int members in Ok (Check.v ~grants ?wall cname definition)
let parsed where f = function | None -> Ok None | Some s -> Result.map Option.some (msg where (f s))
let branch_rule (name, v) = let where = Fmt.str "branch.%S" name in let* members = members where v in let* () = only where [ "checks"; "takes"; "every"; "report" ] members in let* pattern = msg where (Branch.Pattern.of_string name) in let* checks = opt where "checks" strings members in let* checks = all (fun c -> msg where (Check.name_of_string c)) (Option.value ~default:[] checks) in let* takes = Result.bind (opt where "takes" string members) (parsed where Branch.of_string) in let* every = Result.bind (opt where "every" string members) (parsed (where ^ ".every") Duration.of_string) in let* report = opt where "report" bool members in let report = Option.value ~default:false report in match (Branch.Pattern.literal pattern, takes, every) with | None, Some _, _ | None, _, Some _ -> err "%s is a pattern, and a pattern takes from no branch (a series is not \ an edge)" where | _, None, Some _ -> err "%s has an interval and takes from no branch" where | _, None, _ when report -> err "%s reports and takes from no branch" where | _ -> Ok { pattern; checks; takes; every; report }
let bounds v = let where = "bounds" in let* members = members where v in let* () = only where [ "check_wall"; "check_grace"; "wait_wall"; "run_start"; "resolve_wall"; "hook_wall"; "remote_bytes"; ] members in let d = default_bounds in let get k default = Result.map (Option.value ~default) (opt where k int members) in let* check_wall = get "check_wall" d.check_wall in let* check_grace = get "check_grace" d.check_grace in let* wait_wall = get "wait_wall" d.wait_wall in let* run_start = get "run_start" d.run_start in let* hook_wall = get "hook_wall" d.hook_wall in let* remote_bytes = Result.map (Option.value ~default:d.remote_bytes) (opt where "remote_bytes" bytes members) in let* resolve_wall = opt where "resolve_wall" int members in Ok { check_wall; check_grace; wait_wall; run_start; resolve_wall; hook_wall; remote_bytes; }
let resolve v = let where = "resolve" in let* members = members where v in let* () = only where [ "command"; "default" ] members in let* command = opt where "command" string members in let* default = opt where "default" string members in match (command, default) with | _, None | _, Some "stop" -> Ok { command; default = `Stop } | Some _, Some "auto" -> Ok { command; default = `Auto } | None, Some "auto" -> err "resolve.default is auto and there is no resolve.command" | _, Some d -> err "resolve.default is %S, which is neither auto nor stop" d
let single where key f v = let* members = members where v in let* () = only where [ key ] members in match find key members with | None -> err "%s has no %s" where key | Some v -> f (where ^ "." ^ key) v
(* {1 The DAG} *)
let rule t b = match List.find_opt (fun r -> match Branch.Pattern.literal r.pattern with | Some n -> Branch.equal n b | None -> false) t.branches with | Some r -> Some r | None -> List.find_opt (fun r -> Branch.Pattern.matches r.pattern b) t.branches
let names t b = Option.is_some (rule t b)let takes t b = Option.bind (rule t b) (fun r -> r.takes)
let literals t = List.filter_map (fun r -> Branch.Pattern.literal r.pattern) t.branches
let takers t b = List.filter (fun n -> match takes t n with Some s -> Branch.equal s b | None -> false) (literals t)
let reports t b = match rule t b with Some r -> r.report | None -> false
let rec last t b = match takers t b with [ n ] when not (reports t n) -> last t n | _ -> b
let route t ~from b = let rec go seen acc b = if Branch.equal b from then Some (from :: acc) else if List.exists (Branch.equal b) seen then None else match takes t b with | Some s -> go (b :: seen) (b :: acc) s | None -> None in go [] [] b
let every t b = Option.bind (rule t b) (fun r -> r.every)
let entry t = match t.entry with | Some b -> Ok b | None -> ( match List.filter (fun b -> Option.is_none (takes t b)) (literals t) with | [ b ] -> Ok b | [] -> err "the rules name no branch that takes from no other, so there is no \ entry branch" | bs -> err "the rules name %d branches that take from no other (%a): entry \ names the one new work lands into" (List.length bs) Fmt.(list ~sep:comma Branch.pp) bs)
let check t n = match List.find_opt (fun (c : Check.t) -> Check.equal_name c.name n) t.checks with | Some c -> Some c | None -> Option.map (fun h -> Check.v n (Check.Hook h)) (Check.hook_of_name n)
let checks t b = match rule t b with | None -> [] | Some r -> List.filter_map (check t) r.checks
let validate t = (* Every check a branch lists resolves. *) let* () = match List.find_map (fun (r : branch_rule) -> List.find_map (fun n -> match check t n with Some _ -> None | None -> Some (r, n)) r.checks) t.branches with | Some (r, n) when Check.equal_name n Check.rules.name -> err "branch %a lists check %a, which is mq's own and runs on a land into \ the rules branch alone" Branch.Pattern.pp r.pattern Check.pp_name n | Some (r, n) -> err "branch %a lists check %a, which has no [check.%a] section and is no \ Git hook" Branch.Pattern.pp r.pattern Check.pp_name n Check.pp_name n | None -> Ok () in (* Every [takes] names a branch of the rules by its own name. *) let* () = match List.find_map (fun (r : branch_rule) -> match r.takes with | Some s when not (List.exists (Branch.equal s) (literals t)) -> Some (r, s) | _ -> None) t.branches with | Some (r, s) -> err "branch %a takes %a, which the rules do not name" Branch.Pattern.pp r.pattern Branch.pp s | None -> Ok () in (* The edges form no cycle: following them from a branch as many times as there are branches leaves the DAG, since a chain one longer names some branch twice. The walk is a fold over that count, so it ends whatever the rules hold. *) let* () = let branches = literals t in let steps = List.map (fun _ -> ()) branches in let after b = List.fold_left (fun at () -> Option.bind at (takes t)) (Some b) steps in match List.find_opt (fun b -> Option.is_some (after b)) branches with | Some b -> err "the edges into %a form a cycle" Branch.pp b | None -> Ok () in (* The entry is one branch that takes no other. *) let* () = match t.entry with | Some b when not (List.exists (Branch.equal b) (literals t)) -> err "entry names %a, which the rules do not name by its own name" Branch.pp b | Some b when Option.is_some (takes t b) -> err "entry names %a, which takes its commits from another branch" Branch.pp b | _ -> Result.map ignore (entry t) in Ok t
let optional top k f = match find k top with | None -> Ok None | Some v -> Result.map Option.some (f v)
let top_keys = [ "check"; "branch"; "bounds"; "resolve"; "expedite"; "hook"; "cone"; "entry"; "name"; ]
let section top k f = match find k top with | None -> Ok [] | Some v -> Result.bind (members k v) (all f)
let with_default top k f default = Result.map (Option.value ~default) (optional top k f)
let entry_of v = Result.bind (string "entry" v) (fun b -> msg "entry" (Branch.of_string b))
let name_of v = Result.bind (string "mq.toml.name" v) (fun name -> msg "mq.toml.name" (Branch.of_string name))
(* The sections that hold one table each, every one optional. *)let settings top t = let* bounds = with_default top "bounds" bounds default_bounds in let* resolve = with_default top "resolve" resolve { command = None; default = `Stop } in let* expedite_per_day = optional top "expedite" (single "expedite" "per_day" int) in let* hook = optional top "hook" (single "hook" "command" string) in let* cone = optional top "cone" (single "cone" "command" string) in let* entry = optional top "entry" entry_of in let* name = optional top "name" name_of in Ok { t with bounds; resolve; expedite_per_day; hook; cone; entry; name }
let repairing = { name = None; checks = []; branches = []; entry = None; bounds = default_bounds; resolve = { command = None; default = `Stop }; expedite_per_day = None; hook = None; cone = None; }
let of_toml v = let* top = members "mq.toml" v in let* () = only "mq.toml" top_keys top in let* checks = section top "check" check_section in let* branches = section top "branch" branch_rule in let* t = settings top { repairing with checks; branches } in validate t
(* A TOML error at its first line, in [file]: "mq.toml at C, line 1: expected ]", as Git names a configuration file and its line. *)let toml_error file (e : Toml.Error.t) = let loc = Loc.Meta.loc e.meta in let kind = Toml.Error.string_of_kind e.kind in if Loc.is_none loc then err "%s: %s" file kind else err "%s, line %d: %s" file (Loc.first_line_num loc) kind
let of_string ?(file = "mq.toml") s = match Toml.of_string Toml.Value.codec s with | Error e -> toml_error file e | Ok v -> of_toml v
(* {1 Writing} *)
let quote s = let b = Buffer.create (String.length s + 2) in Buffer.add_char b '"'; String.iter (function | '"' -> Buffer.add_string b "\\\"" | '\\' -> Buffer.add_string b "\\\\" | '\n' -> Buffer.add_string b "\\n" | '\t' -> Buffer.add_string b "\\t" | c when Char.code c < 0x20 -> Fmt.pf (Fmt.with_buffer b) "\\u%04x%!" (Char.code c) | c -> Buffer.add_char b c) s; Buffer.add_char b '"'; Buffer.contents b
let bare_key k = String.for_all (fun c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') || c = '_' || c = '-') k
let key k = if bare_key k && k <> "" then k else quote klet array l = "[" ^ String.concat ", " (List.map quote l) ^ "]"
let to_string t = let b = Buffer.create 256 in let section header lines = if Buffer.length b > 0 then Buffer.add_char b '\n'; Buffer.add_string b ("[" ^ header ^ "]\n"); List.iter (fun l -> Buffer.add_string b (l ^ "\n")) lines in (match t.name with | Some name -> Buffer.add_string b ("name = " ^ quote (Branch.to_string name) ^ "\n") | None -> ()); (match t.entry with | Some e -> Buffer.add_string b ("entry = " ^ quote (Branch.to_string e) ^ "\n") | None -> ()); List.iter (fun (c : Check.t) -> let lines = (match c.definition with | Check.Command cmd -> [ "command = " ^ quote cmd ] | _ -> []) @ (if c.grants.read = [] then [] else [ "read = " ^ array c.grants.read ]) @ (if c.grants.write = [] then [] else [ "write = " ^ array c.grants.write ]) @ (if c.grants.network then [ "network = true" ] else []) @ match c.wall with | None -> [] | Some w -> [ "wall = " ^ string_of_int w ] in section ("check." ^ key (Check.string_of_name c.name)) lines) t.checks; List.iter (fun r -> let lines = (match r.takes with | None -> [] | Some s -> [ "takes = " ^ quote (Branch.to_string s) ]) @ (match r.every with | None -> [] | Some d -> [ "every = " ^ quote (Duration.to_string d) ]) @ (if r.report then [ "report = true" ] else []) @ [ "checks = " ^ array (List.map Check.string_of_name r.checks) ] in section ("branch." ^ key (Branch.Pattern.to_string r.pattern)) lines) t.branches; let d = default_bounds and bo = t.bounds in let bound k v dv = if v = dv then [] else [ k ^ " = " ^ string_of_int v ] in let bounds = bound "check_wall" bo.check_wall d.check_wall @ bound "check_grace" bo.check_grace d.check_grace @ bound "wait_wall" bo.wait_wall d.wait_wall @ bound "run_start" bo.run_start d.run_start @ (match bo.resolve_wall with | None -> [] | Some w -> [ "resolve_wall = " ^ string_of_int w ]) @ bound "hook_wall" bo.hook_wall d.hook_wall @ bound "remote_bytes" bo.remote_bytes d.remote_bytes in if bounds <> [] then section "bounds" bounds; (match t.resolve with | { command = None; default = `Stop } -> () | { command; default } -> section "resolve" ((match command with | None -> [] | Some c -> [ "command = " ^ quote c ]) @ match default with `Auto -> [ "default = \"auto\"" ] | `Stop -> [])); (match t.expedite_per_day with | None -> () | Some n -> section "expedite" [ "per_day = " ^ string_of_int n ]); (match t.hook with | None -> () | Some c -> section "hook" [ "command = " ^ quote c ]); (match t.cone with | None -> () | Some c -> section "cone" [ "command = " ^ quote c ]); Buffer.contents b
let initial branch check = let checks, names = match check with | None -> ([], []) | Some (c : Check.t) -> ( match c.definition with | Check.Hook _ -> ([], [ c.name ]) | _ -> ([ c ], [ c.name ])) in { name = None; checks; branches = [ { pattern = Result.get_ok (Branch.Pattern.of_string (Branch.to_string branch)); checks = names; takes = None; every = None; report = false; }; ]; entry = None; bounds = default_bounds; resolve = { command = None; default = `Stop }; expedite_per_day = None; hook = None; cone = None; }
(* {1 The rules check} *)
let candidate = function | None -> Error [ "the tree holds no mq.toml" ] | Some text -> ( match of_string text with Ok t -> Ok t | Error (`Msg m) -> Error [ m ])
type tips = (Branch.t * Commit.t) list
type lookups = { in_tree : (Commit.t * Fpath.t) list; on_machine : Fpath.t list;}
(* Each check a branch of [tips] requires, with its tip and the place of its program, in the order of [tips] then of the branch's list. *)let required t ~rules_branch ~hooks tips = List.concat_map (fun (b, tip) -> if Branch.equal b rules_branch then [] else List.filter_map (fun (c : Check.t) -> Option.map (fun place -> (b, tip, c, place)) (Check.program ~hooks c)) (checks t b)) tips
let lookups t ~rules_branch ~hooks tips = let req = required t ~rules_branch ~hooks tips in { in_tree = List.filter_map (function | _, tip, _, Check.In_tree p -> Some (tip, p) | _, _, _, _ -> None) req; on_machine = List.filter_map (function _, _, _, Check.On_machine p -> Some p | _ -> None) req; }
let judge t ~rules_branch ~hooks tips ~found = let here b = List.exists (fun (n, _) -> Branch.equal n b) tips in let missing = List.filter_map (fun b -> if here b then None else Fmt.kstr Option.some "the rules name %a, which is not a branch here" Branch.pp b) (literals t) in let unresolved = List.filter_map (fun (b, tip, (c : Check.t), place) -> match place with | Check.In_tree p when not (List.exists (fun (t', p') -> Commit.equal t' tip && Fpath.equal p' p) found.in_tree) -> Fmt.kstr Option.some "check %a does not resolve at the tip of %a (%s): %a is no \ executable file of its tree" Check.pp_name c.name Branch.pp b (Commit.short tip) Fpath.pp p | Check.On_machine p when not (List.exists (Fpath.equal p) found.on_machine) -> Fmt.kstr Option.some "check %a, which %a requires, does not resolve: %a is no \ executable file on this machine" Check.pp_name c.name Branch.pp b Fpath.pp p | Check.In_tree _ | Check.On_machine _ -> None) (required t ~rules_branch ~hooks tips) in match missing @ unresolved with [] -> Ok () | reasons -> Error reasons
let summary t = (* The chains of the DAG, from each branch that takes no other: a fold over the branches, so the walk ends whatever the rules hold, and a branch already on the chain ends it. *) let branches = literals t in let chain b = List.fold_left (fun (acc, at) _ -> match at with | Some x when not (List.exists (Branch.equal x) acc) -> ( match takers t x with | [] -> (x :: acc, None) | next :: _ -> (x :: acc, Some next)) | _ -> (acc, None)) ([], Some b) branches |> fst |> List.rev in let roots = List.filter (fun b -> Option.is_none (takes t b)) branches in let chains = List.map (fun b -> String.concat " -> " (List.map Branch.to_string (chain b))) roots in let patterns = List.filter_map (fun r -> match Branch.Pattern.literal r.pattern with | None -> Some (Branch.Pattern.to_string r.pattern) | Some _ -> None) t.branches in let dag = String.concat ", " (chains @ patterns) in match (branches, patterns) with | [ b ], [] -> ( match List.map (fun (c : Check.t) -> Check.string_of_name c.name) (checks t b) with | [] -> Fmt.str "DAG %s, no checks" dag | [ c ] -> Fmt.str "DAG %s, check %s" dag c | cs -> Fmt.str "DAG %s, checks %s" dag (String.concat " " cs)) | _ -> "DAG " ^ dag
let equal a b = String.equal (to_string a) (to_string b)let pp ppf t = Fmt.string ppf (to_string t)