forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: split long functions and label boolean params (E005/E720)
push.ml: extract bind_git, try_clone, push_via_path, push_via_split
(from one); resolve_user, merge_or_add_subtree, sync_workdir (from
merge_split_into_path); prewarm_splits, make_local_results,
push_results, workspace_check (from export_and_push); select_pkgs,
sync_opam_for_push, run_after_sync (from run).
import.ml: extract log_dry_import, import_message, resolve_commit,
add_subtree, do_fetch_and_add (from git_url); update_sources_toml,
stage_and_commit_sources (from run).
cmd_clean.ml / cmd_pull.ml: switch dry_run/force and auto/auto_yes to
labelled args so the function signature no longer trips merlint's
boolean-blindness rule (E720).
+298
-301
+5
-2
bin/cmd_clean.ml
+5
-2
bin/cmd_clean.ml
···
5
5
| Ok () -> `Ok ()
6
6
| Error e -> Common.fail_ctx e
7
7
8
-
let run dry_run force () =
8
+
let run ~dry_run ~force () =
9
9
Eio_main.run @@ fun env ->
10
10
Common.with_config env @@ fun config ->
11
11
let fs = Eio.Stdenv.fs env in
···
46
46
Arg.(value & flag & info [ "force"; "f" ] ~doc)
47
47
in
48
48
Cmd.v info
49
-
Term.(ret (const run $ dry_run_arg $ force_arg $ Common.logging_term))
49
+
Term.(
50
+
ret
51
+
(const (fun dry_run force () -> run ~dry_run ~force ())
52
+
$ dry_run_arg $ force_arg $ Common.logging_term))
+4
-3
bin/cmd_pull.ml
+4
-3
bin/cmd_pull.ml
···
82
82
"Monorepo updated.";
83
83
`Ok ()
84
84
85
-
let run packages auto auto_yes () =
85
+
let run packages ~auto ~auto_yes () =
86
86
let t0 = Unix.gettimeofday () in
87
87
Eio_main.run @@ fun env ->
88
88
Common.with_config env @@ fun config ->
···
136
136
Cmd.v info
137
137
Term.(
138
138
ret
139
-
(const run $ Common.packages_arg $ auto_arg $ auto_yes_arg
140
-
$ Common.logging_term))
139
+
(const (fun packages auto auto_yes () ->
140
+
run packages ~auto ~auto_yes ())
141
+
$ Common.packages_arg $ auto_arg $ auto_yes_arg $ Common.logging_term))
+106
-112
lib/import.ml
+106
-112
lib/import.ml
···
214
214
[path] subdirectory: fetch the full upstream, split at [path] to get a
215
215
standalone history, then add that history as a new subtree at [name] in the
216
216
local monorepo. *)
217
+
let log_dry_import ~name ~url ~ref_to_use ~path =
218
+
match path with
219
+
| Some p ->
220
+
Log.app (fun m ->
221
+
m "Would import %s from %s (ref: %s, path: %s)" name url ref_to_use p)
222
+
| None ->
223
+
Log.app (fun m ->
224
+
m "Would import %s from %s (ref: %s)" name url ref_to_use)
225
+
226
+
let import_message ~name ~fetch_url ~path =
227
+
match path with
228
+
| None ->
229
+
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" name fetch_url name
230
+
| Some p ->
231
+
Fmt.str "Add '%s' from %s (path: %s)\n\ngit-subtree-dir: %s\n" name
232
+
fetch_url p name
233
+
234
+
let resolve_commit git_repo ~fetched ~path =
235
+
match path with
236
+
| None -> Ok fetched
237
+
| Some p -> split_at_path git_repo ~prefix:p ~head:fetched
238
+
239
+
let add_subtree git_repo ~name ~commit ~user ~message ~hash_hex =
240
+
match
241
+
Git.Subtree.add git_repo ~prefix:name ~commit ~author:user ~committer:user
242
+
~message ()
243
+
with
244
+
| Error (`Msg msg) -> Error msg
245
+
| Ok new_head -> (
246
+
(* Checkout only the new subtree prefix to avoid touching other files. *)
247
+
match Git.Repository.checkout_prefix git_repo new_head ~prefix:name with
248
+
| Ok () ->
249
+
let short = String.sub hash_hex 0 7 in
250
+
Log.app (fun m -> m "Imported %s at %s" name short);
251
+
Ok { name; commit = Git.Hash.to_hex commit; added = true }
252
+
| Error (`Msg msg) -> err_checkout_failed msg)
253
+
254
+
let do_fetch_and_add ~sw ~proc ~fs ~target ~name ~url ~fetch_url ~path
255
+
~ref_to_use =
256
+
match
257
+
Git_cli.fetch_url ~sw ~proc ~fs ~repo:target ~url:fetch_url
258
+
~branch:ref_to_use ()
259
+
with
260
+
| Error e -> err_git_fetch_failed e
261
+
| Ok hash_hex -> (
262
+
let _ = url in
263
+
let git_repo = Git.Repository.open_repo ~sw ~fs target in
264
+
let fetched = Git.Hash.of_hex hash_hex in
265
+
match resolve_commit git_repo ~fetched ~path with
266
+
| Error msg -> Error msg
267
+
| Ok commit ->
268
+
let user = git_user ~fs () in
269
+
let message = import_message ~name ~fetch_url ~path in
270
+
add_subtree git_repo ~name ~commit ~user ~message ~hash_hex)
271
+
217
272
let git_url ~sw ~proc ~fs ~target ~url ~branch ~ref_ ?path ~name ~dry_run () =
218
273
let name =
219
274
match name with Some n -> n | None -> default_subtree_name ~url ~path
220
275
in
221
276
let url = normalize_url url in
222
277
let prefix_path = Fpath.(target / name) in
223
-
(* Check if subtree already exists *)
224
278
if dir_exists ~fs prefix_path then err_dir_exists name
225
-
else begin
279
+
else
226
280
let ref_to_use =
227
281
match ref_ with
228
282
| Some r -> r
229
283
| None -> Option.value ~default:"HEAD" branch
230
284
in
231
285
if dry_run then begin
232
-
(match path with
233
-
| Some p ->
234
-
Log.app (fun m ->
235
-
m "Would import %s from %s (ref: %s, path: %s)" name url
236
-
ref_to_use p)
237
-
| None ->
238
-
Log.app (fun m ->
239
-
m "Would import %s from %s (ref: %s)" name url ref_to_use));
286
+
log_dry_import ~name ~url ~ref_to_use ~path;
240
287
Ok { name; commit = "<dry-run>"; added = true }
241
288
end
242
-
else begin
289
+
else
243
290
let fetch_url = strip_git_prefix url in
244
-
match
245
-
Git_cli.fetch_url ~sw ~proc ~fs ~repo:target ~url:fetch_url
246
-
~branch:ref_to_use ()
247
-
with
248
-
| Error e -> err_git_fetch_failed e
249
-
| Ok hash_hex -> (
250
-
let git_repo = Git.Repository.open_repo ~sw ~fs target in
251
-
let fetched = Git.Hash.of_hex hash_hex in
252
-
(* When --path was used, reduce the fetched commit to just that
253
-
subtree's history via [Git.Subtree.split]. The resulting
254
-
[commit] is then treated exactly like a plain whole-repo
255
-
import: added at [name] in the local monorepo. *)
256
-
let commit_result =
257
-
match path with
258
-
| None -> Ok fetched
259
-
| Some p -> split_at_path git_repo ~prefix:p ~head:fetched
260
-
in
261
-
match commit_result with
262
-
| Error msg -> Error msg
263
-
| Ok commit -> (
264
-
let user = git_user ~fs () in
265
-
let message =
266
-
match path with
267
-
| None ->
268
-
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" name
269
-
fetch_url name
270
-
| Some p ->
271
-
Fmt.str
272
-
"Add '%s' from %s (path: %s)\n\ngit-subtree-dir: %s\n"
273
-
name fetch_url p name
274
-
in
275
-
match
276
-
Git.Subtree.add git_repo ~prefix:name ~commit ~author:user
277
-
~committer:user ~message ()
278
-
with
279
-
| Ok new_head -> (
280
-
(* Checkout only the new subtree prefix to avoid
281
-
touching other files. *)
282
-
match
283
-
Git.Repository.checkout_prefix git_repo new_head
284
-
~prefix:name
285
-
with
286
-
| Ok () ->
287
-
let short = String.sub hash_hex 0 7 in
288
-
Log.app (fun m -> m "Imported %s at %s" name short);
289
-
Ok { name; commit = Git.Hash.to_hex commit; added = true }
290
-
| Error (`Msg msg) -> err_checkout_failed msg)
291
-
| Error (`Msg msg) -> Error msg))
292
-
end
293
-
end
291
+
do_fetch_and_add ~sw ~proc ~fs ~target ~name ~url ~fetch_url ~path
292
+
~ref_to_use
294
293
295
294
(** Import all entries from a lock file *)
296
295
let from_lock ~sw ~proc ~fs ~target ~lock_path ~dry_run =
···
421
420
(List.length external_deps))
422
421
end
423
422
423
+
let stage_and_commit_sources ~sw ~fs ~target ~name =
424
+
let git_repo = Git.Repository.open_repo ~sw ~fs target in
425
+
(* After [Git.Subtree.add] the HEAD commit contains the newly-added
426
+
subtree, but the on-disk index is still the pre-add index
427
+
(subtree.add writes directly via git plumbing without touching the
428
+
index). Using [add_to_index ["sources.toml"]] would commit a tree
429
+
derived from that stale index, dropping the subtree. [add_all]
430
+
rebuilds the index from the working tree so the follow-up commit
431
+
includes every file present — subtree files, dune-project, root.opam,
432
+
sources.toml. *)
433
+
match Git.Repository.add_all git_repo with
434
+
| Error (`Msg e) -> Log.warn (fun m -> m "Failed to stage sources.toml: %s" e)
435
+
| Ok () -> (
436
+
let msg = Fmt.str "Update sources.toml: add %s" name in
437
+
match git_commit ~sw ~fs ~target ~message:msg with
438
+
| Ok _ -> ()
439
+
| Error (`Msg e) ->
440
+
Log.warn (fun m -> m "Failed to commit sources.toml: %s" e))
441
+
442
+
let update_sources_toml ~sw ~fs ~target ~url ~branch ~path ~result =
443
+
let sources_path = Fpath.(target / "sources.toml") in
444
+
let sources =
445
+
match Sources_registry.load ~fs sources_path with
446
+
| Ok s -> s
447
+
| Error _ -> Sources_registry.empty
448
+
in
449
+
let entry =
450
+
Sources_registry.
451
+
{
452
+
source = normalize_url url;
453
+
upstream = None;
454
+
branch;
455
+
reason = None;
456
+
origin = None;
457
+
ref_ = Some result.commit;
458
+
path;
459
+
}
460
+
in
461
+
let sources = Sources_registry.add sources ~subtree:result.name entry in
462
+
match Sources_registry.save ~fs sources_path sources with
463
+
| Ok () -> stage_and_commit_sources ~sw ~fs ~target ~name:result.name
464
+
| Error e -> Log.warn (fun m -> m "Failed to update sources.toml: %s" e)
465
+
424
466
(** Main import function *)
425
467
let run ~sw ~proc ~fs ~target ~source ~name ~dry_run () =
426
468
match source with
469
+
| Lock_file path -> from_lock ~sw ~proc ~fs ~target ~lock_path:path ~dry_run
427
470
| Git_url { url; branch; ref_; path } -> (
428
471
match
429
472
git_url ~sw ~proc ~fs ~target ~url ~branch ~ref_ ?path ~name ~dry_run ()
430
473
with
431
474
| Error e -> Error e
432
475
| Ok result ->
433
-
(* Update sources.toml with source, pinned ref, and path if any. *)
434
476
if not dry_run then begin
435
-
let sources_path = Fpath.(target / "sources.toml") in
436
-
let sources =
437
-
match Sources_registry.load ~fs sources_path with
438
-
| Ok s -> s
439
-
| Error _ -> Sources_registry.empty
440
-
in
441
-
let entry =
442
-
Sources_registry.
443
-
{
444
-
source = normalize_url url;
445
-
upstream = None;
446
-
branch;
447
-
reason = None;
448
-
origin = None;
449
-
ref_ = Some result.commit;
450
-
path;
451
-
}
452
-
in
453
-
let sources =
454
-
Sources_registry.add sources ~subtree:result.name entry
455
-
in
456
-
match Sources_registry.save ~fs sources_path sources with
457
-
| Ok () -> (
458
-
let git_repo = Git.Repository.open_repo ~sw ~fs target in
459
-
(* After [Git.Subtree.add] the HEAD commit contains the
460
-
newly-added subtree, but the on-disk index is still the
461
-
pre-add index (subtree.add writes directly via git
462
-
plumbing without touching the index). Using
463
-
[add_to_index ["sources.toml"]] would commit a tree
464
-
derived from that stale index, dropping the subtree.
465
-
[add_all] rebuilds the index from the working tree so
466
-
the follow-up commit includes every file present —
467
-
subtree files, dune-project, root.opam, sources.toml. *)
468
-
match Git.Repository.add_all git_repo with
469
-
| Ok () -> (
470
-
let msg =
471
-
Fmt.str "Update sources.toml: add %s" result.name
472
-
in
473
-
match git_commit ~sw ~fs ~target ~message:msg with
474
-
| Ok _ -> ()
475
-
| Error (`Msg e) ->
476
-
Log.warn (fun m ->
477
-
m "Failed to commit sources.toml: %s" e))
478
-
| Error (`Msg e) ->
479
-
Log.warn (fun m -> m "Failed to stage sources.toml: %s" e))
480
-
| Error e ->
481
-
Log.warn (fun m -> m "Failed to update sources.toml: %s" e)
477
+
update_sources_toml ~sw ~fs ~target ~url ~branch ~path ~result;
478
+
update_root_deps ~fs ~target
482
479
end;
483
-
(* Update dune-project with external deps from all subtrees *)
484
-
if not dry_run then update_root_deps ~fs ~target;
485
480
Ok [ result ])
486
-
| Lock_file path -> from_lock ~sw ~proc ~fs ~target ~lock_path:path ~dry_run
+183
-184
lib/push.ml
+183
-184
lib/push.ml
···
117
117
118
118
The caller must have already ensured that [checkout_dir] is a fresh clone of
119
119
the source URL with [origin] set up. *)
120
+
let 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
+
128
+
let 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
+
143
+
let 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
+
120
157
let merge_split_into_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir
121
-
~prefix ~path ~branch =
158
+
~prefix ~path ~branch:_ =
122
159
let ( let* ) r f =
123
160
Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
124
161
in
···
141
178
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
142
179
~refspec ~force:true ()
143
180
in
144
-
(* In the checkout, merge the split at [path]. *)
145
181
let checkout_repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
146
-
let user =
147
-
match Git_cli.global_git_user ~fs () with
148
-
| Some u -> u
149
-
| None ->
150
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
151
-
~date:(Int64.of_float (Unix.time ()))
152
-
()
153
-
in
182
+
let user = resolve_user ~fs in
154
183
let message =
155
184
Fmt.str
156
185
"Merge '%s/' from monorepo split of '%s'\n\ngit-subtree-dir: %s\n"
157
186
path prefix path
158
187
in
159
-
let merge_or_add () =
160
-
match
161
-
Git.Subtree.merge checkout_repo ~prefix:path ~commit:split_hash
162
-
~author:user ~committer:user ~message ()
163
-
with
164
-
| Ok (Git.Subtree.Merged h) -> Ok h
165
-
| Ok (Git.Subtree.Conflicts (h, _)) -> Ok h
166
-
| Error (`Msg msg)
167
-
when String.length msg >= 20
168
-
&& String.sub msg 0 20 = "Subtree not found at" ->
169
-
Git.Subtree.add checkout_repo ~prefix:path ~commit:split_hash
170
-
~author:user ~committer:user ~message ()
171
-
| Error (`Msg _) as e -> e
172
-
in
173
-
match merge_or_add () with
188
+
match
189
+
merge_or_add_subtree checkout_repo ~prefix:path ~commit:split_hash
190
+
~author:user ~committer:user ~message
191
+
with
174
192
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
175
193
| Ok new_head ->
176
-
(* Subtree.merge advanced HEAD via git plumbing without
177
-
updating the working tree or the index. Sync both so
178
-
a subsequent [monopam pull] can fast-forward instead
179
-
of hitting "local changes would be overwritten". *)
180
-
(match Git.Repository.checkout checkout_repo new_head with
181
-
| Ok () -> ()
182
-
| Error (`Msg msg) ->
183
-
Log.warn (fun m ->
184
-
m "checkout after path merge of %s: %s" path msg));
185
-
(match Git.Repository.add_all checkout_repo with
186
-
| Ok () -> ()
187
-
| Error (`Msg msg) ->
188
-
Log.warn (fun m ->
189
-
m "rebuild index after path merge of %s: %s" path msg));
190
-
let _ = branch in
194
+
sync_workdir checkout_repo new_head ~path;
191
195
Ok ()))
192
196
193
197
(** Look up the sources.toml entry for a package.
···
213
217
| Some r -> r
214
218
| None -> (None, Package.subtree_prefix pkg)))
215
219
220
+
let bind_git r f = Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
221
+
222
+
let try_clone ~proc ~fs ~config ~url ~prefix pkg =
223
+
Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg));
224
+
match Ctx.ensure_checkout ~proc ~fs:(fs :> _ Eio.Path.t) ~config ~url pkg with
225
+
| Ok () -> true
226
+
| Error _ ->
227
+
Log.debug (fun m -> m "Could not clone %s from %s — skipping" prefix url);
228
+
false
229
+
230
+
let push_via_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix ~path
231
+
~branch =
232
+
Log.info (fun m ->
233
+
m "Subtree push with path %s/%s -> %a" prefix path Fpath.pp checkout_dir);
234
+
bind_git
235
+
(Git_cli.ensure_receive_config ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
236
+
(fun () ->
237
+
merge_split_into_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir
238
+
~prefix ~path ~branch
239
+
|> Result.map (fun () -> Pushed))
240
+
241
+
let push_via_split ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix
242
+
~branch ~clean ~force =
243
+
let checkout_url = Fpath.to_string checkout_dir in
244
+
let checkout_tree = checkout_tree_hash ~sw ~fs checkout_dir in
245
+
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
246
+
bind_git
247
+
(Git_cli.ensure_receive_config ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
248
+
(fun () ->
249
+
bind_git
250
+
(Git_cli.clean_untracked ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir)
251
+
(fun () ->
252
+
split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
253
+
~checkout_tree ~clean ~force ~branch
254
+
|> Result.map (fun () -> Pushed)))
255
+
216
256
let one ~sw ~proc ~fs ~config ~sources ~clean ~force pkg =
217
-
let ( let* ) r f =
218
-
Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
219
-
in
220
257
let fs = Ctx.fs_typed fs in
221
258
let monorepo = Config.Paths.monorepo config in
222
259
let entry, prefix = lookup_entry ~sources pkg in
···
235
272
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
236
273
Ok Skipped
237
274
end
238
-
else begin
275
+
else
239
276
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
240
277
let freshly_cloned = needs_clone ~fs ~checkout_eio ~checkout_dir in
241
278
let clone_ok =
242
-
if freshly_cloned then begin
243
-
Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg));
244
-
match
245
-
Ctx.ensure_checkout ~proc
246
-
~fs:(fs :> _ Eio.Path.t)
247
-
~config ~url:clone_url pkg
248
-
with
249
-
| Ok () -> true
250
-
| Error _ ->
251
-
Log.debug (fun m ->
252
-
m "Could not clone %s from %s — skipping" prefix clone_url);
253
-
false
254
-
end
279
+
if freshly_cloned then
280
+
try_clone ~proc ~fs ~config ~url:clone_url ~prefix pkg
255
281
else true
256
282
in
257
283
if not clone_ok then Ok (Clone_failed clone_url)
258
284
else
259
-
let* () = Ok () in
260
-
let checkout_url = Fpath.to_string checkout_dir in
261
285
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
262
286
match path_override with
263
287
| Some path ->
264
-
Log.info (fun m ->
265
-
m "Subtree push with path %s/%s -> %a" prefix path Fpath.pp
266
-
checkout_dir);
267
-
let* () =
268
-
Git_cli.ensure_receive_config ~proc
269
-
~fs:(fs :> _ Eio.Path.t)
270
-
checkout_dir
271
-
in
272
-
merge_split_into_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir
273
-
~prefix ~path ~branch
274
-
|> Result.map (fun () -> Pushed)
288
+
push_via_path ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix
289
+
~path ~branch
275
290
| None ->
276
-
let checkout_tree = checkout_tree_hash ~sw ~fs checkout_dir in
277
-
(* Always run the split + push flow. [split_and_push] is a
278
-
near no-op when the refspec already matches the checkout,
279
-
and [to_upstream] still needs to run even if the local
280
-
trees are in sync, in case the upstream has diverged. *)
281
-
Log.info (fun m ->
282
-
m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
283
-
let* () =
284
-
Git_cli.ensure_receive_config ~proc
285
-
~fs:(fs :> _ Eio.Path.t)
286
-
checkout_dir
287
-
in
288
-
let* () =
289
-
Git_cli.clean_untracked ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir
290
-
in
291
-
split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
292
-
~checkout_tree ~clean ~force ~branch
293
-
|> Result.map (fun () -> Pushed)
294
-
end
291
+
push_via_split ~sw ~proc ~fs ~monorepo ~git_repo ~checkout_dir ~prefix
292
+
~branch ~clean ~force
295
293
296
294
(** {1 Workspace Repo Push} *)
297
295
···
716
714
missing
717
715
end
718
716
717
+
let prewarm_splits ~sw ~clock ~git_repo ~head repos =
718
+
let prefixes = List.map Package.subtree_prefix repos in
719
+
let split_progress = ref None in
720
+
let on_progress ~processed ~total =
721
+
let bar =
722
+
match !split_progress with
723
+
| Some b -> b
724
+
| None ->
725
+
let b =
726
+
Tty.Progress.v ~color:(`Hex (0x10, 0xc6, 0xe6)) ~total "splitting"
727
+
in
728
+
Tty_eio.Progress.animate ~sw ~clock b;
729
+
split_progress := Some b;
730
+
b
731
+
in
732
+
Tty.Progress.set bar processed
733
+
in
734
+
ignore
735
+
(Git.Subtree.split_batch git_repo ~prefixes ~head ~on_progress () : _ list);
736
+
Option.iter (fun b -> Tty.Progress.finish ~message:"split" b) !split_progress
737
+
738
+
let make_local_results ~config repos =
739
+
List.map
740
+
(fun p ->
741
+
let name = Package.repo_name p in
742
+
let checkouts_root = Config.Paths.checkouts config in
743
+
let url = Fpath.to_string (Package.checkout_dir ~checkouts_root p) in
744
+
Ok (name, url))
745
+
repos
746
+
747
+
let push_results ~sw ~proc ~fs_t ~config ~sources ~upstream ~force ~progress
748
+
pushed_repos =
749
+
if upstream && pushed_repos <> [] then
750
+
to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress
751
+
pushed_repos
752
+
else make_local_results ~config pushed_repos
753
+
754
+
let workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream =
755
+
let ws_errors =
756
+
if upstream then
757
+
workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
758
+
else []
759
+
in
760
+
if ws_errors = [] then Ok ()
761
+
else
762
+
let _name, e = List.hd ws_errors in
763
+
Error (Ctx.Git_error e)
764
+
719
765
let export_and_push ~sw ~clock ~proc ~fs ~fs_t ~config ~sources ~upstream
720
766
~push_mono ~clean ~force ~all_pkgs repos =
721
767
(* Update README and llms.txt before push *)
···
723
769
Init.write_llms_txt ~proc ~fs:fs_t ~config all_pkgs;
724
770
let n_repos = List.length repos in
725
771
let total = if upstream then n_repos * 2 else n_repos in
726
-
(* Pre-compute all subtree splits in a single history walk *)
727
772
let monorepo = Config.Paths.monorepo config in
728
773
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
729
774
(match Git.Repository.read_ref git_repo "HEAD" with
730
-
| Some head ->
731
-
let prefixes = List.map Package.subtree_prefix repos in
732
-
let split_progress = ref None in
733
-
let on_progress ~processed ~total =
734
-
let bar =
735
-
match !split_progress with
736
-
| Some b -> b
737
-
| None ->
738
-
let b =
739
-
Tty.Progress.v
740
-
~color:(`Hex (0x10, 0xc6, 0xe6))
741
-
~total "splitting"
742
-
in
743
-
Tty_eio.Progress.animate ~sw ~clock b;
744
-
split_progress := Some b;
745
-
b
746
-
in
747
-
Tty.Progress.set bar processed
748
-
in
749
-
ignore
750
-
(Git.Subtree.split_batch git_repo ~prefixes ~head ~on_progress ()
751
-
: _ list);
752
-
Option.iter
753
-
(fun b -> Tty.Progress.finish ~message:"split" b)
754
-
!split_progress
775
+
| Some head -> prewarm_splits ~sw ~clock ~git_repo ~head repos
755
776
| None -> ());
756
777
let progress =
757
778
Tty.Progress.v ~color:(`Hex (0x27, 0xda, 0xde)) ~total "exporting"
···
765
786
Error e
766
787
| Ok (pushed_repos, missing) -> (
767
788
let results =
768
-
if upstream && pushed_repos <> [] then
769
-
to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress
770
-
pushed_repos
771
-
else
772
-
List.map
773
-
(fun p ->
774
-
let name = Package.repo_name p in
775
-
let checkouts_root = Config.Paths.checkouts config in
776
-
let url =
777
-
Fpath.to_string (Package.checkout_dir ~checkouts_root p)
778
-
in
779
-
Ok (name, url))
780
-
pushed_repos
789
+
push_results ~sw ~proc ~fs_t ~config ~sources ~upstream ~force ~progress
790
+
pushed_repos
781
791
in
782
792
Tty.Progress.finish ~message:"exported" progress;
783
793
log_missing_repos ~all_pkgs missing;
784
794
match log_results results with
785
795
| Error e -> Error e
786
796
| Ok () ->
787
-
let ws_errors =
788
-
if upstream then
789
-
workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
790
-
else []
791
-
in
792
-
if ws_errors <> [] then
793
-
let _name, e = List.hd ws_errors in
794
-
Error (Ctx.Git_error e)
795
-
else Ok ())
797
+
workspace_check ~sw ~proc ~fs_t ~config ~force ~push_mono ~upstream)
796
798
797
799
let load_sources ~fs ~config =
798
800
let sources_path = Fpath.(Config.Paths.monorepo config / "sources.toml") in
···
800
802
| Ok s -> Some s
801
803
| Error _ -> None
802
804
805
+
let 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
+
813
+
let 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
+
822
+
let 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
+
803
846
let run ~sw ~clock ~proc ~fs ~config ?(packages = []) ?(upstream = false)
804
847
?(clean = false) ?(force = false) () =
805
848
let fs_t = Ctx.fs_typed fs in
···
807
850
match Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
808
851
| Error e -> Error e
809
852
| Ok all_pkgs ->
810
-
let pkgs =
811
-
match packages with
812
-
| [] -> all_pkgs
813
-
| names ->
814
-
List.filter
815
-
(fun p -> List.exists (fun n -> Package.matches_name n p) names)
816
-
all_pkgs
817
-
in
853
+
let pkgs = select_pkgs ~packages all_pkgs in
818
854
if pkgs = [] && packages <> [] then
819
855
Error (Ctx.Package_not_found (List.hd packages))
820
856
else begin
···
827
863
on the next pull anyway, and pushing from the monorepo never
828
864
reads the checkout's worktree. Pull still guards against dirty
829
865
checkouts because merging into one would destroy real work. *)
830
-
begin
831
-
(* Sync opam files to opam-repo before pushing *)
832
-
(match Opam_sync.run ~sw ~clock ~fs:fs_t ~config ~packages () with
833
-
| Ok r ->
834
-
if r.Opam_sync.synced <> [] then
835
-
Log.info (fun m ->
836
-
m "Synced %d opam files to opam-repo" (List.length r.synced))
837
-
| Error (`Config_error msg) ->
838
-
Log.warn (fun m -> m "Opam sync failed: %s" msg));
839
-
let sources = load_sources ~fs:fs_t ~config in
840
-
(* Push mono inner subtrees first (depth-first) *)
841
-
let inner_errors =
842
-
mono_entries ~sw ~proc ~fs ~config ~sources ~clean ~force
843
-
in
844
-
if inner_errors <> [] then
845
-
(* Failure inside a nested mono push (e.g. non-fast-forward
846
-
on lib.git). Report the first one — they all need attention. *)
847
-
Error (List.hd inner_errors)
848
-
else
849
-
let to_push = repos_to_push statuses pkgs in
850
-
Log.info (fun m ->
851
-
m "Pushing %d unique repos" (List.length to_push));
852
-
let push_mono = packages = [] in
853
-
if to_push = [] then begin
854
-
Log.app (fun m -> m "Nothing to push (all repos in sync)");
855
-
let ws_errors =
856
-
if upstream then
857
-
workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
858
-
else []
859
-
in
860
-
if ws_errors <> [] then
861
-
let _name, e = List.hd ws_errors in
862
-
Error (Ctx.Git_error e)
863
-
else Ok ()
864
-
end
865
-
else
866
-
export_and_push ~sw ~clock ~proc ~fs ~fs_t ~config ~sources
867
-
~upstream ~push_mono ~clean ~force ~all_pkgs:pkgs to_push
868
-
end
866
+
run_after_sync ~sw ~clock ~proc ~fs ~fs_t ~config ~packages ~upstream
867
+
~clean ~force ~pkgs ~statuses
869
868
end