Monorepo management for opam overlays
1(** Verse collaboration diff operations.
2
3 Compares local repositories with verse member forks to identify commits that
4 can be pulled or cherry-picked. *)
5
6let src = Logs.Src.create "monopam.diff" ~doc:"Monopam diff operations"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10(** {1 Types} *)
11
12type entry = {
13 repo_name : string;
14 handle : string;
15 relationship : Forks.relationship;
16 commits : Git.Repository.log_entry list;
17 patches : (string * string) list;
18}
19
20type result = { entries : entry list; forks : Forks.t }
21
22type commit_info = {
23 commit_repo : string;
24 commit_handle : string;
25 commit_hash : string;
26 commit_subject : string;
27 commit_author : string;
28 commit_patch : string;
29}
30
31type handle_pull_result = {
32 repos_pulled : (string * int) list;
33 repos_skipped : string list;
34 repos_failed : (string * string) list;
35}
36
37type cherrypick_result = {
38 repo_name : string;
39 commit_hash : string;
40 commit_subject : string;
41}
42
43(** {1 Pretty Printers} *)
44
45let pp_entry ~show_patch ppf entry =
46 let n_commits = List.length entry.commits in
47 Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@,"
48 Fmt.(styled `Bold string)
49 entry.repo_name entry.handle Forks.pp_relationship entry.relationship
50 n_commits
51 (if n_commits = 1 then "" else "s");
52 List.iter
53 (fun (c : Git.Repository.log_entry) ->
54 let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
55 Fmt.pf ppf " %a %s %a@,"
56 Fmt.(styled `Yellow string)
57 short_hash c.subject
58 Fmt.(styled `Faint string)
59 c.author;
60 if show_patch then
61 match List.assoc_opt c.hash entry.patches with
62 | Some patch -> Fmt.pf ppf "@,%s@," patch
63 | None -> ())
64 entry.commits;
65 Fmt.pf ppf "@]"
66
67let pp ~show_patch ppf result =
68 Fmt.pf ppf "%a@." (Forks.pp_summary' ~show_all:false) result.forks;
69 if result.entries <> [] then begin
70 Fmt.pf ppf "@[<v>%a@]@."
71 Fmt.(list ~sep:(any "@,@,") (pp_entry ~show_patch))
72 result.entries
73 end
74
75let pp_handle_pull_result ppf result =
76 if result.repos_pulled <> [] then begin
77 Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:";
78 List.iter
79 (fun (repo, count) -> Fmt.pf ppf " %s: %d commits@," repo count)
80 result.repos_pulled;
81 Fmt.pf ppf "@]"
82 end;
83 if result.repos_skipped <> [] then
84 Fmt.pf ppf "%a %s@,"
85 Fmt.(styled `Faint string)
86 "Skipped:"
87 (String.concat ", " result.repos_skipped);
88 if result.repos_failed <> [] then begin
89 Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:";
90 List.iter
91 (fun (repo, err) -> Fmt.pf ppf " %s: %s@," repo err)
92 result.repos_failed;
93 Fmt.pf ppf "@]"
94 end
95
96let pp_cherrypick_result ppf result =
97 let short_hash =
98 String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash))
99 in
100 Fmt.pf ppf "Cherry-picked %a %s into %s@."
101 Fmt.(styled `Yellow string)
102 short_hash result.commit_subject result.repo_name
103
104(** {1 Utilities} *)
105
106let is_commit_sha s =
107 String.length s >= 7
108 && String.for_all
109 (function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
110 s
111
112(** {1 Diff Operations} *)
113
114let check_source ~sw ~fs ~checkouts_path ~patch ~repo_name (handle, _src, rel) =
115 let checkout_path = Fpath.(checkouts_path / repo_name) in
116 if not (Git.Repository.is_repo ~fs checkout_path) then None
117 else begin
118 let repo = Git.Repository.open_repo ~sw ~fs checkout_path in
119 let remote_name = "verse/" ^ handle in
120 let my_ref = "origin/main" in
121 let their_ref = remote_name ^ "/main" in
122 match
123 Git.Repository.log_range_refs repo ~base:my_ref ~tip:their_ref
124 ~max_count:20 ()
125 with
126 | Error _ -> None
127 | Ok commits when commits = [] -> None
128 | Ok commits ->
129 let patches =
130 if patch then
131 List.filter_map
132 (fun (c : Git.Repository.log_entry) ->
133 match Git.Repository.show_patch repo ~commit:c.hash with
134 | Ok p -> Some (c.hash, p)
135 | Error _ -> None)
136 commits
137 else []
138 in
139 Some { repo_name; handle; relationship = rel; commits; patches }
140 end
141
142let check_repo ~sw ~fs ~checkouts_path ~patch (r : Forks.repo_analysis) =
143 let actionable =
144 List.filter
145 (fun (_, _, rel) ->
146 match rel with
147 | Forks.I_am_behind _ -> true
148 | Forks.Diverged _ -> true
149 | _ -> false)
150 r.verse_sources
151 in
152 match actionable with
153 | [] -> None
154 | sources -> (
155 let entries =
156 List.filter_map
157 (check_source ~sw ~fs ~checkouts_path ~patch ~repo_name:r.repo_name)
158 sources
159 in
160 match entries with [] -> None | _ -> Some entries)
161
162let compute ~sw ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
163 ?(patch = false) () =
164 let checkouts_path = Config.Paths.checkouts config in
165 let forks =
166 Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
167 in
168 let repos_to_check =
169 match repo with
170 | None -> forks.repos
171 | Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
172 in
173 let entries =
174 List.filter_map (check_repo ~sw ~fs ~checkouts_path ~patch) repos_to_check
175 |> List.flatten
176 in
177 { entries; forks }
178
179let show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
180 let checkouts_path = Config.Paths.checkouts config in
181 let forks =
182 Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
183 in
184 List.find_map
185 (fun (r : Forks.repo_analysis) ->
186 let checkout_path = Fpath.(checkouts_path / r.repo_name) in
187 if not (Git.Repository.is_repo ~fs checkout_path) then None
188 else
189 let repo = Git.Repository.open_repo ~sw ~fs checkout_path in
190 List.find_map
191 (fun (handle, _src, rel) ->
192 match rel with
193 | Forks.I_am_behind _ | Forks.Diverged _ -> (
194 let remote_name = "verse/" ^ handle in
195 let my_ref = "origin/main" in
196 let their_ref = remote_name ^ "/main" in
197 match
198 Git.Repository.log_range_refs repo ~base:my_ref ~tip:their_ref
199 ~max_count:50 ()
200 with
201 | Error _ -> None
202 | Ok commits -> (
203 let matching =
204 List.find_opt
205 (fun (c : Git.Repository.log_entry) ->
206 String.starts_with ~prefix:sha c.hash
207 || String.starts_with
208 ~prefix:(String.lowercase_ascii sha)
209 (String.lowercase_ascii c.hash))
210 commits
211 in
212 match matching with
213 | None -> None
214 | Some c -> (
215 match Git.Repository.show_patch repo ~commit:c.hash with
216 | Ok patch ->
217 Some
218 {
219 commit_repo = r.repo_name;
220 commit_handle = handle;
221 commit_hash = c.hash;
222 commit_subject = c.subject;
223 commit_author = c.author;
224 commit_patch = patch;
225 }
226 | Error _ -> None)))
227 | _ -> None)
228 r.verse_sources)
229 forks.repos
230
231(** {1 Pull from Handle} *)
232
233type pull_action =
234 | Pulled of string * int
235 | Skipped of string
236 | Failed of string * string
237
238let pull_one_repo ~sw ~fs ~checkouts_path ~handle (r : Forks.repo_analysis) =
239 let handle_source =
240 List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
241 in
242 match handle_source with
243 | None -> []
244 | Some (_, _, rel) ->
245 let checkout_path = Fpath.(checkouts_path / r.repo_name) in
246 if not (Git.Repository.is_repo ~fs checkout_path) then
247 [ Skipped r.repo_name ]
248 else begin
249 let git_repo = Git.Repository.open_repo ~sw ~fs checkout_path in
250 match rel with
251 | Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _
252 | Forks.Not_fetched | Forks.Unrelated ->
253 [ Skipped r.repo_name ]
254 | Forks.I_am_behind count -> (
255 let remote_ref = "verse/" ^ handle ^ "/main" in
256 match
257 Git.Repository.merge git_repo ~ref_name:remote_ref ~ff_only:true
258 with
259 | Ok () -> [ Pulled (r.repo_name, count) ]
260 | Error (`Msg msg) -> [ Failed (r.repo_name, msg) ])
261 | Forks.Diverged { their_ahead; _ } -> (
262 let remote_ref = "verse/" ^ handle ^ "/main" in
263 match
264 Git.Repository.merge git_repo ~ref_name:remote_ref ~ff_only:false
265 with
266 | Ok () -> [ Pulled (r.repo_name, their_ahead) ]
267 | Error (`Msg msg) -> [ Failed (r.repo_name, msg) ])
268 end
269
270let pull_from_handle ~sw ~proc ~fs ~config ~verse_config ~handle ?repo
271 ?(refresh = false) () =
272 let checkouts_path = Config.Paths.checkouts config in
273 let forks =
274 Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
275 in
276 let repos_to_check =
277 match repo with
278 | None -> forks.repos
279 | Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
280 in
281 let actions =
282 List.concat_map
283 (pull_one_repo ~sw ~fs ~checkouts_path ~handle)
284 repos_to_check
285 in
286 let repos_pulled, repos_skipped, repos_failed =
287 List.fold_left
288 (fun (pulled, skipped, failed) -> function
289 | Pulled (name, count) -> ((name, count) :: pulled, skipped, failed)
290 | Skipped name -> (pulled, name :: skipped, failed)
291 | Failed (name, msg) -> (pulled, skipped, (name, msg) :: failed))
292 ([], [], []) actions
293 in
294 Ok
295 {
296 repos_pulled = List.rev repos_pulled;
297 repos_skipped = List.rev repos_skipped;
298 repos_failed = List.rev repos_failed;
299 }
300
301(** {1 Cherry-pick} *)
302
303let cherrypick ~sw ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
304 let checkouts_path = Config.Paths.checkouts config in
305 match show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh () with
306 | None ->
307 Error
308 (Ctx.Config_error (Fmt.str "Commit %s not found in any verse diff" sha))
309 | Some info ->
310 let checkout_path = Fpath.(checkouts_path / info.commit_repo) in
311 if not (Git.Repository.is_repo ~fs checkout_path) then
312 Error
313 (Ctx.Config_error
314 (Fmt.str "No checkout for repository %s" info.commit_repo))
315 else begin
316 let git_repo = Git.Repository.open_repo ~sw ~fs checkout_path in
317 match Git.Repository.cherry_pick git_repo ~commit:info.commit_hash with
318 | Ok _new_hash ->
319 Ok
320 {
321 repo_name = info.commit_repo;
322 commit_hash = info.commit_hash;
323 commit_subject = info.commit_subject;
324 }
325 | Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
326 end