Monorepo management for opam overlays
1(** Operational context for monopam commands.
2
3 Provides filesystem utilities, package discovery, checkout management, and
4 repository grouping functions shared across command modules. *)
5
6let src = Logs.Src.create "monopam.ctx" ~doc:"Monopam context"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10(** {1 Error Types} *)
11
12type error =
13 | Config_error of string
14 | Repo_error of Opam_repo.error
15 | Git_error of Git_cli.error
16 | Dirty_state of Package.t list
17 | Monorepo_dirty
18 | Package_not_found of string
19 | Pull_conflict of { paths : string list; hint : string }
20 | Claude_error of string
21 | Other of { msg : string; hint : string option }
22
23let err ?hint msg = Other { msg; hint }
24
25let pp_error ppf = function
26 | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
27 | Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
28 | Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
29 | Dirty_state pkgs ->
30 Fmt.pf ppf "Dirty packages: %a"
31 Fmt.(list ~sep:comma (using Package.name string))
32 pkgs
33 | Monorepo_dirty -> Fmt.pf ppf "Monorepo has uncommitted changes"
34 | Package_not_found name -> Fmt.pf ppf "Package not found: %s" name
35 | Pull_conflict _ -> ()
36 | Claude_error msg -> Fmt.pf ppf "Claude error: %s" msg
37 | Other { msg; hint = _ } -> Fmt.pf ppf "%s" msg
38
39let error_hint = function
40 | Config_error _ ->
41 Some "Run 'monopam init --handle <your-handle>' to create a workspace."
42 | Repo_error (Opam_repo.No_dev_repo _) ->
43 Some
44 "Add a 'dev-repo' field to the package's opam file pointing to a git \
45 URL."
46 | Repo_error (Opam_repo.Not_git_remote _) ->
47 Some "The dev-repo must be a git URL (git+https:// or git://)."
48 | Repo_error _ -> None
49 | Git_error (Git_cli.Dirty_worktree _) ->
50 Some "Commit or stash your changes first: cd <repo> && git status"
51 | Git_error (Git_cli.Not_a_repo _) ->
52 Some "Run 'monopam pull' to clone missing repositories."
53 | Git_error (Git_cli.Subtree_prefix_missing _) ->
54 Some "Run 'monopam pull' to set up the subtree."
55 | Git_error (Git_cli.Remote_not_found _) ->
56 Some "Check that the remote is configured: git remote -v"
57 | Git_error (Git_cli.Branch_not_found _) ->
58 Some "Check available branches: git branch -a"
59 | Git_error (Git_cli.Command_failed (cmd, result))
60 when String.starts_with ~prefix:"git push" cmd ->
61 if
62 Astring.String.is_infix ~affix:"non-fast-forward" result.Git_cli.stderr
63 || Astring.String.is_infix ~affix:"[rejected]" result.Git_cli.stderr
64 || Astring.String.is_infix ~affix:"fetch first" result.Git_cli.stderr
65 then
66 Some
67 "Run 'monopam pull' to merge the upstream changes, resolve any \
68 conflicts, and push again."
69 else Some "Check your network connection and git credentials."
70 | Git_error _ -> None
71 | Dirty_state _ ->
72 Some
73 "Commit changes in the monorepo first: cd mono && git add -A && git \
74 commit"
75 | Monorepo_dirty ->
76 Some
77 "Commit or stash your changes first: git status && git add -A && git \
78 commit"
79 | Package_not_found _ ->
80 Some "Check available packages: ls opam-repo/packages/"
81 | Pull_conflict { hint; _ } -> Some hint
82 | Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg ->
83 Some "The Claude API may have returned an unexpected response. Try again."
84 | Claude_error _ ->
85 Some "Check ANTHROPIC_API_KEY is set. See: https://console.anthropic.com/"
86 | Other { hint; _ } -> hint
87
88let pp_error_with_hint ppf e =
89 pp_error ppf e;
90 match error_hint e with
91 | Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint
92 | None -> ()
93
94(** Map each error category to a shell exit code. See [ctx.mli] for the
95 contract. Kept as a flat match so new variants force a compile error if
96 someone extends [error] without thinking about exit codes. *)
97let exit_code = function
98 | Config_error _ -> 2
99 | Repo_error _ -> 2
100 | Dirty_state _ -> 2
101 | Monorepo_dirty -> 2
102 | Package_not_found _ -> 2
103 | Pull_conflict _ -> 4
104 | Claude_error _ -> 5
105 | Other _ -> 2
106 | Git_error g -> (
107 match g with
108 | Git_cli.Not_a_repo _ -> 2
109 | Git_cli.Dirty_worktree _ -> 2
110 | Git_cli.Remote_not_found _ -> 2
111 | Git_cli.Branch_not_found _ -> 2
112 | Git_cli.Subtree_prefix_exists _ -> 2
113 | Git_cli.Subtree_prefix_missing _ -> 2
114 | Git_cli.Io_error _ -> 3
115 | Git_cli.Command_failed (_, r) ->
116 let err = r.Git_cli.stderr in
117 let has s = Astring.String.is_infix ~affix:s err in
118 if has "non-fast-forward" || has "[rejected]" || has "fetch first"
119 then 4
120 else if
121 has "Could not resolve host"
122 || has "unable to access" || has "Connection refused"
123 || has "Network is unreachable"
124 || has "Could not read from remote"
125 then 3
126 else 2)
127
128(** {1 Filesystem Utilities} *)
129
130let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
131 let dir, _ = fs in
132 (dir, "")
133
134let rec mkdirs path =
135 match Eio.Path.kind ~follow:true path with
136 | `Directory -> ()
137 | _ ->
138 Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
139 Eio.Path.mkdir ~perm:0o755 path
140 | exception Eio.Io _ ->
141 let parent = Eio.Path.split path in
142 (match parent with
143 | Some (parent_path, _) -> mkdirs parent_path
144 | None -> ());
145 Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
146 Eio.Path.mkdir ~perm:0o755 path
147
148let is_directory ~fs path =
149 let eio_path = Eio.Path.(fs / Fpath.to_string path) in
150 match Eio.Path.kind ~follow:true eio_path with
151 | `Directory -> true
152 | _ -> false
153 | exception _ -> false
154
155(** Walk every immediate subdirectory of [monorepo] and pick the ones that look
156 like nested monorepos (= contain a [sources.toml] file). Pair each with its
157 outer sources entry if any. *)
158let nested_monos ~fs ~monorepo ~sources =
159 let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
160 let entries = try Eio.Path.read_dir monorepo_eio with Eio.Io _ -> [] in
161 List.filter_map
162 (fun name ->
163 if name = ".git" || name = "_build" then None
164 else
165 let sub = Fpath.(monorepo / name) in
166 if not (is_directory ~fs sub) then None
167 else
168 let inner_toml = Eio.Path.(monorepo_eio / name / "sources.toml") in
169 match Eio.Path.kind ~follow:true inner_toml with
170 | `Regular_file ->
171 let entry =
172 Option.bind sources (fun s ->
173 Sources_registry.find s ~subtree:name)
174 in
175 Some (name, entry)
176 | _ -> None
177 | exception _ -> None)
178 entries
179
180let normalize_opam_url_string s =
181 if String.starts_with ~prefix:"git+" s then
182 String.sub s 4 (String.length s - 4)
183 else s
184
185let normalize_opam_url uri =
186 Uri.of_string (normalize_opam_url_string (Uri.to_string uri))
187
188let ensure_checkouts_dir ~fs ~config =
189 let checkouts = Config.Paths.checkouts config in
190 let checkouts_eio = Eio.Path.(fs / Fpath.to_string checkouts) in
191 Log.debug (fun m ->
192 m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
193 mkdirs checkouts_eio
194
195(** {1 Package Discovery} *)
196
197let discover_packages ~fs ~config () =
198 let repo_path = Config.Paths.opam_repo config in
199 Log.debug (fun m -> m "Scanning opam repo at %a" Fpath.pp repo_path);
200 Opam_repo.scan ~fs repo_path
201 |> Result.map_error (fun e -> Repo_error e)
202 |> Result.map (fun pkgs ->
203 Log.info (fun m -> m "Found %d packages in opam repo" (List.length pkgs));
204 pkgs)
205
206let package ~fs ~config name =
207 Result.bind (discover_packages ~fs ~config ()) (fun pkgs ->
208 List.find_opt (fun p -> Package.name p = name) pkgs
209 |> Option.to_result ~none:(Package_not_found name))
210
211(** {1 Branch and Checkout Management} *)
212
213let branch ~config pkg =
214 let default = Config.default_branch in
215 match Package.branch pkg with
216 | Some b -> b
217 | None ->
218 Option.bind
219 (Config.package_config config (Package.name pkg))
220 Config.Package_config.branch
221 |> Option.value ~default
222
223let ensure_checkout ~proc ~fs ~config ?url pkg =
224 let checkouts_root = Config.Paths.checkouts config in
225 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
226 let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
227 let branch = branch ~config pkg in
228 let clone_url =
229 let default = Uri.to_string (Package.dev_repo pkg) in
230 normalize_opam_url_string (Option.value ~default url)
231 in
232 let do_clone () =
233 Log.info (fun m ->
234 m "Cloning %s from %s (branch: %s)" (Package.repo_name pkg) clone_url
235 branch);
236 Git_cli.clone ~proc ~fs ~url:clone_url ~branch checkout_dir
237 in
238 let is_directory =
239 match Eio.Path.kind ~follow:true checkout_eio with
240 | `Directory -> true
241 | _ -> false
242 | exception Eio.Io _ -> false
243 in
244 if not is_directory then do_clone ()
245 else if not (Git.Repository.is_repo ~fs checkout_dir) then do_clone ()
246 else begin
247 Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
248 match Git_cli.fetch ~proc ~fs checkout_dir with
249 | Error e -> Error e
250 | Ok () -> (
251 Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
252 match Git_cli.merge_ff ~proc ~fs ~branch checkout_dir with
253 | Ok () -> Ok ()
254 | Error _ ->
255 (* Checkout diverged from upstream (e.g. after a failed push where
256 the split was pushed to the checkout but the upstream had a
257 different commit). Reset to the upstream's HEAD — the checkout
258 is a derived cache, the monorepo is authoritative. *)
259 Log.info (fun m ->
260 m "Fast-forward failed for %s, resetting to upstream"
261 (Package.repo_name pkg));
262 Git_cli.fetch_and_reset ~proc ~fs ~branch checkout_dir)
263 end
264
265let checkout_exists ~fs ~config pkg =
266 let checkouts_root = Config.Paths.checkouts config in
267 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
268 let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
269 match Eio.Path.kind ~follow:true checkout_eio with
270 | `Directory -> Git.Repository.is_repo ~fs checkout_dir
271 | _ -> false
272 | exception Eio.Io _ -> false
273
274let behind ~sw ~fs ~config pkg =
275 let checkouts_root = Config.Paths.checkouts config in
276 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
277 let branch = branch ~config pkg in
278 if not (Git.Repository.is_repo ~fs checkout_dir) then 0
279 else
280 let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
281 match Git.Repository.ahead_behind repo ~branch () with
282 | Some ab -> ab.behind
283 | None -> 0
284
285(** {1 Repository Grouping} *)
286
287let group_by_repo pkgs =
288 let tbl = Hashtbl.create 16 in
289 List.iter
290 (fun pkg ->
291 let repo = Package.repo_name pkg in
292 let existing = try Hashtbl.find tbl repo with Not_found -> [] in
293 Hashtbl.replace tbl repo (pkg :: existing))
294 pkgs;
295 Hashtbl.fold
296 (fun repo pkgs acc -> (repo, List.sort Package.compare pkgs) :: acc)
297 tbl []
298 |> List.sort (fun (a, _) (b, _) -> String.compare a b)
299
300let normalize_url_for_comparison uri =
301 let scheme = Option.value ~default:"" (Uri.scheme uri) in
302 let host = Option.value ~default:"" (Uri.host uri) in
303 let path = Uri.path uri in
304 let path =
305 if String.length path > 1 && path.[String.length path - 1] = '/' then
306 String.sub path 0 (String.length path - 1)
307 else path
308 in
309 Fmt.str "%s://%s%s" scheme host path
310
311let unique_repos pkgs =
312 let seen = Hashtbl.create 16 in
313 List.filter
314 (fun pkg ->
315 let url = normalize_url_for_comparison (Package.dev_repo pkg) in
316 Log.debug (fun m ->
317 m "Checking repo URL: %s (from %s)" url (Package.name pkg));
318 if Hashtbl.mem seen url then begin
319 Log.debug (fun m -> m " -> Already seen, skipping");
320 false
321 end
322 else begin
323 Hashtbl.add seen url ();
324 Log.debug (fun m -> m " -> New repo, keeping");
325 true
326 end)
327 pkgs
328
329(** {1 URL Utilities} *)
330
331let is_tangled_host = function
332 | Some "tangled.org" | Some "tangled.sh" -> true
333 | _ -> false
334
335let url_to_push_url ?knot url =
336 let url = normalize_opam_url_string url in
337 (* SSH URLs (git@host:path) are already push URLs *)
338 if String.contains url '@' && not (String.contains url '/') then url
339 else if String.starts_with ~prefix:"git@" url then url
340 else
341 let uri = Uri.of_string url in
342 let scheme = Uri.scheme uri in
343 let host = Uri.host uri in
344 let path = Uri.path uri in
345 match (scheme, host) with
346 | Some ("https" | "http"), Some "github.com" ->
347 let path =
348 if String.length path > 0 && path.[0] = '/' then
349 String.sub path 1 (String.length path - 1)
350 else path
351 in
352 Fmt.str "git@github.com:%s" path
353 | Some ("https" | "http"), Some "gitlab.com" ->
354 let path =
355 if String.length path > 0 && path.[0] = '/' then
356 String.sub path 1 (String.length path - 1)
357 else path
358 in
359 Fmt.str "git@gitlab.com:%s" path
360 | Some ("https" | "http"), _ when is_tangled_host host ->
361 let path =
362 if String.length path > 0 && path.[0] = '/' then
363 String.sub path 1 (String.length path - 1)
364 else path
365 in
366 let path =
367 if String.length path > 0 && path.[0] = '@' then
368 String.sub path 1 (String.length path - 1)
369 else path
370 in
371 let path =
372 if String.ends_with ~suffix:".git" path then
373 String.sub path 0 (String.length path - 4)
374 else path
375 in
376 let knot_server = Option.value ~default:"git.recoil.org" knot in
377 Fmt.str "git@%s:%s" knot_server path
378 | _ -> url
379
380(** {1 Unregistered Package Detection} *)
381
382let unregistered_opam_files ~fs ~config pkgs =
383 let fs = fs_typed fs in
384 let monorepo = Config.Paths.monorepo config in
385 let registered_by_repo = Hashtbl.create 16 in
386 List.iter
387 (fun pkg ->
388 let repo = Package.repo_name pkg in
389 let name = Package.name pkg in
390 let existing =
391 try Hashtbl.find registered_by_repo repo with Not_found -> []
392 in
393 Hashtbl.replace registered_by_repo repo (name :: existing))
394 pkgs;
395 let seen_repos = Hashtbl.create 16 in
396 let repos =
397 List.filter
398 (fun pkg ->
399 let repo = Package.repo_name pkg in
400 if Hashtbl.mem seen_repos repo then false
401 else begin
402 Hashtbl.add seen_repos repo ();
403 true
404 end)
405 pkgs
406 in
407 let check_opam_file ~repo ~registered name =
408 if not (Filename.check_suffix name ".opam") then None
409 else
410 let pkg_name = Filename.chop_suffix name ".opam" in
411 if List.mem pkg_name registered then None else Some (repo, pkg_name)
412 in
413 List.concat_map
414 (fun pkg ->
415 let repo = Package.repo_name pkg in
416 let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
417 let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in
418 let registered =
419 try Hashtbl.find registered_by_repo repo with Not_found -> []
420 in
421 try
422 Eio.Path.read_dir eio_path
423 |> List.filter_map (check_opam_file ~repo ~registered)
424 with Eio.Io _ -> [])
425 repos
426
427let untracked_subdirs ~fs ~config pkgs =
428 let fs = fs_typed fs in
429 let monorepo = Config.Paths.monorepo config in
430 let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
431 let tracked = Hashtbl.create 256 in
432 List.iter
433 (fun pkg -> Hashtbl.replace tracked (Package.subtree_prefix pkg) ())
434 pkgs;
435 let is_candidate name =
436 if Hashtbl.mem tracked name then false
437 else if String.length name = 0 then false
438 else
439 match name.[0] with
440 | '.' | '_' -> false
441 | _ -> (
442 let dune_project = Eio.Path.(monorepo_eio / name / "dune-project") in
443 match Eio.Path.kind ~follow:false dune_project with
444 | `Regular_file -> true
445 | _ -> false)
446 in
447 try
448 Eio.Path.read_dir monorepo_eio
449 |> List.filter (fun name ->
450 let child = Eio.Path.(monorepo_eio / name) in
451 match Eio.Path.kind ~follow:false child with
452 | `Directory -> is_candidate name
453 | _ -> false)
454 |> List.sort String.compare
455 with Eio.Io _ -> []
456
457(** {1 Status} *)
458
459let status ~sw ~fs ~config () =
460 let fs = fs_typed fs in
461 ensure_checkouts_dir ~fs ~config;
462 discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
463 |> Result.map (Status.compute_all ~sw ~fs ~config)
464
465(** {1 Timing} *)
466
467let time_phase name f =
468 let t0 = Unix.gettimeofday () in
469 let result = f () in
470 let t1 = Unix.gettimeofday () in
471 Log.debug (fun m -> m "[TIMING] %s: %.3fs" name (t1 -. t0));
472 result