Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
11 kB · 359 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360type mode = Self | Scheduled
type t = { result : Check.result; check : Check.name; tree : Tree.t; attempt : int; config : Build_config.t; rules : Commit.t; machine : Host.t; platform : Platform_name.t; mode : mode; confined : Confinement.mechanism option; seconds : Duration.t; at : Ptime.t; log : string option;}
let schema = "mq2"let earlier = [ "mq1" ]let err fmt = Fmt.kstr (fun m -> Error (`Msg m)) fmt
let hex64 s = String.length s = 64 && String.for_all (fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) s
let v ~result ~check ~tree ~attempt ~config ~rules ~machine ~platform ~mode ~confined ~seconds ~at ?log () = if attempt < 1 then err "attempt %d is not a run's" attempt else match log with | Some l when not (hex64 l) -> err "log digest %S is not a SHA-256" l | _ -> Ok { result; check; tree; attempt; config; rules; machine; platform; mode; confined; seconds; at; log; }
let string_of_mode = function Self -> "self" | Scheduled -> "scheduled"
let to_line r = let log = match r.log with None -> "" | Some l -> " log=" ^ l in Fmt.str "%s %s %s tree=%s attempt=%d config=%s rules=%s machine=%s platform=%s \ mode=%s confined=%s seconds=%d at=%s%s" schema (Check.string_of_result r.result) (Check.string_of_name r.check) (Tree.to_hex r.tree) r.attempt (Build_config.to_string r.config) (Commit.to_hex r.rules) (Host.to_string r.machine) (Platform_name.to_field r.platform) (string_of_mode r.mode) (match r.confined with | Some m -> Confinement.string_of_mechanism m | None -> "no") (Duration.seconds r.seconds) (Timestamp.Rfc3339.format r.at) log
let ( let* ) = Result.bind
let keys = [ "tree"; "attempt"; "config"; "rules"; "machine"; "platform"; "mode"; "confined"; "seconds"; "at"; ]
(* The [key=value] fields of a line, in the order [keys] then [log]. *)let pairs line fields = let pair s = match String.index_opt s '=' with | Some i -> Ok (String.sub s 0 i, String.sub s (i + 1) (String.length s - i - 1)) | None -> err "field %S of %S is not key=value" s line in let* pairs = List.fold_right (fun f acc -> Result.bind acc (fun acc -> Result.map (fun p -> p :: acc) (pair f))) fields (Ok []) in let names = List.map fst pairs in if names = keys || names = keys @ [ "log" ] then Ok pairs else err "the fields of %S are not %s [log]" line (String.concat " " keys)
let tree_of s = match Tree.of_hex s with Some t -> Ok t | None -> err "not a tree id: %S" s
let hash_of s = match Commit.of_hex s with | Some c -> Ok c | None -> err "not a commit id: %S" s
let mode_of = function | "self" -> Ok Self | "scheduled" -> Ok Scheduled | m -> err "not a mode: %S" m
let seconds_of s = match int_of_string_opt s with | Some n when n >= 0 && string_of_int n = s -> Ok (Duration.of_seconds n) | _ -> err "not a count of seconds: %S" s
let time_of s = match Timestamp.Rfc3339.parse s with | Some t -> Ok t | None -> err "not an RFC 3339 time: %S" s
let attempt_of s = match int_of_string_opt s with | Some n -> Ok n | None -> err "not an attempt: %S" s
let result_of s = match Check.result_of_string s with | Some r -> Ok r | None -> err "not a result: %S" s
(* The machine and the platform a result ran on. *)let where_ran get = let* machine = Host.of_string (get "machine") in let* platform = Platform_name.of_field (get "platform") in Ok (machine, platform)
(* [pairs] has checked that every key read here is present. *)let of_pairs ~result ~check pairs = let get k = List.assoc k pairs in let* tree = tree_of (get "tree") in let* attempt = attempt_of (get "attempt") in let* config = Build_config.of_string (get "config") in let* rules = hash_of (get "rules") in let* mode = mode_of (get "mode") in let* confined = Confinement.of_field (get "confined") in let* seconds = seconds_of (get "seconds") in let* at = time_of (get "at") in let* machine, platform = where_ran get in v ~result ~check ~tree ~attempt ~config ~rules ~machine ~platform ~mode ~confined ~seconds ~at ?log:(List.assoc_opt "log" pairs) ()
let of_fields line = match String.split_on_char ' ' line with | _ :: result :: check :: fields -> let* result = result_of result in let* check = Check.name_of_string check in let* pairs = pairs line fields in of_pairs ~result ~check pairs | _ -> err "a %s line has too few fields: %S" schema line
let of_line line = match String.split_on_char ' ' line with | w :: _ when w <> schema -> Error (`Schema w) | _ -> (of_fields line :> (t, [ `Msg of string | `Schema of string ]) result)
type forgotten = { forgot : Check.name option; forgot_tree : Tree.t; forgot_by : Host.t; forgot_at : Ptime.t; set_aside : string list; reason : string option;}
let digest r = Cas.Hash.to_hex (Cas.Hash.sha256 (to_line r))
let forgotten ?check ?reason ~tree ~machine ~at rs = let reason = match Option.map Outcome.line reason with | Some "" | None -> None | Some r -> Some r in let named (r : t) = Tree.equal r.tree tree && match check with None -> true | Some c -> Check.equal_name c r.check in { forgot = check; forgot_tree = tree; forgot_by = machine; forgot_at = at; set_aside = List.sort_uniq String.compare (List.map digest (List.filter named rs)); reason; }
let forgot_word = "forgot"let every_check = "*"
let forgotten_line f = Fmt.str "%s %s %s tree=%s machine=%s at=%s results=%s%s" schema forgot_word (match f.forgot with | Some c -> Check.string_of_name c | None -> every_check) (Tree.to_hex f.forgot_tree) (Host.to_string f.forgot_by) (Timestamp.Rfc3339.format f.forgot_at) (String.concat "," f.set_aside) (match f.reason with None -> "" | Some r -> " reason=" ^ r)
(* The reason is the rest of the line, spaces included. *)let split_reason line = let tag = " reason=" in let n = String.length line and k = String.length tag in let rec find i = if i + k > n then (line, None) else if String.sub line i k = tag then (String.sub line 0 i, Some (String.sub line (i + k) (n - i - k))) else find (i + 1) in find 0
let forgotten_of_line line = let fields, reason = split_reason line in match String.split_on_char ' ' fields with | [ w; word; check; tree; machine; at; results ] when String.equal w schema && String.equal word forgot_word -> let value k f = match String.index_opt f '=' with | Some i when String.sub f 0 i = k -> Ok (String.sub f (i + 1) (String.length f - i - 1)) | _ -> err "field %S of %S is not %s=" f line k in let* check = if String.equal check every_check then Ok None else Result.map Option.some (Check.name_of_string check) in let* tree = Result.bind (value "tree" tree) tree_of in let* machine = Result.bind (value "machine" machine) Host.of_string in let* at = Result.bind (value "at" at) time_of in let* results = value "results" results in let set_aside = List.filter (fun d -> d <> "") (String.split_on_char ',' results) in if List.for_all hex64 set_aside then Ok { forgot = check; forgot_tree = tree; forgot_by = machine; forgot_at = at; set_aside; reason; } else err "the results of %S are not SHA-256 digests" line | _ -> err "not a %s line: %S" forgot_word line
let forgotten_check f = f.forgotlet forgotten_tree f = f.forgot_treelet forgotten_reason f = f.reasonlet forgotten_count f = List.length f.set_aside
(* A result's line names its tree, so its digest does too. *)let sets_aside f r = List.mem (digest r) f.set_aside
(* A line of a schema this mq replaced is no result and no line it cannot read: it is the record it was, read no further. *)let of_earlier l = match String.index_opt l ' ' with | Some i -> List.mem (String.sub l 0 i) earlier | None -> false
let of_note text = String.split_on_char '\n' text |> List.filter (fun l -> String.trim l <> "" && not (of_earlier l)) |> List.fold_left (fun (ok, forgot, bad) l -> match of_line l with | Ok r -> (r :: ok, forgot, bad) | Error _ -> ( match forgotten_of_line l with | Ok f -> (ok, f :: forgot, bad) | Error _ -> (ok, forgot, l :: bad))) ([], [], []) |> fun (ok, forgot, bad) -> ( List.filter (fun r -> not (List.exists (fun f -> sets_aside f r) forgot)) (List.rev ok), List.rev bad )
let only_about tree text = String.split_on_char '\n' text |> List.filter (fun l -> String.trim l <> "") |> List.mapi (fun i l -> (i + 1, l)) |> List.filter (fun (_, l) -> not (of_earlier l)) |> List.fold_left (fun acc (n, l) -> let* () = acc in let about t = if Tree.equal t tree then Ok () else err "line %d of the note of %a names another tree" n Tree.pp tree in match of_line l with | Ok r -> about r.tree | Error _ -> ( match forgotten_of_line l with | Ok f -> about f.forgot_tree | Error _ -> err "line %d of the note of %a is an unreadable %s line" n Tree.pp tree schema)) (Ok ())
let union rs = List.map to_line rs |> List.sort_uniq String.compare |> List.map (fun l -> l ^ "\n") |> String.concat ""
let commit_title = "mq: a check result"let commit_message r = Fmt.str "%s\n\n%s\n" commit_title (to_line r)
let is_commit_message m = match String.index_opt m '\n' with | Some i -> String.equal (String.sub m 0 i) commit_title | None -> String.equal m commit_title
let forgotten_title = "mq: check results forgotten"
let forgotten_message f = Fmt.str "%s\n\n%s\n" forgotten_title (forgotten_line f)
let equal a b = Check.equal_result a.result b.result && Check.equal_name a.check b.check && Tree.equal a.tree b.tree && a.attempt = b.attempt && Build_config.equal a.config b.config && Commit.equal a.rules b.rules && Host.equal a.machine b.machine && Platform_name.equal a.platform b.platform && a.mode = b.mode && a.confined = b.confined && Duration.equal a.seconds b.seconds && Ptime.equal (Ptime.truncate ~frac_s:0 a.at) (Ptime.truncate ~frac_s:0 b.at) && Option.equal String.equal a.log b.log
let pp ppf r = Fmt.string ppf (to_line r)