Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
35 kB · 987 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988type append = { message : string; on_tip : bool }type notes_lock = { held : Settle.held; append : append option }
let stale l = match l.append with | Some a -> a.on_tip && Note.is_commit_message a.message | None -> false
type request = { checks : Check.t list; key : Key.t; notes : Note.t list; scripts : (Check.name * string) list; logs : (Check.name * int * Fpath.t) list; notes_lock : notes_lock option; leftovers : Fpath.t list; retry : bool; mode : Note.mode; machine : Host.t; platform : string; rules : Commit.t; commit : Commit.t; target : Branch.t; target_tip : Commit.t; check_wall : int; grace : int; slot_wait : int; slots : int; estimates : Order.estimates; job : Branch.t; serve : bool; confinement : Confinement.t; prerequisites : Generation.t list;}
type event = | Run of Check.name * Check_run.event | Recorded of Check.name | Not_recorded of Check.name * string | Cancelled of string | Drain of string | Failed of string | Prepared | Unprepared of [ `Msg of string | `Busy of string ]
type action = | Run of Check.name * Check_run.action | Note of { key : Key.t; note : Note.t } | Journal of Event.kind | Remove_lock of Settle.held | Remove_worktree of Fpath.t | Prepare of { commit : Commit.t; generations : Generation.t list }
type ending = | Passed of string | Red of { check : Check.name; detail : string; log : Fpath.t option; recorded : Ptime.t option; reds : Outcome.red list; } | Base_red of { detail : string; reds : Outcome.red list } | Stuck of { detail : string; log : Fpath.t option; attempt : int option } | Unavailable of string | Busy of string | Withdrawn | Drained of string
type t = { req : request; results : Results.t; queue : Check.t list; (** The checks still to start, in order. *) running : (Check.t * Check_run.t) list; ran : (Check.t * Check_run.ending * int) list; (** With its seconds. *) reds : (Check.t * string * Outcome.red) list; (** The confirmed reds, with why and the last run's log and failures, in the order they ended. *) inherited : (Check.t * Outcome.red) list; (** The checks red only as the target's tip is, with the last run's log and failures, in the order they ended. *) reused : (Check.t * Note.t) list; captured : Note.t list; pending : int; (** The notes asked for and not answered yet. *) stopping : (Check.name * int) list; (** The attempts a [Stop] cancelled, whose task has not answered yet. *) withdrawing : (Check.t * Check_run.t) list; (** The runs stopped under way, whose answer records them. *) unrecorded : string list; (** What could not be recorded, said. *) decided : ending option; (** How the checks end, once every note asked for is answered. *) drained : string option; (** Why the checks not started were dropped, once a [Drain] dropped any: the checks end {!Drained} once the runs under way have. *) preparing : bool; (** The prerequisites are asked for and not answered yet: no check starts before. *) began : Ptime.t; (** When the checks began. *) last_end : Ptime.t option; (** When the last run that ended ended. *)}
let machine = "checking"
(* {1 Words} *)
(* The build configuration of [c]. *)let config req (c : Check.t) = Build_config.v ~platform:req.platform ?script:(List.assoc_opt c.name req.scripts) c
let wall_of req (c : Check.t) = Option.value c.wall ~default:req.check_walllet names l = List.map (fun ((k : Check.t), _) -> Check.string_of_name k.name) llet run_seconds t = List.fold_left (fun n (_, _, s) -> n + s) 0 t.ran
let wall t = match t.last_end with | Some e when Ptime.is_later e ~than:t.began -> (t.began, e) | Some _ | None -> (t.began, t.began)
(* The clause of an outcome whose checks passed (doc/outcomes.md: "the checks and the time they took", their wall beside their runs' time, and "checks reused from build-host"). *)let clause t = (* In the order the branch lists them, whichever ended first. *) let listed (k : Check.t) = Option.value ~default:max_int (List.find_index (fun (c : Check.t) -> Check.equal_name c.name k.name) t.req.checks) in let ran = List.stable_sort (fun ((a : Check.t), _, _) ((b : Check.t), _, _) -> Int.compare (listed a) (listed b)) t.ran in let flaked = List.filter_map (fun ((k : Check.t), e, _) -> match e with | Check_run.Flaked -> Some (Check.string_of_name k.name) | _ -> None) ran in let ran = List.map (fun ((k : Check.t), _, _) -> Check.string_of_name k.name) ran in let took = let began, ended = wall t in Fmt.str "%a wall, %a of runs" Duration.pp (Duration.of_span (Ptime.Span.to_float_s (Ptime.diff ended began))) Duration.pp (Duration.of_seconds (run_seconds t)) in let machines = List.sort_uniq String.compare (List.map (fun (_, (n : Note.t)) -> Host.to_string n.machine) t.reused) in let base = match (ran, names t.reused) with | [], [] -> "no checks configured" | [], _ -> Fmt.str "checks reused from %s" (String.concat ", " machines) | _, [] -> Fmt.str "checks %s (%s)" (String.concat " " ran) took | _, rs -> Fmt.str "checks %s (%s), %s reused from %s" (String.concat " " ran) took (String.concat " " rs) (String.concat ", " machines) in let flaked = match flaked with | [] -> [] | fs -> [ Fmt.str "%s flaked and passed on its rerun" (String.concat " " fs) ] in String.concat "; " ((base :: flaked) @ t.unrecorded)
let with_unrecorded t detail = String.concat "; " (detail :: t.unrecorded)
(* [l]'s checks in the order the branch lists them. *)let in_order t l = List.filter_map (fun (k : Check.t) -> List.find_opt (fun ((r : Check.t), _) -> Check.equal_name r.name k.name) l) t.req.checks
let is_inherited t (k : Check.t) = List.exists (fun ((r : Check.t), _) -> Check.equal_name r.name k.name) t.inherited
(* An inherited check, as a clause of the checks' ending. *)let inherited_clause t ((k : Check.t), _) = Fmt.str "check %a fails as %a's tip %s does" Check.pp_name k.name Branch.pp t.req.target (Commit.short t.req.target_tip)
(* The clause that names the checks that passed: every check but those [left_out] says. *)let passed_clause t ~left_out = match List.filter_map (fun (k : Check.t) -> if left_out k then None else Some (Check.string_of_name k.name)) t.req.checks with | [] -> [] | [ k ] -> [ Fmt.str "check %s passed" k ] | ks -> [ Fmt.str "checks %s passed" (String.concat " " ks) ]
(* The checks that ended, none red of its own and some inherited: the change is held until its target moves. *)let base_red t = let inherited = in_order t t.inherited in let passed = passed_clause t ~left_out:(is_inherited t) in Base_red { detail = String.concat "; " (List.map (inherited_clause t) inherited @ passed); reds = List.map snd inherited; }
(* The red of checks that all ended, some red: each red with why, in the order the branch lists them, then the checks that passed. *)let red t = let is_red (k : Check.t) = List.exists (fun ((r : Check.t), _, _) -> Check.equal_name r.name k.name) in let reds = List.filter_map (fun (k : Check.t) -> List.find_opt (fun ((r : Check.t), _, _) -> Check.equal_name r.name k.name) t.reds) t.req.checks in let failed = List.map (fun ((k : Check.t), why, _) -> Fmt.str "check %a failed%s" Check.pp_name k.name why) reds in let passed = passed_clause t ~left_out:(fun k -> is_red k t.reds || is_inherited t k) in let failed = failed @ List.map (inherited_clause t) (in_order t t.inherited) in let check, log = match reds with | ((k : Check.t), _, (r : Outcome.red)) :: _ -> (k.name, r.log) | [] -> invalid_arg "Checking.red: no red" in Red { check; detail = String.concat "; " (failed @ passed); log; recorded = None; reds = List.map (fun (_, _, r) -> r) reds; }
(* The log of the newest attempt of [k] still on this machine. *)let stored_log req (k : Check.t) = List.fold_left (fun acc (n, attempt, path) -> if Check.equal_name n k.name then match acc with | Some (best, _) when best >= attempt -> acc | _ -> Some (attempt, path) else acc) None req.logs |> Option.map snd
let stored_red req (k : Check.t) notes = let recorded = match List.rev notes with (n : Note.t) :: _ -> Some n.at | [] -> None in let clause = match recorded with | Some at -> Fmt.str ", recorded %s" (Timestamp.Rfc3339.format at) | None -> "" in let log = stored_log req k in Red { check = k.name; detail = Fmt.str "check %a failed%s" Check.pp_name k.name clause; log; recorded; reds = [ { Outcome.check = k.name; log; failures = Failures.empty } ]; }
let held_detail (l : notes_lock) = Fmt.str "%a is held by another process, or was left by one that died" Fpath.pp l.held.path
(* {1 Printing} *)
let pp_ending ppf = function | Passed c -> Fmt.pf ppf "passed (%s)" c | Red { detail; _ } -> Fmt.pf ppf "red (%s)" detail | Base_red { detail; _ } -> Fmt.pf ppf "base red (%s)" detail | Stuck { detail; _ } -> Fmt.pf ppf "stuck (%s)" detail | Unavailable why -> Fmt.pf ppf "unavailable (%s)" why | Busy why -> Fmt.pf ppf "busy (%s)" why | Withdrawn -> Fmt.string ppf "withdrawn" | Drained why -> Fmt.pf ppf "drained (%s)" why
let pp ppf t = Fmt.pf ppf "checks of %a: %d to start, %d running, %d ran, %d reused%a" Key.pp t.req.key (List.length t.queue) (List.length t.running) (List.length t.ran) (List.length t.reused) Fmt.(option (any ", " ++ pp_ending)) t.decided
let pp_event ppf (e : event) = match e with | Run (n, e) -> Fmt.pf ppf "check %a: %a" Check.pp_name n Check_run.pp_event e | Recorded n -> Fmt.pf ppf "recorded %a" Check.pp_name n | Not_recorded (n, why) -> Fmt.pf ppf "not recorded %a: %s" Check.pp_name n why | Cancelled why -> Fmt.pf ppf "cancelled because %s" why | Drain why -> Fmt.pf ppf "drained because %s" why | Failed why -> Fmt.pf ppf "failed: %s" why | Prepared -> Fmt.string ppf "prepared" | Unprepared (`Msg why) -> Fmt.pf ppf "unprepared: %s" why | Unprepared (`Busy why) -> Fmt.pf ppf "unprepared, busy: %s" why
let pp_action ppf (a : action) = match a with | Run (n, a) -> Fmt.pf ppf "check %a: %a" Check.pp_name n Check_run.pp_action a | Note { note; _ } -> Fmt.pf ppf "note %a" Note.pp note | Journal k -> Fmt.pf ppf "journal %s" (Event.kind_name k) | Remove_lock h -> Fmt.pf ppf "remove %a" Fpath.pp h.path | Remove_worktree p -> Fmt.pf ppf "remove the worktree %a" Fpath.pp p | Prepare { generations; _ } -> Fmt.pf ppf "prepare %a" Fmt.(list ~sep:sp (using Generation.path Fpath.pp)) generations
(* {1 Transitions} *)
(* How the checks end: at once once withdrawn; otherwise once every run stopped has answered, and, but for an unavailable ending, every note asked for, with what could not be recorded said. *)let ending t = match t.decided with | Some (Withdrawn as e) -> Some e | Some _ when t.stopping <> [] -> None | Some ((Unavailable _ | Busy _) as e) -> Some e | Some _ when t.pending > 0 -> None | Some (Red r) -> Some (Red { r with detail = with_unrecorded t r.detail }) | Some (Base_red r) -> Some (Base_red { r with detail = with_unrecorded t r.detail }) | Some (Stuck s) -> Some (Stuck { s with detail = with_unrecorded t s.detail }) | Some (Passed _) -> Some (Passed (clause t)) | Some (Drained _ as e) -> Some e | None -> None
let decide t e = { t with decided = Some e }let run_actions n = List.map (fun a -> (Run (n, a) : action))
let start t ~now ~gang (k : Check.t) = let req = t.req in let run, actions = Check_run.v { Check_run.check = k; key = req.key; commit = req.commit; target = req.target; target_tip = req.target_tip; wall = wall_of req k; grace = req.grace; slot_wait = req.slot_wait; tag = { job = req.job; serve = req.serve; gang }; } ~now in ({ t with running = t.running @ [ (k, run) ] }, run_actions k.name actions)
(* The checks to start while fewer than [slots] run, shortest first, a failure's rerun holding its check's place, those started at once a gang ({!Order.tag}); or the end once none is left. *)let rec next ?gang t ~now = match (t.queue, t.running) with | [], [] -> ( match (t.drained, t.reds, t.inherited) with | Some why, _, _ -> (decide t (Drained why), []) | None, [], [] -> (decide t (Passed (clause t)), []) | None, [], _ -> (decide t (base_red t), []) | None, _, _ -> (decide t (red t), [])) | k :: queue, running when List.length running < max 1 t.req.slots -> let gang = match gang with | Some g -> g | None -> min (List.length t.queue) (max 1 t.req.slots - List.length running) in let t, actions = start { t with queue } ~now ~gang k in let t, more = next ~gang t ~now in (t, actions @ more) | _ -> (t, [])
(* The runs under way, stopped because of [why]: each stopped attempt is awaited until its task answers, and a run stopped under way is recorded then, stopped and why ({!Check_run}); one still waiting for a build slot records nothing. *)let stop_running ?(only = fun _ -> true) t ~now ~why = let stopped, kept = List.partition (fun (_, run) -> only run) t.running in let withdrawing, actions = List.fold_left (fun (ws, acc) ((k : Check.t), run) -> match Check_run.incoming run ~now (Check_run.Cancelled why) with | Ok (run, actions) -> let ws = match Check_run.ending run with | Some _ -> ws | None -> ws @ [ (k, run) ] in (ws, acc @ run_actions k.name actions) | Error _ -> (ws, acc)) (t.withdrawing, []) stopped in ({ t with running = kept; queue = []; withdrawing }, actions)
(* Each run a [Stop] among [actions] cancels owes its task's answer, which is an end of that attempt: the ending waits for it. *)let track t actions = let stopped = List.filter_map (function | (Run (n, Check_run.Stop { attempt; _ }) : action) -> Some (n, attempt) | Run (_, (Start _ | Hold _)) | Note _ | Journal _ | Remove_lock _ | Remove_worktree _ | Prepare _ -> None) actions in ({ t with stopping = t.stopping @ stopped }, actions)
let answer t n (ce : Check_run.event) = match ce with | Ended { attempt; _ } -> { t with stopping = List.filter (fun (n', a) -> not (Check.equal_name n n' && Int.equal a attempt)) t.stopping; } | Slot_taken _ | Command_started _ | Cancelled _ -> t
(* The verdict on [key] taken from the stored result [n], as a fact. *)let reuse key (n : Note.t) = Journal (Event.Reused { check = n.check; key; result = n.result; machine = n.machine; seconds = Duration.seconds n.seconds; at = n.at; })
let verdict t (k : Check.t) = if (not t.req.retry) && Check.reusable k then Results.verdict ~reader:t.req.mode t.results k.name (config t.req k) else Results.Missing
(* [checks] in the order {!Order.v} gives the land's one job: shortest estimate first, ties in the order the branch lists them. *)let shortest_first req ~now (checks : Check.t list) = let job = { Order.branch = req.target; arrived = now; ready = List.map (fun (k : Check.t) -> k.name) checks; } in Order.v req.estimates ~now [ job ] |> List.filter_map (fun (_, n) -> List.find_opt (fun (k : Check.t) -> Check.equal_name k.name n) checks)
(* The checks stuck on the notes ref another writer holds: no run ended them. *)let held l = Stuck { detail = held_detail l; log = None; attempt = None }
(* The checks of [req], before any verdict. *)let fresh req ~now = { req; results = Results.of_notes req.key req.notes; queue = []; running = []; ran = []; reds = []; inherited = []; reused = []; captured = []; pending = 0; stopping = []; withdrawing = []; unrecorded = []; decided = None; drained = None; preparing = false; began = now; last_end = None; }
let v req ~now = let t = fresh req ~now in match req.notes_lock with | Some l when not (stale l) -> (decide t (held l), []) | lock -> ( let unlock = (match lock with Some l -> [ Remove_lock l.held ] | None -> []) @ List.map (fun p -> Remove_worktree p) req.leftovers in let verdicts = List.map (fun k -> (k, verdict t k)) req.checks in match List.find_map (fun (k, v) -> match v with Results.Failed ns -> Some (k, ns) | _ -> None) verdicts with | Some (k, ns) -> let newest = match List.rev ns with n :: _ -> [ reuse req.key n ] | [] -> [] in (decide t (stored_red req k ns), unlock @ newest) | None -> ( let reused = List.filter_map (fun (k, v) -> match v with Results.Passed n -> Some (k, n) | _ -> None) verdicts in let queue = shortest_first req ~now (List.filter_map (fun (k, v) -> match v with Results.Passed _ -> None | _ -> Some k) verdicts) in let t = { t with reused; queue } in let reuses = List.map (fun (_, n) -> reuse req.key n) reused in match queue with | [] -> (decide t (Passed (clause t)), unlock @ reuses) | _ -> (* The prerequisites every check reads come first, once, so that no check waits on another's preparation of them. *) let t, actions = match req.prerequisites with | [] -> next t ~now | generations -> ( { t with preparing = true }, [ Prepare { commit = req.commit; generations } ] ) in let checks = List.map (fun (k : Check.t) -> k.name) req.checks in ( t, unlock @ reuses @ Journal (Event.Checking { target = req.target; checks }) :: actions )))
let note_of t (k : Check.t) (r : Check_run.run) = Note.v ~result:r.result ~check:k.name ~tree:(Key.tree t.req.key) ~attempt:r.attempt ~config:(config t.req k) ~rules:t.req.rules ~machine:t.req.machine ~mode:t.req.mode ~confined: (match (k.definition, t.req.confinement) with | (Check.Command _ | Check.Hook _), Confinement.Confined m -> Some m | (Check.Command _ | Check.Hook _), Confinement.Unconfined _ | Check.Rules, _ -> None) ~seconds:(Duration.of_seconds r.seconds) ~at:r.at ?log:r.digest ()
(* The records of the runs [run] finished since [before]: a journal record and a note asked for each, the journal's first, the journal saying whether the run is rerun, which [started] says: the attempts [run] started meanwhile. A run of a check the land withdrew ([~withdrawn]) has its journal record and no note: stopped, it says nothing about the tree, and ended by itself first, it is no longer the land's to record. A result that cannot be written as a note line is said, never dropped. *)let records ?(withdrawn = false) t (k : Check.t) run ~before ~started = List.filteri (fun i _ -> i >= before) (Check_run.runs run) |> List.fold_left (fun (t, (journals, notes)) (r : Check_run.run) -> let journal = Journal (Event.Check { check = k.name; key = t.req.key; result = r.result; seconds = r.seconds; log = r.log; attempt = r.attempt; rerun = List.mem (r.attempt + 1) started; build = r.build; phases = r.phases; stopped = r.stopped; reason = r.reason; failures = r.failures; }) in match note_of t k r with | _ when withdrawn -> (t, (journals @ [ journal ], notes)) | Ok note -> ( { t with pending = t.pending + 1; captured = note :: t.captured }, ( journals @ [ journal ], notes @ [ Note { key = t.req.key; note } ] ) ) | Error (`Msg m) -> ( { t with unrecorded = t.unrecorded @ [ Fmt.str "the result of check %a was not recorded: %s" Check.pp_name k.name m; ]; }, (journals @ [ journal ], notes) )) (t, ([], []))
let last_log run = match List.rev (Check_run.runs run) with r :: _ -> r.log | [] -> None
(* A confirmed red as its outcome lists it: its last run's log and what that run named as failed. *)let last_red (k : Check.t) run : Outcome.red = match List.rev (Check_run.runs run) with | r :: _ -> { check = k.name; log = r.log; failures = r.failures } | [] -> { check = k.name; log = None; failures = Failures.empty }
(* Why a confirmed red failed, after "check NAME failed": what its last run marked as failed, its count and the first; else the run's exit status, as a CI runner gives it, then what its confinement denied or the last line it wrote (doc/outcomes.md). The rules check runs in mq, so its status is its verdict and its line mq's finding, said bare. *)let why_red (k : Check.t) run = match (k.definition, List.rev (Check_run.runs run)) with | Check.Rules, { said = Some said; _ } :: _ -> Fmt.str " (%s)" said | _, { status = Denied { code; what }; _ } :: _ -> Fmt.str " with exit code %d, denied: %s" code what | _, { failures; status = Exited code; said; _ } :: _ -> ( match (Failures.summary failures, said) with | Some marked, _ -> ": " ^ Check_run.cut marked | None, Some said -> Fmt.str " with exit code %d, last line \"%s\"" code said | None, None -> Fmt.str " with exit code %d" code) | _ -> ""
let seconds run = List.fold_left (fun s (r : Check_run.run) -> s + r.seconds) 0 (Check_run.runs run)
(* The attempts on this tree of [k] that its run did not decide, this one included: the stuck and errored results recorded for the tree under [k]'s configuration, and one. *)let undecided_attempt t (k : Check.t) = let config = config t.req k in let undecided (n : Note.t) = Check.equal_name n.check k.name && Build_config.equal n.config config && match n.result with | Check.Stuck | Check.Error -> true | Check.Passed | Check.Failed | Check.Inherited | Check.Stopped -> false in 1 + List.length (List.filter undecided (Results.notes t.results))
(* A run that ended: the next check, or how the checks end. A confirmed red stops no other check: every check runs to its verdict. *)let ended t ~now (k : Check.t) run ending = let t = { t with running = List.filter (fun ((k' : Check.t), _) -> not (Check.equal_name k'.name k.name)) t.running; ran = t.ran @ [ (k, ending, seconds run) ]; last_end = Some now; } in (* The checks stuck: the runs still under way are stopped, because of what ended them. *) let stuck detail log = let t, stops = stop_running t ~now ~why:detail in ( decide t (Stuck { detail; log; attempt = Some (undecided_attempt t k) }), stops ) in match (ending : Check_run.ending) with | Passed | Flaked -> next t ~now | Confirmed_red -> next { t with reds = t.reds @ [ (k, why_red k run, last_red k run) ] } ~now | Inherited -> next { t with inherited = t.inherited @ [ (k, last_red k run) ] } ~now | Stuck -> stuck (Fmt.str "check %a %s" Check.pp_name k.name (Check_run.wall_clause (Check_run.request run))) (last_log run) | Starved -> let detail = Fmt.str "check %a waited for a build slot (%a)" Check.pp_name k.name Rules.pp_bound (Rules.Wait_wall, t.req.slot_wait) in let t, stops = stop_running t ~now ~why:detail in (decide t (Busy detail), stops) | Errored why -> stuck (Fmt.str "check %a %s" Check.pp_name k.name why) (last_log run) | Waited why -> let detail = Fmt.str "check %a %s" Check.pp_name k.name why in let t, stops = stop_running t ~now ~why:detail in (decide t (Busy detail), stops) | Withdrawn -> let t, stops = stop_running t ~now ~why:(Fmt.str "check %a was withdrawn" Check.pp_name k.name) in (decide t Withdrawn, stops)
(* The answer of a run stopped under way: its record, once it has one. *)let on_withdrawn t ~now (k : Check.t) run ce = let before = List.length (Check_run.runs run) in match Check_run.incoming run ~now ce with | Error _ as err -> err | Ok (run, cactions) -> let others = List.filter (fun ((k' : Check.t), _) -> not (Check.equal_name k'.name k.name)) t.withdrawing in let withdrawing = match Check_run.ending run with | Some _ -> others | None -> t.withdrawing in let t, (journals, notes) = records ~withdrawn:true { t with withdrawing } k run ~before ~started:[] in Ok (t, run_actions k.name cactions @ journals @ notes)
(* Where a run under way is, journaled for whoever follows the land. *)let phase_record t (k : Check.t) (ce : Check_run.event) : action list = let started attempt phase = [ Journal (Event.Check_started { check = k.name; key = t.req.key; attempt; phase }); ] in match ce with | Slot_taken { attempt; _ } -> started attempt Event.Preparing | Command_started { attempt } -> started attempt Event.Running | Ended _ | Cancelled _ -> []
let on_run t ~now e n ce = let t = answer t n ce in let named ((k : Check.t), _) = Check.equal_name k.name n in match List.find_opt named t.running with | None -> ( match (List.find_opt named t.withdrawing, t.decided) with | Some (k, run), _ -> on_withdrawn t ~now k run ce | None, Some _ -> (* A late answer of a run cancelled: an end is its task's last. *) Ok (t, []) | None, None -> Machine.unexpected machine ~state:(Fmt.str "%a" pp t) ~event:(Fmt.str "%a" pp_event e)) | Some (k, run) -> ( let before = List.length (Check_run.runs run) in match Check_run.incoming run ~now ce with | Error _ as err -> err | Ok (run, cactions) -> ( let t = { t with running = List.map (fun ((k' : Check.t), r) -> if Check.equal_name k'.name k.name then (k, run) else (k', r)) t.running; } in (* The notes come last: a note the shell could not write stops only the actions after it in its list (doc/design.md, "A failed action is an event"), each answered as not recorded. *) let started = List.filter_map (function | Check_run.Start { attempt; _ } -> Some attempt | Check_run.Stop _ | Check_run.Hold _ -> None) cactions in let t, (journals, notes) = records t k run ~before ~started in let journals = phase_record t k ce @ journals in let runs = run_actions k.name cactions in match Check_run.ending run with | None -> Ok (t, runs @ journals @ notes) | Some ending -> let t, next = ended t ~now k run ending in Ok (t, runs @ next @ journals @ notes)))
let answered t = { t with pending = max 0 (t.pending - 1) }
let incoming t ~now (e : event) = Result.map (fun (t, actions) -> track t actions) @@ match e with | Run (n, ce) -> on_run t ~now e n ce | Recorded _ -> Ok (answered t, []) | Not_recorded (n, why) -> let t = answered t in Ok ( { t with unrecorded = t.unrecorded @ [ Fmt.str "the result of check %a was not recorded: %s" Check.pp_name n why; ]; }, [] ) | Cancelled why -> let t, stops = stop_running t ~now ~why in Ok (decide t Withdrawn, stops) | Drain _ when Option.is_some t.decided -> Ok (t, []) | Drain why -> (* The checks not started yet, and the runs still waiting for a build slot, are dropped; the runs under way go on to their verdicts. *) let dropped = t.queue <> [] || List.exists (fun (_, r) -> Check_run.waiting r) t.running in let t, stops = stop_running ~only:Check_run.waiting t ~now ~why in let t = if dropped then { t with drained = Some why } else t in if t.running = [] && not t.preparing then let t, more = next t ~now in Ok (t, stops @ more) else Ok (t, stops) | Failed why -> ( let t, stops = stop_running t ~now ~why:("mq could not record the checks: " ^ why) in (* A failed action cancels the actions after it in its list: their answers say nothing the first failure did not, and its reason stands. *) match t.decided with | Some (Unavailable _) -> Ok (t, stops) | _ -> Ok (decide t (Unavailable why), stops)) | Prepared when t.preparing && Option.is_none t.decided -> next { t with preparing = false } ~now |> Result.ok | Prepared -> Ok ({ t with preparing = false }, []) | Unprepared cause -> let t = { t with preparing = false } in let why = match cause with `Msg why | `Busy why -> why in let detail = "the dependency generations could not be prepared: " ^ why in let t, stops = stop_running t ~now ~why:detail in let ending = match cause with | `Busy _ -> Busy detail | `Msg _ -> Stuck { detail; log = None; attempt = None } in Ok (decide t ending, stops)
(* Each run's timer, in turn, on the runs still under way: a run the timer ends (no build slot within bounds.wait_wall) ends the checks as an Ended would. *)let tick t ~now = List.fold_left (fun acc ((k : Check.t), _) -> match acc with | Error _ -> acc | Ok (t, actions) -> ( match List.find_opt (fun ((k' : Check.t), _) -> Check.equal_name k'.name k.name) t.running with | None -> acc | Some (_, run) -> ( match Check_run.timer run ~now with | Error _ as e -> e | Ok (run, more) -> ( let t = { t with running = List.map (fun ((k' : Check.t), r) -> if Check.equal_name k'.name k.name then (k, run) else (k', r)) t.running; } in let more = run_actions k.name more in match Check_run.ending run with | None -> Ok (t, actions @ more) | Some ending -> let t, next = ended t ~now k run ending in Ok (t, actions @ more @ next))))) (Ok (t, [])) t.running
let timer t ~now = Result.map (fun (t, actions) -> track t actions) (tick t ~now)
let next_timeout t = List.fold_left (fun acc (_, run) -> match (acc, Check_run.next_timeout run) with | None, d | d, None -> d | Some a, Some b -> Some (if Ptime.compare a b <= 0 then a else b)) None t.running
let prepare_task = Machine.Task.v "prepare"
let task : action -> Machine.Task.t = function | Run (n, a) -> Machine.Task.under ("check " ^ Check.string_of_name n) (Check_run.task a) | Prepare _ -> Machine.Task.Start prepare_task | Note _ | Journal _ | Remove_lock _ | Remove_worktree _ -> Machine.Task.Now
let unanswered a why : event = match a with | Run (n, a) -> Run (n, Check_run.unanswered a why) | Note { note; _ } -> Fmt.kstr (fun s -> Not_recorded (note.check, s)) "%a" Machine.pp_unanswered why | Prepare _ -> Fmt.kstr (fun s -> Unprepared (`Msg s)) "%a" Machine.pp_unanswered why | Journal _ | Remove_lock _ | Remove_worktree _ -> Fmt.kstr (fun s -> Failed s) "%a" Machine.pp_unanswered why
let running t = List.map (fun ((k : Check.t), _) -> k.name) t.running
let waiting t = List.length t.queue + List.length (List.filter (fun (_, r) -> Check_run.waiting r) t.running)
let idle t = match (t.running, t.stopping) with [], [] -> t.pending = 0 | _ -> false
let footprint t = let n = List.length in n (Results.notes t.results) + n t.req.scripts + n t.req.logs + n t.req.leftovers + n t.queue + n t.ran + n t.reds + n t.inherited + n t.captured + n t.reused + n t.unrecorded + n t.stopping + List.fold_left (fun s (_, r) -> s + 1 + n (Check_run.runs r)) 0 (t.running @ t.withdrawing)
let certificates t = match t.decided with | Some (Passed _) -> let notes = t.captured @ List.map snd t.reused in let rec collect acc = function | [] -> Ok (List.rev acc) | (c : Check.t) :: rest -> ( match List.find_opt (fun (n : Note.t) -> Check.equal_name n.check c.name && n.result = Check.Passed) notes with | Some n -> collect (n :: acc) rest | None -> Fmt.error "check %a passed without a representable certificate" Check.pp_name c.name) in collect [] t.req.checks | _ -> Error "checks have not passed"