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
54let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
55 let dir, _ = fs in
56 (dir, Fpath.to_string path)
57
58let is_repo ~proc ~fs path =
59 let cwd = path_to_eio ~fs path in
60 let result = run_git ~proc ~cwd [ "rev-parse"; "--git-dir" ] in
61 result.exit_code = 0
62
63let is_dirty ~proc ~fs path =
64 let cwd = path_to_eio ~fs path in
65 let result = run_git ~proc ~cwd [ "status"; "--porcelain" ] in
66 result.exit_code = 0 && result.stdout <> ""
67
68let current_branch ~proc ~fs path =
69 let cwd = path_to_eio ~fs path in
70 let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
71 if result.exit_code = 0 then Some result.stdout else None
72
73let head_commit ~proc ~fs path =
74 let cwd = path_to_eio ~fs path in
75 run_git_ok ~proc ~cwd [ "rev-parse"; "HEAD" ]
76
77let rev_parse ~proc ~fs ~rev path =
78 let cwd = path_to_eio ~fs path in
79 run_git_ok ~proc ~cwd [ "rev-parse"; rev ]
80
81let clone ~proc ~fs ~url ~branch target =
82 let parent = Fpath.parent target in
83 let cwd = Eio.Path.(fs / Fpath.to_string parent) in
84 let target_name = Fpath.basename target in
85 let url_str = Uri.to_string url in
86 run_git_ok ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
87 |> Result.map ignore
88
89let fetch ~proc ~fs ?(remote = "origin") path =
90 let cwd = path_to_eio ~fs path in
91 run_git_ok ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
92
93let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
94 let cwd = path_to_eio ~fs path in
95 let branch =
96 match branch with
97 | Some b -> b
98 | None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
99 in
100 let upstream = remote ^ "/" ^ branch in
101 run_git_ok ~proc ~cwd [ "merge"; "--ff-only"; upstream ] |> Result.map ignore
102
103let pull ~proc ~fs ?(remote = "origin") ?branch path =
104 let cwd = path_to_eio ~fs path in
105 let args =
106 match branch with
107 | Some b -> [ "pull"; remote; b ]
108 | None -> [ "pull"; remote ]
109 in
110 run_git_ok ~proc ~cwd args |> Result.map ignore
111
112let checkout ~proc ~fs ~branch path =
113 let cwd = path_to_eio ~fs path in
114 run_git_ok ~proc ~cwd [ "checkout"; branch ] |> Result.map ignore
115
116type ahead_behind = { ahead : int; behind : int }
117
118let ahead_behind ~proc ~fs ?(remote = "origin") ?branch path =
119 let cwd = path_to_eio ~fs path in
120 let branch =
121 match branch with
122 | Some b -> b
123 | None -> Option.value ~default:"HEAD" (current_branch ~proc ~fs path)
124 in
125 let upstream = remote ^ "/" ^ branch in
126 match
127 run_git_ok ~proc ~cwd
128 [ "rev-list"; "--left-right"; "--count"; branch ^ "..." ^ upstream ]
129 with
130 | Error e -> Error e
131 | Ok output -> (
132 match String.split_on_char '\t' output with
133 | [ ahead; behind ] ->
134 Ok { ahead = int_of_string ahead; behind = int_of_string behind }
135 | _ -> Ok { ahead = 0; behind = 0 })
136
137module Subtree = struct
138 let exists ~fs ~repo ~prefix =
139 let path = Eio.Path.(fs / Fpath.to_string repo / prefix) in
140 match Eio.Path.kind ~follow:true path with
141 | `Directory -> true
142 | _ -> false
143 | exception _ -> false
144
145 let add ~proc ~fs ~repo ~prefix ~url ~branch () =
146 if exists ~fs ~repo ~prefix then Error (Subtree_prefix_exists prefix)
147 else
148 let cwd = path_to_eio ~fs repo in
149 let url_str = Uri.to_string url in
150 run_git_ok ~proc ~cwd
151 [ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ]
152 |> Result.map ignore
153
154 let pull ~proc ~fs ~repo ~prefix ~url ~branch () =
155 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
156 else
157 let cwd = path_to_eio ~fs repo in
158 let url_str = Uri.to_string url in
159 run_git_ok ~proc ~cwd
160 [ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ]
161 |> Result.map ignore
162
163 let push ~proc ~fs ~repo ~prefix ~url ~branch () =
164 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
165 else
166 let cwd = path_to_eio ~fs repo in
167 let url_str = Uri.to_string url in
168 run_git_ok ~proc ~cwd
169 [ "subtree"; "push"; "--prefix"; prefix; url_str; branch ]
170 |> Result.map ignore
171
172 let split ~proc ~fs ~repo ~prefix () =
173 if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
174 else
175 let cwd = path_to_eio ~fs repo in
176 run_git_ok ~proc ~cwd [ "subtree"; "split"; "--prefix"; prefix ]
177end
178
179let init ~proc ~fs path =
180 let cwd = path_to_eio ~fs (Fpath.parent path) in
181 let name = Fpath.basename path in
182 run_git_ok ~proc ~cwd [ "init"; name ] |> Result.map ignore
183
184let commit_allow_empty ~proc ~fs ~message path =
185 let cwd = path_to_eio ~fs path in
186 run_git_ok ~proc ~cwd [ "commit"; "--allow-empty"; "-m"; message ]
187 |> Result.map ignore
188
189let push_remote ~proc ~fs ?(remote = "origin") ?branch path =
190 let cwd = path_to_eio ~fs path in
191 let branch =
192 match branch with
193 | Some b -> b
194 | None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
195 in
196 run_git_ok ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
197
198let set_push_url ~proc ~fs ?(remote = "origin") ~url path =
199 let cwd = path_to_eio ~fs path in
200 run_git_ok ~proc ~cwd [ "remote"; "set-url"; "--push"; remote; url ]
201 |> Result.map ignore
202
203let get_push_url ~proc ~fs ?(remote = "origin") path =
204 let cwd = path_to_eio ~fs path in
205 match run_git_ok ~proc ~cwd [ "remote"; "get-url"; "--push"; remote ] with
206 | Ok url -> Some url
207 | Error _ -> None
208
209type log_entry = {
210 hash : string;
211 author : string;
212 date : string;
213 subject : string;
214 body : string;
215}
216
217let parse_log_entries output =
218 if String.trim output = "" then []
219 else
220 (* Split by the record separator (NUL at end of each record) *)
221 let records = String.split_on_char '\x00' output in
222 (* Filter empty strings and parse each record *)
223 List.filter_map
224 (fun record ->
225 let record = String.trim record in
226 if record = "" then None
227 else
228 (* Each record is: hash\nauthor\ndate\nsubject\nbody *)
229 match String.split_on_char '\n' record with
230 | hash :: author :: date :: subject :: body_lines ->
231 Some
232 {
233 hash;
234 author;
235 date;
236 subject;
237 body = String.concat "\n" body_lines;
238 }
239 | _ -> None)
240 records
241
242let log ~proc ~fs ?since ?until ?path:(filter_path : string option) repo_path =
243 let cwd = path_to_eio ~fs repo_path in
244 (* Build args: use format with NUL separator between records *)
245 let format_arg = "--format=%H%n%an%n%aI%n%s%n%b%x00" in
246 let args = [ "log"; format_arg ] in
247 let args =
248 match since with Some s -> args @ [ "--since=" ^ s ] | None -> args
249 in
250 let args =
251 match until with Some u -> args @ [ "--until=" ^ u ] | None -> args
252 in
253 let args = match filter_path with Some p -> args @ [ "--"; p ] | None -> args in
254 match run_git_ok ~proc ~cwd args with
255 | Ok output -> Ok (parse_log_entries output)
256 | Error e -> Error e