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
82let default_branch ~proc ~fs ~url =
83 let cwd = Eio.Path.(fs / "/") in
84 match run_git_ok ~proc ~cwd [ "ls-remote"; "--symref"; url; "HEAD" ] with
85 | Error _ -> None
86 | Ok stdout -> (
87 (* First line is "ref: refs/heads/<branch>\tHEAD" when HEAD is a
88 symbolic ref; absent when HEAD is detached. *)
89 match String.split_on_char '\n' stdout with
90 | first :: _ when String.starts_with ~prefix:"ref: refs/heads/" first -> (
91 let after = String.sub first 16 (String.length first - 16) in
92 match String.index_opt after '\t' with
93 | Some i -> Some (String.sub after 0 i)
94 | None -> None)
95 | _ -> None)
96
97(** Read user info from global git config (~/.gitconfig). *)
98let global_git_user ~fs () =
99 let path = Eio.Path.(Xdg_eio.home_dir fs / ".gitconfig") in
100 match Eio.Path.load path with
101 | content -> (
102 let config = Git.Config.of_string content in
103 let user = Git.Config.user config in
104 match (user.name, user.email) with
105 | Some name, Some email ->
106 let date = Int64.of_float (Unix.gettimeofday ()) in
107 Some (Git.User.v ~name ~email ~date ())
108 | _ -> None)
109 | exception Eio.Io _ -> None
110
111(** Retryable HTTP 5xx and transient network error patterns, compiled once. Only
112 matches errors where a retry is likely to succeed (server-side errors and
113 mid-connection drops). Permanent failures like DNS resolution errors,
114 connection refused, and unreachable networks are not retried. *)
115let retryable_re =
116 let open Re in
117 let patterns =
118 [
119 "500";
120 "502";
121 "503";
122 "504";
123 "HTTP 5";
124 "http 5";
125 "Internal Server Error";
126 "Bad Gateway";
127 "Service Unavailable";
128 "Gateway Timeout";
129 "RPC failed";
130 "unexpected disconnect";
131 "the remote end hung up";
132 "early EOF";
133 "Connection reset";
134 ]
135 in
136 compile (alt (List.map str patterns))
137
138(** Check if an error is a retryable HTTP server error (5xx) or network error *)
139let is_retryable_error result =
140 result.stderr <> "" && Re.execp retryable_re result.stderr
141
142(** Run a git command with retry logic for network errors. Retries up to
143 [max_retries] times with exponential backoff starting at [initial_delay_ms].
144*)
145let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3)
146 ?(initial_delay_ms = 2000) args =
147 let rec attempt n delay_ms =
148 let result = run_git ~proc ~cwd args in
149 if result.exit_code = 0 then Ok result.stdout
150 else if n < max_retries && is_retryable_error result then begin
151 (* Log the retry (only with -v) *)
152 Log.info (fun m ->
153 m "Retrying in %dms (%d/%d)..." delay_ms (n + 1) max_retries);
154 (* Sleep before retry - convert ms to seconds for Unix.sleepf *)
155 Unix.sleepf (float_of_int delay_ms /. 1000.0);
156 (* Exponential backoff: double the delay for next attempt *)
157 attempt (n + 1) (delay_ms * 2)
158 end
159 else Error (Command_failed (String.concat " " ("git" :: args), result))
160 in
161 attempt 0 initial_delay_ms
162
163let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
164 let dir, _ = fs in
165 (dir, Fpath.to_string path)
166
167let clone ~proc ~fs ~url ~branch target =
168 let parent = Fpath.parent target in
169 let cwd = Eio.Path.(fs / Fpath.to_string parent) in
170 let target_name = Fpath.basename target in
171 let url_str = url in
172 let result =
173 run_git_ok_with_retry ~proc ~cwd
174 [ "clone"; "--branch"; branch; url_str; target_name ]
175 in
176 match result with
177 | Ok _ -> Ok ()
178 | Error (Command_failed (_, r))
179 when Re.execp Re.(compile (str "Remote branch")) r.stderr
180 && Re.execp Re.(compile (str "not found")) r.stderr ->
181 (* Empty remote repo - init locally and add remote *)
182 let target_dir = Eio.Path.(cwd / target_name) in
183 (try Eio.Path.mkdir ~perm:0o755 target_dir with Eio.Io _ -> ());
184 let ( let* ) = Result.bind in
185 let* _ = run_git_ok ~proc ~cwd:target_dir [ "init"; "-b"; branch ] in
186 (* Allow pushes to this non-bare repo (needed for subtree push) *)
187 let* _ =
188 run_git_ok ~proc ~cwd:target_dir
189 [ "config"; "receive.denyCurrentBranch"; "updateInstead" ]
190 in
191 let* _ =
192 run_git_ok ~proc ~cwd:target_dir [ "remote"; "add"; "origin"; url_str ]
193 in
194 Ok ()
195 | Error e -> Error e
196
197let ensure_receive_config ~proc ~fs path =
198 let cwd = path_to_eio ~fs path in
199 run_git_ok ~proc ~cwd
200 [ "config"; "receive.denyCurrentBranch"; "updateInstead" ]
201 |> Result.map ignore
202
203let clean_untracked ~proc ~fs path =
204 let cwd = path_to_eio ~fs path in
205 run_git_ok ~proc ~cwd [ "clean"; "-fd" ] |> Result.map ignore
206
207let fetch ~proc ~fs ?(remote = "origin") path =
208 let cwd = path_to_eio ~fs path in
209 run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
210
211let fetch_all ~proc ~fs path =
212 let cwd = path_to_eio ~fs path in
213 run_git_ok_with_retry ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore
214
215let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
216 let cwd = path_to_eio ~fs path in
217 let branch =
218 match branch with
219 | Some b -> b
220 | None ->
221 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
222 if result.exit_code = 0 then result.stdout else "main"
223 in
224 let upstream = remote ^ "/" ^ branch in
225 run_git_ok ~proc ~cwd [ "merge"; "--ff-only"; upstream ] |> Result.map ignore
226
227let pull ~proc ~fs ?(remote = "origin") ?branch path =
228 let cwd = path_to_eio ~fs path in
229 let args =
230 match branch with
231 | Some b -> [ "pull"; remote; b ]
232 | None -> [ "pull"; remote ]
233 in
234 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
235
236let fetch_and_reset ~proc ~fs ?(remote = "origin") ~branch path =
237 let cwd = path_to_eio ~fs path in
238 match run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] with
239 | Error e -> Error e
240 | Ok _ ->
241 let upstream = remote ^ "/" ^ branch in
242 run_git_ok ~proc ~cwd [ "reset"; "--hard"; upstream ] |> Result.map ignore
243
244(** Open a local git repository, detecting whether it's bare or not. A bare repo
245 has [HEAD] / [refs/] / [objects/] directly under [path]; a regular one has
246 them under [path/.git/]. *)
247let open_local ~sw ~fs path =
248 let dotgit = Eio.Path.(fs / Fpath.to_string path / ".git") in
249 match Eio.Path.kind ~follow:true dotgit with
250 | `Directory -> Git.Repository.open_repo ~sw ~fs path
251 | _ | (exception _) -> Git.Repository.open_bare ~sw ~fs path
252
253(* Fetch from URL and return the commit hash for the branch.
254
255 For file:// URLs (and bare local paths) this uses the native
256 [Git.Fetch.local] which copies objects directly between the two
257 on-disk repos — no [git] subprocess, no zlib re-compression of pack
258 contents, fully cancellable via the Eio switch. The native path covers
259 the entire monopam test suite and the daily-driver local-checkout flow
260 (under [src/]). HTTP/SSH URLs still go through [git fetch]. *)
261let fetch_url ~sw ~proc ~fs ~repo ~url ~branch () =
262 match Git.Fetch.parse_url url with
263 | `File src_path -> (
264 let src_fpath =
265 match Fpath.of_string src_path with
266 | Ok p -> p
267 | Error (`Msg m) ->
268 failwith ("fetch_url: bad path " ^ src_path ^ ": " ^ m)
269 in
270 try
271 let src_repo = open_local ~sw ~fs src_fpath in
272 let dst_repo = open_local ~sw ~fs repo in
273 match Git.Fetch.local ~src:src_repo ~dst:dst_repo ~ref_name:branch with
274 | Ok hash -> Ok (Git.Hash.to_hex hash)
275 | Error (`Msg msg) -> Error (Io_error msg)
276 with e -> Error (Io_error (Printexc.to_string e)))
277 | `Other _ -> (
278 let cwd = path_to_eio ~fs repo in
279 let url_str = url in
280 match run_git_ok_with_retry ~proc ~cwd [ "fetch"; url_str; branch ] with
281 | Error e -> Error e
282 | Ok _ -> (
283 match run_git_ok ~proc ~cwd [ "rev-parse"; "FETCH_HEAD" ] with
284 | Error e -> Error e
285 | Ok hash -> Ok (String.trim hash)))
286
287let push_refspec ~proc ~fs ~repo ~url ~refspec ?(force = false) () =
288 let cwd = path_to_eio ~fs repo in
289 let url_str = url in
290 let args =
291 [ "push" ] @ (if force then [ "--force" ] else []) @ [ url_str; refspec ]
292 in
293 Log.debug (fun m -> m "push_refspec: git %s" (String.concat " " args));
294 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
295
296let push_remote ~proc ~fs ?(remote = "origin") ?branch ?(force = false) path =
297 let cwd = path_to_eio ~fs path in
298 let branch =
299 match branch with
300 | Some b -> b
301 | None ->
302 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
303 if result.exit_code = 0 then result.stdout else "main"
304 in
305 let args =
306 [ "push" ] @ (if force then [ "--force" ] else []) @ [ remote; branch ]
307 in
308 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
309
310let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
311 let cwd = path_to_eio ~fs repo in
312 run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore