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

@@ -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

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. *)