anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
1type cmd_result = { exit_code : int; stdout : string; stderr : string }
2
3type error =
4 | Command_failed of string * cmd_result
5 | Not_a_repo of Fpath.t
6 | Dirty_worktree of Fpath.t
7 | Remote_not_found of string
8 | Branch_not_found of string
9 | Subtree_prefix_exists of string
10 | Subtree_prefix_missing of string
11 | Io_error of string
12
13let pp_error ppf = function
14 | Command_failed (cmd, r) ->
15 Fmt.pf ppf "Command failed: %s (exit %d)@.stdout: %s@.stderr: %s" cmd
16 r.exit_code r.stdout r.stderr
17 | Not_a_repo path -> Fmt.pf ppf "Not a git repository: %a" Fpath.pp path
18 | Dirty_worktree path ->
19 Fmt.pf ppf "Repository has uncommitted changes: %a" Fpath.pp path
20 | Remote_not_found name -> Fmt.pf ppf "Remote not found: %s" name
21 | Branch_not_found name -> Fmt.pf ppf "Branch not found: %s" name
22 | Subtree_prefix_exists prefix ->
23 Fmt.pf ppf "Subtree prefix already exists: %s" prefix
24 | Subtree_prefix_missing prefix ->
25 Fmt.pf ppf "Subtree prefix does not exist: %s" prefix
26 | Io_error msg -> Fmt.pf ppf "I/O error: %s" msg
27
28let run_git ~proc ~cwd args =
29 let cmd = "git" :: args in
30 let buf_stdout = Buffer.create 256 in
31 let buf_stderr = Buffer.create 256 in
32 Eio.Switch.run @@ fun sw ->
33 let child =
34 Eio.Process.spawn proc ~sw ~cwd
35 ~stdout:(Eio.Flow.buffer_sink buf_stdout)
36 ~stderr:(Eio.Flow.buffer_sink buf_stderr)
37 cmd
38 in
39 let exit_status = Eio.Process.await child in
40 let exit_code =
41 match exit_status with `Exited n -> n | `Signaled n -> 128 + n
42 in
43 {
44 exit_code;
45 stdout = Buffer.contents buf_stdout |> String.trim;
46 stderr = Buffer.contents buf_stderr |> String.trim;
47 }
48
49let run_git_ok ~proc ~cwd args =
50 let result = run_git ~proc ~cwd args in
51 if result.exit_code = 0 then Ok result.stdout
52 else Error (Command_failed (String.concat " " ("git" :: args), result))
53
54(** Helper for substring check *)
55let string_contains ~needle haystack =
56 let needle_len = String.length needle in
57 let haystack_len = String.length haystack in
58 if needle_len > haystack_len then false
59 else
60 let rec check i =
61 if i + needle_len > haystack_len then false
62 else if String.sub haystack i needle_len = needle then true
63 else check (i + 1)
64 in
65 check 0
66
67(** Patterns indicating retryable HTTP 5xx or network errors *)
68let retryable_error_patterns =
69 [
70 (* HTTP 5xx errors *)
71 "500"; "502"; "503"; "504"; "HTTP 5"; "http 5";
72 "Internal Server Error"; "Bad Gateway"; "Service Unavailable"; "Gateway Timeout";
73 (* RPC failures (common git smart HTTP errors) *)
74 "RPC failed"; "curl"; "unexpected disconnect";
75 "the remote end hung up"; "early EOF";
76 (* Connection errors *)
77 "Connection refused"; "Connection reset"; "Connection timed out";
78 "Could not resolve host"; "Failed to connect";
79 "Network is unreachable"; "Temporary failure";
80 ]
81
82(** Check if an error is a retryable HTTP server error (5xx) or network error *)
83let is_retryable_error result =
84 let stderr = result.stderr in
85 String.length stderr > 0
86 && List.exists (fun needle -> string_contains ~needle stderr) retryable_error_patterns
87
88(** Run a git command with retry logic for network errors.
89 Retries up to [max_retries] times with exponential backoff starting at [initial_delay_ms]. *)
90let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3) ?(initial_delay_ms = 2000) args =
91 let rec attempt n delay_ms =
92 let result = run_git ~proc ~cwd args in
93 if result.exit_code = 0 then Ok result.stdout
94 else if n < max_retries && is_retryable_error result then begin
95 (* Log the retry *)
96 Logs.warn (fun m ->
97 m "Git command failed with retryable error, retrying in %dms (%d/%d): %s"
98 delay_ms (n + 1) max_retries result.stderr);
99 (* Sleep before retry - convert ms to seconds for Unix.sleepf *)
100 Unix.sleepf (float_of_int delay_ms /. 1000.0);
101 (* Exponential backoff: double the delay for next attempt *)
102 attempt (n + 1) (delay_ms * 2)
103 end
104 else Error (Command_failed (String.concat " " ("git" :: args), result))
105 in
106 attempt 0 initial_delay_ms
107
108let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
109 let dir, _ = fs in
110 (dir, Fpath.to_string path)
111
112let is_repo ~proc ~fs path =
113 let cwd = path_to_eio ~fs path in
114 try
115 let result = run_git ~proc ~cwd [ "rev-parse"; "--git-dir" ] in
116 result.exit_code = 0
117 with Eio.Io _ -> false (* Directory doesn't exist or not accessible *)
118
119let is_dirty ~proc ~fs path =
120 let cwd = path_to_eio ~fs path in
121 let result = run_git ~proc ~cwd [ "status"; "--porcelain" ] in
122 result.exit_code = 0 && result.stdout <> ""
123
124let current_branch ~proc ~fs path =
125 let cwd = path_to_eio ~fs path in
126 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
127 if result.exit_code = 0 then Some result.stdout else None
128
129let head_commit ~proc ~fs path =
130 let cwd = path_to_eio ~fs path in
131 run_git_ok ~proc ~cwd [ "rev-parse"; "HEAD" ]
132
133let rev_parse ~proc ~fs ~rev path =
134 let cwd = path_to_eio ~fs path in
135 run_git_ok ~proc ~cwd [ "rev-parse"; rev ]
136
137let clone ~proc ~fs ~url ~branch target =
138 let parent = Fpath.parent target in
139 let cwd = Eio.Path.(fs / Fpath.to_string parent) in
140 let target_name = Fpath.basename target in
141 let url_str = Uri.to_string url in
142 run_git_ok_with_retry ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
143 |> Result.map ignore
144
145let fetch ~proc ~fs ?(remote = "origin") path =
146 let cwd = path_to_eio ~fs path in
147 run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
148
149let fetch_all ~proc ~fs path =
150 let cwd = path_to_eio ~fs path in
151 run_git_ok_with_retry ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore
152
153let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
154 let cwd = path_to_eio ~fs path in
155 let branch =
156 match branch with
157 | Some b -> b
158 | None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
159 in
160 let upstream = remote ^ "/" ^ branch in
161 run_git_ok ~proc ~cwd [ "merge"; "--ff-only"; upstream ] |> Result.map ignore
162
163let pull ~proc ~fs ?(remote = "origin") ?branch path =
164 let cwd = path_to_eio ~fs path in
165 let args =
166 match branch with
167 | Some b -> [ "pull"; remote; b ]
168 | None -> [ "pull"; remote ]
169 in
170 run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
171
172let fetch_and_reset ~proc ~fs ?(remote = "origin") ~branch path =
173 let cwd = path_to_eio ~fs path in
174 match run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] with
175 | Error e -> Error e
176 | Ok _ ->
177 let upstream = remote ^ "/" ^ branch in
178 run_git_ok ~proc ~cwd [ "reset"; "--hard"; upstream ] |> Result.map ignore
179
180let checkout ~proc ~fs ~branch path =
181 let cwd = path_to_eio ~fs path in
182 run_git_ok ~proc ~cwd [ "checkout"; branch ] |> Result.map ignore
183
184type ahead_behind = { ahead : int; behind : int }
185
186let ahead_behind ~proc ~fs ?(remote = "origin") ?branch path =
187 let cwd = path_to_eio ~fs path in
188 let branch =
189 match branch with
190 | Some b -> b
191 | None -> Option.value ~default:"HEAD" (current_branch ~proc ~fs path)
192 in
193 let upstream = remote ^ "/" ^ branch in
194 match
195 run_git_ok ~proc ~cwd
196 [ "rev-list"; "--left-right"; "--count"; branch ^ "..." ^ upstream ]
197 with
198 | Error e -> Error e
199 | Ok output -> (
200 match String.split_on_char '\t' output with
201 | [ ahead; behind ] ->
202 Ok { ahead = int_of_string ahead; behind = int_of_string behind }
203 | _ -> Ok { ahead = 0; behind = 0 })
204
205module Subtree = struct
206 let exists ~fs ~repo ~prefix =
207 let path = Eio.Path.(fs / Fpath.to_string repo / prefix) in
208 match Eio.Path.kind ~follow:true path with
209 | `Directory -> true
210 | _ -> false
211 | exception _ -> false
212
213 let add ~proc ~fs ~repo ~prefix ~url ~branch () =
214 if exists ~fs ~repo ~prefix then Error (Subtree_prefix_exists prefix)
215 else
216 let cwd = path_to_eio ~fs repo in
217 let url_str = Uri.to_string url in
218 run_git_ok_with_retry ~proc ~cwd
219 [ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ]
220 |> Result.map ignore
221
222 let pull ~proc ~fs ~repo ~prefix ~url ~branch () =
223 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
224 else
225 let cwd = path_to_eio ~fs repo in
226 let url_str = Uri.to_string url in
227 run_git_ok_with_retry ~proc ~cwd
228 [ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ]
229 |> Result.map ignore
230
231 let push ~proc ~fs ~repo ~prefix ~url ~branch () =
232 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
233 else
234 let cwd = path_to_eio ~fs repo in
235 let url_str = Uri.to_string url in
236 run_git_ok_with_retry ~proc ~cwd
237 [ "subtree"; "push"; "--prefix"; prefix; url_str; branch ]
238 |> Result.map ignore
239
240 let split ~proc ~fs ~repo ~prefix () =
241 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
242 else
243 let cwd = path_to_eio ~fs repo in
244 run_git_ok ~proc ~cwd [ "subtree"; "split"; "--prefix"; prefix ]
245end
246
247let init ~proc ~fs path =
248 let cwd = path_to_eio ~fs (Fpath.parent path) in
249 let name = Fpath.basename path in
250 run_git_ok ~proc ~cwd [ "init"; name ] |> Result.map ignore
251
252let commit_allow_empty ~proc ~fs ~message path =
253 let cwd = path_to_eio ~fs path in
254 run_git_ok ~proc ~cwd [ "commit"; "--allow-empty"; "-m"; message ]
255 |> Result.map ignore
256
257let push_remote ~proc ~fs ?(remote = "origin") ?branch path =
258 let cwd = path_to_eio ~fs path in
259 let branch =
260 match branch with
261 | Some b -> b
262 | None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
263 in
264 run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
265
266let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
267 let cwd = path_to_eio ~fs repo in
268 run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore
269
270let set_push_url ~proc ~fs ?(remote = "origin") ~url path =
271 let cwd = path_to_eio ~fs path in
272 run_git_ok ~proc ~cwd [ "remote"; "set-url"; "--push"; remote; url ]
273 |> Result.map ignore
274
275let get_push_url ~proc ~fs ?(remote = "origin") path =
276 let cwd = path_to_eio ~fs path in
277 match run_git_ok ~proc ~cwd [ "remote"; "get-url"; "--push"; remote ] with
278 | Ok url -> Some url
279 | Error _ -> None
280
281let list_remotes ~proc ~fs path =
282 let cwd = path_to_eio ~fs path in
283 match run_git_ok ~proc ~cwd [ "remote" ] with
284 | Ok output ->
285 String.split_on_char '\n' output
286 |> List.filter (fun s -> String.trim s <> "")
287 | Error _ -> []
288
289let get_remote_url ~proc ~fs ~remote path =
290 let cwd = path_to_eio ~fs path in
291 match run_git_ok ~proc ~cwd [ "remote"; "get-url"; remote ] with
292 | Ok url -> Some (String.trim url)
293 | Error _ -> None
294
295let add_remote ~proc ~fs ~name ~url path =
296 let cwd = path_to_eio ~fs path in
297 run_git_ok ~proc ~cwd [ "remote"; "add"; name; url ] |> Result.map ignore
298
299let remove_remote ~proc ~fs ~name path =
300 let cwd = path_to_eio ~fs path in
301 run_git_ok ~proc ~cwd [ "remote"; "remove"; name ] |> Result.map ignore
302
303let set_remote_url ~proc ~fs ~name ~url path =
304 let cwd = path_to_eio ~fs path in
305 run_git_ok ~proc ~cwd [ "remote"; "set-url"; name; url ] |> Result.map ignore
306
307let ensure_remote ~proc ~fs ~name ~url path =
308 let remotes = list_remotes ~proc ~fs path in
309 if List.mem name remotes then begin
310 (* Remote exists, check if URL matches *)
311 match get_remote_url ~proc ~fs ~remote:name path with
312 | Some existing_url when existing_url = url -> Ok ()
313 | _ -> set_remote_url ~proc ~fs ~name ~url path
314 end
315 else add_remote ~proc ~fs ~name ~url path
316
317type log_entry = {
318 hash : string;
319 author : string;
320 date : string;
321 subject : string;
322 body : string;
323}
324
325let parse_log_entries output =
326 if String.trim output = "" then []
327 else
328 (* Split by the record separator (NUL at end of each record) *)
329 let records = String.split_on_char '\x00' output in
330 (* Filter empty strings and parse each record *)
331 List.filter_map
332 (fun record ->
333 let record = String.trim record in
334 if record = "" then None
335 else
336 (* Each record is: hash\nauthor\ndate\nsubject\nbody *)
337 match String.split_on_char '\n' record with
338 | hash :: author :: date :: subject :: body_lines ->
339 Some
340 {
341 hash;
342 author;
343 date;
344 subject;
345 body = String.concat "\n" body_lines;
346 }
347 | _ -> None)
348 records
349
350let log ~proc ~fs ?since ?until ?path:(filter_path : string option) repo_path =
351 let cwd = path_to_eio ~fs repo_path in
352 (* Build args: use format with NUL separator between records *)
353 let format_arg = "--format=%H%n%an%n%aI%n%s%n%b%x00" in
354 let args = [ "log"; format_arg ] in
355 let args =
356 match since with Some s -> args @ [ "--since=" ^ s ] | None -> args
357 in
358 let args =
359 match until with Some u -> args @ [ "--until=" ^ u ] | None -> args
360 in
361 let args =
362 match filter_path with Some p -> args @ [ "--"; p ] | None -> args
363 in
364 match run_git_ok ~proc ~cwd args with
365 | Ok output -> Ok (parse_log_entries output)
366 | Error e -> Error e
367
368let log_range ~proc ~fs ~base ~tip ?max_count repo_path =
369 let cwd = path_to_eio ~fs repo_path in
370 let format_arg = "--format=%H%n%an%n%aI%n%s%n%b%x00" in
371 let range = Printf.sprintf "%s..%s" base tip in
372 let args = [ "log"; format_arg; range ] in
373 let args =
374 match max_count with
375 | Some n -> args @ [ "-n"; string_of_int n ]
376 | None -> args
377 in
378 match run_git_ok ~proc ~cwd args with
379 | Ok output -> Ok (parse_log_entries output)
380 | Error e -> Error e
381
382let show_patch ~proc ~fs ~commit repo_path =
383 let cwd = path_to_eio ~fs repo_path in
384 run_git_ok ~proc ~cwd [ "show"; "--patch"; "--stat"; commit ]
385
386(** Parse a subtree merge/squash commit message to extract the upstream commit range.
387 Messages look like: "Squashed 'prefix/' changes from abc123..def456"
388 or "Squashed 'prefix/' content from commit abc123"
389 Returns the end commit (most recent) if found. *)
390let parse_subtree_message subject =
391 (* Helper to extract hex commit hash starting at position *)
392 let extract_hex s start =
393 let len = String.length s in
394 let rec find_end i =
395 if i >= len then i
396 else
397 match s.[i] with '0' .. '9' | 'a' .. 'f' -> find_end (i + 1) | _ -> i
398 in
399 let end_pos = find_end start in
400 if end_pos > start then Some (String.sub s start (end_pos - start))
401 else None
402 in
403 (* Pattern 1: "Squashed 'prefix/' changes from abc123..def456" *)
404 if String.starts_with ~prefix:"Squashed '" subject then
405 match String.index_opt subject '.' with
406 | Some i when i + 1 < String.length subject && subject.[i + 1] = '.' ->
407 extract_hex subject (i + 2)
408 | _ -> (
409 (* Pattern 2: "Squashed 'prefix/' content from commit abc123" *)
410 match String.split_on_char ' ' subject |> List.rev with
411 | last :: "commit" :: "from" :: _ -> extract_hex last 0
412 | _ -> None) (* Pattern 3: "Add 'prefix/' from commit abc123" *)
413 else if String.starts_with ~prefix:"Add '" subject then
414 match String.split_on_char ' ' subject |> List.rev with
415 | last :: "commit" :: "from" :: _ -> extract_hex last 0
416 | _ -> None
417 else None
418
419(** Find the last subtree-related commit for a given prefix. Searches git log
420 for commits with subtree merge/squash messages. *)
421let subtree_last_upstream_commit ~proc ~fs ~repo ~prefix () =
422 let cwd = path_to_eio ~fs repo in
423 (* Search for subtree-related commits - don't use path filter as it can miss merge commits *)
424 let grep_pattern = Printf.sprintf "^Squashed '%s/'" prefix in
425 match
426 run_git_ok ~proc ~cwd [ "log"; "--oneline"; "-1"; "--grep"; grep_pattern ]
427 with
428 | Error _ -> None
429 | Ok "" -> (
430 (* Try alternate pattern: Add 'prefix/' from commit *)
431 let add_pattern = Printf.sprintf "^Add '%s/'" prefix in
432 match
433 run_git_ok ~proc ~cwd
434 [ "log"; "--oneline"; "-1"; "--grep"; add_pattern ]
435 with
436 | Error _ -> None
437 | Ok "" -> None
438 | Ok line -> (
439 (* line is "abc1234 Add 'prefix/' from commit ..." *)
440 let hash = String.sub line 0 (min 7 (String.length line)) in
441 (* Get the full commit message to parse *)
442 match run_git_ok ~proc ~cwd [ "log"; "-1"; "--format=%s"; hash ] with
443 | Error _ -> None
444 | Ok subject -> parse_subtree_message subject))
445 | Ok line -> (
446 let hash = String.sub line 0 (min 7 (String.length line)) in
447 match run_git_ok ~proc ~cwd [ "log"; "-1"; "--format=%s"; hash ] with
448 | Error _ -> None
449 | Ok subject -> parse_subtree_message subject)
450
451(** Check if commit1 is an ancestor of commit2. *)
452let is_ancestor ~proc ~fs ~repo ~commit1 ~commit2 () =
453 let cwd = path_to_eio ~fs repo in
454 let result =
455 run_git ~proc ~cwd [ "merge-base"; "--is-ancestor"; commit1; commit2 ]
456 in
457 result.exit_code = 0
458
459(** Find the merge-base (common ancestor) of two commits. *)
460let merge_base ~proc ~fs ~repo ~commit1 ~commit2 () =
461 let cwd = path_to_eio ~fs repo in
462 run_git_ok ~proc ~cwd [ "merge-base"; commit1; commit2 ]
463
464(** Count commits between two commits (exclusive of base, inclusive of head). *)
465let count_commits_between ~proc ~fs ~repo ~base ~head () =
466 let cwd = path_to_eio ~fs repo in
467 match run_git_ok ~proc ~cwd [ "rev-list"; "--count"; base ^ ".." ^ head ] with
468 | Error _ -> 0
469 | Ok s -> ( try int_of_string (String.trim s) with _ -> 0)
470
471(** {1 Worktree Operations} *)
472
473module Worktree = struct
474 type entry = {
475 path : Fpath.t;
476 head : string;
477 branch : string option;
478 }
479
480 let add ~proc ~fs ~repo ~path ~branch () =
481 let cwd = path_to_eio ~fs repo in
482 let path_str = Fpath.to_string path in
483 run_git_ok ~proc ~cwd
484 [ "worktree"; "add"; "-b"; branch; path_str ]
485 |> Result.map ignore
486
487 let remove ~proc ~fs ~repo ~path ~force () =
488 let cwd = path_to_eio ~fs repo in
489 let path_str = Fpath.to_string path in
490 let args =
491 if force then [ "worktree"; "remove"; "--force"; path_str ]
492 else [ "worktree"; "remove"; path_str ]
493 in
494 run_git_ok ~proc ~cwd args |> Result.map ignore
495
496 let list ~proc ~fs repo =
497 let cwd = path_to_eio ~fs repo in
498 match run_git_ok ~proc ~cwd [ "worktree"; "list"; "--porcelain" ] with
499 | Error _ -> []
500 | Ok output ->
501 if String.trim output = "" then []
502 else
503 (* Parse porcelain output: blocks separated by blank lines
504 Each block has:
505 worktree /path/to/worktree
506 HEAD abc123...
507 branch refs/heads/branchname (or detached) *)
508 let lines = String.split_on_char '\n' output in
509 let rec parse_entries acc current_path current_head current_branch = function
510 | [] ->
511 (* Finalize last entry if we have one *)
512 (match current_path, current_head with
513 | Some p, Some h ->
514 let entry = { path = p; head = h; branch = current_branch } in
515 List.rev (entry :: acc)
516 | _ -> List.rev acc)
517 | "" :: rest ->
518 (* End of entry block *)
519 (match current_path, current_head with
520 | Some p, Some h ->
521 let entry = { path = p; head = h; branch = current_branch } in
522 parse_entries (entry :: acc) None None None rest
523 | _ -> parse_entries acc None None None rest)
524 | line :: rest ->
525 if String.starts_with ~prefix:"worktree " line then
526 let path_str = String.sub line 9 (String.length line - 9) in
527 (match Fpath.of_string path_str with
528 | Ok p -> parse_entries acc (Some p) current_head current_branch rest
529 | Error _ -> parse_entries acc current_path current_head current_branch rest)
530 else if String.starts_with ~prefix:"HEAD " line then
531 let head = String.sub line 5 (String.length line - 5) in
532 parse_entries acc current_path (Some head) current_branch rest
533 else if String.starts_with ~prefix:"branch " line then
534 let branch_ref = String.sub line 7 (String.length line - 7) in
535 (* Extract branch name from refs/heads/... *)
536 let branch =
537 if String.starts_with ~prefix:"refs/heads/" branch_ref then
538 Some (String.sub branch_ref 11 (String.length branch_ref - 11))
539 else
540 Some branch_ref
541 in
542 parse_entries acc current_path current_head branch rest
543 else if line = "detached" then
544 parse_entries acc current_path current_head None rest
545 else
546 parse_entries acc current_path current_head current_branch rest
547 in
548 parse_entries [] None None None lines
549
550 let exists ~proc ~fs ~repo ~path =
551 let worktrees = list ~proc ~fs repo in
552 List.exists (fun e -> Fpath.equal e.path path) worktrees
553end
554
555let cherry_pick ~proc ~fs ~commit path =
556 let cwd = path_to_eio ~fs path in
557 run_git_ok ~proc ~cwd [ "cherry-pick"; commit ] |> Result.map ignore
558
559let merge ~proc ~fs ~ref_name ?(ff_only=false) path =
560 let cwd = path_to_eio ~fs path in
561 let args = ["merge"] @ (if ff_only then ["--ff-only"] else []) @ [ref_name] in
562 run_git_ok ~proc ~cwd args |> Result.map ignore
563
564(** {1 Diff Operations} *)
565
566let diff_trees ~proc ~fs ~source ~target =
567 (* Use git diff --no-index to compare two directory trees.
568 This works even if neither directory is a git repo.
569 Exit code 0 = no diff, exit code 1 = diff found, other = error *)
570 let cwd = path_to_eio ~fs (Fpath.v ".") in
571 let source_str = Fpath.to_string source in
572 let target_str = Fpath.to_string target in
573 let result =
574 run_git ~proc ~cwd
575 [
576 "diff";
577 "--no-index";
578 "--binary";
579 (* Handle binary files *)
580 "--no-color";
581 target_str;
582 (* old = checkout *)
583 source_str (* new = monorepo subtree *);
584 ]
585 in
586 match result.exit_code with
587 | 0 ->
588 (* No differences *)
589 Ok ""
590 | 1 ->
591 (* Differences found - this is success for diff *)
592 Ok result.stdout
593 | _ ->
594 (* Actual error *)
595 Error
596 (Command_failed
597 (String.concat " " [ "git"; "diff"; "--no-index" ], result))
598
599let apply_diff ~proc ~fs ~cwd ~diff =
600 if String.length diff = 0 then Ok ()
601 else
602 let cwd_eio = path_to_eio ~fs cwd in
603 (* Apply the diff using git apply.
604 We need to handle the path rewriting since git diff --no-index
605 uses absolute or relative paths as prefixes. *)
606 let cmd = [ "apply"; "--binary"; "-p1"; "-" ] in
607 let buf_stdout = Buffer.create 256 in
608 let buf_stderr = Buffer.create 256 in
609 Eio.Switch.run @@ fun sw ->
610 let child =
611 Eio.Process.spawn proc ~sw ~cwd:cwd_eio
612 ~stdin:(Eio.Flow.string_source diff)
613 ~stdout:(Eio.Flow.buffer_sink buf_stdout)
614 ~stderr:(Eio.Flow.buffer_sink buf_stderr)
615 ("git" :: cmd)
616 in
617 let exit_status = Eio.Process.await child in
618 match exit_status with
619 | `Exited 0 -> Ok ()
620 | `Exited n | `Signaled n ->
621 Error
622 (Command_failed
623 ( String.concat " " ("git" :: cmd),
624 {
625 exit_code = n;
626 stdout = Buffer.contents buf_stdout;
627 stderr = Buffer.contents buf_stderr;
628 } ))
629
630let add_all ~proc ~fs path =
631 let cwd = path_to_eio ~fs path in
632 run_git_ok ~proc ~cwd [ "add"; "-A" ] |> Result.map ignore
633
634let commit ~proc ~fs ~message path =
635 let cwd = path_to_eio ~fs path in
636 run_git_ok ~proc ~cwd [ "commit"; "-m"; message ] |> Result.map ignore
637
638let rm ~proc ~fs ~recursive path target =
639 let cwd = path_to_eio ~fs path in
640 let args = if recursive then [ "rm"; "-r"; target ] else [ "rm"; target ] in
641 run_git_ok ~proc ~cwd args |> Result.map ignore
642
643let config ~proc ~fs ~key ~value path =
644 let cwd = path_to_eio ~fs path in
645 run_git_ok ~proc ~cwd [ "config"; key; value ] |> Result.map ignore
646
647let has_subtree_history ~proc ~fs ~repo ~prefix () =
648 (* Check if there's subtree commit history for this prefix.
649 Returns true if we can find a subtree-related commit message. *)
650 subtree_last_upstream_commit ~proc ~fs ~repo ~prefix () |> Option.is_some
651
652let branch_rename ~proc ~fs ~new_name path =
653 let cwd = path_to_eio ~fs path in
654 run_git_ok ~proc ~cwd [ "branch"; "-M"; new_name ] |> Result.map ignore