jon.recoil.org
forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
1type error =
2 | Config_error of string
3 | Git_error of Git.error
4 | Registry_error of string
5 | Member_not_found of string
6 | Workspace_exists of Fpath.t
7 | Not_a_workspace of Fpath.t
8 | Package_not_found of string * string (** (package, handle) *)
9 | Package_already_exists of string list (** List of conflicting package names *)
10 | Opam_repo_error of Opam_repo.error
11
12let pp_error ppf = function
13 | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
14 | Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
15 | Registry_error msg -> Fmt.pf ppf "Registry error: %s" msg
16 | Member_not_found h -> Fmt.pf ppf "Member not in registry: %s" h
17 | Workspace_exists p -> Fmt.pf ppf "Workspace already exists: %a" Fpath.pp p
18 | Not_a_workspace p -> Fmt.pf ppf "Not a opamverse workspace: %a" Fpath.pp p
19 | Package_not_found (pkg, handle) ->
20 Fmt.pf ppf "Package %s not found in %s's opam repo" pkg handle
21 | Package_already_exists pkgs ->
22 Fmt.pf ppf "Packages already exist in your opam repo: %a"
23 Fmt.(list ~sep:comma string) pkgs
24 | Opam_repo_error e -> Fmt.pf ppf "Opam repo error: %a" Opam_repo.pp_error e
25
26let error_hint = function
27 | Config_error _ ->
28 Some
29 "Run 'monopam init --handle <your-handle>' to create a workspace."
30 | Git_error (Git.Dirty_worktree _) ->
31 Some "Commit or stash your changes first: git status"
32 | Git_error (Git.Command_failed (cmd, _))
33 when String.starts_with ~prefix:"git clone" cmd ->
34 Some "Check the URL is correct and you have network access."
35 | Git_error (Git.Command_failed (cmd, _))
36 when String.starts_with ~prefix:"git pull" cmd ->
37 Some "Check your network connection. Try: git fetch origin"
38 | Git_error _ -> None
39 | Registry_error _ ->
40 Some "The registry may be temporarily unavailable. Try again later."
41 | Member_not_found h ->
42 Some
43 (Fmt.str
44 "Check available members: monopam verse members (looking for '%s')" h)
45 | Workspace_exists _ ->
46 Some "Use a different directory, or remove the existing workspace."
47 | Not_a_workspace _ ->
48 Some "Run 'monopam init --handle <your-handle>' to create a workspace here."
49 | Package_not_found (pkg, handle) ->
50 Some (Fmt.str "Run 'monopam verse pull %s' to sync their opam repo, then check package name: %s" handle pkg)
51 | Package_already_exists pkgs ->
52 Some (Fmt.str "Remove conflicting packages first:\n %s"
53 (String.concat "\n " (List.map (fun p -> "rm -rf opam-repo/packages/" ^ p) pkgs)))
54 | Opam_repo_error _ -> None
55
56let pp_error_with_hint ppf e =
57 pp_error ppf e;
58 match error_hint e with
59 | Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint
60 | None -> ()
61
62type member_status = {
63 handle : string;
64 monorepo_url : string;
65 local_path : Fpath.t;
66 cloned : bool;
67 clean : bool option;
68 ahead_behind : Git.ahead_behind option;
69}
70
71type status = {
72 config : Verse_config.t;
73 registry : Verse_registry.t;
74 tracked_members : member_status list;
75}
76
77let pp_member_status ppf m =
78 let status =
79 if not m.cloned then "not cloned"
80 else
81 match (m.clean, m.ahead_behind) with
82 | Some false, _ -> "dirty"
83 | Some true, Some ab when ab.ahead > 0 || ab.behind > 0 ->
84 Fmt.str "ahead %d, behind %d" ab.ahead ab.behind
85 | Some true, _ -> "clean"
86 | None, _ -> "unknown"
87 in
88 Fmt.pf ppf "@[<hov 2>%s@ (%s)@ [%s]@]" m.handle m.monorepo_url status
89
90let pp_status ppf s =
91 Fmt.pf ppf "@[<v>Workspace: %a@,Registry: %s@,Members:@, @[<v>%a@]@]"
92 Fpath.pp
93 (Verse_config.root s.config)
94 s.registry.name
95 Fmt.(list ~sep:cut pp_member_status)
96 s.tracked_members
97
98(* Helper to check if a path is a directory *)
99let is_directory ~fs path =
100 let eio_path = Eio.Path.(fs / Fpath.to_string path) in
101 match Eio.Path.kind ~follow:true eio_path with
102 | `Directory -> true
103 | _ -> false
104 | exception _ -> false
105
106(* Helper to check if a path is a regular file *)
107let is_file ~fs path =
108 let eio_path = Eio.Path.(fs / Fpath.to_string path) in
109 match Eio.Path.kind ~follow:true eio_path with
110 | `Regular_file -> true
111 | _ -> false
112 | exception _ -> false
113
114(* Helper to create a directory if it doesn't exist *)
115let ensure_dir ~fs path =
116 let eio_path = Eio.Path.(fs / Fpath.to_string path) in
117 try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ()
118
119(* Get list of tracked members by looking at verse/ directory *)
120let get_tracked_handles ~fs config =
121 let verse_path = Verse_config.verse_path config in
122 if not (is_directory ~fs verse_path) then []
123 else
124 let eio_path = Eio.Path.(fs / Fpath.to_string verse_path) in
125 try
126 Eio.Path.read_dir eio_path
127 |> List.filter (fun name -> is_directory ~fs Fpath.(verse_path / name))
128 with Eio.Io _ -> []
129
130let init ~proc ~fs ~root ~handle () =
131 (* Check if config already exists in XDG *)
132 let config_file = Verse_config.config_file () in
133 Logs.info (fun m -> m "Config file: %a" Fpath.pp config_file);
134 if is_file ~fs config_file then begin
135 Logs.err (fun m -> m "Config already exists at %a" Fpath.pp config_file);
136 Error (Workspace_exists root)
137 end
138 else
139 (* Resolve root to absolute path *)
140 let root =
141 if Fpath.is_abs root then root
142 else
143 (* Get absolute path via realpath *)
144 let root_str = Fpath.to_string root in
145 let eio_path = Eio.Path.(fs / root_str) in
146 (* Ensure the directory exists first so realpath works *)
147 (try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ());
148 match Unix.realpath root_str with
149 | abs_str -> (
150 match Fpath.of_string abs_str with Ok p -> p | Error _ -> root)
151 | exception _ -> root
152 in
153 Logs.info (fun m -> m "Workspace root: %a" Fpath.pp root);
154 (* Create config - need this temporarily to get paths *)
155 let config = Verse_config.create ~root ~handle () in
156 (* Clone registry first to look up user's repos *)
157 Logs.info (fun m -> m "Cloning registry...");
158 match Verse_registry.clone_or_pull ~proc ~fs ~config () with
159 | Error msg ->
160 Logs.err (fun m -> m "Registry clone failed: %s" msg);
161 Error (Registry_error msg)
162 | Ok registry -> (
163 Logs.info (fun m -> m "Registry loaded");
164 (* Look up user in registry - this validates the handle *)
165 match Verse_registry.find_member registry ~handle with
166 | None ->
167 Logs.err (fun m -> m "Handle %s not found in registry" handle);
168 Error (Member_not_found handle)
169 | Some member -> (
170 Logs.info (fun m ->
171 m "Found member: mono=%s opam=%s" member.monorepo
172 member.opamrepo);
173 (* Create workspace directories *)
174 Logs.info (fun m -> m "Creating workspace directories...");
175 ensure_dir ~fs root;
176 ensure_dir ~fs (Verse_config.src_path config);
177 ensure_dir ~fs (Verse_config.verse_path config);
178 (* Clone user's monorepo *)
179 let mono_path = Verse_config.mono_path config in
180 Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
181 let mono_url = Uri.of_string member.monorepo in
182 match
183 Git.clone ~proc ~fs ~url:mono_url
184 ~branch:Verse_config.default_branch mono_path
185 with
186 | Error e ->
187 Logs.err (fun m -> m "Monorepo clone failed: %a" Git.pp_error e);
188 Error (Git_error e)
189 | Ok () -> (
190 Logs.info (fun m -> m "Monorepo cloned");
191 (* Clone user's opam repo *)
192 let opam_path = Verse_config.opam_repo_path config in
193 Logs.info (fun m ->
194 m "Cloning opam repo to %a" Fpath.pp opam_path);
195 let opam_url = Uri.of_string member.opamrepo in
196 match
197 Git.clone ~proc ~fs ~url:opam_url
198 ~branch:Verse_config.default_branch opam_path
199 with
200 | Error e ->
201 Logs.err (fun m ->
202 m "Opam repo clone failed: %a" Git.pp_error e);
203 Error (Git_error e)
204 | Ok () -> (
205 Logs.info (fun m -> m "Opam repo cloned");
206 (* Save config to XDG *)
207 Logs.info (fun m ->
208 m "Saving config to %a" Fpath.pp config_file);
209 match Verse_config.save ~fs config with
210 | Error msg ->
211 Logs.err (fun m -> m "Failed to save config: %s" msg);
212 Error (Config_error msg)
213 | Ok () ->
214 Logs.info (fun m ->
215 m "Workspace initialized successfully");
216 Ok ()))))
217
218let status ~proc ~fs ~config () =
219 (* Load registry *)
220 match Verse_registry.clone_or_pull ~proc ~fs ~config () with
221 | Error msg -> Error (Registry_error msg)
222 | Ok registry ->
223 (* Get tracked handles *)
224 let tracked_handles = get_tracked_handles ~fs config in
225 (* Build status for each tracked member *)
226 let tracked_members =
227 List.filter_map
228 (fun handle ->
229 (* Find member in registry *)
230 match Verse_registry.find_member registry ~handle with
231 | None ->
232 (* Member not in registry but locally tracked - show anyway *)
233 let local_path =
234 Fpath.(Verse_config.verse_path config / handle)
235 in
236 let cloned = is_directory ~fs local_path in
237 Some
238 {
239 handle;
240 monorepo_url = "(not in registry)";
241 local_path;
242 cloned;
243 clean = None;
244 ahead_behind = None;
245 }
246 | Some member ->
247 let local_path =
248 Fpath.(Verse_config.verse_path config / handle)
249 in
250 let cloned = Git.is_repo ~proc ~fs local_path in
251 let clean =
252 if cloned then Some (not (Git.is_dirty ~proc ~fs local_path))
253 else None
254 in
255 let ahead_behind =
256 if cloned then
257 match Git.ahead_behind ~proc ~fs local_path with
258 | Ok ab -> Some ab
259 | Error _ -> None
260 else None
261 in
262 Some
263 {
264 handle;
265 monorepo_url = member.monorepo;
266 local_path;
267 cloned;
268 clean;
269 ahead_behind;
270 })
271 tracked_handles
272 in
273 Ok { config; registry; tracked_members }
274
275let members ~proc ~fs ~config () =
276 match Verse_registry.clone_or_pull ~proc ~fs ~config () with
277 | Error msg -> Error (Registry_error msg)
278 | Ok registry -> Ok registry.members
279
280(** Clone or fetch+reset a single git repo. Returns Ok true if cloned, Ok false if reset.
281 Uses fetch+reset instead of pull since verse repos should not have local changes. *)
282let clone_or_reset_repo ~proc ~fs ~url ~branch path =
283 if Git.is_repo ~proc ~fs path then begin
284 match Git.fetch_and_reset ~proc ~fs ~branch path with
285 | Error e -> Error e
286 | Ok () -> Ok false
287 end
288 else begin
289 let url = Uri.of_string url in
290 match Git.clone ~proc ~fs ~url ~branch path with
291 | Error e -> Error e
292 | Ok () -> Ok true
293 end
294
295let pull ~proc ~fs ~config ?handle () =
296 (* Load registry to get all members *)
297 match Verse_registry.clone_or_pull ~proc ~fs ~config () with
298 | Error msg -> Error (Registry_error msg)
299 | Ok registry ->
300 let members =
301 match handle with
302 | Some h -> (
303 match Verse_registry.find_member registry ~handle:h with
304 | Some m -> [ m ]
305 | None -> [])
306 | None -> registry.members
307 in
308 if members = [] && handle <> None then
309 Error (Member_not_found (Option.get handle))
310 else begin
311 let verse_dir = Verse_config.verse_path config in
312 ensure_dir ~fs verse_dir;
313 Logs.info (fun m -> m "Syncing %d members" (List.length members));
314 let errors =
315 List.filter_map
316 (fun (member : Verse_registry.member) ->
317 let h = member.handle in
318 let mono_path = Fpath.(verse_dir / h) in
319 let opam_path = Fpath.(verse_dir / (h ^ "-opam")) in
320 (* Clone or fetch+reset monorepo *)
321 Logs.info (fun m -> m "Syncing %s monorepo" h);
322 let mono_branch =
323 Option.value ~default:Verse_config.default_branch member.monorepo_branch
324 in
325 let mono_result =
326 clone_or_reset_repo ~proc ~fs ~url:member.monorepo
327 ~branch:mono_branch mono_path
328 in
329 let mono_err =
330 match mono_result with
331 | Ok true ->
332 Logs.info (fun m -> m " Cloned %s monorepo" h);
333 None
334 | Ok false ->
335 Logs.info (fun m -> m " Reset %s monorepo" h);
336 None
337 | Error e ->
338 Logs.warn (fun m ->
339 m " Failed %s monorepo: %a" h Git.pp_error e);
340 Some (Fmt.str "%s monorepo: %a" h Git.pp_error e)
341 in
342 (* Clone or fetch+reset opam repo *)
343 Logs.info (fun m -> m "Syncing %s opam repo" h);
344 let opam_branch =
345 Option.value ~default:Verse_config.default_branch member.opamrepo_branch
346 in
347 let opam_result =
348 clone_or_reset_repo ~proc ~fs ~url:member.opamrepo
349 ~branch:opam_branch opam_path
350 in
351 let opam_err =
352 match opam_result with
353 | Ok true ->
354 Logs.info (fun m -> m " Cloned %s opam repo" h);
355 None
356 | Ok false ->
357 Logs.info (fun m -> m " Reset %s opam repo" h);
358 None
359 | Error e ->
360 Logs.warn (fun m ->
361 m " Failed %s opam repo: %a" h Git.pp_error e);
362 Some (Fmt.str "%s opam: %a" h Git.pp_error e)
363 in
364 match (mono_err, opam_err) with
365 | None, None -> None
366 | Some e, None | None, Some e -> Some e
367 | Some e1, Some e2 -> Some (e1 ^ "; " ^ e2))
368 members
369 in
370 if errors = [] then Ok ()
371 else Error (Git_error (Git.Io_error (String.concat "; " errors)))
372 end
373
374let sync ~proc ~fs ~config () =
375 (* pull already updates registry and syncs all members *)
376 pull ~proc ~fs ~config ()
377
378(** Scan a monorepo for subtree directories. Returns a list of directory names
379 that look like subtrees (have commits). *)
380let scan_subtrees ~proc ~fs monorepo_path =
381 if not (Git.is_repo ~proc ~fs monorepo_path) then []
382 else
383 let eio_path = Eio.Path.(fs / Fpath.to_string monorepo_path) in
384 try
385 Eio.Path.read_dir eio_path
386 |> List.filter (fun name ->
387 (* Skip hidden dirs and common non-subtree dirs *)
388 (not (String.starts_with ~prefix:"." name))
389 && name <> "_build" && name <> "node_modules"
390 && is_directory ~fs Fpath.(monorepo_path / name))
391 with Eio.Io _ -> []
392
393(** Get subtrees from all tracked verse members. Returns a map from subtree name
394 to list of (handle, monorepo_path) pairs. *)
395let get_verse_subtrees ~proc ~fs ~config () =
396 let verse_path = Verse_config.verse_path config in
397 let tracked_handles = get_tracked_handles ~fs config in
398 (* Build map: subtree_name -> [(handle, monorepo_path)] *)
399 let subtree_map = Hashtbl.create 64 in
400 List.iter
401 (fun handle ->
402 let member_mono = Fpath.(verse_path / handle) in
403 if Git.is_repo ~proc ~fs member_mono then begin
404 let subtrees = scan_subtrees ~proc ~fs member_mono in
405 List.iter
406 (fun subtree ->
407 let existing =
408 try Hashtbl.find subtree_map subtree with Not_found -> []
409 in
410 Hashtbl.replace subtree_map subtree
411 ((handle, member_mono) :: existing))
412 subtrees
413 end)
414 tracked_handles;
415 subtree_map
416
417(** Result of a fork operation. *)
418type fork_result = {
419 packages_forked : string list; (** Package names that were forked *)
420 source_handle : string; (** Handle of the verse member we forked from *)
421 fork_url : string; (** URL of the fork *)
422 upstream_url : string; (** Original dev-repo URL (upstream) *)
423 subtree_name : string; (** Name for the subtree directory (derived from fork URL) *)
424}
425
426(** Extract subtree name from a URL (last path component without .git suffix) *)
427let subtree_name_from_url url =
428 let uri = Uri.of_string url in
429 let path = Uri.path uri in
430 (* Remove leading slash and .git suffix *)
431 let path = if String.length path > 0 && path.[0] = '/' then
432 String.sub path 1 (String.length path - 1)
433 else path in
434 let path = if String.ends_with ~suffix:".git" path then
435 String.sub path 0 (String.length path - 4)
436 else path in
437 (* Get last component *)
438 match String.rindex_opt path '/' with
439 | Some i -> String.sub path (i + 1) (String.length path - i - 1)
440 | None -> path
441
442let pp_fork_result ppf r =
443 Fmt.pf ppf "@[<v>Forked %d package(s) from %s:@, @[<v>%a@]@,Fork URL: %s@,Upstream: %s@,Subtree: %s@]"
444 (List.length r.packages_forked)
445 r.source_handle
446 Fmt.(list ~sep:cut string) r.packages_forked
447 r.fork_url
448 r.upstream_url
449 r.subtree_name
450
451(** Fork a package from a verse member's opam repo into your workspace.
452
453 This looks up the package in the member's opam-repo (verse/<handle>-opam/),
454 finds all packages sharing the same dev-repo, and creates entries in your
455 opam-repo with the fork URL as the dev-repo.
456
457 @param proc Eio process manager
458 @param fs Eio filesystem
459 @param config Verse configuration
460 @param handle Verse member handle to fork from
461 @param package Package name to fork
462 @param fork_url Git URL of your fork
463 @param dry_run If true, show what would be done without making changes *)
464let fork ~proc ~fs ~config ~handle ~package ~fork_url ?(dry_run = false) () =
465 (* Ensure the member exists and their opam-repo is synced *)
466 match Verse_registry.clone_or_pull ~proc ~fs ~config () with
467 | Error msg -> Error (Registry_error msg)
468 | Ok registry ->
469 match Verse_registry.find_member registry ~handle with
470 | None -> Error (Member_not_found handle)
471 | Some _member ->
472 let verse_path = Verse_config.verse_path config in
473 let member_opam_repo = Fpath.(verse_path / (handle ^ "-opam")) in
474 (* Check if their opam repo exists locally *)
475 if not (is_directory ~fs member_opam_repo) then
476 Error (Config_error (Fmt.str "Member's opam repo not synced. Run: monopam verse pull %s" handle))
477 else
478 (* Scan their opam repo to find the package *)
479 let pkgs, _errors = Opam_repo.scan_all ~fs member_opam_repo in
480 (* Find the requested package *)
481 match List.find_opt (fun p -> Package.name p = package) pkgs with
482 | None -> Error (Package_not_found (package, handle))
483 | Some pkg ->
484 (* Find all packages from the same dev-repo *)
485 let related_pkgs =
486 List.filter (fun p -> Package.same_repo p pkg) pkgs
487 in
488 let pkg_names = List.map Package.name related_pkgs in
489 (* Get upstream URL and subtree name *)
490 let upstream_url = Uri.to_string (Package.dev_repo pkg) in
491 let subtree_name = subtree_name_from_url fork_url in
492 (* Check for conflicts in user's opam-repo *)
493 let user_opam_repo = Verse_config.opam_repo_path config in
494 let conflicts =
495 List.filter
496 (fun name -> Opam_repo.package_exists ~fs ~repo_path:user_opam_repo ~name)
497 pkg_names
498 in
499 if conflicts <> [] then
500 Error (Package_already_exists conflicts)
501 else if dry_run then
502 (* Dry run - just report what would be done *)
503 Ok { packages_forked = pkg_names; source_handle = handle; fork_url; upstream_url; subtree_name }
504 else begin
505 (* Fork each package *)
506 let results =
507 List.map
508 (fun p ->
509 let name = Package.name p in
510 let version = Package.version p in
511 let opam_path =
512 Fpath.(member_opam_repo / "packages" / name / (name ^ "." ^ version) / "opam")
513 in
514 match Opam_repo.read_opam_file ~fs opam_path with
515 | Error e -> Error (Opam_repo_error e)
516 | Ok content ->
517 (* Replace dev-repo and url with fork URL *)
518 let new_content = Opam_repo.replace_dev_repo_url content ~new_url:fork_url in
519 (* Write to user's opam-repo *)
520 match Opam_repo.write_package ~fs ~repo_path:user_opam_repo ~name ~version ~content:new_content with
521 | Error e -> Error (Opam_repo_error e)
522 | Ok () -> Ok name)
523 related_pkgs
524 in
525 (* Check for errors *)
526 match List.find_opt Result.is_error results with
527 | Some (Error e) -> Error e
528 | _ ->
529 let forked_names = List.filter_map (function Ok n -> Some n | Error _ -> None) results in
530 Ok { packages_forked = forked_names; source_handle = handle; fork_url; upstream_url; subtree_name }
531 end