From fbf76e74bac148ea2b72a0b851dae0a00aefea20 Mon Sep 17 00:00:00 2001 From: SowinskiBraeden Date: Thu, 24 Sep 2026 21:08:47 -0700 Subject: [PATCH] plan push destination changes Compute the git actions a request needs before running any of them, so a dry run and a real run can never describe different changes. Adding the first explicit push destination records the implicit one first, and removing one collapses redundant configuration back to implicit pushing. --- lib/plan.ml | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++ lib/plan.mli | 33 ++++++++++++++++++++++++++ 2 files changed, 100 insertions(+) create mode 100644 lib/plan.ml create mode 100644 lib/plan.mli diff --git a/lib/plan.ml b/lib/plan.ml new file mode 100644 index 0000000..426c409 --- /dev/null +++ b/lib/plan.ml @@ -0,0 +1,67 @@ +type t = Git.action list + +let ( let* ) = Result.bind + +(* Plan whatever is needed for [url] to become one of the remote's effective + push destinations, leaving the existing destinations in place. + + Git stops using the fetch URL as soon as a remote has an explicit pushurl, + so the implicit destination has to be written out before the first explicit + one is added. *) +let ensure_push_destination ~name ~explicit ~effective ~url = + let add url = Git.Add_push_url { name; url } in + if List.mem url explicit then [] + else if explicit <> [] then [ add url ] + else if effective = [ url ] then [] + else List.map add effective @ [ add url ] + +let add ~cwd ~name ~fetch ~push ~url = + (* With neither flag the URL is a push destination. *) + let want_fetch = fetch and want_push = push || not fetch in + let* exists = Git.remote_exists ~cwd ~name in + if not exists then + (* A new remote fetches and, implicitly, pushes to its only URL. *) + Ok [ Git.Add_remote { name; url } ] + else + let* remote = Git.remote ~cwd ~name in + let fetch_actions = + if want_fetch && remote.fetch_urls <> [ url ] then + [ Git.Set_fetch_url { name; url } ] + else [] + in + let push_actions = + if not want_push then [] + else + (* A changed fetch URL also moves the implicit push destination. *) + let effective = + if fetch_actions <> [] && remote.explicit_push_urls = [] then [ url ] + else remote.push_urls + in + ensure_push_destination ~name ~explicit:remote.explicit_push_urls + ~effective ~url + in + Ok (fetch_actions @ push_actions) + +let remove ~cwd ~name ~url = + let* remote = Git.remote ~cwd ~name in + if not (List.mem url remote.explicit_push_urls) then + if remote.explicit_push_urls = [] && List.mem url remote.push_urls then + Error (Git.Implicit_push_destination { remote = name; url }) + else Error (Git.Not_a_push_destination { remote = name; url }) + else + let remaining = + List.filter (fun existing -> existing <> url) remote.explicit_push_urls + in + let clear = Git.Clear_push_urls { name } in + (* Dropping every explicit entry, or keeping only the fetch URL, restores + Git's implicit push behaviour. *) + if remaining = [] || remaining = remote.fetch_urls then Ok [ clear ] + else + Ok (clear :: List.map (fun url -> Git.Add_push_url { name; url }) remaining) + +let execute ~cwd plan = + List.fold_left + (fun result action -> + let* () = result in + Git.apply ~cwd action) + (Ok ()) plan diff --git a/lib/plan.mli b/lib/plan.mli new file mode 100644 index 0000000..aaad088 --- /dev/null +++ b/lib/plan.mli @@ -0,0 +1,33 @@ +(** Working out which Git actions a request needs. + + Planning is separated from execution so that a dry run and a real run + describe exactly the same changes. A plan is applied in order; an empty + plan means the repository is already in the requested state. *) + +type t = Git.action list + +val add : + cwd:string -> + name:string -> + fetch:bool -> + push:bool -> + url:string -> + (t, Git.error) result +(** [add ~cwd ~name ~fetch ~push ~url] plans the addition of [url] to remote + [name] as a fetch URL, a push destination, or both. + + The remote is created when it does not exist yet. When the first explicit + push destination is added, the remote's current implicit destination is + recorded first, so that Git keeps pushing where it already pushed. Adding + a destination that is already in use plans nothing. *) + +val remove : cwd:string -> name:string -> url:string -> (t, Git.error) result +(** [remove ~cwd ~name ~url] plans the removal of the push destination [url] + from remote [name]. URLs are matched exactly. + + When the only remaining explicit destination is the remote's fetch URL, + the redundant entries are dropped so that the remote returns to Git's + implicit push behaviour. *) + +val execute : cwd:string -> t -> (unit, Git.error) result +(** Apply every action in order, stopping at the first failure. *)