add git subprocess runner and remote model
Run git directly through Unix.create_process so that user supplied values such as URLs stay separate argv entries, and model a remote as its fetch URLs, its effective push destinations and its explicit pushurl entries.
This commit is contained in:
SowinskiBraeden committed
1 parent
a09bc5f08c
commit
efd03bd897
3 files changed
+259
-1
No files matched your search
+194
@@ -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
|
||||
Reference in new issue
Block a user