Something went wrong. Try again.
A local Git merge queue with content-bound gate verdicts
Something went wrong. Try again.
9.4 kB · 216 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217(** [mq pull]: the agreed history brought in, and this machine's landings replayed on it.
[mq pull] fetches the agreed copy of each branch of the DAG and of the rules, outside the run lock, and reconciles this machine's copy with it under the lock (doc/machines.md, "Offline first"). For each branch, against the value this machine last saw on the remote ([refs/mq/seen/]): - a branch this machine lacks is created at the agreed value; - a branch the agreed copy contains fast-forwards to it; - a branch that contains the agreed copy, which still holds what this machine last saw, moves nothing: it is ahead; - otherwise this machine's landings since the value last seen are pinned again under their names as entries into the branch ([NAME-returned] when the name is taken), the branch takes the agreed value, a checkout that has it out moving as [git reset --keep] moves it, and the call lands each entry in turn ({!replays}); - a commit the agreed copy held when this machine last saw it and holds no longer is kept under [refs/mq/rescue/] and not replayed; - a branch deleted on the remote is named, and nothing moves.
The rules branch moves only by fast-forward, as [git merge --ff-only] moves a branch (doc/configuration.md): a remote copy rewound behind the value this machine last saw there is refused, naming [mq push], which restores the newer value; one that diverged from this machine's is refused; and no landing into the rules is replayed.
The branch is refused, and nothing moves, when this machine has no value last seen to tell its own landings from the remote's, when a commit since that value is not one of this machine's landings, and when a commit to replay carries a tag ([next: git tag -d TAG]).
Invariants, over every trace: - the agreed copy is never rewritten, and no remote ref moves; - only this machine's landings are replayed, each once, in landing order, and each is pinned before the branch is taken back, so a pull cut at any write leaves them queued; - a commit made with Git is never discarded: it stays on its branch or under [refs/mq/rescue/]; - nothing the network answers is waited on under the run lock. *)
(** {1:inputs Inputs} *)
type request = { remote : string option; (** [REMOTE], else each branch's own. *) no_wait : bool; (** [--no-wait]. *)}(** The type for what the caller asked. *)
type context = { rules : Rules.t; rules_branch : Branch.t; scheduler : bool; (** Whether a scheduler is registered on this machine. *)}(** The type for what the command tells the pull. *)
type landing = { submission : Submission.t; (** The original submission in the saved landing. *) name : Branch.t; landed : Commit.t; (** The commit it landed as on this machine. *) since : Commit.t; (** The branch's commit below it. *) pinned : bool; (** [refs/mq/queue/NAME] already holds an entry of {!field-landed} into the branch: a pull cut before it took the branch back. *) taken : bool; (** NAME is a branch here, or another entry's pin. *)}(** The type for one of this machine's landings since the value last seen, from its landing record. *)
type facts = { branch : Branch.t; remote : string; local : Commit.t option; agreed : Commit.t option; (** What the fetch found on the remote. *) seen : Commit.t option; (** [refs/mq/seen/REMOTE/NAME]. *) tracking : Commit.t option; (** [refs/remotes/REMOTE/NAME]. *) contains : (Commit.t * Commit.t) list; (** [(a, b)] when [a] is [b] or an ancestor of it, among {!field-local}, {!field-agreed} and {!field-seen}. *) landings : landing list; (** This machine's landings into the branch since {!field-seen}, oldest first. *) foreign : int; (** The commits since {!field-seen} on the local branch that no landing holds. *) tags : string list; (** The tags on commits since {!field-seen} on the branch. *) checkouts : Fpath.t list; (** The worktrees that have the branch out. *) pulled : int; (** The commits {!field-agreed} holds and {!field-local} lacks. *) serial : int; (** One past every serial of [refs/mq/rescue/REMOTE/NAME.N]. *)}(** The type for what the shell reads of one branch under the lock. *)
type replay = { name : Branch.t; target : Branch.t; was : Commit.t }(** The type for a landing put back through the queue: its name, its target, and the commit it was on this machine. *)
(** The type for what a pull writes, in order. *)type write = | Rescue of { tracking : Branch.t; serial : int; commit : Commit.t } (** Keep [commit] at [refs/mq/rescue/TRACKING.SERIAL]. *) | Requeue of { entry : Entry.t; local : Commit.t } (** Write [entry] and pin it at [refs/mq/queue/NAME], absent before, in a transaction that verifies the target at [local]. *) | Reset of { branch : Branch.t; expected : Commit.t option; value : Commit.t; checkouts : Fpath.t list; } (** Move [branch] from [expected] to [value], each checkout of [checkouts] with it, as [git reset --keep] moves it. *) | Seen of { remote : string; branch : Branch.t; seen : Commit.t option; tracking : Commit.t option; value : Commit.t; } (** Point [refs/mq/seen/REMOTE/NAME] and [refs/remotes/REMOTE/NAME] at [value], by compare-and-swap against [seen] and [tracking]. *) | Track of { branch : Branch.t; remote : string } (** Set [branch], which the pull created, up to track [REMOTE/NAME], as Git sets up a branch created from a remote-tracking branch (git-config(1), [branch.autoSetupMerge]). *)
(** {1:machine The machine} *)
(** The type for the events. *)type event = | Local_read of Push.local list | Fetched of { remote : string; values : (Branch.t * Commit.t) list } | Unreachable of { remote : string; why : string } | Unsupported of { remote : string; why : string } (** The remote's URL names a transport mq does not speak. *) | Untrusted of { remote : string; why : string } (** The SSH client refused [remote]'s host key, which known_hosts does not record or records otherwise, or [remote] accepted none of the caller's keys, for this reason. *) | Facts_read of facts list | Written (** The write is done. *) | Requeued of Record.id (** The entry is pinned, with this record id. *) | Lost of string (** A ref held another value than read: which. *) | Overwritten of { checkout : Fpath.t; paths : string list } (** [checkout] holds changes to [paths] the move would overwrite. *) | Unmerged of { checkout : Fpath.t; paths : string list } (** [checkout]'s index is in conflict at [paths]. *) | Unpinned | Signalled of Signal.t | Unanswered of action * Machine.unanswered
(** The type for the actions. *)and action = | Read_local (** Read every local branch, with Git's remotes for each. *) | Fetch of { remote : string; branches : Branch.t list } (** Copy the objects of [refs/heads/B] of [remote] for each [B], naming each ref, writing none. *) | Read_facts of { fetched : (string * (Branch.t * Commit.t) list) list; branches : (string * Branch.t) list; } | Write of write | Unpin of { name : Branch.t; expected : Record.id }
(** The type for how a pull ends. *)type ending = | Reconciled of { report : Report.t; replays : replay list; remotes : string; (** The remotes pulled from, as the report names them. *) pulled : int; (** The commits the pull brought in. *) } (** The branches are reconciled: the replays, in order, are the entries the call lands next. *) | Stopped of Outcome.t (** The outcome that ended the pull. *)
type t(** The type for pulls. *)
val v : context -> request -> t * action list(** [v context request] is the pull [request] asks for, and its first read. *)
include Work.S with type t := t and type event := event and type action := action and type ending := ending
val reconcile : facts -> (write list * replay list * string option, Outcome.t) result(** [reconcile facts] is what the pull writes for one branch, the landings it puts back through the queue, and what it names, if anything (a branch the remote deleted, a commit it dropped); or the outcome that refuses the branch. *)
val interrupted : replay list -> Outcome.t(** [interrupted replays] is the outcome of a pull a signal ended while [replays], each pinned, waited to land again: they stay queued, and the land of the first takes them up. *)
val summary : ?named:string -> remote:string -> pulled:int -> (replay * Outcome.t * Commit.t option * Branch.t option) list -> Outcome.t(** [summary ~named ~remote ~pulled results] is the outcome block of a pull whose replays ended as [results], each with the commit it landed as again, if it did, and the branch its commits were restored to when it did not: the outcome needs work (exit 1) when any needs work, else it is a landing, and its JSON landings array has one element for each. [named] is what the pull named, a commit the remote dropped or a branch it deleted, after the count.*)