Monorepo management for opam overlays
1(** Push operations for exporting monorepo changes to checkouts and remotes.
2
3 Extracts per-package commits and pushes to local checkouts under [src/] and
4 then, unless [--local] was passed, to the git remote configured for each
5 subtree. Those remotes are always the user's own repositories (origin, not
6 upstream in the git sense) — push never writes to a canonical repo the user
7 doesn't own. *)
8
9let src = Logs.Src.create "monopam.push" ~doc:"Monopam push operations"
10
11module Log = (val Logs.src_log src : Logs.LOG)
12
13(** {1 Single Package Push} *)
14
15let checkout_tree_hash ~sw ~fs checkout_dir =
16 let checkout_repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
17 match Git.Repository.head checkout_repo with
18 | None -> None
19 | Some h -> (
20 match Git.Repository.read checkout_repo h with
21 | Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
22 | _ -> None)
23
24(** Check if [target_tree] appears in the commit ancestry of [head]. *)
25let tree_in_history repo head target_tree =
26 let visited = Hashtbl.create 64 in
27 let queue = Queue.create () in
28 Queue.push head queue;
29 let found = ref false in
30 while (not (Queue.is_empty queue)) && not !found do
31 let h = Queue.pop queue in
32 if not (Hashtbl.mem visited h) then begin
33 Hashtbl.replace visited h ();
34 match Git.Repository.read repo h with
35 | Ok (Git.Value.Commit c) ->
36 if Git.Hash.equal (Git.Commit.tree c) target_tree then found := true
37 else List.iter (fun p -> Queue.push p queue) (Git.Commit.parents c)
38 | _ -> ()
39 end
40 done;
41 !found
42
43let split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
44 ~checkout_tree ~clean ~force ~branch =
45 match Git.Repository.read_ref git_repo "HEAD" with
46 | None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
47 | Some head -> (
48 match Git.Subtree.split git_repo ~prefix ~head () with
49 | Ok None -> Error (Ctx.Git_error (Git_cli.Subtree_prefix_missing prefix))
50 | Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
51 | Ok (Some split_hash) -> (
52 let final_hash =
53 if clean then (
54 match Git.Subtree.fix git_repo ~prefix ~head:split_hash () with
55 | Ok (Some h) ->
56 Log.info (fun m -> m "Cleaned history for %s" prefix);
57 h
58 | Ok None -> split_hash
59 | Error (`Msg msg) ->
60 Log.warn (fun m -> m "Failed to clean %s: %s" prefix msg);
61 split_hash)
62 else split_hash
63 in
64 let refspec = Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch in
65 match
66 Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
67 ~refspec ~force ()
68 with
69 | Ok () -> Ok ()
70 | Error (Git_cli.Command_failed _ as _e) when not force -> (
71 (* Push rejected without --force. Check if the checkout's tree
72 is in our split chain — if so, safely auto-force. *)
73 match checkout_tree with
74 | Some ct when tree_in_history git_repo final_hash ct ->
75 Log.debug (fun m ->
76 m "Checkout tree is in split chain, forcing local push");
77 Git_cli.push_refspec ~proc ~fs ~repo:monorepo
78 ~url:checkout_url ~refspec ~force:true ()
79 |> Result.map_error (fun e -> Ctx.Git_error e)
80 | _ ->
81 Error
82 (Ctx.Git_error
83 (Git_cli.Io_error
84 (Fmt.str
85 "%s: checkout has content not in monorepo. Use \
86 --force to overwrite, or pull first."
87 prefix))))
88 | Error e -> Error (Ctx.Git_error e)))
89
90(** Resolve the fetch URL for a package: sources.toml entry > dev-repo fallback.
91 Returns a plain string suitable for git operations (no percent-encoding). *)
92let resolve_fetch_url ~sources pkg =
93 let name = Package.repo_name pkg in
94 match sources with
95 | Some s -> (
96 match Sources_registry.derive_url s ~subtree:name with
97 | Some url -> Ctx.normalize_opam_url_string url
98 | None ->
99 Ctx.normalize_opam_url_string (Uri.to_string (Package.dev_repo pkg)))
100 | None -> Ctx.normalize_opam_url_string (Uri.to_string (Package.dev_repo pkg))
101
102let needs_clone ~fs ~checkout_eio ~checkout_dir =
103 match Eio.Path.kind ~follow:true checkout_eio with
104 | exception Eio.Io _ -> true
105 | `Directory when Git.Repository.is_repo ~fs checkout_dir -> false
106 | _ -> true
107
108type result =
109 | Pushed (** Subtree was exported and pushed to checkout *)
110 | Skipped (** Nothing to push (up-to-date or not in monorepo) *)
111 | Clone_failed of string (** Remote repo doesn't exist or is unreachable *)
112
113(** Merge a monorepo's split subtree into a checkout that's a full clone of the
114 source monorepo, at the configured [path]. This is the push-side of the
115 [--path] feature: the split produced at [prefix] in the local monorepo
116 becomes a new commit in the source at [path].
117
118 The caller must have already ensured that [checkout_dir] is a fresh clone of
119 the source URL with [origin] set up. *)
120let resolve_user ~fs =
121 match Git_cli.global_git_user ~fs () with
122 | Some u -> u
123 | None ->
124 Git.User.v ~name:"monopam" ~email:"monopam@localhost"
125 ~date:(Int64.of_float (Unix.time ()))
126 ()
127
128let merge_or_add_subtree checkout_repo ~prefix:path ~commit ~author ~committer
129 ~message =
130 match
131 Git.Subtree.merge checkout_repo ~prefix:path ~commit ~author ~committer
132 ~message ()
133 with
134 | Ok (Git.Subtree.Merged h) -> Ok h
135 | Ok (Git.Subtree.Conflicts (h, _)) -> Ok h
136 | Error (`Msg msg)
137 when String.length msg >= 20 && String.sub msg 0 20 = "Subtree not found at"
138 ->
139 Git.Subtree.add checkout_repo ~prefix:path ~commit ~author ~committer
140 ~message ()
141 | Error (`Msg _) as e -> e
142
143let sync_workdir checkout_repo new_head ~path =
144 (* Subtree.merge advanced HEAD via git plumbing without updating the
145 working tree or the index. Sync both so a subsequent [monopam pull]
146 can fast-forward instead of hitting "local changes would be
147 overwritten". *)
148 (match Git.Repository.checkout checkout_repo new_head with
149 | Ok () -> ()
150 | Error (`Msg msg) ->
151 Log.warn (fun m -> m "checkout after path merge of %s: %s" path msg));
152 match Git.Repository.add_all checkout_repo with
153 | Ok () -> ()
154 | Error (`Msg msg) ->
155 Log.warn (fun m -> m "rebuild index after path merge of %s: %s" path msg)
156
157let merge_split_into_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir
158 ~prefix ~path ~branch:_ =
159 let ( let* ) r f =
160 Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
161 in
162 match Git.Repository.read_ref git_repo "HEAD" with
163 | None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
164 | Some head -> (
165 match Git.Subtree.split git_repo ~prefix ~head () with
166 | Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
167 | Ok None -> Error (Ctx.Git_error (Git_cli.Subtree_prefix_missing prefix))
168 | Ok (Some split_hash) -> (
169 (* Publish the split commit from the monorepo to the checkout
170 so the checkout's git objects include it. We push it to a
171 disposable ref (refs/monopam/path-push) — it's only used
172 transiently to feed [Subtree.merge] below. *)
173 let refspec =
174 Git.Hash.to_hex split_hash ^ ":refs/monopam/path-push"
175 in
176 let checkout_url = Fpath.to_string checkout_dir in
177 let* () =
178 Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
179 ~refspec ~force:true ()
180 in
181 let checkout_repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
182 let user = resolve_user ~fs in
183 let message =
184 Fmt.str "Merge '%s/' from monorepo split of '%s'\n" path prefix
185 in
186 match
187 merge_or_add_subtree checkout_repo ~prefix:path ~commit:split_hash
188 ~author:user ~committer:user ~message
189 with
190 | Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
191 | Ok new_head ->
192 sync_workdir checkout_repo new_head ~path;
193 Ok ()))
194
195(** Look up the sources.toml entry for a package.
196
197 sources.toml is keyed by the LOCAL subtree name, which is chosen at
198 [monopam add] time. For a plain whole-repo import this is the dev-repo
199 basename (= [Package.repo_name]). For a [--path] import, it's the path
200 basename (typically = [Package.name]). Check both keys and return the entry
201 \+ the matching key as the effective local prefix. *)
202let lookup_entry ~sources pkg =
203 match sources with
204 | None -> (None, Package.subtree_prefix pkg)
205 | Some s -> (
206 let try_key k =
207 Option.map
208 (fun entry -> (Some entry, k))
209 (Sources_registry.find s ~subtree:k)
210 in
211 match try_key (Package.name pkg) with
212 | Some r -> r
213 | None -> (
214 match try_key (Package.subtree_prefix pkg) with
215 | Some r -> r
216 | None -> (None, Package.subtree_prefix pkg)))
217
218let bind_git r f = Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
219
220let try_clone ~proc ~fs ~config ~url ~prefix pkg =
221 Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg));
222 match Ctx.ensure_checkout ~proc ~fs:(fs :> _ Eio.Path.t) ~config ~url pkg with
223 | Ok () -> true
224 | Error _ ->
225 Log.debug (fun m -> m "Could not clone %s from %s — skipping" prefix url);
226 false
227
228let via_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix ~path
229 ~branch =
230 Log.info (fun m ->
231 m "Subtree push with path %s/%s -> %a" prefix path Fpath.pp checkout_dir);
232 bind_git
233 (Git_cli.ensure_receive_config ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
234 (fun () ->
235 merge_split_into_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir
236 ~prefix ~path ~branch
237 |> Result.map (fun () -> Pushed))
238
239let via_split ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix ~branch
240 ~clean ~force =
241 let checkout_url = Fpath.to_string checkout_dir in
242 let checkout_tree = checkout_tree_hash ~sw ~fs checkout_dir in
243 Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
244 bind_git
245 (Git_cli.ensure_receive_config ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
246 (fun () ->
247 bind_git
248 (Git_cli.clean_untracked ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
249 (fun () ->
250 split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
251 ~checkout_tree ~clean ~force ~branch
252 |> Result.map (fun () -> Pushed)))
253
254let one ~sw ~proc ~fs ~config ~sources ~clean ~force pkg =
255 let fs = Ctx.fs_typed fs in
256 let monorepo = Config.Paths.monorepo config in
257 let entry, prefix = lookup_entry ~sources pkg in
258 let checkouts_root = Config.Paths.checkouts config in
259 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
260 let branch = Ctx.branch ~config pkg in
261 let clone_url = resolve_fetch_url ~sources pkg in
262 (* If this subtree has a [path] override, the local checkout is a
263 clone of the SOURCE monorepo and we merge our split into it at
264 [path] rather than force-pushing the split as the checkout's
265 main branch. *)
266 let path_override =
267 Option.bind entry (fun (e : Sources_registry.entry) -> e.path)
268 in
269 if not (Ctx.is_directory ~fs Fpath.(monorepo / prefix)) then begin
270 Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
271 Ok Skipped
272 end
273 else
274 let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
275 let freshly_cloned = needs_clone ~fs ~checkout_eio ~checkout_dir in
276 let clone_ok =
277 if freshly_cloned then
278 try_clone ~proc ~fs ~config ~url:clone_url ~prefix pkg
279 else true
280 in
281 if not clone_ok then Ok (Clone_failed clone_url)
282 else
283 let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
284 match path_override with
285 | Some path ->
286 via_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix ~path
287 ~branch
288 | None ->
289 via_split ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix
290 ~branch ~clean ~force
291
292(** {1 Workspace Repo Push} *)
293
294let needs_push repo ~branch =
295 match Git.Repository.head repo with
296 | None -> false
297 | Some local_head -> (
298 let remote_ref = "refs/remotes/origin/" ^ branch in
299 match Git.Repository.read_ref repo remote_ref with
300 | None -> true
301 | Some remote_head -> not (Git.Hash.equal local_head remote_head))
302
303let commit_pending ~sw ~fs path name =
304 let repo = Git.Repository.open_repo ~sw ~fs path in
305 match Git.Repository.add_all repo with
306 | Error (`Msg e) ->
307 Log.warn (fun m -> m "Failed to stage changes in %s: %s" name e)
308 | Ok () -> (
309 match Git_cli.global_git_user ~fs () with
310 | None ->
311 Log.warn (fun m -> m "No git user config, skipping commit in %s" name)
312 | Some user -> (
313 let msg = "Sync from monorepo" in
314 match
315 Git.Repository.commit_index repo ~author:user ~committer:user
316 ~message:msg ()
317 with
318 | Ok _ -> Log.info (fun m -> m "Committed pending changes in %s" name)
319 | Error (`Msg msg)
320 when String.starts_with ~prefix:"nothing to commit" msg ->
321 ()
322 | Error (`Msg e) ->
323 Log.warn (fun m -> m "Failed to commit in %s: %s" name e)))
324
325let workspace_repos ~sw ~proc ~fs ~config ~force ~push_mono =
326 let knot = Config.knot config in
327 let errors = ref [] in
328 let push_repo ~commit name path =
329 if Git.Repository.is_repo ~fs path then begin
330 let repo = Git.Repository.open_repo ~sw ~fs path in
331 match Git.Repository.remote_url repo "origin" with
332 | None -> Log.debug (fun m -> m "%s has no origin remote, skipping" name)
333 | Some fetch_url -> (
334 (* Ensure push URL uses SSH, not HTTPS *)
335 let push_url = Ctx.url_to_push_url ~knot fetch_url in
336 (match
337 Git.Repository.set_push_url repo ~name:"origin" ~url:push_url
338 with
339 | Ok () -> ()
340 | Error (`Msg msg) ->
341 Log.warn (fun m -> m "Failed to set push URL for %s: %s" name msg));
342 if commit then commit_pending ~sw ~fs path name;
343 let branch =
344 Git.Repository.current_branch repo |> Option.value ~default:"main"
345 in
346 if (not force) && not (needs_push repo ~branch) then
347 Log.debug (fun m -> m "%s is up-to-date, skipping" name)
348 else
349 match
350 Git_cli.push_remote ~proc ~fs:(fs :> _ Eio.Path.t) ~force path
351 with
352 | Ok () -> Log.app (fun m -> m " ✓ %s" name)
353 | Error (Git_cli.Command_failed (_, result))
354 when String.starts_with ~prefix:"Everything up-to-date"
355 result.Git_cli.stderr ->
356 Log.app (fun m -> m " ✓ %s (already synced)" name)
357 | Error e ->
358 Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e);
359 errors := (name, e) :: !errors)
360 end
361 in
362 let mono = Config.Paths.monorepo config in
363 let opam_repo = Config.Paths.opam_repo config in
364 if push_mono then push_repo ~commit:false "mono" mono;
365 push_repo ~commit:true "opam-repo" opam_repo;
366 !errors
367
368(** {1 Main Push Operation} *)
369
370type missing_repo = { pkg : Package.t; url : string }
371
372let export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos =
373 let update_progress name =
374 Tty.Progress.update progress ~phase:"Export" ~msg:name
375 in
376 let rec loop pushed_repos missing = function
377 | [] -> Ok (List.rev pushed_repos, List.rev missing)
378 | pkg :: rest -> (
379 let name = Package.subtree_prefix pkg in
380 update_progress name;
381 Log.debug (fun m -> m "Subtree push %s" name);
382 match
383 Eio.Switch.run @@ fun pkg_sw ->
384 one ~sw:pkg_sw ~proc ~fs ~config ~sources ~clean ~force pkg
385 with
386 | Ok Pushed -> loop (pkg :: pushed_repos) missing rest
387 | Ok Skipped -> loop pushed_repos missing rest
388 | Ok (Clone_failed url) ->
389 loop pushed_repos ({ pkg; url } :: missing) rest
390 | Error e ->
391 Tty.Progress.finish progress;
392 Error e)
393 in
394 loop [] [] repos
395
396let to_upstream ~proc ~fs ~config ~sources ~force ~progress pushed_repos =
397 Log.info (fun m ->
398 m "Pushing %d repos to configured remotes (parallel)"
399 (List.length pushed_repos));
400 let checkouts_root = Config.Paths.checkouts config in
401 Eio.Fiber.List.map ~max_fibers:8
402 (fun pkg ->
403 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
404 let name = Package.repo_name pkg in
405 Tty.Progress.update progress ~phase:"Push" ~msg:name;
406 let branch = Ctx.branch ~config pkg in
407 let knot = Config.knot config in
408 let fetch_url = resolve_fetch_url ~sources pkg in
409 let push_url = Ctx.url_to_push_url ~knot fetch_url in
410 Log.info (fun m -> m "Pushing %s to %s" name push_url);
411 (* Scope per-package: open_repo acquires fds that must be released
412 before moving to the next package. Without this, 168 repos ×
413 multiple fds exhausts the process fd limit. *)
414 Eio.Switch.run @@ fun pkg_sw ->
415 let repo = Git.Repository.open_repo ~sw:pkg_sw ~fs checkout_dir in
416 (match
417 Git.Repository.ensure_remote repo ~name:"origin" ~url:fetch_url
418 with
419 | Ok () -> ()
420 | Error (`Msg msg) ->
421 Log.warn (fun m -> m "Failed to ensure remote: %s" msg));
422 (match Git.Repository.set_push_url repo ~name:"origin" ~url:push_url with
423 | Ok () -> ()
424 | Error (`Msg msg) ->
425 Log.warn (fun m -> m "Failed to set push URL: %s" msg));
426 match Git_cli.push_remote ~proc ~fs ~branch ~force checkout_dir with
427 | Ok () -> Ok (name, push_url)
428 | Error e -> Error (name, push_url, Ctx.Git_error e))
429 pushed_repos
430
431let log_results results =
432 let successes, failures =
433 List.partition_map
434 (function
435 | Ok (name, url) -> Left (name, url)
436 | Error (name, url, _) -> Right (name, url))
437 results
438 in
439 if successes <> [] || failures <> [] then begin
440 let rows =
441 List.map
442 (fun (name, url) ->
443 [
444 Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓";
445 Tty.Span.text name;
446 Tty.Span.text url;
447 ])
448 successes
449 @ List.map
450 (fun (name, url) ->
451 [
452 Tty.Span.styled Tty.Style.(fg Tty.Color.red) "✗";
453 Tty.Span.text name;
454 Tty.Span.text url;
455 ])
456 failures
457 in
458 let table =
459 Tty.Table.(
460 of_rows ~border:Tty.Border.rounded
461 [
462 column ~align:`Center " ";
463 column ~align:`Left "Package";
464 column ~align:`Left "Remote";
465 ]
466 rows)
467 in
468 Log.app (fun m -> m "%s" (Tty.Table.to_string table))
469 end;
470 match List.find_opt Result.is_error results with
471 | Some (Error (_, _, e)) -> Error e
472 | _ -> Ok ()
473
474let repos_to_push statuses pkgs =
475 let status_by_prefix =
476 List.fold_left
477 (fun acc s ->
478 let prefix = Package.subtree_prefix s.Status.package in
479 (prefix, s) :: acc)
480 [] statuses
481 in
482 let needs_export pkg =
483 let prefix = Package.subtree_prefix pkg in
484 match List.assoc_opt prefix status_by_prefix with
485 | Some s -> not (Status.is_fully_synced s)
486 | None -> true
487 in
488 let all_repos = Ctx.unique_repos pkgs in
489 let repos = List.filter needs_export all_repos in
490 let skipped = List.length all_repos - List.length repos in
491 if skipped > 0 then
492 Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
493 repos
494
495(** {1 Mono (Nested Monorepo) Push} *)
496
497(** Ensure an inner checkout exists, cloning if needed. Returns [true] if the
498 checkout is ready. *)
499let ensure_inner_clone ~proc ~fs_t ~checkout_dir ~clone_url ~name ~label ~branch
500 =
501 let checkout_eio = Eio.Path.(fs_t / Fpath.to_string checkout_dir) in
502 let needs_clone =
503 match Eio.Path.kind ~follow:true checkout_eio with
504 | exception Eio.Io _ -> true
505 | `Directory when Git.Repository.is_repo ~fs:fs_t checkout_dir -> false
506 | _ -> true
507 in
508 if needs_clone then begin
509 Log.info (fun m -> m "Cloning %s for mono inner subtree %s" clone_url label);
510 match
511 Git_cli.clone ~proc
512 ~fs:(fs_t :> _ Eio.Path.t)
513 ~url:clone_url ~branch checkout_dir
514 with
515 | Ok () -> true
516 | Error e ->
517 Log.warn (fun m -> m "Failed to clone %s: %a" name Git_cli.pp_error e);
518 false
519 end
520 else true
521
522(** Configure a checkout, push a subtree split to it, then send the updated
523 checkout out to its configured remote.
524
525 Returns [Error] when the upstream push fails so the outer push command can
526 report the right exit code. The local-checkout step is wrapped in a warning
527 because it should only fail on a corrupt working copy, not on a remote race.
528*)
529let inner_subtree ~sw ~proc ~fs_t ~monorepo ~git_repo ~prefix ~checkout_dir
530 ~name ~clean ~force ~branch =
531 (match
532 Git_cli.ensure_receive_config ~proc ~fs:(fs_t :> _ Eio.Path.t) checkout_dir
533 with
534 | Ok () -> ()
535 | Error e ->
536 Log.warn (fun m -> m "Failed to configure %s: %a" name Git_cli.pp_error e));
537 let checkout_url = Fpath.to_string checkout_dir in
538 let checkout_tree = checkout_tree_hash ~sw ~fs:fs_t checkout_dir in
539 match
540 split_and_push ~proc ~fs:fs_t ~monorepo ~git_repo ~prefix ~checkout_url
541 ~checkout_tree ~clean ~force ~branch
542 with
543 | Error e -> Error e
544 | Ok () -> (
545 Log.info (fun m ->
546 m "Split mono inner subtree %s into %a" prefix Fpath.pp checkout_dir);
547 match
548 Git_cli.push_remote ~proc
549 ~fs:(fs_t :> _ Eio.Path.t)
550 ~branch ~force checkout_dir
551 with
552 | Ok () ->
553 Log.app (fun m ->
554 m " ✓ %s (nested) → %a" prefix Fpath.pp checkout_dir);
555 Ok ()
556 | Error e -> Error (Ctx.Git_error e))
557
558(** Process one mono entry: load its inner sources.toml and push each inner
559 subtree. Returns the list of errors encountered (empty on success). *)
560let mono_inner ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo ~clean ~force
561 mono_name =
562 let inner_sources_path = Fpath.(monorepo / mono_name / "sources.toml") in
563 match Sources_registry.load ~fs:(fs_t :> _ Eio.Path.t) inner_sources_path with
564 | Error msg ->
565 Log.warn (fun m ->
566 m "Failed to load %a: %s" Fpath.pp inner_sources_path msg);
567 []
568 | Ok inner_sources ->
569 let errors = ref [] in
570 let inner_entries = Sources_registry.to_list inner_sources in
571 List.iter
572 (fun (inner_name, (inner_entry : Sources_registry.entry)) ->
573 (* [nested_prefix] is the slash-separated path inside the
574 monorepo (e.g. "open-mono/lib"). Git.Subtree.split treats
575 it as a path, but [Fpath.(/)] (which calls [add_seg])
576 refuses strings containing "/". Build the Fpath
577 component-by-component so the existence check doesn't
578 crash. *)
579 let nested_prefix = mono_name ^ "/" ^ inner_name in
580 let nested_path = Fpath.(monorepo / mono_name / inner_name) in
581 let branch = Option.value ~default:"main" inner_entry.branch in
582 if not (Ctx.is_directory ~fs:fs_t nested_path) then
583 Log.debug (fun m ->
584 m "Skipping mono inner %s (not in monorepo)" nested_prefix)
585 else begin
586 let checkout_dir = Fpath.(checkouts_root / inner_name) in
587 let clone_url = Ctx.normalize_opam_url_string inner_entry.source in
588 let cloned =
589 ensure_inner_clone ~proc ~fs_t ~checkout_dir ~clone_url
590 ~name:inner_name ~label:nested_prefix ~branch
591 in
592 if cloned then
593 match
594 inner_subtree ~sw ~proc ~fs_t ~monorepo ~git_repo
595 ~prefix:nested_prefix ~checkout_dir ~name:inner_name ~clean
596 ~force ~branch
597 with
598 | Ok () -> ()
599 | Error e -> errors := e :: !errors
600 end)
601 inner_entries;
602 List.rev !errors
603
604(** Push the outer subtree of a nested monorepo to the inner mono's own remote.
605 This is the middle layer of the depth-first push:
606
607 - inner-most: push individual subtrees inside the mono to their own upstream
608 URLs. Done by [mono_inner] above.
609 - middle: push the outer monorepo's split at the mono prefix to the inner
610 mono's URL (e.g. product split at "open-mono" → open-mono.git). This is
611 what this function does.
612 - outermost: workspace_repos pushes the outer monorepo to its remote.
613
614 Without this step, the inner mono's git history never receives the outer's
615 edits and a downstream developer pulling from open-mono.git would not see
616 them. *)
617let mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo
618 ~clean ~force mono_name mono_entry =
619 match mono_entry with
620 | None ->
621 Log.debug (fun m ->
622 m "Skipping mono outer subtree %s (no source URL in sources.toml)"
623 mono_name)
624 | Some (mono_entry : Sources_registry.entry) ->
625 if not (Ctx.is_directory ~fs:fs_t Fpath.(monorepo / mono_name)) then
626 Log.debug (fun m ->
627 m "Skipping mono outer subtree %s (not in monorepo)" mono_name)
628 else begin
629 let checkout_dir = Fpath.(checkouts_root / mono_name) in
630 let clone_url = Ctx.normalize_opam_url_string mono_entry.source in
631 let branch = Option.value ~default:"main" mono_entry.branch in
632 let cloned =
633 ensure_inner_clone ~proc ~fs_t ~checkout_dir ~clone_url
634 ~name:mono_name ~label:mono_name ~branch
635 in
636 if cloned then
637 match
638 inner_subtree ~sw ~proc ~fs_t ~monorepo ~git_repo ~prefix:mono_name
639 ~checkout_dir ~name:mono_name ~clean ~force ~branch
640 with
641 | Ok () -> ()
642 | Error e ->
643 Log.warn (fun m ->
644 m "Failed to push mono outer subtree %s: %a" mono_name
645 Ctx.pp_error_with_hint e)
646 end
647
648(** Push every nested monorepo found in the workspace. A subtree is a nested
649 monorepo iff its directory contains a [sources.toml] file — no flag, no
650 marker required. *)
651let mono_entries ~sw ~proc ~fs ~config ~sources ~clean ~force =
652 let fs_t = Ctx.fs_typed fs in
653 let monorepo = Config.Paths.monorepo config in
654 let checkouts_root = Config.Paths.checkouts config in
655 let nested = Ctx.nested_monos ~fs:fs_t ~monorepo ~sources in
656 if nested = [] then []
657 else begin
658 Log.info (fun m ->
659 m "Processing %d nested monorepo(s) for inner subtree push"
660 (List.length nested));
661 let git_repo = Git.Repository.open_repo ~sw ~fs:fs_t monorepo in
662 (* Depth-first: inner subtrees first, then the outer mono itself. *)
663 let inner_errors =
664 List.concat_map
665 (fun (mono_name, _entry) ->
666 mono_inner ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo ~clean
667 ~force mono_name)
668 nested
669 in
670 List.iter
671 (fun (mono_name, entry) ->
672 mono_outer_subtree ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo
673 ~clean ~force mono_name entry)
674 nested;
675 inner_errors
676 end
677
678let log_missing_repos ~all_pkgs missing =
679 if missing <> [] then begin
680 Log.app (fun m ->
681 m "\n%d repo(s) could not be cloned (remote not found):"
682 (List.length missing));
683 Log.app (fun m ->
684 m "Create them and re-run push. Suggested descriptions:\n");
685 List.iter
686 (fun { pkg; url } ->
687 let name = Package.repo_name pkg in
688 (* Find the package whose name matches the repo name for the best
689 synopsis (e.g. "scitt" for ocaml-scitt, not "atp-lexicon-scitt") *)
690 (* Find the main package: prefer exact name match, then
691 name matching with ocaml- prefix stripped. *)
692 let stripped =
693 if String.starts_with ~prefix:"ocaml-" name then
694 String.sub name 6 (String.length name - 6)
695 else name
696 in
697 let best =
698 match List.find_opt (fun p -> Package.name p = name) all_pkgs with
699 | Some p -> p
700 | None -> (
701 match
702 List.find_opt (fun p -> Package.name p = stripped) all_pkgs
703 with
704 | Some p -> p
705 | None -> pkg)
706 in
707 let synopsis =
708 Option.value ~default:"OCaml library" (Package.synopsis best)
709 in
710 Log.app (fun m -> m " %s %s" url name);
711 Log.app (fun m -> m " %s" synopsis))
712 missing
713 end
714
715let prewarm_splits ~sw ~clock ~git_repo ~head repos =
716 let prefixes = List.map Package.subtree_prefix repos in
717 let split_progress = ref None in
718 let on_progress ~processed ~total =
719 let bar =
720 match !split_progress with
721 | Some b -> b
722 | None ->
723 let b =
724 Tty.Progress.v ~color:(`Hex (0x10, 0xc6, 0xe6)) ~total "splitting"
725 in
726 Tty_eio.Progress.animate ~sw ~clock b;
727 split_progress := Some b;
728 b
729 in
730 Tty.Progress.set bar processed
731 in
732 ignore
733 (Git.Subtree.split_batch git_repo ~prefixes ~head ~on_progress () : _ list);
734 Option.iter (fun b -> Tty.Progress.finish ~message:"split" b) !split_progress
735
736let local_results ~config repos =
737 List.map
738 (fun p ->
739 let name = Package.repo_name p in
740 let checkouts_root = Config.Paths.checkouts config in
741 let url = Fpath.to_string (Package.checkout_dir ~checkouts_root p) in
742 Ok (name, url))
743 repos
744
745let to_checkout_results ~proc ~fs_t ~config ~sources ~upstream ~force ~progress
746 pushed_repos =
747 if upstream && pushed_repos <> [] then
748 to_upstream ~proc ~fs:fs_t ~config ~sources ~force ~progress pushed_repos
749 else local_results ~config pushed_repos
750
751let workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream =
752 let ws_errors =
753 if upstream then
754 workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
755 else []
756 in
757 if ws_errors = [] then Ok ()
758 else
759 let _name, e = List.hd ws_errors in
760 Error (Ctx.Git_error e)
761
762let export_and_push ~sw ~clock ~proc ~fs ~fs_t ~config ~sources ~upstream
763 ~push_mono ~clean ~force ~all_pkgs repos =
764 (* Refresh root files before export so the push ships them. *)
765 let monorepo_for_root = Config.Paths.monorepo config in
766 let (_ : string list) =
767 Root.regenerate ~sw ~fs:fs_t ~monorepo:monorepo_for_root ~packages:all_pkgs
768 ()
769 in
770 let n_repos = List.length repos in
771 let total = if upstream then n_repos * 2 else n_repos in
772 let monorepo = Config.Paths.monorepo config in
773 let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
774 (match Git.Repository.read_ref git_repo "HEAD" with
775 | Some head -> prewarm_splits ~sw ~clock ~git_repo ~head repos
776 | None -> ());
777 let progress =
778 Tty.Progress.v ~color:(`Hex (0x27, 0xda, 0xde)) ~total "exporting"
779 in
780 Tty_eio.Progress.animate ~sw ~clock progress;
781 match
782 export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos
783 with
784 | Error e ->
785 Tty.Progress.finish progress;
786 Error e
787 | Ok (pushed_repos, missing) -> (
788 let results =
789 to_checkout_results ~proc ~fs_t ~config ~sources ~upstream ~force
790 ~progress pushed_repos
791 in
792 Tty.Progress.finish ~message:"exported" progress;
793 log_missing_repos ~all_pkgs missing;
794 match log_results results with
795 | Error e -> Error e
796 | Ok () ->
797 workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream)
798
799let load_sources ~fs ~config =
800 let sources_path = Fpath.(Config.Paths.monorepo config / "sources.toml") in
801 match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
802 | Ok s -> Some s
803 | Error _ -> None
804
805let select_pkgs ~packages all_pkgs =
806 match packages with
807 | [] -> all_pkgs
808 | names ->
809 List.filter
810 (fun p -> List.exists (fun n -> Package.matches_name n p) names)
811 all_pkgs
812
813let sync_opam_for_push ~sw ~clock ~fs_t ~config ~packages =
814 match Opam_sync.run ~sw ~clock ~fs:fs_t ~config ~packages () with
815 | Ok r ->
816 if r.Opam_sync.synced <> [] then
817 Log.info (fun m ->
818 m "Synced %d opam files to opam-repo" (List.length r.synced))
819 | Error (`Config_error msg) ->
820 Log.warn (fun m -> m "Opam sync failed: %s" msg)
821
822let run_after_sync ~sw ~clock ~proc ~fs ~fs_t ~config ~packages ~upstream ~clean
823 ~force ~pkgs ~statuses =
824 sync_opam_for_push ~sw ~clock ~fs_t ~config ~packages;
825 let sources = load_sources ~fs:fs_t ~config in
826 (* Push mono inner subtrees first (depth-first) *)
827 let inner_errors =
828 mono_entries ~sw ~proc ~fs ~config ~sources ~clean ~force
829 in
830 if inner_errors <> [] then
831 (* Failure inside a nested mono push (e.g. non-fast-forward on
832 lib.git). Report the first one — they all need attention. *)
833 Error (List.hd inner_errors)
834 else
835 let to_push = repos_to_push statuses pkgs in
836 Log.info (fun m -> m "Pushing %d unique repos" (List.length to_push));
837 let push_mono = packages = [] in
838 if to_push = [] then begin
839 Log.app (fun m -> m "Nothing to push (all repos in sync)");
840 workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream
841 end
842 else
843 export_and_push ~sw ~clock ~proc ~fs ~fs_t ~config ~sources ~upstream
844 ~push_mono ~clean ~force ~all_pkgs:pkgs to_push
845
846let run ~sw ~clock ~proc ~fs ~config ?(packages = []) ?(upstream = false)
847 ?(clean = false) ?(force = false) () =
848 let fs_t = Ctx.fs_typed fs in
849 Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
850 match Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
851 | Error e -> Error e
852 | Ok all_pkgs ->
853 let pkgs = select_pkgs ~packages all_pkgs in
854 if pkgs = [] && packages <> [] then
855 Error (Ctx.Package_not_found (List.hd packages))
856 else begin
857 Log.info (fun m ->
858 m "Checking status of %d packages" (List.length pkgs));
859 let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in
860 (* Note: we do NOT block push on dirty checkouts. Checkouts under
861 src/ are a derived cache; the authoritative state lives in the
862 monorepo. Uncommitted edits to a checkout would be clobbered
863 on the next pull anyway, and pushing from the monorepo never
864 reads the checkout's worktree. Pull still guards against dirty
865 checkouts because merging into one would destroy real work. *)
866 run_after_sync ~sw ~clock ~proc ~fs ~fs_t ~config ~packages ~upstream
867 ~clean ~force ~pkgs ~statuses
868 end