diff --git a/bin/main.ml b/bin/main.ml index f7a093a..166511a 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,2 +1 @@ -let () = - exit (Cmdliner.Cmd.eval Git_fleet.Cli.cmd) +let () = exit (Cmdliner.Cmd.eval' Git_fleet.Cli.cmd) diff --git a/lib/cli.ml b/lib/cli.ml index cafede2..7ff0b61 100644 --- a/lib/cli.ml +++ b/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 - (Cmd.info "git-fleet" ~version:Version.value ~doc) - (Term.const ()) + let man = + [ + `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 ]