Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
5.1 kB · 151 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152type settlement = Finished of Outcome.t | Restartedtype settled = { name : Branch.t; entry : Record.id; settlement : settlement }type pass = { rules : Rules.t; rules_commit : Commit.t; settled : settled list }
type refusal = | Lock_held of { holder : int option; waited : Duration.t } | Unavailable of string
module type S = sig include Machine.S
val signal : Signal.t -> event val needs_lock : t -> bool val queued : t -> (Branch.t * Record.id) option val exit_code : ending -> int val reason : ending -> string option
val run_started : t -> now:Ptime.t -> (pass, refusal) result -> (t * action list, Machine.error) resultend
module Then (A : S) (B : S) = struct type t = { a : A.t; b : B.t; pass : pass option; (** The pass the run handed, once handed. *) b_started : bool; (** Whether [b] was handed the run. *) pending : Signal.t option; (** A signal that came while [a] ran, for [b] once it is handed the run. *) }
type event = First of A.event | Second of B.event | Signalled of Signal.t type action = First of A.action | Second of B.action type ending = A.ending option * B.ending
let first actions = List.map (fun a : action -> First a) actions let second actions = List.map (fun a : action -> Second a) actions
let v a (b, actions) = ({ a; b; pass = None; b_started = false; pending = None }, second actions)
let a_running t = Option.is_some t.pass && Option.is_none (A.ending t.a)
(* A signal held while [a] ran reaches [b] once [b] has the run, so [b] answers from what the run's recovery settled. *) let deliver t ~now = match t.pending with | None -> Ok (t, []) | Some s -> Result.map (fun (b, actions) -> ({ t with b; pending = None }, second actions)) (B.incoming t.b ~now (B.signal s))
(* Once [a] has ended under the lock, [b] is handed the same pass. *) let start_b t ~now = match (t.pass, A.ending t.a, t.b_started, B.ending t.b) with | Some pass, Some _, false, None -> ( match B.run_started t.b ~now (Ok pass) with | Error _ as e -> e | Ok (b, actions) -> Result.map (fun (t, more) -> (t, second actions @ more)) (deliver { t with b; b_started = true } ~now)) | _ -> Ok (t, [])
let after_a t ~now (a, actions) = Result.map (fun (t, more) -> (t, first actions @ more)) (start_b { t with a } ~now)
let after_b t (b, actions) = Ok ({ t with b }, second actions)
(* A signal is [b]'s to decide. While [a] runs, under the lock, it is held until [b] has the run: [a] is bounded, and [b] then answers from what the run's recovery settled, a landing a killed run made included. *) let incoming t ~now (e : event) = match e with | First e -> Result.bind (A.incoming t.a ~now e) (after_a t ~now) | Second e -> Result.bind (B.incoming t.b ~now e) (after_b t) | Signalled s when a_running t -> Ok ({ t with pending = Some s }, []) | Signalled s -> Result.bind (B.incoming t.b ~now (B.signal s)) (after_b t)
let due now = function Some at -> Ptime.compare at now <= 0 | None -> false
let timer t ~now = if a_running t && due now (A.next_timeout t.a) then Result.bind (A.timer t.a ~now) (after_a t ~now) else if due now (B.next_timeout t.b) then Result.bind (B.timer t.b ~now) (after_b t) else Ok (t, [])
let earliest a b = match (a, b) with | Some x, Some y -> Some (if Ptime.compare x y <= 0 then x else y) | Some x, None | None, Some x -> Some x | None, None -> None
let next_timeout t = earliest (if a_running t then A.next_timeout t.a else None) (B.next_timeout t.b)
let ending t = match B.ending t.b with Some b -> Some (A.ending t.a, b) | None -> None
let task : action -> Machine.Task.t = function | First a -> Machine.Task.under "first" (A.task a) | Second a -> Machine.Task.under "second" (B.task a)
let unanswered (a : action) why : event = match a with | First a -> First (A.unanswered a why) | Second a -> Second (B.unanswered a why)
let signal s = Signalled s
let needs_lock t = Option.is_none t.pass && (not t.b_started) && B.needs_lock t.b
let queued t = B.queued t.b let exit_code (_, b) = B.exit_code b let reason (_, b) = B.reason b
let run_started t ~now r = match r with | Ok pass -> let t = { t with pass = Some pass } in Result.bind (A.run_started t.a ~now r) (after_a t ~now) | Error _ -> Result.bind (B.run_started t.b ~now r) (after_b { t with b_started = true })
let pp ppf t = if a_running t then Fmt.pf ppf "%a, before %a" A.pp t.a B.pp t.b else B.pp ppf t.b
let pp_event ppf : event -> unit = function | First e -> A.pp_event ppf e | Second e -> B.pp_event ppf e | Signalled s -> Fmt.pf ppf "signalled %a" Signal.pp s
let pp_action ppf : action -> unit = function | First a -> A.pp_action ppf a | Second a -> B.pp_action ppf a
let work t = t.bend