Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
30 kB · 839 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840type request = { remote : string option; branches : Branch.t list }
type context = { rules : Rules.t; rules_branch : Branch.t; default_remote : string option; attest : bool;}
type local = { branch : Branch.t; value : Commit.t; push_remote : string option; pull_remote : string option;}
type update = { branch : Branch.t; expected : Commit.t option; value : Commit.t;}
type evidence_update = { expected : Commit.t option; value : Commit.t }type results = Unchanged | Forward of evidence_update | Lacked
type remote = { name : string; url : string; seen_key : string; values : (Branch.t * Commit.t) list; seen : (Branch.t * Commit.t) list; tracking : (Branch.t * Commit.t) list; contains : (Commit.t * Commit.t) list; evidence : Commit.t option; evidence_held : bool; results : results; origins : results;}
type plan = { remote : string; url : string; agreed : bool; updates : update list; current : update list; track : Branch.t list; evidence : evidence_update option; results : evidence_update option; origins : evidence_update option;}
type event = | Local_read of local list | Remote_read of remote list | Attested of { evidence : Commit.t option; attested : int } | Unattested of string | Unreachable of { remote : string; why : string } | Unsupported of { remote : string; why : string } | Untrusted of { remote : string; why : string } | Pushed of { landings : int } | Checkpointed | Stale of { branch : Branch.t; held : Commit.t option } | Push_refused of string | Push_unknown of string | Checkpoint_held of string | Journalled | Recorded | Signalled of Signal.t | Unanswered of action * Machine.unanswered
and action = | Read_local | Read_remote of { remote : string; branches : Branch.t list; commits : Commit.t list; } | Attest of { updates : update list } | Push of plan | Checkpoint_only of { remote : string; branches : (Branch.t * Commit.t) list; } | Journal of Event.kind | Record of { remote : remote; updates : update list; track : Branch.t list }
type ending = (Report.t, Outcome.t) resulttype target = string * (local * Commit.t) list
(* One push URL's turn: the plan it takes, or, named by its remote and URL, the refusal its read gave. *)type turn = (plan * remote, string * string * Outcome.t) result
type phase = | Reading_local | Reading_remote of { current : target; rest : target list; read : (target * remote) list; } | Attesting of turn list | Pushing of { plan : plan; facts : remote; rest : turn list } | Checkpointing of { remote : string; original : Outcome.t } | Recording of { plan : plan; rest : turn list } | Journalling of Outcome.t | Done of ending
type t = { context : context; request : request; phase : phase; sent : (plan * int) list; (** The plans the remotes took, newest first. *) tracked : (string * Branch.t list) list; (** The branches set up to track each remote, newest first. *) missed : (string * string * Outcome.t) list; (** The push URLs of the remote being pushed that did not take the push, each with its remote and why, newest first. *) attested : int; (** The attestations added to the evidence ref. *)}
let machine = "push"
let v context request = ( { context; request; phase = Reading_local; sent = []; tracked = []; missed = []; attested = 0; }, [ Read_local ] )
let plural n one = if n = 1 then Fmt.str "1 %s" one else Fmt.str "%d %ss" n one
let find b l = List.find_opt (fun (x, _) -> Branch.equal x b) l |> Option.map snd
(* {1 What goes where} *)
let in_dag ctx b = Branch.equal b ctx.rules_branch || Rules.names ctx.rules b
(* How far a branch is from the branch the DAG enters by: a source is sent before the branches that take from it, so no remote holds a [main] its [staging] lacks, even between two updates. *)let rec depth ctx b = match Rules.takes ctx.rules b with | Some s when not (Branch.equal s b) -> 1 + depth ctx s | _ -> 0
let refused ?branch ?next detail = Outcome.v ?branch ?next Outcome.Refused detail
let local_of locals b = List.find_opt (fun (l : local) -> Branch.equal l.branch b) locals
let branch_remote remote locals b = match remote with | Some _ -> remote | None -> Option.bind (local_of locals b) (fun (l : local) -> l.push_remote)
(* A work branch named: Git pushes it, to the remote it would go to. *)let work_branch ~remote locals b = let to_ = branch_remote remote locals b in Fmt.kstr (refused ~branch:b ?next:(Option.map (fun r -> Fmt.str "git push %s %a" r Branch.pp b) to_)) "%a is not a branch of the DAG: a work branch is pushed with Git" Branch.pp b
(* The branches named, each at its own value, then the branches they take from, each at the value of the branch that takes from it: the part of [staging] that [main] holds. *)let named ctx ~remote locals branches = let rec sources acc (l : local) value = match Rules.takes ctx.rules l.branch with | None -> Ok acc | Some s -> ( if List.exists (fun ((x : local), _) -> Branch.equal x.branch s) acc then Ok acc else match local_of locals s with | None -> Ok acc | Some ls -> sources (acc @ [ (ls, value) ]) ls value) in List.fold_left (fun acc b -> Result.bind acc @@ fun acc -> if not (in_dag ctx b) then Error (work_branch ~remote locals b) else match local_of locals b with | None -> Error (Fmt.kstr (refused ~branch:b) "%a is not a branch here" Branch.pp b) | Some l -> let acc = List.filter (fun ((x : local), _) -> not (Branch.equal x.branch b)) acc in sources (acc @ [ (l, l.value) ]) l l.value) (Ok []) branches |> Result.map (fun acc -> (* A branch named by the caller keeps its own value over the part a taker would give it. *) List.filter (fun ((l : local), v) -> Commit.equal l.value v || not (List.exists (Branch.equal l.branch) branches)) acc)
(* The remote Git pushes [l] to. The rules branch goes where the DAG's branches go when Git names no remote for it: mq init creates it with none. *)let remote_for ctx chosen (l : local) = match l.push_remote with | None when Branch.equal l.branch ctx.rules_branch -> List.find_map (fun ((l : local), _) -> if Branch.equal l.branch ctx.rules_branch then None else l.push_remote) chosen | r -> r
(* Every branch of the DAG this machine has, each at its own value: what a push with no branch sends. *)let every ctx locals = List.filter_map (fun (l : local) -> if in_dag ctx l.branch then Some (l, l.value) else None) locals
let destination ctx locals b = match local_of locals b with | Some l when in_dag ctx b -> remote_for ctx (every ctx locals) l | Some _ | None -> None
let tracking remote b = Fmt.kstr Branch.v "%s/%a" remote Branch.pp b
let targets ctx request locals = let chosen = match request.branches with | [] -> Ok (every ctx locals) | bs -> named ctx ~remote:request.remote locals bs in Result.bind chosen @@ fun chosen -> let with_remote = List.map (fun (((l : local), _) as x) -> match request.remote with | Some r -> Ok (r, x) | None -> ( match remote_for ctx chosen l with | Some r -> Ok (r, x) | None -> Error (Fmt.kstr (refused ~branch:l.branch ?next:(Option.map (( ^ ) "mq push ") ctx.default_remote)) "Git names no remote for %a (branch.%a.remote), and no \ REMOTE was given" Branch.pp l.branch Branch.pp l.branch))) chosen in match List.find_map (function Error o -> Some o | Ok _ -> None) with_remote with | Some o -> Error o | None -> let pairs = List.filter_map Result.to_option with_remote in let remotes = List.sort_uniq String.compare (List.map fst pairs) in Ok (List.map (fun r -> let bs = List.filter_map (fun (r', x) -> if String.equal r r' then Some x else None) pairs |> List.stable_sort (fun ((a : local), _) ((b : local), _) -> compare (depth ctx a.branch) (depth ctx b.branch)) in (r, bs)) remotes)
(* {1 What one remote takes} *)
let contains (facts : remote) a b = Commit.equal a b || List.exists (fun (x, y) -> Commit.equal x a && Commit.equal y b) facts.contains
let agreed_by remote (l : local) = match l.pull_remote with None -> true | Some p -> String.equal p remote
type verdict = | Update of update | Current of update | Behind of Outcome.t | No of Outcome.t * bool
let decide ~remote (facts : remote) ~agreed ((l : local), value) = let b = l.branch in let held = find b facts.values and seen = find b facts.seen in let at expected = { branch = b; expected; value } in let pull = Fmt.kstr (refused ~branch:b ~next:("mq pull " ^ remote)) "%s/%a holds commits %a lacks: nothing moved" remote Branch.pp b Branch.pp b in if agreed then match (held, seen) with | Some x, _ when Commit.equal x value -> Current (at (Some x)) | Some x, _ when contains facts x value -> Update (at (Some x)) | Some x, _ when contains facts value x -> Behind pull | Some _, _ -> No (pull, true) | None, Some _ -> No ( Fmt.kstr (refused ~branch:b ~next:(Fmt.str "git push %s %a" remote Branch.pp b)) "%a was deleted on %s, which held it when this machine last saw \ it: mq does not create it again" Branch.pp b remote, false ) | None, None -> Update (at None) else match (held, seen) with | Some x, _ when Commit.equal x value -> Current (at (Some x)) | held, seen when Option.equal Commit.equal held seen -> Update (at held) | _ -> No ( Fmt.kstr (refused ~branch:b) "%a moved on %s since this machine last pushed it there: nothing \ moved" Branch.pp b remote, false )
(* A remote whose check results or change origins this machine lacks refuses the push before any ref moves, as a branch the remote moved does (refs.md, decision 7). *)let lacked remote what ref = Fmt.kstr (refused ~next:("mq pull " ^ remote)) "%s holds %s in %a that this machine lacks: nothing moved" remote what Ref_name.pp ref
let lacks = function Lacked -> true | Unchanged | Forward _ -> falselet forward = function Forward e -> Some e | Unchanged | Lacked -> None
let plan_detailed ?(track = false) (remote, branches) (facts : remote) = let agreed = List.for_all (fun ((l : local), _) -> agreed_by remote l) branches in let verdicts = List.map (decide ~remote facts ~agreed) branches in match List.find_map (function No (o, checkpoint) -> Some (o, checkpoint) | _ -> None) verdicts with | Some o -> Error o | None -> ( match List.find_map (function Behind o -> Some o | _ -> None) verdicts with | Some o -> Error (o, true) | None when lacks facts.results -> Error (lacked remote "check results" Ref_name.notes, false) | None when lacks facts.origins -> Error (lacked remote "change origins" Ref_name.changes, false) | None -> let updates = List.filter_map (function Update u -> Some u | _ -> None) verdicts and current = List.filter_map (function Current u -> Some u | _ -> None) verdicts in let track = if not (track && agreed) then [] else List.filter_map (fun ((l : local), _) -> if Option.is_none l.pull_remote then Some l.branch else None) branches in Ok { remote; url = facts.url; agreed; updates; current; track; evidence = None; results = forward facts.results; origins = forward facts.origins; })
let plan ?track target facts = Result.map_error fst (plan_detailed ?track target facts)
(* {1 The report} *)
let subject (p : plan) = Fmt.str "%s to %s" (String.concat ", " (List.map (fun (u : update) -> Branch.to_string u.branch) (p.updates @ p.current))) p.remote
let report ~tracked ~attested sent = let tracked = List.rev tracked |> List.filter_map (fun (remote, bs) -> Report.tracking ~remote (List.map Branch.to_string bs)) |> List.map (( ^ ) "; ") |> String.concat "" in let sent = List.rev sent in let by_remote = List.fold_left (fun acc ((p : plan), landings) -> let prior = Option.value ~default:0 (List.assoc_opt p.remote acc) in (p.remote, max prior landings) :: List.remove_assoc p.remote acc) [] sent in let landings = List.fold_left (fun n (_, l) -> n + l) 0 by_remote in let moved = List.exists (fun ((p : plan), _) -> p.updates <> []) sent in let subjects = List.fold_left (fun (names, subjects) ((p : plan), _) -> if List.mem p.remote names then (names, subjects) else (p.remote :: names, subject p :: subjects)) ([], []) sent |> snd |> List.rev |> String.concat ", " in if List.for_all (fun ((p : plan), _) -> p.agreed) sent then let attested = if attested = 0 then "" else Fmt.str ", %d attested" attested in let detail = (if moved then plural landings "landing" ^ attested else "already up to date") ^ tracked in Report.v ~detail Report.Published subjects else Report.v Report.Pushed (subjects ^ "; not published")
(* {1 Transitions} *)
let pp_phase ppf = function | Reading_local -> Fmt.string ppf "reading the local branches" | Reading_remote { current = r, _; _ } -> Fmt.pf ppf "reading %s" r | Attesting _ -> Fmt.string ppf "attesting the landings" | Pushing { plan; _ } -> Fmt.pf ppf "pushing to %s" plan.remote | Checkpointing { remote; _ } -> Fmt.pf ppf "checkpointing to %s" remote | Recording { plan; _ } -> Fmt.pf ppf "recording what %s took" plan.remote | Journalling _ -> Fmt.string ppf "recording the refusal" | Done _ -> Fmt.string ppf "done"
let pp ppf t = Fmt.pf ppf "%s: %a" machine pp_phase t.phase
let pp_action ppf = function | Journal kind -> Fmt.pf ppf "journal %s" (Event.kind_name kind) | Read_local -> Fmt.string ppf "read the local branches" | Read_remote { remote; _ } -> Fmt.pf ppf "read %s" remote | Attest { updates } -> Fmt.pf ppf "attest %d updates" (List.length updates) | Push p -> Fmt.pf ppf "push %s" (subject p) | Checkpoint_only { remote; _ } -> Fmt.pf ppf "checkpoint to %s" remote | Record { remote; _ } -> Fmt.pf ppf "record what %s took" remote.name
let pp_event ppf = function | Local_read ls -> Fmt.pf ppf "%d local branches" (List.length ls) | Remote_read rs -> Fmt.pf ppf "%d endpoints read" (List.length rs) | Attested { attested; _ } -> Fmt.pf ppf "%d attested" attested | Unattested m -> Fmt.pf ppf "unattested: %s" (Console_text.strip m) | Unreachable { remote; why } -> Fmt.pf ppf "%s unreachable: %s" remote why | Unsupported { remote; why } -> Fmt.pf ppf "%s unsupported: %s" remote why | Untrusted { remote; why } -> Fmt.pf ppf "%s untrusted: %s" remote why | Pushed { landings } -> Fmt.pf ppf "pushed, %d landings" landings | Checkpointed -> Fmt.string ppf "checkpointed" | Stale { branch; _ } -> Fmt.pf ppf "%a stale" Branch.pp branch | Push_refused m -> Fmt.pf ppf "refused: %s" (Console_text.strip m) | Push_unknown m -> Fmt.pf ppf "unknown: %s" (Console_text.strip m) | Checkpoint_held m -> Fmt.pf ppf "checkpoint held: %s" (Console_text.strip m) | Journalled -> Fmt.string ppf "journalled" | Recorded -> Fmt.string ppf "recorded" | Signalled s -> Fmt.pf ppf "signalled %a" Signal.pp s | Unanswered (a, why) -> Fmt.pf ppf "%a: %a" pp_action a Machine.pp_unanswered why
let finish t e = Ok ({ t with phase = Done e }, [])
let fail ?remote t (o : Outcome.t) = match o.word with | Outcome.Refused -> let remote = match remote with None -> t.request.remote | Some _ -> remote in Ok ( { t with phase = Journalling o }, [ Journal (Event.Push_refused { remote; branches = t.request.branches; reason = o.detail }); ] ) | _ -> finish t (Error o)
let unavailable detail = Outcome.v Outcome.Unavailable detail
let movement t = if t.sent = [] then "nothing moved" else "earlier destinations moved"
let read_remote t ((remote, branches) as current) rest read = let commits = List.map snd branches in Ok ( { t with phase = Reading_remote { current; rest; read } }, [ Read_remote { remote; branches = List.map (fun ((l : local), _) -> l.branch) branches; commits; }; ] )
(* The refusal of a push some of [remote]'s push URLs did not take: the one refusal when no other URL was tried, else what each URL did, as git push reports each URL (builtin/push.c, do_push). The word is the first that is not a refusal, if any: a URL whose answer was lost may hold the push. *)let missed_outcome t remote ((_, _, (first : Outcome.t)) as m) others = let took = List.rev t.sent |> List.filter_map (fun ((p : plan), _) -> if String.equal p.remote remote then Some p.url else None) in match (took, others) with | [], [] -> first | _ -> let missed = m :: others in let did_not i (_, url, (o : Outcome.t)) = Fmt.str "%s did not take %s (%s)" url (if i = 0 && took = [] then "the push" else "it") o.detail in let took = match took with | [] -> [] | urls -> [ Fmt.str "%s took the push at %s" remote (String.concat ", " urls); ] in let word = List.find_map (fun (_, _, (o : Outcome.t)) -> match o.word with Outcome.Refused -> None | w -> Some w) missed |> Option.value ~default:Outcome.Refused in Outcome.v ?branch:first.branch ?next:first.next word (String.concat ", and " (took @ List.mapi did_not missed))
let turn_remote = function | Ok ((p : plan), _) -> p.remote | Error (remote, _, _) -> remote
(* git push goes on to a remote's next push URL past one that refused, and fails once every URL was tried (builtin/push.c, do_push): the push ends refused when the turns leave a remote some of whose URLs did not take it. *)let rec next_plan t rest = match (List.rev t.missed, rest) with | (remote, _, _) :: _, turn :: _ when String.equal remote (turn_remote turn) -> take t rest | ((remote, _, _) as m) :: others, _ -> fail ~remote t (missed_outcome t remote m others) | [], [] -> finish t (Ok (report ~tracked:t.tracked ~attested:t.attested t.sent)) | [], _ -> take t rest
and take t = function | [] -> next_plan t [] | Error m :: rest -> next_plan { t with missed = m :: t.missed } rest | Ok (p, facts) :: rest -> Ok ({ t with phase = Pushing { plan = p; facts; rest } }, [ Push p ])
(* The push URL [plan] names did not take the push, for [o]. *)let miss t (plan : plan) rest o = next_plan { t with missed = (plan.remote, plan.url, o) :: t.missed } rest
let record t (p : plan) facts rest = match p.updates @ p.current with | [] -> next_plan t rest | updates -> Ok ( { t with phase = Recording { plan = p; rest } }, [ Record { remote = facts; updates; track = p.track } ] )
(* The updates of the agreed copies, each once: a remote with two push URLs publishes the same landings twice. *)let attest t turns = let same (a : update) (b : update) = Branch.equal a.branch b.branch && Option.equal Commit.equal a.expected b.expected && Commit.equal a.value b.value in let updates = List.fold_left (fun acc -> function | Ok ((p : plan), _) when p.agreed -> acc @ List.filter (fun u -> not (List.exists (same u) acc)) p.updates | Ok _ | Error _ -> acc) [] turns in Ok ({ t with phase = Attesting turns }, [ Attest { updates } ])
(* The evidence ref goes to each agreed copy that lacks this machine's, by fast-forward; a copy that holds evidence this machine lacks refuses the push. *)let with_evidence evidence (turn : turn) = match (turn, evidence) with | Ok ((p : plan), (facts : remote)), Some value when p.agreed && not (Option.equal Commit.equal (Some value) facts.evidence) -> if facts.evidence_held then Ok (Ok ( { p with evidence = Some { expected = facts.evidence; value } }, facts )) else Error (Fmt.kstr refused "%s holds evidence in %s that this machine lacks: nothing moved" p.remote Evidence.ref_name) | _ -> Ok turn
let on_attested t turns ~evidence ~attested = let t = { t with attested } in match List.fold_left (fun acc turn -> Result.bind acc (fun acc -> Result.map (fun turn -> turn :: acc) (with_evidence evidence turn))) (Ok []) turns with | Error o -> fail t o | Ok turns -> next_plan t (List.rev turns)
let on_local t locals = match targets t.context t.request locals with | Error o -> let remote = Option.bind o.Outcome.branch (branch_remote t.request.remote locals) in fail ?remote t o | Ok [] -> fail t (refused "no branch of the DAG is here to push") | Ok (first :: rest) -> read_remote t first rest []
let on_remote t ((current : target), rest, read) facts = let read = read @ List.map (fun facts -> (current, facts)) facts in match rest with | next :: rest -> read_remote t next rest read | [] -> ( let plans = List.map (fun (target, (facts : remote)) -> match plan_detailed ~track:(Option.is_some t.request.remote) target facts with | Ok p -> Ok (p, facts) | Error o -> Error (target, facts.url, o)) read in (* A push URL whose read refuses the push is passed over when another of its remote's takes it, as git push goes on to the next URL; no checkpoint is sent there, since the work is published at the other. *) let planned remote = List.exists (function | Ok ((p : plan), _) -> String.equal p.remote remote | Error _ -> false) plans in let turns = List.map (function | Ok x -> Ok x | Error ((remote, _), url, (o, _)) -> Error (remote, url, o)) plans in match List.find_map (function | Error (((remote, _) as target), _, o) when not (planned remote) -> Some (target, o) | Error _ | Ok _ -> None) plans with | Some ((remote, branches), (o, true)) -> Ok ( { t with phase = Checkpointing { remote; original = o } }, [ Checkpoint_only { remote; branches = List.map (fun ((l : local), value) -> (l.branch, value)) branches; }; ] ) | Some ((remote, _), (o, false)) -> fail ~remote t o | None -> if t.context.attest then attest t turns else next_plan t turns)
let stale remote (b : Branch.t) movement = Fmt.kstr (refused ~branch:b ~next:("mq pull " ^ remote)) "%s/%a moved during the push: %s" remote Branch.pp b movement
let incoming t ~now:_ e = match (t.phase, e) with | Done _, _ -> Ok (t, []) | _, Signalled _ -> fail t (Outcome.v Outcome.Interrupted "the push was interrupted: what a remote took stays") | Reading_local, Local_read locals -> on_local t locals | Reading_remote { current; rest; read }, Remote_read facts -> on_remote t (current, rest, read) facts | Attesting turns, Attested { evidence; attested } -> on_attested t turns ~evidence ~attested | Attesting _, Unattested why -> fail t (Fmt.kstr refused "the landings could not be attested: %s: nothing moved" why) | Attesting _, Unanswered (Attest _, why) -> fail t (Fmt.kstr unavailable "the landings could not be attested: %a" Machine.pp_unanswered why) | Pushing { plan; rest; _ }, Unreachable { remote; why } -> miss t plan rest (Fmt.kstr unavailable "%s cannot be reached (%s): %s" remote why (movement t)) | ( Pushing { plan; rest; _ }, (Unsupported { remote; why } | Untrusted { remote; why }) ) -> miss t plan rest (Fmt.kstr refused "%s: %s: %s" remote why (movement t)) | Reading_remote _, Unreachable { remote; why } | Checkpointing _, Unreachable { remote; why } -> fail t (Fmt.kstr unavailable "%s cannot be reached (%s): %s" remote why (movement t)) | ( (Reading_remote _ | Checkpointing _), (Unsupported { remote; why } | Untrusted { remote; why }) ) -> fail t (Fmt.kstr refused "%s: %s: %s" remote why (movement t)) | Pushing { plan; facts; rest }, Pushed { landings } -> record { t with sent = (plan, landings) :: t.sent } plan facts rest | Checkpointing { remote; original }, Checkpointed -> fail ~remote t original | (Pushing _ | Checkpointing _), Checkpoint_held why -> fail t (Fmt.kstr unavailable "%s: %s" why (movement t)) | Checkpointing { remote; _ }, Push_refused why -> fail ~remote t (Fmt.kstr refused "private checkpoint to %s refused: %s" remote why) | Checkpointing { remote; _ }, Push_unknown why -> fail t (Fmt.kstr unavailable "private checkpoint to %s is uncertain: %s" remote why) | Checkpointing { remote; _ }, Unanswered (Checkpoint_only _, why) -> fail t (Fmt.kstr unavailable "private checkpoint to %s did not finish: %a" remote Machine.pp_unanswered why) | Pushing { plan; rest; _ }, Stale { branch; _ } -> miss t plan rest (stale plan.remote branch (movement t)) | Pushing { plan; rest; _ }, Push_refused why -> miss t plan rest (Fmt.kstr refused "%s refused the push (%s): %s" plan.remote why (movement t)) | Pushing { plan; rest; _ }, Push_unknown why -> miss t plan rest (Outcome.v Outcome.Unavailable (Fmt.str "%s may have taken the push, and its answer did not arrive (%s)" plan.remote why)) | Pushing { plan; rest; _ }, Unanswered (Push _, why) -> miss t plan rest (Fmt.kstr unavailable "the push to %s did not finish: %a" plan.remote Machine.pp_unanswered why) | Journalling outcome, Journalled -> finish t (Error outcome) | Journalling _, Unanswered (Journal _, why) -> fail t (Fmt.kstr unavailable "the push refusal could not be recorded: %a" Machine.pp_unanswered why) | Recording { plan; rest }, Recorded -> (* A remote with several push URLs records each; its branches are set up once. *) let tracked = if plan.track = [] || List.mem_assoc plan.remote t.tracked then t.tracked else (plan.remote, plan.track) :: t.tracked in next_plan { t with tracked } rest | Recording { plan; rest }, Unanswered (Record _, why) -> ( match next_plan t rest with | Ok ({ phase = Done (Ok r); _ }, _) -> let detail = Fmt.str "%s; this machine did not record what %s took: %a" (Option.value ~default:"" r.Report.detail) plan.remote Machine.pp_unanswered why in finish t (Ok (Report.v ~detail r.verb r.subject)) | other -> other) | (Reading_local | Reading_remote _), Unanswered (_, why) -> fail t (Fmt.kstr unavailable "the branches could not be read: %a" Machine.pp_unanswered why) | ( ( Reading_local | Reading_remote _ | Attesting _ | Pushing _ | Checkpointing _ | Recording _ | Journalling _ ), ( Local_read _ | Remote_read _ | Attested _ | Unattested _ | Unreachable _ | Unsupported _ | Untrusted _ | Pushed _ | Checkpointed | Stale _ | Push_refused _ | Push_unknown _ | Checkpoint_held _ | Journalled | Recorded | Unanswered _ ) ) -> Machine.unexpected machine ~state:(Fmt.str "%a" pp t) ~event:(Fmt.str "%a" pp_event e)
let timer t ~now:_ = Ok (t, [])let next_timeout _ = Nonelet ending t = match t.phase with Done e -> Some e | _ -> Nonelet task (_ : action) = Machine.Task.Nowlet unanswered a why = Unanswered (a, why)let signal s = Signalled s