jon.recoil.org
forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
1(** Cross-user repository comparison for monopam.
2
3 Compares subtrees across multiple verse users' monorepos to identify common
4 repositories and their relative commit states. *)
5
6(** Relationship between two subtree commits. *)
7type relationship =
8 | Same (** Commits are the same *)
9 | I_am_ahead of int (** My commit is ahead by N commits *)
10 | I_am_behind of int (** My commit is behind by N commits *)
11 | Diverged of { my_ahead : int; their_ahead : int }
12 (** Commits have diverged from a common ancestor *)
13 | Unknown (** Cannot determine relationship (missing commits, etc.) *)
14
15type subtree_info = {
16 monorepo_path : Fpath.t; (** Path to the monorepo *)
17 prefix : string; (** Subtree directory name *)
18 upstream_commit : string option; (** Last synced upstream commit SHA *)
19}
20(** Information about a subtree in a monorepo. *)
21
22type repo_comparison = {
23 repo_name : string; (** Repository/subtree name *)
24 my_info : subtree_info option;
25 (** My subtree info (None if not in my mono) *)
26 others : (string * subtree_info * relationship) list;
27 (** List of (handle, info, relationship to me) *)
28}
29(** Comparison of a repo across multiple users. *)
30
31type t = {
32 my_repos : repo_comparison list; (** Repos I have, compared against others *)
33 other_repos : (string * string list) list;
34 (** Repos I don't have: (repo_name, list of handles who have it) *)
35}
36(** Summary of all cross-user comparisons. *)
37
38let pp_relationship ppf = function
39 | Same -> Fmt.string ppf "same"
40 | I_am_ahead n -> Fmt.pf ppf "%d behind" n (* They are behind me *)
41 | I_am_behind n -> Fmt.pf ppf "%d ahead" n (* They are ahead of me *)
42 | Diverged { my_ahead; their_ahead } ->
43 Fmt.pf ppf "diverged: them +%d, me +%d" their_ahead my_ahead
44 | Unknown -> Fmt.string ppf "unknown"
45
46let pp_subtree_info ppf info =
47 match info.upstream_commit with
48 | Some commit ->
49 Fmt.pf ppf "%s" (String.sub commit 0 (min 7 (String.length commit)))
50 | None -> Fmt.string ppf "(no commit)"
51
52let pp_repo_comparison ppf comp =
53 Fmt.pf ppf "@[<v 2>%s:@," comp.repo_name;
54 (match comp.my_info with
55 | Some info -> Fmt.pf ppf "me: %a@," pp_subtree_info info
56 | None -> ());
57 List.iter
58 (fun (handle, info, rel) ->
59 Fmt.pf ppf "%-19s %a (%a)@," handle pp_subtree_info info pp_relationship
60 rel)
61 comp.others;
62 Fmt.pf ppf "@]"
63
64(** Verbose output with commit SHAs *)
65let pp ppf t =
66 if t.my_repos <> [] then begin
67 Fmt.pf ppf "@[<v>Cross-user comparison:@,";
68 List.iter
69 (fun comp -> Fmt.pf ppf " %a@," pp_repo_comparison comp)
70 t.my_repos;
71 Fmt.pf ppf "@]"
72 end;
73 if t.other_repos <> [] then begin
74 Fmt.pf ppf "@[<v>@,Not in my monorepo:@,";
75 List.iter
76 (fun (repo, handles) ->
77 Fmt.pf ppf " %-19s %s@," repo (String.concat ", " handles))
78 t.other_repos;
79 Fmt.pf ppf "@]"
80 end
81
82(** Check if a relationship represents "others have commits I don't" *)
83let is_actionable = function
84 | I_am_behind _ -> true
85 | Diverged _ -> true
86 | _ -> false
87
88(** Succinct relationship display *)
89let pp_rel_short ppf = function
90 | Same -> Fmt.string ppf "="
91 | I_am_ahead n -> Fmt.pf ppf "-%d" n
92 | I_am_behind n -> Fmt.pf ppf "+%d" n
93 | Diverged { my_ahead; their_ahead } ->
94 Fmt.pf ppf "+%d/-%d" their_ahead my_ahead
95 | Unknown -> Fmt.string ppf "?"
96
97(** Succinct summary: one line per repo with emphasis on action needed *)
98let pp_summary ppf t =
99 if t.my_repos = [] && t.other_repos = [] then ()
100 else begin
101 (* Separate repos into categories *)
102 let with_actions = ref [] in
103 let in_sync = ref [] in
104
105 List.iter
106 (fun comp ->
107 let actionable =
108 List.filter (fun (_, _, rel) -> is_actionable rel) comp.others
109 in
110 if actionable <> [] then
111 with_actions := (comp, actionable) :: !with_actions
112 else in_sync := comp :: !in_sync)
113 t.my_repos;
114
115 (* Print repos with actions needed first *)
116 if !with_actions <> [] then begin
117 Fmt.pf ppf "@[<v>@,Subtrees with upstream changes:@,";
118 List.iter
119 (fun (comp, actionable) ->
120 let changes =
121 List.map
122 (fun (h, _, rel) -> Fmt.str "%s:%a" h pp_rel_short rel)
123 actionable
124 in
125 Fmt.pf ppf " %-24s %s@," comp.repo_name (String.concat " " changes))
126 (List.rev !with_actions);
127 Fmt.pf ppf "@]"
128 end;
129
130 (* Print in-sync repos compactly *)
131 if !in_sync <> [] then
132 Fmt.pf ppf "@,Subtrees in sync: %d repos@," (List.length !in_sync);
133
134 (* Print not-mine repos *)
135 if t.other_repos <> [] then begin
136 let names = List.map fst t.other_repos in
137 Fmt.pf ppf "@,Not in my monorepo: %s@," (String.concat ", " names)
138 end
139 end
140
141(** Get subtree info for a given prefix in a monorepo. *)
142let get_subtree_info ~proc ~fs ~monorepo_path ~prefix () : subtree_info =
143 let upstream_commit =
144 Git.subtree_last_upstream_commit ~proc ~fs ~repo:monorepo_path ~prefix ()
145 in
146 { monorepo_path; prefix; upstream_commit }
147
148(** Compare two subtree commits using a reference checkout. If checkout is
149 available, use it as the authoritative source. Otherwise, just check if
150 commits match. *)
151let compare_commits ~proc ~fs ~checkout_path ~my_commit ~their_commit () =
152 match (my_commit, their_commit) with
153 | None, _ | _, None -> Unknown
154 | Some my, Some their when my = their -> Same
155 | Some my, Some their ->
156 (* Try to compare using checkout if available *)
157 if not (Git.is_repo ~proc ~fs checkout_path) then Unknown
158 else begin
159 (* Check if either is ancestor of the other *)
160 let my_is_ancestor =
161 Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my
162 ~commit2:their ()
163 in
164 let their_is_ancestor =
165 Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their
166 ~commit2:my ()
167 in
168 match (my_is_ancestor, their_is_ancestor) with
169 | true, false ->
170 (* My commit is ancestor of theirs -> I'm behind *)
171 let behind =
172 Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:my
173 ~head:their ()
174 in
175 I_am_behind behind
176 | false, true ->
177 (* Their commit is ancestor of mine -> I'm ahead *)
178 let ahead =
179 Git.count_commits_between ~proc ~fs ~repo:checkout_path
180 ~base:their ~head:my ()
181 in
182 I_am_ahead ahead
183 | true, true ->
184 (* Both are ancestors of each other -> same commit *)
185 Same
186 | false, false -> (
187 (* Neither is ancestor -> diverged *)
188 match
189 Git.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my
190 ~commit2:their ()
191 with
192 | Error _ -> Unknown
193 | Ok base ->
194 let my_ahead =
195 Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
196 ~head:my ()
197 in
198 let their_ahead =
199 Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
200 ~head:their ()
201 in
202 Diverged { my_ahead; their_ahead })
203 end
204
205(** Compute cross-user status comparing my monorepo against all verse members.
206*)
207let compute ~proc ~fs ~verse_config ~monopam_config () =
208 let my_mono = Verse_config.mono_path verse_config in
209 let checkouts = Config.Paths.checkouts monopam_config in
210
211 (* Get my subtrees *)
212 let my_subtrees = Verse.scan_subtrees ~proc ~fs my_mono in
213
214 (* Get verse subtrees (map: repo_name -> [(handle, monorepo_path)]) *)
215 let verse_subtrees =
216 Verse.get_verse_subtrees ~proc ~fs ~config:verse_config ()
217 in
218
219 (* Build comparisons for repos I have *)
220 let my_repos =
221 List.filter_map
222 (fun repo_name ->
223 let my_info =
224 get_subtree_info ~proc ~fs ~monorepo_path:my_mono ~prefix:repo_name ()
225 in
226 let checkout_path = Fpath.(checkouts / repo_name) in
227
228 (* Find others who have this repo *)
229 let others_with_repo =
230 try Hashtbl.find verse_subtrees repo_name with Not_found -> []
231 in
232
233 if others_with_repo = [] then None (* No one else has this repo, skip *)
234 else begin
235 let others =
236 List.map
237 (fun (handle, their_mono) ->
238 let their_info =
239 get_subtree_info ~proc ~fs ~monorepo_path:their_mono
240 ~prefix:repo_name ()
241 in
242 let rel =
243 compare_commits ~proc ~fs ~checkout_path
244 ~my_commit:my_info.upstream_commit
245 ~their_commit:their_info.upstream_commit ()
246 in
247 (handle, their_info, rel))
248 others_with_repo
249 in
250 Some { repo_name; my_info = Some my_info; others }
251 end)
252 my_subtrees
253 in
254
255 (* Find repos others have that I don't *)
256 let my_subtrees_set = Hashtbl.create 64 in
257 List.iter (fun s -> Hashtbl.add my_subtrees_set s ()) my_subtrees;
258
259 let other_repos =
260 Hashtbl.fold
261 (fun repo_name handles_and_paths acc ->
262 if Hashtbl.mem my_subtrees_set repo_name then acc
263 else
264 let handles = List.map fst handles_and_paths in
265 (repo_name, handles) :: acc)
266 verse_subtrees []
267 |> List.sort (fun (a, _) (b, _) -> String.compare a b)
268 in
269
270 { my_repos; other_repos }