forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
1let src = Logs.Src.create "monopam.git_cli" ~doc:"Git CLI operations"
2
3module Log = (val Logs.src_log src : Logs.LOG)
4
5type cmd_result = { exit_code : int; stdout : string; stderr : string }
6
7type error =
8 | Command_failed of string * cmd_result
9 | Not_a_repo of Fpath.t
10 | Dirty_worktree of Fpath.t
11 | Remote_not_found of string
12 | Branch_not_found of string
13 | Subtree_prefix_exists of string
14 | Subtree_prefix_missing of string
15 | Io_error of string
16
17let pp_error ppf = function
18 | Command_failed (cmd, r) ->
19 Fmt.pf ppf "Command failed: %s (exit %d)@.stdout: %s@.stderr: %s" cmd
20 r.exit_code r.stdout r.stderr
21 | Not_a_repo path -> Fmt.pf ppf "Not a git repository: %a" Fpath.pp path
22 | Dirty_worktree path ->
23 Fmt.pf ppf "Repository has uncommitted changes: %a" Fpath.pp path
24 | Remote_not_found name -> Fmt.pf ppf "Remote not found: %s" name
25 | Branch_not_found name -> Fmt.pf ppf "Branch not found: %s" name
26 | Subtree_prefix_exists prefix ->
27 Fmt.pf ppf "Subtree prefix already exists: %s" prefix
28 | Subtree_prefix_missing prefix ->
29 Fmt.pf ppf "Subtree prefix does not exist: %s" prefix
30 | Io_error msg -> Fmt.pf ppf "I/O error: %s" msg
31
32let run_git ~proc ~cwd args =
33 let cmd = "git" :: args in
34 let buf_stdout = Buffer.create 256 in
35 let buf_stderr = Buffer.create 256 in
36 Eio.Switch.run @@ fun sw ->
37 let child =
38 Eio.Process.spawn proc ~sw ~cwd
39 ~stdout:(Eio.Flow.buffer_sink buf_stdout)
40 ~stderr:(Eio.Flow.buffer_sink buf_stderr)
41 cmd
42 in
43 let exit_status = Eio.Process.await child in
44 let exit_code =
45 match exit_status with `Exited n -> n | `Signaled n -> 128 + n
46 in
47 {
48 exit_code;
49 stdout = Buffer.contents buf_stdout |> String.trim;
50 stderr = Buffer.contents buf_stderr |> String.trim;
51 }
52
53(* Retry configuration shared by all [ls_remote_exists] calls. *)
54let ls_remote_retry_config =
55 Retry.config ~max_retries:2 ~backoff_factor:0.3 ~backoff_max:4.0 ()
56
57(* [git ls-remote --exit-code] returns 0 if the remote has any refs, 2 if the
58 remote is reachable but empty (a freshly created repo with no branches), and
59 128 if the remote is unreachable. A freshly provisioned repo counts as
60 "exists". *)
61let ls_remote_exists ~clock ~proc ~fs ~url =
62 let cwd = Eio.Path.(fs / "/") in
63 let result_ref = ref None in
64 let reachable (r : cmd_result) = r.exit_code = 0 || r.exit_code = 2 in
65 let should_retry r = not (reachable r) in
66 let attempt () =
67 let r = run_git ~proc ~cwd [ "ls-remote"; "--exit-code"; url ] in
68 result_ref := Some r;
69 if reachable r then Ok () else Error r
70 in
71 let _ =
72 Retry.with_retry_result ~clock ~config:ls_remote_retry_config ~should_retry
73 attempt
74 in
75 match !result_ref with Some r -> reachable r | None -> false
76
77let run_git_ok ~proc ~cwd args =
78 let result = run_git ~proc ~cwd args in
79 if result.exit_code = 0 then Ok result.stdout
80 else Error (Command_failed (String.concat " " ("git" :: args), result))
81
82(** Read user info from global git config (~/.gitconfig). *)
83let global_git_user ~fs () =
84 let path = Eio.Path.(Xdg_eio.home_dir fs / ".gitconfig") in
85 match Eio.Path.load path with
86 | content -> (
87 let config = Git.Config.of_string content in
88 let user = Git.Config.user config in
89 match (user.name, user.email) with
90 | Some name, Some email ->
91 let date = Int64.of_float (Unix.gettimeofday ()) in
92 Some (Git.User.v ~name ~email ~date ())
93 | _ -> None)
94 | exception Eio.Io _ -> None
95
96(** Retryable HTTP 5xx and transient network error patterns, compiled once. Only
97 matches errors where a retry is likely to succeed (server-side errors and
98 mid-connection drops). Permanent failures like DNS resolution errors,
99 connection refused, and unreachable networks are not retried. *)
100let retryable_re =
101 let open Re in
102 let patterns =
103 [
104 "500";
105 "502";
106 "503";
107 "504";
108 "HTTP 5";
109 "http 5";
110 "Internal Server Error";
111 "Bad Gateway";
112 "Service Unavailable";
113 "Gateway Timeout";
114 "RPC failed";
115 "unexpected disconnect";
116 "the remote end hung up";
117 "early EOF";
118 "Connection reset";
119 ]
120 in
121 compile (alt (List.map str patterns))
122
123(** Check if an error is a retryable HTTP server error (5xx) or network error *)
124let is_retryable_error result =
125 result.stderr <> "" && Re.execp retryable_re result.stderr
126
127(** Run a git command with retry logic for network errors. Retries up to
128 [max_retries] times with exponential backoff starting at [initial_delay_ms].
129*)
130let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3)
131 ?(initial_delay_ms = 2000) args =
132 let rec attempt n delay_ms =
133 let result = run_git ~proc ~cwd args in
134 if result.exit_code = 0 then Ok result.stdout
135 else if n < max_retries && is_retryable_error result then begin
136 (* Log the retry (only with -v) *)
137 Log.info (fun m ->
138 m "Retrying in %dms (%d/%d)..." delay_ms (n + 1) max_retries);
139 (* Sleep before retry - convert ms to seconds for Unix.sleepf *)
140 Unix.sleepf (float_of_int delay_ms /. 1000.0);
141 (* Exponential backoff: double the delay for next attempt *)
142 attempt (n + 1) (delay_ms * 2)
143 end
144 else Error (Command_failed (String.concat " " ("git" :: args), result))
145 in
146 attempt 0 initial_delay_ms
147
148let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
149 let dir, _ = fs in
150 (dir, Fpath.to_string path)
151
152let clone ~proc ~fs ~url ~branch target =
153 let parent = Fpath.parent target in
154 let cwd = Eio.Path.(fs / Fpath.to_string parent) in
155 let target_name = Fpath.basename target in
156 let url_str = url in
157 let result =
158 run_git_ok_with_retry ~proc ~cwd
159 [ "clone"; "--branch"; branch; url_str; target_name ]
160 in
161 match result with
162 | Ok _ -> Ok ()
163 | Error (Command_failed (_, r))
164 when Re.execp Re.(compile (str "Remote branch")) r.stderr
165 && Re.execp Re.(compile (str "not found")) r.stderr ->
166 (* Empty remote repo - init locally and add remote *)
167 let target_dir = Eio.Path.(cwd / target_name) in
168 (try Eio.Path.mkdir ~perm:0o755 target_dir with Eio.Io _ -> ());
169 let ( let* ) = Result.bind in
170 let* _ = run_git_ok ~proc ~cwd:target_dir [ "init"; "-b"; branch ] in
171 (* Allow pushes to this non-bare repo (needed for subtree push) *)
172 let* _ =
173 run_git_ok ~proc ~cwd:target_dir
174 [ "config"; "receive.denyCurrentBranch"; "updateInstead" ]
175 in
176 let* _ =
177 run_git_ok ~proc ~cwd:target_dir [ "remote"; "add"; "origin"; url_str ]
178 in
179 Ok ()
180 | Error e -> Error e
181
182let ensure_receive_config ~proc ~fs path =
183 let cwd = path_to_eio ~fs path in
184 run_git_ok ~proc ~cwd
185 [ "config"; "receive.denyCurrentBranch"; "updateInstead" ]
186 |> Result.map ignore
187
188let clean_untracked ~proc ~fs path =
189 let cwd = path_to_eio ~fs path in
190 run_git_ok ~proc ~cwd [ "clean"; "-fd" ] |> Result.map ignore
191
192let fetch ~proc ~fs ?(remote = "origin") path =
193 let cwd = path_to_eio ~fs path in
194 run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
195
196let fetch_all ~proc ~fs path =
197 let cwd = path_to_eio ~fs path in
198 run_git_ok_with_retry ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore
199
200let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
201 let cwd = path_to_eio ~fs path in
202 let branch =
203 match branch with
204 | Some b -> b
205 | None ->
206 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
207 if result.exit_code = 0 then result.stdout else "main"
208 in
209 let upstream = remote ^ "/" ^ branch in
210 run_git_ok ~proc ~cwd [ "merge"; "--ff-only"; upstream ] |> Result.map ignore
211
212let pull ~proc ~fs ?(remote = "origin") ?branch path =
213 let cwd = path_to_eio ~fs path in
214 let args =
215 match branch with
216 | Some b -> [ "pull"; remote; b ]
217 | None -> [ "pull"; remote ]
218 in
219 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
220
221let fetch_and_reset ~proc ~fs ?(remote = "origin") ~branch path =
222 let cwd = path_to_eio ~fs path in
223 match run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] with
224 | Error e -> Error e
225 | Ok _ ->
226 let upstream = remote ^ "/" ^ branch in
227 run_git_ok ~proc ~cwd [ "reset"; "--hard"; upstream ] |> Result.map ignore
228
229(** Open a local git repository, detecting whether it's bare or not. A bare repo
230 has [HEAD] / [refs/] / [objects/] directly under [path]; a regular one has
231 them under [path/.git/]. *)
232let open_local ~sw ~fs path =
233 let dotgit = Eio.Path.(fs / Fpath.to_string path / ".git") in
234 match Eio.Path.kind ~follow:true dotgit with
235 | `Directory -> Git.Repository.open_repo ~sw ~fs path
236 | _ | (exception _) -> Git.Repository.open_bare ~sw ~fs path
237
238(* Fetch from URL and return the commit hash for the branch.
239
240 For file:// URLs (and bare local paths) this uses the native
241 [Git.Fetch.local] which copies objects directly between the two
242 on-disk repos — no [git] subprocess, no zlib re-compression of pack
243 contents, fully cancellable via the Eio switch. The native path covers
244 the entire monopam test suite and the daily-driver local-checkout flow
245 (under [src/]). HTTP/SSH URLs still go through [git fetch]. *)
246let fetch_url ~sw ~proc ~fs ~repo ~url ~branch () =
247 match Git.Fetch.parse_url url with
248 | `File src_path -> (
249 let src_fpath =
250 match Fpath.of_string src_path with
251 | Ok p -> p
252 | Error (`Msg m) ->
253 failwith ("fetch_url: bad path " ^ src_path ^ ": " ^ m)
254 in
255 try
256 let src_repo = open_local ~sw ~fs src_fpath in
257 let dst_repo = open_local ~sw ~fs repo in
258 match Git.Fetch.local ~src:src_repo ~dst:dst_repo ~ref_name:branch with
259 | Ok hash -> Ok (Git.Hash.to_hex hash)
260 | Error (`Msg msg) -> Error (Io_error msg)
261 with e -> Error (Io_error (Printexc.to_string e)))
262 | `Other _ -> (
263 let cwd = path_to_eio ~fs repo in
264 let url_str = url in
265 match run_git_ok_with_retry ~proc ~cwd [ "fetch"; url_str; branch ] with
266 | Error e -> Error e
267 | Ok _ -> (
268 match run_git_ok ~proc ~cwd [ "rev-parse"; "FETCH_HEAD" ] with
269 | Error e -> Error e
270 | Ok hash -> Ok (String.trim hash)))
271
272let push_refspec ~proc ~fs ~repo ~url ~refspec ?(force = false) () =
273 let cwd = path_to_eio ~fs repo in
274 let url_str = url in
275 let args =
276 [ "push" ] @ (if force then [ "--force" ] else []) @ [ url_str; refspec ]
277 in
278 Log.debug (fun m -> m "push_refspec: git %s" (String.concat " " args));
279 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
280
281let push_remote ~proc ~fs ?(remote = "origin") ?branch ?(force = false) path =
282 let cwd = path_to_eio ~fs path in
283 let branch =
284 match branch with
285 | Some b -> b
286 | None ->
287 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
288 if result.exit_code = 0 then result.stdout else "main"
289 in
290 let args =
291 [ "push" ] @ (if force then [ "--force" ] else []) @ [ remote; branch ]
292 in
293 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
294
295let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
296 let cwd = path_to_eio ~fs repo in
297 run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore