git remote management for v0.2.0

Document the commands that exist in this version.

README.md

@@ -6,33 +6,92 @@ A Git extension for managing repositories across multiple Git hosts and destinat
 
 ## Status
 
-**v0.1.0: CLI foundation**
+**v0.2.0: remote management**
 
-Initial release is just figuring out the project structure and command-line interface:
+- `git fleet status`, `git fleet add` and `git fleet remove`
+- Multiple push destinations on a single remote
+- Preserves the destination a remote already pushed to
+- Collapses redundant configuration back to plain Git behaviour
+- `--dry-run` on every command that changes something
+- Git is run directly, never through a shell
 
-- Native OCaml executable
+## How it works
-- Dune build system
-- Cmdliner command interface
-- `git fleet` Git subcommand integration
-- Automated tests
 
-Remote and multi-destination management will begin in v0.2.0.
+`git-fleet` configures ordinary Git remotes. A remote fetches from one URL and may push to several, which is how a repository stays mirrored across more than one host:
+
+```ini
+[remote "origin"]
+	url = git@git.example.invalid:user/project.git
+	fetch = +refs/heads/*:refs/remotes/origin/*
+	pushurl = git@git.example.invalid:user/project.git
+	pushurl = git@github.com:user/project.git
+```
+
+A remote with no `pushurl` pushes to the URL it fetches from. As soon as it has one `pushurl`, Git pushes only to the URLs listed there, so `git fleet add` writes out the existing destination before adding a new one. Removing a destination reverses that: when the only one left is the fetch URL, the redundant configuration is dropped.
+
+Every command works on `origin` unless `--remote` says otherwise.
 
 ## Usage
 
-Once `git-fleet` is installed somewhere on your `PATH`, Git automatically exposes it as a subcommand:
+Show where a remote fetches from and pushes to:
+
+```sh
+git fleet status
+git fleet status --remote upstream
+```
+
+```
+origin
+  fetch  git@git.example.invalid:user/project.git
+  push   git@git.example.invalid:user/project.git
+  push   git@github.com:user/project.git
+```
+
+Add a destination. With neither `--fetch` nor `--push`, the URL is added as a push destination. A remote that does not exist yet is created:
+
+```sh
+git fleet add git@github.com:user/project.git
+git fleet add git@git.example.invalid:user/project.git --fetch
+git fleet add git@git.example.invalid:user/project.git --fetch --push
+git fleet add git@github.com:user/project.git --remote upstream
+```
+
+Remove a push destination. URLs are matched exactly, as they appear in `git fleet status`:
+
+```sh
+git fleet remove git@github.com:user/project.git
+```
+
+Preview the Git commands instead of running them:
+
+```sh
+git fleet add git@github.com:user/project.git --dry-run
+```
+
+```
+Would change remote 'origin':
+  git remote set-url --add --push origin git@git.example.invalid:user/project.git
+  git remote set-url --add --push origin git@github.com:user/project.git
+```
+
+Commands exit with `1` and a single line on standard error when something is wrong, such as running outside a repository or naming a remote that does not exist.
+
+## Installation
+
+Build a release binary and put it on your `PATH`:
+
+```sh
+dune build --release
+install -Dm755 _build/default/bin/main.exe ~/.local/bin/git-fleet
+```
+
+Git exposes any `git-*` executable on `PATH` as a subcommand, so `git-fleet` becomes:
 
 ```sh
 git fleet --help
 git fleet --version
 ```
 
-You can also invoke the executable directly:
-
-```sh
-git-fleet --help
-```
-
 ## Development
 
 Install the project dependencies:
@@ -41,24 +100,15 @@ Install the project dependencies:
 opam install . --deps-only --with-test
 ```
 
-Build:
+Build, test and run:
 
 ```sh
 dune build
-```
-
-Run the tests:
-
-```sh
 dune runtest
+dune exec git-fleet -- status
 ```
 
-Run the development executable:
+The tests create temporary repositories and never change the configuration of this one.
-
-```sh
-dune exec git-fleet -- --help
-dune exec git-fleet -- --version
-```
 
 ## License
 

bin/main.ml

@@ -1,2 +1 @@
-let () =
+let () = exit (Cmdliner.Cmd.eval' Git_fleet.Cli.cmd)
-  exit (Cmdliner.Cmd.eval Git_fleet.Cli.cmd)

dune-project

@@ -1,7 +1,7 @@
 (lang dune 3.16)
 
 (name git-fleet)
-(version 0.1.0)
+(version 0.2.0)
 
 (generate_opam_files true)
 

git-fleet.opam

@@ -1,6 +1,6 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-version: "0.1.0"
+version: "0.2.0"
 synopsis: "Manage Git repositories across multiple destinations"
 description:
   "git-fleet is a Git extension for managing repositories across multiple Git hosts and push destinations."

lib/cli.ml

@@ -1,7 +1,197 @@
 open Cmdliner
 
+let exit_error = 1
+
+let fail message =
+  prerr_endline ("git-fleet: " ^ message);
+  exit_error
+
+let report = function Ok () -> 0 | Error error -> fail (Git.string_of_error error)
+
+let ( let* ) = Result.bind
+
+let repository () =
+  let cwd = Sys.getcwd () in
+  if Git.is_repository ~cwd then Ok cwd else Error (Git.Not_a_repository cwd)
+
+(* Only quote arguments that would otherwise be misread when pasted into a
+   shell, so that ordinary Git URLs stay readable. *)
+let shell_safe = function
+  | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '@' | ':' | '/' | '.' | '_' | '-'
+  | '+' | '~' | '=' ->
+      true
+  | _ -> false
+
+let quote argument =
+  if argument <> "" && String.for_all shell_safe argument then argument
+  else Filename.quote argument
+
+let print_action action =
+  print_endline
+    ("  " ^ String.concat " " (List.map quote (Git.command_of_action action)))
+
+let render_remote (remote : Git.remote) =
+  let line label url = Printf.sprintf "  %-5s  %s" label url in
+  String.concat "\n"
+    ((remote.name :: List.map (line "fetch") remote.fetch_urls)
+    @ List.map (line "push") remote.push_urls)
+
+let print_remote remote = print_endline (render_remote remote)
+
+let show_remote ~cwd ~name =
+  let* remote = Git.remote ~cwd ~name in
+  print_remote remote;
+  Ok ()
+
+let run_plan ~cwd ~name ~dry_run ~unchanged plan =
+  if plan = [] then (
+    print_endline unchanged;
+    Ok ())
+  else if dry_run then (
+    Printf.printf "Would change remote '%s':\n" name;
+    List.iter print_action plan;
+    Ok ())
+  else
+    let* () = Plan.execute ~cwd plan in
+    show_remote ~cwd ~name
+
+let remote_arg =
+  let doc = "The Git remote to operate on." in
+  Arg.(value & opt string "origin" & info [ "remote" ] ~docv:"REMOTE" ~doc)
+
+let dry_run_arg =
+  let doc = "Report the Git commands that would run, changing nothing." in
+  Arg.(value & flag & info [ "dry-run" ] ~doc)
+
+let url_arg ~doc = Arg.(required & pos 0 (some string) None & info [] ~docv:"URL" ~doc)
+
+let status_term =
+  let run name =
+    report
+      (let* cwd = repository () in
+       show_remote ~cwd ~name)
+  in
+  Term.(const run $ remote_arg)
+
+let status_cmd =
+  let doc = "Show the destinations of a remote." in
+  let man =
+    [
+      `S Manpage.s_description;
+      `P
+        "Print the fetch URL and every push destination of a remote. A remote \
+         with no explicit push destination pushes to its fetch URL, and that \
+         destination is shown as well.";
+      `S Manpage.s_examples;
+      `Pre "git fleet status";
+      `Pre "git fleet status --remote upstream";
+    ]
+  in
+  Cmd.v (Cmd.info "status" ~doc ~man) status_term
+
+let add_term =
+  let fetch_arg =
+    let doc = "Use $(i,URL) as the fetch URL of the remote." in
+    Arg.(value & flag & info [ "fetch" ] ~doc)
+  in
+  let push_arg =
+    let doc = "Add $(i,URL) as a push destination of the remote." in
+    Arg.(value & flag & info [ "push" ] ~doc)
+  in
+  let run name fetch push dry_run url =
+    report
+      (let* cwd = repository () in
+       let* plan = Plan.add ~cwd ~name ~fetch ~push ~url in
+       let unchanged =
+         Printf.sprintf "Remote '%s' already uses %s; nothing to change." name
+           url
+       in
+       run_plan ~cwd ~name ~dry_run ~unchanged plan)
+  in
+  Term.(
+    const run $ remote_arg $ fetch_arg $ push_arg $ dry_run_arg
+    $ url_arg ~doc:"The Git URL to add.")
+
+let add_cmd =
+  let doc = "Add a destination to a remote." in
+  let man =
+    [
+      `S Manpage.s_description;
+      `P
+        "Add a Git URL to a remote. With neither $(b,--fetch) nor $(b,--push) \
+         the URL becomes a push destination.";
+      `P
+        "A remote that does not exist yet is created with $(i,URL) as its \
+         fetch URL. When a remote gains its first explicit push destination, \
+         the destination it already pushed to is kept, so that pushing \
+         continues to reach it.";
+      `S Manpage.s_examples;
+      `Pre "git fleet add git@github.com:user/project.git";
+      `Pre "git fleet add git@git.example.invalid:user/project.git --fetch --push";
+      `Pre "git fleet add git@github.com:user/project.git --remote upstream";
+      `Pre "git fleet add git@github.com:user/project.git --dry-run";
+    ]
+  in
+  Cmd.v (Cmd.info "add" ~doc ~man) add_term
+
+let remove_term =
+  let run name dry_run url =
+    report
+      (let* cwd = repository () in
+       let* plan = Plan.remove ~cwd ~name ~url in
+       let unchanged =
+         Printf.sprintf "Remote '%s' does not push to %s; nothing to change."
+           name url
+       in
+       run_plan ~cwd ~name ~dry_run ~unchanged plan)
+  in
+  Term.(
+    const run $ remote_arg $ dry_run_arg
+    $ url_arg ~doc:"The push destination to remove.")
+
+let remove_cmd =
+  let doc = "Remove a push destination from a remote." in
+  let man =
+    [
+      `S Manpage.s_description;
+      `P
+        "Remove a push destination from a remote. The URL is matched exactly, \
+         as it appears in $(b,git fleet status).";
+      `P
+        "When the only destination left is the remote's fetch URL, the \
+         redundant configuration is removed and the remote returns to Git's \
+         usual behaviour of pushing to where it fetches from.";
+      `S Manpage.s_examples;
+      `Pre "git fleet remove git@github.com:user/project.git";
+      `Pre "git fleet remove git@github.com:user/project.git --remote upstream";
+      `Pre "git fleet remove git@github.com:user/project.git --dry-run";
+    ]
+  in
+  Cmd.v (Cmd.info "remove" ~doc ~man) remove_term
+
 let cmd =
   let doc = "Manage Git repositories across multiple destinations." in
-  Cmd.v
+  let man =
-    (Cmd.info "git-fleet" ~version:Version.value ~doc)
+    [
-    (Term.const ())
+      `S Manpage.s_description;
+      `P
+        "git-fleet manages the destinations of ordinary Git remotes. A remote \
+         fetches from one URL and may push to several, which keeps a \
+         repository mirrored across more than one Git host.";
+      `P
+        "Installed on $(b,PATH), git-fleet is available as $(b,git fleet). \
+         Commands act on the remote $(b,origin) unless $(b,--remote) says \
+         otherwise.";
+      `S Manpage.s_examples;
+      `Pre "git fleet status";
+      `Pre "git fleet add git@github.com:user/project.git";
+      `Pre "git fleet remove git@github.com:user/project.git";
+    ]
+  in
+  let exits =
+    Cmd.Exit.info exit_error ~doc:"on a git-fleet error, such as an unknown remote."
+    :: Cmd.Exit.defaults
+  in
+  let info = Cmd.info "git-fleet" ~version:Version.value ~doc ~man ~exits in
+  let default = Term.ret (Term.const (`Help (`Pager, None))) in
+  Cmd.group info ~default [ status_cmd; add_cmd; remove_cmd ]

lib/dune

@@ -1,4 +1,4 @@
 (library
  (name git_fleet)
  (public_name git-fleet.lib)
- (libraries cmdliner))
+ (libraries cmdliner unix))

lib/git.ml

@@ -0,0 +1,194 @@
+type error =
+  | Git_unavailable of string
+  | Not_a_repository of string
+  | No_such_remote of string
+  | Not_a_push_destination of { remote : string; url : string }
+  | Implicit_push_destination of { remote : string; url : string }
+  | Command_failed of { args : string list; status : int; stderr : string }
+
+type remote = {
+  name : string;
+  fetch_urls : string list;
+  push_urls : string list;
+  explicit_push_urls : string list;
+}
+
+type action =
+  | Add_remote of { name : string; url : string }
+  | Set_fetch_url of { name : string; url : string }
+  | Add_push_url of { name : string; url : string }
+  | Clear_push_urls of { name : string }
+
+let executable = "git"
+
+(* Read every pipe to end of file without blocking on one while the other
+   fills up. *)
+let drain fds =
+  let buffers = List.map (fun fd -> (fd, Buffer.create 1024)) fds in
+  let chunk = Bytes.create 65536 in
+  let rec loop open_fds =
+    if open_fds <> [] then begin
+      let ready =
+        try
+          let ready, _, _ = Unix.select open_fds [] [] (-1.0) in
+          ready
+        with Unix.Unix_error (Unix.EINTR, _, _) -> []
+      in
+      let finished =
+        List.filter
+          (fun fd ->
+            match Unix.read fd chunk 0 (Bytes.length chunk) with
+            | 0 -> true
+            | n ->
+                Buffer.add_subbytes (List.assq fd buffers) chunk 0 n;
+                false
+            | exception Unix.Unix_error (Unix.EINTR, _, _) -> false)
+          ready
+      in
+      loop (List.filter (fun fd -> not (List.memq fd finished)) open_fds)
+    end
+  in
+  loop fds;
+  List.map (fun (_, buffer) -> Buffer.contents buffer) buffers
+
+type output = { status : int; stdout : string; stderr : string }
+
+(* Run [git] with [args] as distinct argv entries. No shell is involved. *)
+let exec args =
+  let out_read, out_write = Unix.pipe ~cloexec:true () in
+  let err_read, err_write = Unix.pipe ~cloexec:true () in
+  let close_all () =
+    List.iter
+      (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ())
+      [ out_read; out_write; err_read; err_write ]
+  in
+  match
+    let devnull = Unix.openfile Filename.null [ Unix.O_RDONLY ] 0 in
+    Fun.protect
+      ~finally:(fun () -> Unix.close devnull)
+      (fun () ->
+        Unix.create_process executable
+          (Array.of_list (executable :: args))
+          devnull out_write err_write)
+  with
+  | exception Unix.Unix_error (code, _, _) ->
+      close_all ();
+      Error (Git_unavailable (Unix.error_message code))
+  | pid ->
+      Unix.close out_write;
+      Unix.close err_write;
+      let stdout, stderr =
+        match drain [ out_read; err_read ] with
+        | [ stdout; stderr ] -> (stdout, stderr)
+        | _ -> ("", "")
+      in
+      Unix.close out_read;
+      Unix.close err_read;
+      let status =
+        match snd (Unix.waitpid [] pid) with
+        | Unix.WEXITED code -> code
+        | Unix.WSIGNALED signal | Unix.WSTOPPED signal -> 128 + signal
+      in
+      Ok { status; stdout; stderr }
+
+let failed args { status; stderr; _ } =
+  Command_failed { args; status; stderr = String.trim stderr }
+
+let in_repo ~cwd args = exec ("-C" :: cwd :: args)
+
+(* Run a command that is expected to succeed, returning its standard output. *)
+let output ~cwd args =
+  match in_repo ~cwd args with
+  | Error _ as error -> error
+  | Ok ({ status = 0; stdout; _ } : output) -> Ok stdout
+  | Ok result -> Error (failed args result)
+
+let lines text =
+  String.split_on_char '\n' text
+  |> List.map String.trim
+  |> List.filter (fun line -> line <> "")
+
+let unit_of_output result = Result.map (fun (_ : string) -> ()) result
+
+let is_repository ~cwd =
+  match in_repo ~cwd [ "rev-parse"; "--is-inside-work-tree" ] with
+  | Ok { status = 0; stdout; _ } -> String.trim stdout = "true"
+  | Ok _ | Error _ -> false
+
+let remotes ~cwd = Result.map lines (output ~cwd [ "remote" ])
+
+let remote_exists ~cwd ~name =
+  Result.map (fun names -> List.mem name names) (remotes ~cwd)
+
+(* [git remote get-url] fails when the remote is unknown; report that as a
+   first class error rather than a raw command failure. *)
+let get_urls ~cwd ~name args =
+  match in_repo ~cwd args with
+  | Error _ as error -> error
+  | Ok ({ status = 0; stdout; _ } : output) -> Ok (lines stdout)
+  | Ok result -> (
+      match remote_exists ~cwd ~name with
+      | Ok false -> Error (No_such_remote name)
+      | Ok true -> Error (failed args result)
+      | Error _ as error -> error)
+
+let get_fetch_urls ~cwd ~name =
+  get_urls ~cwd ~name [ "remote"; "get-url"; "--all"; name ]
+
+let get_push_urls ~cwd ~name =
+  get_urls ~cwd ~name [ "remote"; "get-url"; "--push"; "--all"; name ]
+
+let get_explicit_push_urls ~cwd ~name =
+  let key = "remote." ^ name ^ ".pushurl" in
+  let args = [ "config"; "--get-all"; key ] in
+  match in_repo ~cwd args with
+  | Error _ as error -> error
+  | Ok ({ status = 0; stdout; _ } : output) -> Ok (lines stdout)
+  (* Exit status 1 means the key is simply not set. *)
+  | Ok { status = 1; _ } -> Ok []
+  | Ok result -> Error (failed args result)
+
+let ( let* ) = Result.bind
+
+let remote ~cwd ~name =
+  let* fetch_urls = get_fetch_urls ~cwd ~name in
+  let* push_urls = get_push_urls ~cwd ~name in
+  let* explicit_push_urls = get_explicit_push_urls ~cwd ~name in
+  Ok { name; fetch_urls; push_urls; explicit_push_urls }
+
+let command_of_action = function
+  | Add_remote { name; url } -> [ "git"; "remote"; "add"; name; url ]
+  | Set_fetch_url { name; url } -> [ "git"; "remote"; "set-url"; name; url ]
+  | Add_push_url { name; url } ->
+      [ "git"; "remote"; "set-url"; "--add"; "--push"; name; url ]
+  | Clear_push_urls { name } ->
+      [ "git"; "config"; "--unset-all"; "remote." ^ name ^ ".pushurl" ]
+
+let apply ~cwd action =
+  let args = List.tl (command_of_action action) in
+  match action with
+  | Clear_push_urls _ -> (
+      match in_repo ~cwd args with
+      | Error _ as error -> error
+      (* Status 5 means there was nothing to unset. *)
+      | Ok ({ status = 0 | 5; _ } : output) -> Ok ()
+      | Ok result -> Error (failed args result))
+  | Add_remote _ | Set_fetch_url _ | Add_push_url _ ->
+      unit_of_output (output ~cwd args)
+
+let string_of_error = function
+  | Git_unavailable reason -> "could not run git: " ^ reason
+  | Not_a_repository cwd -> "not a Git repository: " ^ cwd
+  | No_such_remote name -> "no such remote: " ^ name
+  | Not_a_push_destination { remote; url } ->
+      Printf.sprintf "%s is not a push destination of remote '%s'" url remote
+  | Implicit_push_destination { remote; url } ->
+      Printf.sprintf
+        "%s is the implicit push destination of remote '%s' and follows its \
+         fetch URL; change the fetch URL instead"
+        url remote
+  | Command_failed { args; status; stderr } ->
+      let command = String.concat " " ("git" :: args) in
+      if stderr = "" then
+        Printf.sprintf "%s exited with status %d" command status
+      else Printf.sprintf "%s: %s" command stderr

lib/git.mli

@@ -0,0 +1,64 @@
+(** Execution of [git] subprocesses and inspection of repository remotes.
+
+    Every operation runs the [git] executable directly. User supplied values,
+    such as URLs, are always passed as separate arguments and are never
+    interpolated into a shell command line. *)
+
+(** Failures that are expected during normal use of the command line. *)
+type error =
+  | Git_unavailable of string
+      (** The [git] executable could not be started. *)
+  | Not_a_repository of string  (** The directory is not a Git work tree. *)
+  | No_such_remote of string  (** The repository has no such remote. *)
+  | Not_a_push_destination of { remote : string; url : string }
+      (** The URL is not configured as a push destination of the remote. *)
+  | Implicit_push_destination of { remote : string; url : string }
+      (** The URL is the remote's implicit push destination, which follows its
+          fetch URL and so cannot be removed on its own. *)
+  | Command_failed of { args : string list; status : int; stderr : string }
+      (** A [git] command exited with a non-zero status. *)
+
+val string_of_error : error -> string
+(** A concise single line description, without a trailing newline. *)
+
+(** A Git remote.
+
+    [push_urls] are the destinations Git actually pushes to. When a remote has
+    no [remote.<name>.pushurl] entries, Git pushes to the fetch URL, so
+    [explicit_push_urls] is empty while [push_urls] is not. *)
+type remote = {
+  name : string;
+  fetch_urls : string list;
+  push_urls : string list;
+  explicit_push_urls : string list;
+}
+
+val is_repository : cwd:string -> bool
+(** Whether [cwd] is inside a Git work tree. *)
+
+val remotes : cwd:string -> (string list, error) result
+(** The names of every configured remote, in Git's order. *)
+
+val remote_exists : cwd:string -> name:string -> (bool, error) result
+val get_fetch_urls : cwd:string -> name:string -> (string list, error) result
+
+val get_push_urls : cwd:string -> name:string -> (string list, error) result
+(** The effective push destinations, including the implicit one. *)
+
+val get_explicit_push_urls :
+  cwd:string -> name:string -> (string list, error) result
+(** The [remote.<name>.pushurl] entries, in configuration order. *)
+
+val remote : cwd:string -> name:string -> (remote, error) result
+
+(** A single change to a repository's configuration. *)
+type action =
+  | Add_remote of { name : string; url : string }
+  | Set_fetch_url of { name : string; url : string }
+  | Add_push_url of { name : string; url : string }
+  | Clear_push_urls of { name : string }
+
+val command_of_action : action -> string list
+(** The equivalent Git command line, as an argument list starting with ["git"]. *)
+
+val apply : cwd:string -> action -> (unit, error) result

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

lib/version.ml

@@ -1 +1 @@
-let value = "0.1.0"
+let value = "0.2.0"

test/dune

@@ -1,3 +1,3 @@
 (test
  (name test_git_fleet)
- (libraries git_fleet alcotest))
+ (libraries git_fleet alcotest unix))

test/test_git_fleet.ml

@@ -1,18 +1,259 @@
-let test_version () =
+open Git_fleet
+
+let primary = "git@git.example.invalid:user/project.git"
+let github = "git@github.com:user/project.git"
+let backup = "git@backup.example.invalid:user/project.git"
+let urls = Alcotest.(list string)
+
+let ok = function
+  | Ok value -> value
+  | Error error ->
+      Alcotest.failf "unexpected error: %s" (Git.string_of_error error)
+
+let error = function
+  | Ok _ -> Alcotest.fail "expected an error"
+  | Error error -> error
+
+(* Arrange repository state with Git itself, so that the assertions do not
+   depend on the code under test. *)
+let git_exn dir args =
+  let argv = Array.of_list (("git" :: "-C" :: dir :: args)) in
+  let input = Unix.openfile Filename.null [ Unix.O_RDONLY ] 0 in
+  let output = Unix.openfile Filename.null [ Unix.O_WRONLY ] 0 in
+  let pid = Unix.create_process "git" argv input output output in
+  let _, status = Unix.waitpid [] pid in
+  Unix.close input;
+  Unix.close output;
+  match status with
+  | Unix.WEXITED 0 -> ()
+  | _ -> Alcotest.failf "git %s failed" (String.concat " " args)
+
+let rec remove_tree path =
+  match Unix.lstat path with
+  | exception Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+  | { st_kind = Unix.S_DIR; _ } ->
+      Array.iter
+        (fun entry -> remove_tree (Filename.concat path entry))
+        (Sys.readdir path);
+      Unix.rmdir path
+  | _ -> Unix.unlink path
+
+(* Temporary directories only: the git-fleet repository itself is never
+   touched by the tests. *)
+let with_dir f =
+  let dir = Filename.temp_dir "git-fleet-test" "" in
+  Fun.protect ~finally:(fun () -> remove_tree dir) (fun () -> f dir)
+
+let with_repo f =
+  with_dir (fun dir ->
+      git_exn dir [ "init"; "-q" ];
+      f dir)
+
+let with_origin f =
+  with_repo (fun cwd ->
+      git_exn cwd [ "remote"; "add"; "origin"; primary ];
+      f cwd)
+
+let add ?(name = "origin") ?(fetch = false) ?(push = false) ~cwd url =
+  let plan = ok (Plan.add ~cwd ~name ~fetch ~push ~url) in
+  ok (Plan.execute ~cwd plan);
+  plan
+
+let remove ?(name = "origin") ~cwd url =
+  let plan = ok (Plan.remove ~cwd ~name ~url) in
+  ok (Plan.execute ~cwd plan);
+  plan
+
+let explicit ?(name = "origin") cwd = ok (Git.get_explicit_push_urls ~cwd ~name)
+let effective ?(name = "origin") cwd = ok (Git.get_push_urls ~cwd ~name)
+let fetch_urls ?(name = "origin") cwd = ok (Git.get_fetch_urls ~cwd ~name)
+
+let test_not_a_repository () =
+  with_dir (fun dir ->
+      Alcotest.(check bool) "outside a work tree" false (Git.is_repository ~cwd:dir))
+
+let test_empty_repository () =
+  with_repo (fun cwd ->
+      Alcotest.(check bool) "inside a work tree" true (Git.is_repository ~cwd);
+      Alcotest.(check urls) "no remotes" [] (ok (Git.remotes ~cwd)))
+
+let test_create_origin () =
+  with_repo (fun cwd ->
+      let plan = add ~cwd primary in
+      Alcotest.(check int) "one action" 1 (List.length plan);
+      Alcotest.(check urls) "remotes" [ "origin" ] (ok (Git.remotes ~cwd));
+      Alcotest.(check urls) "fetch" [ primary ] (fetch_urls cwd);
+      Alcotest.(check urls) "effective push" [ primary ] (effective cwd);
+      Alcotest.(check urls) "no explicit push" [] (explicit cwd))
+
+let test_custom_remote_name () =
+  with_repo (fun cwd ->
+      ignore (add ~cwd ~name:"upstream" primary);
+      Alcotest.(check urls) "remotes" [ "upstream" ] (ok (Git.remotes ~cwd));
+      Alcotest.(check urls) "fetch" [ primary ] (fetch_urls ~name:"upstream" cwd))
+
+let test_change_fetch_url () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd ~fetch:true backup);
+      Alcotest.(check urls) "fetch" [ backup ] (fetch_urls cwd);
+      Alcotest.(check urls) "no explicit push" [] (explicit cwd);
+      Alcotest.(check urls) "push follows fetch" [ backup ] (effective cwd))
+
+let test_first_push_url_preserves_implicit () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      Alcotest.(check urls)
+        "implicit destination kept first" [ primary; github ] (explicit cwd);
+      Alcotest.(check urls) "effective push" [ primary; github ] (effective cwd);
+      Alcotest.(check urls) "fetch unchanged" [ primary ] (fetch_urls cwd))
+
+let test_add_second_push_url () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      ignore (add ~cwd backup);
+      Alcotest.(check urls)
+        "three destinations" [ primary; github; backup ] (explicit cwd))
+
+let test_duplicate_push_url_is_idempotent () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      let before = explicit cwd in
+      let plan = add ~cwd github in
+      Alcotest.(check int) "nothing planned" 0 (List.length plan);
+      Alcotest.(check urls) "configuration unchanged" before (explicit cwd))
+
+let test_implicit_destination_is_idempotent () =
+  with_origin (fun cwd ->
+      let plan = add ~cwd primary in
+      Alcotest.(check int) "nothing planned" 0 (List.length plan);
+      Alcotest.(check urls) "still implicit" [] (explicit cwd))
+
+let test_remove_push_url () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      ignore (add ~cwd backup);
+      ignore (remove ~cwd github);
+      Alcotest.(check urls) "order preserved" [ primary; backup ] (explicit cwd);
+      Alcotest.(check urls) "fetch unchanged" [ primary ] (fetch_urls cwd))
+
+let test_remove_collapses_to_implicit () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      ignore (remove ~cwd github);
+      Alcotest.(check urls) "redundant entry removed" [] (explicit cwd);
+      Alcotest.(check urls) "pushes where it fetches" [ primary ] (effective cwd))
+
+let test_remove_unknown_url () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      match error (Plan.remove ~cwd ~name:"origin" ~url:backup) with
+      | Git.Not_a_push_destination { remote = "origin"; url } ->
+          Alcotest.(check string) "reported url" backup url
+      | other -> Alcotest.failf "unexpected error: %s" (Git.string_of_error other))
+
+let test_remove_implicit_destination () =
+  with_origin (fun cwd ->
+      match error (Plan.remove ~cwd ~name:"origin" ~url:primary) with
+      | Git.Implicit_push_destination { remote = "origin"; url } ->
+          Alcotest.(check string) "reported url" primary url
+      | other -> Alcotest.failf "unexpected error: %s" (Git.string_of_error other))
+
+let test_unknown_remote () =
+  with_origin (fun cwd ->
+      Alcotest.(check bool)
+        "remote_exists" false
+        (ok (Git.remote_exists ~cwd ~name:"upstream"));
+      match error (Git.remote ~cwd ~name:"upstream") with
+      | Git.No_such_remote name -> Alcotest.(check string) "name" "upstream" name
+      | other -> Alcotest.failf "unexpected error: %s" (Git.string_of_error other))
+
+let test_planning_changes_nothing () =
+  with_origin (fun cwd ->
+      let plan = ok (Plan.add ~cwd ~name:"origin" ~fetch:false ~push:true ~url:github) in
+      Alcotest.(check int) "two actions planned" 2 (List.length plan);
+      Alcotest.(check urls) "no explicit push url written" [] (explicit cwd);
+      Alcotest.(check urls) "fetch untouched" [ primary ] (fetch_urls cwd);
+      Alcotest.(check (list string))
+        "equivalent git commands"
+        [
+          "git remote set-url --add --push origin " ^ primary;
+          "git remote set-url --add --push origin " ^ github;
+        ]
+        (List.map
+           (fun action -> String.concat " " (Git.command_of_action action))
+           plan))
+
+let test_status_representation () =
+  with_origin (fun cwd ->
+      ignore (add ~cwd github);
+      let remote = ok (Git.remote ~cwd ~name:"origin") in
       Alcotest.(check string)
-    "version"
+        "rendered status"
-    "0.1.0"
+        (String.concat "\n"
-    Git_fleet.Version.value
+           [
+             "origin";
+             "  fetch  " ^ primary;
+             "  push   " ^ primary;
+             "  push   " ^ github;
+           ])
+        (Cli.render_remote remote))
+
+(* A URL that would run a command, or lose its meaning, if git-fleet built
+   shell command lines out of user input. *)
+let test_hostile_url () =
+  with_repo (fun cwd ->
+      let marker = Filename.concat cwd "pwned" in
+      let hostile =
+        Printf.sprintf "ssh://git@example.invalid/a b;$(touch %s)`touch %s`.git"
+          marker marker
+      in
+      ignore (add ~cwd primary);
+      ignore (add ~cwd hostile);
+      Alcotest.(check bool) "no command was executed" false (Sys.file_exists marker);
+      Alcotest.(check urls) "stored verbatim" [ primary; hostile ] (explicit cwd);
+      ignore (remove ~cwd hostile);
+      Alcotest.(check urls) "removed exactly" [] (explicit cwd);
+      Alcotest.(check urls) "fetch url intact" [ primary ] (fetch_urls cwd))
+
+let test_version () =
+  Alcotest.(check string) "version" "0.2.0" Version.value
+
+let case name f = Alcotest.test_case name `Quick f
 
 let () =
-  Alcotest.run
+  (* Keep the developer's own Git configuration, such as url rewrites, out of
-    "git-fleet"
+     the results. *)
+  Unix.putenv "GIT_CONFIG_GLOBAL" Filename.null;
+  Unix.putenv "GIT_CONFIG_SYSTEM" Filename.null;
+  Alcotest.run "git-fleet"
     [
-      ( "version",
+      ( "repository",
         [
-          Alcotest.test_case
+          case "outside a repository" test_not_a_repository;
-            "reports 0.1.0"
+          case "empty repository" test_empty_repository;
-            `Quick
+          case "unknown remote" test_unknown_remote;
-            test_version;
         ] );
+      ( "fetch urls",
+        [
+          case "creates origin" test_create_origin;
+          case "custom remote name" test_custom_remote_name;
+          case "changes the fetch url" test_change_fetch_url;
+        ] );
+      ( "push destinations",
+        [
+          case "first push url preserves the implicit one"
+            test_first_push_url_preserves_implicit;
+          case "adds a second push url" test_add_second_push_url;
+          case "duplicate push url is idempotent" test_duplicate_push_url_is_idempotent;
+          case "implicit destination is idempotent" test_implicit_destination_is_idempotent;
+          case "removes a push url" test_remove_push_url;
+          case "collapses to implicit push" test_remove_collapses_to_implicit;
+          case "removing an unconfigured url fails" test_remove_unknown_url;
+          case "removing the implicit destination fails" test_remove_implicit_destination;
+          case "urls are never interpreted by a shell" test_hostile_url;
+        ] );
+      ( "planning",
+        [ case "planning does not touch the repository" test_planning_changes_nothing ] );
+      ( "status", [ case "renders a remote" test_status_representation ] );
+      ( "version", [ case "reports 0.2.0" test_version ] );
     ]