forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: split into one module per command
Reorganize monopam.ml into focused command modules:
- ctx.ml - operational context (fs, package discovery, checkouts)
- init.ml - monorepo initialization and file generation
- pull.ml - pull operations (fetch checkouts, merge subtrees)
- push.ml - push operations (subtree split, export)
- add.ml - add packages to monorepo
- remove.ml - remove packages from monorepo
- clean.ml - clean empty commits from history
- diff.ml - verse collaboration diff operations
Monopam.ml now re-exports modules with backward-compatible
function exports for existing bin commands.
+1840
-2557
+23
lib/add.ml
+23
lib/add.ml
···
1
+
(** Add a package to the monorepo.
2
+
3
+
Looks up the package in the opam repo, ensures its checkout exists, and
4
+
pulls the subtree into the monorepo. *)
5
+
6
+
let src = Logs.Src.create "monopam.add" ~doc:"Monopam add operation"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
let add ~proc ~fs ~config ~package:pkg_name () =
11
+
let fs_t = Ctx.fs_typed fs in
12
+
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
13
+
match Init.ensure ~proc ~fs:fs_t ~config with
14
+
| Error e -> Error e
15
+
| Ok () -> (
16
+
match Ctx.package ~fs:(fs_t :> _ Eio.Path.t) ~config pkg_name with
17
+
| Error e -> Error e
18
+
| Ok pkg -> (
19
+
Log.info (fun m -> m "Adding package %s" (Package.name pkg));
20
+
match Ctx.ensure_checkout ~proc ~fs:fs_t ~config pkg with
21
+
| Error e -> Error (Ctx.Git_error e)
22
+
| Ok () ->
23
+
Pull.subtree ~proc ~fs ~config pkg |> Result.map (fun _ -> ())))
+122
lib/clean.ml
+122
lib/clean.ml
···
1
+
(** Clean empty commits from monorepo and checkouts.
2
+
3
+
Removes empty commits and unrelated merge commits from git history. *)
4
+
5
+
let src = Logs.Src.create "monopam.clean" ~doc:"Monopam clean operation"
6
+
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(** {1 Helpers} *)
10
+
11
+
let write_cleaned_head repo new_head =
12
+
match Git.Repository.current_branch repo with
13
+
| Some branch ->
14
+
Git.Repository.write_ref repo ("refs/heads/" ^ branch) new_head
15
+
| None -> Git.Repository.write_ref repo "HEAD" new_head
16
+
17
+
let apply_fix ~name ~repo ~dry_run ~fix_fn ~issue_count =
18
+
if dry_run then Some issue_count
19
+
else
20
+
match fix_fn () with
21
+
| Error (`Msg msg) ->
22
+
Log.warn (fun m -> m " Failed to clean %s: %s" name msg);
23
+
None
24
+
| Ok None ->
25
+
Log.warn (fun m -> m " %s: history became empty" name);
26
+
None
27
+
| Ok (Some new_head) ->
28
+
write_cleaned_head repo new_head;
29
+
Log.app (fun m -> m " ✓ %s cleaned" name);
30
+
Some issue_count
31
+
32
+
(** {1 Main Clean Operation} *)
33
+
34
+
let clean ~proc ~fs ~config ~dry_run ~force () =
35
+
let fs_t = Ctx.fs_typed fs in
36
+
let mono = Config.Paths.monorepo config in
37
+
let checkouts = Config.Paths.checkouts config in
38
+
39
+
let clean_mono () =
40
+
if not (Git.Repository.is_repo ~fs:fs_t mono) then None
41
+
else
42
+
let repo = Git.Repository.open_repo ~fs:fs_t mono in
43
+
match Git.Repository.head repo with
44
+
| None -> None
45
+
| Some head ->
46
+
let checked, issues = Git.Subtree.check_mono repo ~head () in
47
+
if issues = [] then None
48
+
else begin
49
+
Log.app (fun m ->
50
+
m "mono: %d empty commits (of %d checked)" (List.length issues)
51
+
checked);
52
+
apply_fix ~name:"mono" ~repo ~dry_run
53
+
~fix_fn:(fun () -> Git.Subtree.fix_mono repo ~head ())
54
+
~issue_count:(List.length issues)
55
+
end
56
+
in
57
+
58
+
let clean_checkout name =
59
+
let path = Fpath.(checkouts / name) in
60
+
if not (Git.Repository.is_repo ~fs:fs_t path) then None
61
+
else
62
+
let repo = Git.Repository.open_repo ~fs:fs_t path in
63
+
match Git.Repository.head repo with
64
+
| None -> None
65
+
| Some head ->
66
+
let checked, issues = Git.Subtree.check repo ~prefix:name ~head () in
67
+
if issues = [] then None
68
+
else begin
69
+
Log.app (fun m ->
70
+
m "%s: %d unrelated merges (of %d checked)" name
71
+
(List.length issues) checked);
72
+
apply_fix ~name ~repo ~dry_run
73
+
~fix_fn:(fun () -> Git.Subtree.fix repo ~prefix:name ~head ())
74
+
~issue_count:(List.length issues)
75
+
end
76
+
in
77
+
78
+
let mono_cleaned = clean_mono () in
79
+
80
+
let checkouts_path = Eio.Path.(fs_t / Fpath.to_string checkouts) in
81
+
let checkout_results =
82
+
try Eio.Path.read_dir checkouts_path |> List.filter_map clean_checkout
83
+
with Eio.Io _ -> []
84
+
in
85
+
86
+
let total_cleaned =
87
+
Option.value ~default:0 mono_cleaned
88
+
+ List.fold_left ( + ) 0 checkout_results
89
+
in
90
+
91
+
if total_cleaned = 0 then begin
92
+
Log.app (fun m -> m "No empty commits found");
93
+
Ok ()
94
+
end
95
+
else if dry_run then begin
96
+
Log.app (fun m ->
97
+
m "Would remove %d commits (use without --dry-run to apply)"
98
+
total_cleaned);
99
+
Ok ()
100
+
end
101
+
else begin
102
+
Log.app (fun m -> m "Removed %d commits" total_cleaned);
103
+
if force then begin
104
+
Log.app (fun m -> m "Force-pushing cleaned histories to upstream...");
105
+
(try
106
+
Eio.Path.read_dir checkouts_path
107
+
|> List.iter (fun name ->
108
+
let path = Fpath.(checkouts / name) in
109
+
if Git.Repository.is_repo ~fs:fs_t path then
110
+
match
111
+
Git_cli.push_remote ~proc
112
+
~fs:(fs_t :> _ Eio.Path.t)
113
+
~force:true path
114
+
with
115
+
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
116
+
| Error e ->
117
+
Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e))
118
+
with Eio.Io _ -> ());
119
+
Ok ()
120
+
end
121
+
else Ok ()
122
+
end
+327
lib/ctx.ml
+327
lib/ctx.ml
···
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
+
6
+
let src = Logs.Src.create "monopam.ctx" ~doc:"Monopam context"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** {1 Error Types} *)
11
+
12
+
type 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
+
| Claude_error of string
20
+
21
+
let pp_error ppf = function
22
+
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
23
+
| Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
24
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
25
+
| Dirty_state pkgs ->
26
+
Fmt.pf ppf "Dirty packages: %a"
27
+
Fmt.(list ~sep:comma (using Package.name string))
28
+
pkgs
29
+
| Monorepo_dirty -> Fmt.pf ppf "Monorepo has uncommitted changes"
30
+
| Package_not_found name -> Fmt.pf ppf "Package not found: %s" name
31
+
| Claude_error msg -> Fmt.pf ppf "Claude error: %s" msg
32
+
33
+
let error_hint = function
34
+
| Config_error _ ->
35
+
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
36
+
| Repo_error (Opam_repo.No_dev_repo _) ->
37
+
Some
38
+
"Add a 'dev-repo' field to the package's opam file pointing to a git \
39
+
URL."
40
+
| Repo_error (Opam_repo.Not_git_remote _) ->
41
+
Some "The dev-repo must be a git URL (git+https:// or git://)."
42
+
| Repo_error _ -> None
43
+
| Git_error (Git_cli.Dirty_worktree _) ->
44
+
Some "Commit or stash your changes first: cd <repo> && git status"
45
+
| Git_error (Git_cli.Not_a_repo _) ->
46
+
Some "Run 'monopam sync' to clone missing repositories."
47
+
| Git_error (Git_cli.Subtree_prefix_missing _) ->
48
+
Some "Run 'monopam sync' to set up the subtree."
49
+
| Git_error (Git_cli.Remote_not_found _) ->
50
+
Some "Check that the remote is configured: git remote -v"
51
+
| Git_error (Git_cli.Branch_not_found _) ->
52
+
Some "Check available branches: git branch -a"
53
+
| Git_error (Git_cli.Command_failed (cmd, _))
54
+
when String.starts_with ~prefix:"git push" cmd ->
55
+
Some "Check your network connection and git credentials."
56
+
| Git_error (Git_cli.Command_failed (cmd, _))
57
+
when String.starts_with ~prefix:"git subtree" cmd ->
58
+
Some "Run 'monopam status' to check repository state."
59
+
| Git_error _ -> None
60
+
| Dirty_state _ ->
61
+
Some
62
+
"Commit changes in the monorepo first: cd mono && git add -A && git \
63
+
commit"
64
+
| Monorepo_dirty ->
65
+
Some
66
+
"Commit or stash your changes first: git status && git add -A && git \
67
+
commit"
68
+
| Package_not_found _ ->
69
+
Some "Check available packages: ls opam-repo/packages/"
70
+
| Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg ->
71
+
Some "The Claude API may have returned an unexpected response. Try again."
72
+
| Claude_error _ ->
73
+
Some "Check ANTHROPIC_API_KEY is set. See: https://console.anthropic.com/"
74
+
75
+
let pp_error_with_hint ppf e =
76
+
pp_error ppf e;
77
+
match error_hint e with
78
+
| Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint
79
+
| None -> ()
80
+
81
+
(** {1 Filesystem Utilities} *)
82
+
83
+
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
84
+
let dir, _ = fs in
85
+
(dir, "")
86
+
87
+
let rec mkdirs path =
88
+
match Eio.Path.kind ~follow:true path with
89
+
| `Directory -> ()
90
+
| _ ->
91
+
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
92
+
Eio.Path.mkdir ~perm:0o755 path
93
+
| exception Eio.Io _ ->
94
+
let parent = Eio.Path.split path in
95
+
(match parent with
96
+
| Some (parent_path, _) -> mkdirs parent_path
97
+
| None -> ());
98
+
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
99
+
Eio.Path.mkdir ~perm:0o755 path
100
+
101
+
let is_directory ~fs path =
102
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
103
+
match Eio.Path.kind ~follow:true eio_path with
104
+
| `Directory -> true
105
+
| _ -> false
106
+
| exception _ -> false
107
+
108
+
let ensure_checkouts_dir ~fs ~config =
109
+
let checkouts = Config.Paths.checkouts config in
110
+
let checkouts_eio = Eio.Path.(fs / Fpath.to_string checkouts) in
111
+
Log.debug (fun m ->
112
+
m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
113
+
mkdirs checkouts_eio
114
+
115
+
(** {1 Package Discovery} *)
116
+
117
+
let discover_packages ~fs ~config () =
118
+
let repo_path = Config.Paths.opam_repo config in
119
+
Log.debug (fun m -> m "Scanning opam repo at %a" Fpath.pp repo_path);
120
+
Opam_repo.scan ~fs repo_path
121
+
|> Result.map_error (fun e -> Repo_error e)
122
+
|> Result.map (fun pkgs ->
123
+
Log.info (fun m -> m "Found %d packages in opam repo" (List.length pkgs));
124
+
pkgs)
125
+
126
+
let package ~fs ~config name =
127
+
Result.bind (discover_packages ~fs ~config ()) (fun pkgs ->
128
+
List.find_opt (fun p -> Package.name p = name) pkgs
129
+
|> Option.to_result ~none:(Package_not_found name))
130
+
131
+
(** {1 Branch and Checkout Management} *)
132
+
133
+
let branch ~config pkg =
134
+
let default = Config.default_branch in
135
+
match Package.branch pkg with
136
+
| Some b -> b
137
+
| None ->
138
+
Option.bind
139
+
(Config.package_config config (Package.name pkg))
140
+
Config.Package_config.branch
141
+
|> Option.value ~default
142
+
143
+
let ensure_checkout ~proc ~fs ~config pkg =
144
+
let checkouts_root = Config.Paths.checkouts config in
145
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
146
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
147
+
let branch = branch ~config pkg in
148
+
let do_clone () =
149
+
Log.info (fun m ->
150
+
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
151
+
(Package.dev_repo pkg) branch);
152
+
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
153
+
in
154
+
let is_directory =
155
+
match Eio.Path.kind ~follow:true checkout_eio with
156
+
| `Directory -> true
157
+
| _ -> false
158
+
| exception Eio.Io _ -> false
159
+
in
160
+
if not is_directory then do_clone ()
161
+
else if not (Git.Repository.is_repo ~fs checkout_dir) then do_clone ()
162
+
else begin
163
+
Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
164
+
match Git_cli.fetch ~proc ~fs checkout_dir with
165
+
| Error e -> Error e
166
+
| Ok () ->
167
+
Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
168
+
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
169
+
end
170
+
171
+
let checkout_exists ~fs ~config pkg =
172
+
let checkouts_root = Config.Paths.checkouts config in
173
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
174
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
175
+
match Eio.Path.kind ~follow:true checkout_eio with
176
+
| `Directory -> Git.Repository.is_repo ~fs checkout_dir
177
+
| _ -> false
178
+
| exception Eio.Io _ -> false
179
+
180
+
let behind ~fs ~config pkg =
181
+
let checkouts_root = Config.Paths.checkouts config in
182
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
183
+
let branch = branch ~config pkg in
184
+
if not (Git.Repository.is_repo ~fs checkout_dir) then 0
185
+
else
186
+
let repo = Git.Repository.open_repo ~fs checkout_dir in
187
+
match Git.Repository.ahead_behind repo ~branch () with
188
+
| Some ab -> ab.behind
189
+
| None -> 0
190
+
191
+
(** {1 Repository Grouping} *)
192
+
193
+
let group_by_repo pkgs =
194
+
let tbl = Hashtbl.create 16 in
195
+
List.iter
196
+
(fun pkg ->
197
+
let repo = Package.repo_name pkg in
198
+
let existing = try Hashtbl.find tbl repo with Not_found -> [] in
199
+
Hashtbl.replace tbl repo (pkg :: existing))
200
+
pkgs;
201
+
Hashtbl.fold
202
+
(fun repo pkgs acc -> (repo, List.sort Package.compare pkgs) :: acc)
203
+
tbl []
204
+
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
205
+
206
+
let normalize_url_for_comparison uri =
207
+
let scheme = Option.value ~default:"" (Uri.scheme uri) in
208
+
let host = Option.value ~default:"" (Uri.host uri) in
209
+
let path = Uri.path uri in
210
+
let path =
211
+
if String.length path > 1 && path.[String.length path - 1] = '/' then
212
+
String.sub path 0 (String.length path - 1)
213
+
else path
214
+
in
215
+
Fmt.str "%s://%s%s" scheme host path
216
+
217
+
let unique_repos pkgs =
218
+
let seen = Hashtbl.create 16 in
219
+
List.filter
220
+
(fun pkg ->
221
+
let url = normalize_url_for_comparison (Package.dev_repo pkg) in
222
+
Log.debug (fun m ->
223
+
m "Checking repo URL: %s (from %s)" url (Package.name pkg));
224
+
if Hashtbl.mem seen url then begin
225
+
Log.debug (fun m -> m " -> Already seen, skipping");
226
+
false
227
+
end
228
+
else begin
229
+
Hashtbl.add seen url ();
230
+
Log.debug (fun m -> m " -> New repo, keeping");
231
+
true
232
+
end)
233
+
pkgs
234
+
235
+
(** {1 URL Utilities} *)
236
+
237
+
let is_tangled_host = function
238
+
| Some "tangled.org" | Some "tangled.sh" -> true
239
+
| _ -> false
240
+
241
+
let url_to_push_url ?knot uri =
242
+
let scheme = Uri.scheme uri in
243
+
let host = Uri.host uri in
244
+
let path = Uri.path uri in
245
+
match (scheme, host) with
246
+
| Some ("https" | "http"), Some "github.com" ->
247
+
let path =
248
+
if String.length path > 0 && path.[0] = '/' then
249
+
String.sub path 1 (String.length path - 1)
250
+
else path
251
+
in
252
+
Fmt.str "git@github.com:%s" path
253
+
| Some ("https" | "http"), _ when is_tangled_host host ->
254
+
let path =
255
+
if String.length path > 0 && path.[0] = '/' then
256
+
String.sub path 1 (String.length path - 1)
257
+
else path
258
+
in
259
+
let path =
260
+
if String.length path > 0 && path.[0] = '@' then
261
+
String.sub path 1 (String.length path - 1)
262
+
else path
263
+
in
264
+
let path =
265
+
if String.ends_with ~suffix:".git" path then
266
+
String.sub path 0 (String.length path - 4)
267
+
else path
268
+
in
269
+
let knot_server = Option.value ~default:"git.recoil.org" knot in
270
+
Fmt.str "git@%s:%s" knot_server path
271
+
| _ -> Uri.to_string uri
272
+
273
+
(** {1 Unregistered Package Detection} *)
274
+
275
+
let unregistered_opam_files ~fs ~config pkgs =
276
+
let fs = fs_typed fs in
277
+
let monorepo = Config.Paths.monorepo config in
278
+
let registered_by_repo = Hashtbl.create 16 in
279
+
List.iter
280
+
(fun pkg ->
281
+
let repo = Package.repo_name pkg in
282
+
let name = Package.name pkg in
283
+
let existing =
284
+
try Hashtbl.find registered_by_repo repo with Not_found -> []
285
+
in
286
+
Hashtbl.replace registered_by_repo repo (name :: existing))
287
+
pkgs;
288
+
let seen_repos = Hashtbl.create 16 in
289
+
let repos =
290
+
List.filter
291
+
(fun pkg ->
292
+
let repo = Package.repo_name pkg in
293
+
if Hashtbl.mem seen_repos repo then false
294
+
else begin
295
+
Hashtbl.add seen_repos repo ();
296
+
true
297
+
end)
298
+
pkgs
299
+
in
300
+
let check_opam_file ~repo ~registered name =
301
+
if not (Filename.check_suffix name ".opam") then None
302
+
else
303
+
let pkg_name = Filename.chop_suffix name ".opam" in
304
+
if List.mem pkg_name registered then None else Some (repo, pkg_name)
305
+
in
306
+
List.concat_map
307
+
(fun pkg ->
308
+
let repo = Package.repo_name pkg in
309
+
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
310
+
let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in
311
+
let registered =
312
+
try Hashtbl.find registered_by_repo repo with Not_found -> []
313
+
in
314
+
try
315
+
Eio.Path.read_dir eio_path
316
+
|> List.filter_map (check_opam_file ~repo ~registered)
317
+
with Eio.Io _ -> [])
318
+
repos
319
+
320
+
(** {1 Timing} *)
321
+
322
+
let time_phase name f =
323
+
let t0 = Unix.gettimeofday () in
324
+
let result = f () in
325
+
let t1 = Unix.gettimeofday () in
326
+
Log.debug (fun m -> m "[TIMING] %s: %.3fs" name (t1 -. t0));
327
+
result
+325
lib/diff.ml
+325
lib/diff.ml
···
1
+
(** Verse collaboration diff operations.
2
+
3
+
Compares local repositories with verse member forks to identify commits that
4
+
can be pulled or cherry-picked. *)
5
+
6
+
let src = Logs.Src.create "monopam.diff" ~doc:"Monopam diff operations"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** {1 Types} *)
11
+
12
+
type entry = {
13
+
repo_name : string;
14
+
handle : string;
15
+
relationship : Forks.relationship;
16
+
commits : Git.Repository.log_entry list;
17
+
patches : (string * string) list;
18
+
}
19
+
20
+
type result = { entries : entry list; forks : Forks.t }
21
+
22
+
type commit_info = {
23
+
commit_repo : string;
24
+
commit_handle : string;
25
+
commit_hash : string;
26
+
commit_subject : string;
27
+
commit_author : string;
28
+
commit_patch : string;
29
+
}
30
+
31
+
type handle_pull_result = {
32
+
repos_pulled : (string * int) list;
33
+
repos_skipped : string list;
34
+
repos_failed : (string * string) list;
35
+
}
36
+
37
+
type cherrypick_result = {
38
+
repo_name : string;
39
+
commit_hash : string;
40
+
commit_subject : string;
41
+
}
42
+
43
+
(** {1 Pretty Printers} *)
44
+
45
+
let pp_entry ~show_patch ppf entry =
46
+
let n_commits = List.length entry.commits in
47
+
Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@,"
48
+
Fmt.(styled `Bold string)
49
+
entry.repo_name entry.handle Forks.pp_relationship entry.relationship
50
+
n_commits
51
+
(if n_commits = 1 then "" else "s");
52
+
List.iter
53
+
(fun (c : Git.Repository.log_entry) ->
54
+
let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
55
+
Fmt.pf ppf " %a %s %a@,"
56
+
Fmt.(styled `Yellow string)
57
+
short_hash c.subject
58
+
Fmt.(styled `Faint string)
59
+
c.author;
60
+
if show_patch then
61
+
match List.assoc_opt c.hash entry.patches with
62
+
| Some patch -> Fmt.pf ppf "@,%s@," patch
63
+
| None -> ())
64
+
entry.commits;
65
+
Fmt.pf ppf "@]"
66
+
67
+
let pp ~show_patch ppf result =
68
+
Fmt.pf ppf "%a@." (Forks.pp_summary' ~show_all:false) result.forks;
69
+
if result.entries <> [] then begin
70
+
Fmt.pf ppf "@[<v>%a@]@."
71
+
Fmt.(list ~sep:(any "@,@,") (pp_entry ~show_patch))
72
+
result.entries
73
+
end
74
+
75
+
let pp_handle_pull_result ppf result =
76
+
if result.repos_pulled <> [] then begin
77
+
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:";
78
+
List.iter
79
+
(fun (repo, count) -> Fmt.pf ppf " %s: %d commits@," repo count)
80
+
result.repos_pulled;
81
+
Fmt.pf ppf "@]"
82
+
end;
83
+
if result.repos_skipped <> [] then
84
+
Fmt.pf ppf "%a %s@,"
85
+
Fmt.(styled `Faint string)
86
+
"Skipped:"
87
+
(String.concat ", " result.repos_skipped);
88
+
if result.repos_failed <> [] then begin
89
+
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:";
90
+
List.iter
91
+
(fun (repo, err) -> Fmt.pf ppf " %s: %s@," repo err)
92
+
result.repos_failed;
93
+
Fmt.pf ppf "@]"
94
+
end
95
+
96
+
let pp_cherrypick_result ppf result =
97
+
let short_hash =
98
+
String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash))
99
+
in
100
+
Fmt.pf ppf "Cherry-picked %a %s into %s@."
101
+
Fmt.(styled `Yellow string)
102
+
short_hash result.commit_subject result.repo_name
103
+
104
+
(** {1 Utilities} *)
105
+
106
+
let is_commit_sha s =
107
+
String.length s >= 7
108
+
&& String.for_all
109
+
(function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
110
+
s
111
+
112
+
(** {1 Diff Operations} *)
113
+
114
+
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
115
+
?(patch = false) () =
116
+
let checkouts_path = Config.Paths.checkouts config in
117
+
let forks =
118
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
119
+
in
120
+
let repos_to_check =
121
+
match repo with
122
+
| None -> forks.repos
123
+
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
124
+
in
125
+
let entries =
126
+
List.filter_map
127
+
(fun (r : Forks.repo_analysis) ->
128
+
let actionable =
129
+
List.filter
130
+
(fun (_, _, rel) ->
131
+
match rel with
132
+
| Forks.I_am_behind _ -> true
133
+
| Forks.Diverged _ -> true
134
+
| _ -> false)
135
+
r.verse_sources
136
+
in
137
+
match actionable with
138
+
| [] -> None
139
+
| sources -> (
140
+
let entries =
141
+
List.filter_map
142
+
(fun (handle, _src, rel) ->
143
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
144
+
if not (Git.Repository.is_repo ~fs checkout_path) then None
145
+
else begin
146
+
let repo = Git.Repository.open_repo ~fs checkout_path in
147
+
let remote_name = "verse/" ^ handle in
148
+
let my_ref = "origin/main" in
149
+
let their_ref = remote_name ^ "/main" in
150
+
match
151
+
Git.Repository.log_range_refs repo ~base:my_ref
152
+
~tip:their_ref ~max_count:20 ()
153
+
with
154
+
| Error _ -> None
155
+
| Ok commits when commits = [] -> None
156
+
| Ok commits ->
157
+
let patches =
158
+
if patch then
159
+
List.filter_map
160
+
(fun (c : Git.Repository.log_entry) ->
161
+
match
162
+
Git.Repository.show_patch repo ~commit:c.hash
163
+
with
164
+
| Ok p -> Some (c.hash, p)
165
+
| Error _ -> None)
166
+
commits
167
+
else []
168
+
in
169
+
Some
170
+
{
171
+
repo_name = r.repo_name;
172
+
handle;
173
+
relationship = rel;
174
+
commits;
175
+
patches;
176
+
}
177
+
end)
178
+
sources
179
+
in
180
+
match entries with [] -> None | _ -> Some entries))
181
+
repos_to_check
182
+
|> List.flatten
183
+
in
184
+
{ entries; forks }
185
+
186
+
let show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
187
+
let checkouts_path = Config.Paths.checkouts config in
188
+
let forks =
189
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
190
+
in
191
+
List.find_map
192
+
(fun (r : Forks.repo_analysis) ->
193
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
194
+
if not (Git.Repository.is_repo ~fs checkout_path) then None
195
+
else
196
+
let repo = Git.Repository.open_repo ~fs checkout_path in
197
+
List.find_map
198
+
(fun (handle, _src, rel) ->
199
+
match rel with
200
+
| Forks.I_am_behind _ | Forks.Diverged _ -> (
201
+
let remote_name = "verse/" ^ handle in
202
+
let my_ref = "origin/main" in
203
+
let their_ref = remote_name ^ "/main" in
204
+
match
205
+
Git.Repository.log_range_refs repo ~base:my_ref ~tip:their_ref
206
+
~max_count:50 ()
207
+
with
208
+
| Error _ -> None
209
+
| Ok commits -> (
210
+
let matching =
211
+
List.find_opt
212
+
(fun (c : Git.Repository.log_entry) ->
213
+
String.starts_with ~prefix:sha c.hash
214
+
|| String.starts_with
215
+
~prefix:(String.lowercase_ascii sha)
216
+
(String.lowercase_ascii c.hash))
217
+
commits
218
+
in
219
+
match matching with
220
+
| None -> None
221
+
| Some c -> (
222
+
match Git.Repository.show_patch repo ~commit:c.hash with
223
+
| Ok patch ->
224
+
Some
225
+
{
226
+
commit_repo = r.repo_name;
227
+
commit_handle = handle;
228
+
commit_hash = c.hash;
229
+
commit_subject = c.subject;
230
+
commit_author = c.author;
231
+
commit_patch = patch;
232
+
}
233
+
| Error _ -> None)))
234
+
| _ -> None)
235
+
r.verse_sources)
236
+
forks.repos
237
+
238
+
(** {1 Pull from Handle} *)
239
+
240
+
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
241
+
?(refresh = false) () =
242
+
let checkouts_path = Config.Paths.checkouts config in
243
+
let forks =
244
+
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
245
+
in
246
+
let repos_to_check =
247
+
match repo with
248
+
| None -> forks.repos
249
+
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
250
+
in
251
+
let repos_pulled = ref [] in
252
+
let repos_skipped = ref [] in
253
+
let repos_failed = ref [] in
254
+
List.iter
255
+
(fun (r : Forks.repo_analysis) ->
256
+
let handle_source =
257
+
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
258
+
in
259
+
match handle_source with
260
+
| None -> ()
261
+
| Some (_, _, rel) ->
262
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
263
+
if not (Git.Repository.is_repo ~fs checkout_path) then
264
+
repos_skipped := r.repo_name :: !repos_skipped
265
+
else begin
266
+
let git_repo = Git.Repository.open_repo ~fs checkout_path in
267
+
match rel with
268
+
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ ->
269
+
repos_skipped := r.repo_name :: !repos_skipped
270
+
| Forks.Not_fetched | Forks.Unrelated ->
271
+
repos_skipped := r.repo_name :: !repos_skipped
272
+
| Forks.I_am_behind count -> (
273
+
let remote_ref = "verse/" ^ handle ^ "/main" in
274
+
match
275
+
Git.Repository.merge git_repo ~ref_name:remote_ref
276
+
~ff_only:true
277
+
with
278
+
| Ok () -> repos_pulled := (r.repo_name, count) :: !repos_pulled
279
+
| Error (`Msg msg) ->
280
+
repos_failed := (r.repo_name, msg) :: !repos_failed)
281
+
| Forks.Diverged { their_ahead; _ } -> (
282
+
let remote_ref = "verse/" ^ handle ^ "/main" in
283
+
match
284
+
Git.Repository.merge git_repo ~ref_name:remote_ref
285
+
~ff_only:false
286
+
with
287
+
| Ok () ->
288
+
repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled
289
+
| Error (`Msg msg) ->
290
+
repos_failed := (r.repo_name, msg) :: !repos_failed)
291
+
end)
292
+
repos_to_check;
293
+
Ok
294
+
{
295
+
repos_pulled = List.rev !repos_pulled;
296
+
repos_skipped = List.rev !repos_skipped;
297
+
repos_failed = List.rev !repos_failed;
298
+
}
299
+
300
+
(** {1 Cherry-pick} *)
301
+
302
+
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
303
+
let checkouts_path = Config.Paths.checkouts config in
304
+
match show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
305
+
| None ->
306
+
Error
307
+
(Ctx.Config_error (Fmt.str "Commit %s not found in any verse diff" sha))
308
+
| Some info ->
309
+
let checkout_path = Fpath.(checkouts_path / info.commit_repo) in
310
+
if not (Git.Repository.is_repo ~fs checkout_path) then
311
+
Error
312
+
(Ctx.Config_error
313
+
(Fmt.str "No checkout for repository %s" info.commit_repo))
314
+
else begin
315
+
let git_repo = Git.Repository.open_repo ~fs checkout_path in
316
+
match Git.Repository.cherry_pick git_repo ~commit:info.commit_hash with
317
+
| Ok _new_hash ->
318
+
Ok
319
+
{
320
+
repo_name = info.commit_repo;
321
+
commit_hash = info.commit_hash;
322
+
commit_subject = info.commit_subject;
323
+
}
324
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
325
+
end
+389
lib/init.ml
+389
lib/init.ml
···
1
+
(** Monorepo initialization and file generation.
2
+
3
+
Handles creating and updating the monorepo git repository, README.md,
4
+
CLAUDE.md, .gitignore, and dune-project files. *)
5
+
6
+
let src = Logs.Src.create "monopam.init" ~doc:"Monopam initialization"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** {1 Content Templates} *)
11
+
12
+
let claude_md_content =
13
+
{|# Monorepo Development Guide
14
+
15
+
This is a monorepo managed by `monopam`. Each subdirectory is a git subtree
16
+
from a separate upstream repository.
17
+
18
+
> **Note:** Check `CLAUDE.local.md` (if it exists) for additional local
19
+
> configuration or preferences specific to this workspace.
20
+
21
+
## Quick Reference
22
+
23
+
| Task | Command |
24
+
|------|---------|
25
+
| Check status | `monopam status` |
26
+
| Sync all repos | `monopam sync` |
27
+
| Sync and push upstream | `monopam sync --remote` |
28
+
| Sync one repo | `monopam sync <repo-name>` |
29
+
| Build | `opam exec -- dune build` |
30
+
| Test | `opam exec -- dune test` |
31
+
32
+
## Daily Workflow
33
+
34
+
```bash
35
+
# 1. Check what needs syncing
36
+
monopam status
37
+
38
+
# 2. Sync your monorepo with all upstreams
39
+
monopam sync
40
+
41
+
# 3. Make your changes, build and test
42
+
opam exec -- dune build && opam exec -- dune test
43
+
44
+
# 4. Commit your changes
45
+
git add -A && git commit -m "Description of changes"
46
+
47
+
# 5. Sync and push to upstream remotes
48
+
monopam sync --remote
49
+
```
50
+
51
+
## Understanding Status Output
52
+
53
+
Run `monopam status` to see the sync state:
54
+
55
+
- `local:=` - Monorepo and checkout in sync
56
+
- `local:+N` - Monorepo is N commits ahead (run `monopam sync`)
57
+
- `local:-N` - Checkout is N commits ahead (run `monopam sync`)
58
+
- `local:sync` - Trees differ, needs sync (run `monopam sync`)
59
+
- `remote:=` - Checkout and upstream in sync
60
+
- `remote:+N` - You have N commits to push (run `monopam sync --remote`)
61
+
- `remote:-N` - Upstream has N commits to pull (run `monopam sync`)
62
+
63
+
## Making Changes
64
+
65
+
1. **Edit code** in any subdirectory as normal
66
+
2. **Build and test**: `opam exec -- dune build && opam exec -- dune test`
67
+
3. **Commit** your changes: `git add -A && git commit`
68
+
4. **Sync**: `monopam sync --remote` to push to upstreams
69
+
70
+
## Important Notes
71
+
72
+
- **Always commit before sync**: `monopam sync` only exports committed changes
73
+
- **Check status first**: Run `monopam status` to see what needs attention
74
+
- **One repo per directory**: Each subdirectory maps to exactly one git remote
75
+
76
+
## Troubleshooting
77
+
78
+
### "Dirty packages" Error
79
+
Commit your changes first:
80
+
```bash
81
+
git status && git add -A && git commit -m "Your message"
82
+
```
83
+
84
+
### "local:sync" in Status
85
+
Trees differ but need syncing:
86
+
```bash
87
+
monopam sync
88
+
```
89
+
90
+
### Merge Conflicts
91
+
Resolve conflicts, commit, then sync:
92
+
```bash
93
+
git add -A && git commit -m "Resolve merge conflicts"
94
+
monopam sync
95
+
```
96
+
97
+
### Push Fails
98
+
Check credentials:
99
+
```bash
100
+
cd ../src/<repo-name>
101
+
git push origin main # For better error messages
102
+
```
103
+
104
+
## Getting Help
105
+
106
+
```bash
107
+
monopam --help # Main help
108
+
monopam sync --help # Sync command help
109
+
monopam status --help # Status command help
110
+
```
111
+
|}
112
+
113
+
let gitignore_content = {|_build
114
+
*.install
115
+
root.opam
116
+
|}
117
+
118
+
(** {1 README Generation} *)
119
+
120
+
let generate_readme pkgs =
121
+
let grouped = Ctx.group_by_repo pkgs in
122
+
let buf = Buffer.create 4096 in
123
+
Buffer.add_string buf "# Monorepo Package Index\n\n";
124
+
Buffer.add_string buf
125
+
"This monorepo contains the following packages, synchronized from their \
126
+
upstream repositories.\n\n";
127
+
Buffer.add_string buf "| Repository | Package | Synopsis |\n";
128
+
Buffer.add_string buf "|------------|---------|----------|\n";
129
+
List.iter
130
+
(fun (repo, pkgs) ->
131
+
List.iteri
132
+
(fun i pkg ->
133
+
let dev_repo = Uri.to_string (Package.dev_repo pkg) in
134
+
let display_url =
135
+
if String.starts_with ~prefix:"git+" dev_repo then
136
+
String.sub dev_repo 4 (String.length dev_repo - 4)
137
+
else dev_repo
138
+
in
139
+
let repo_cell =
140
+
if i = 0 then Fmt.str "[**%s**](%s)" repo display_url else ""
141
+
in
142
+
let synopsis = Option.value ~default:"" (Package.synopsis pkg) in
143
+
Buffer.add_string buf
144
+
(Fmt.str "| %s | %s | %s |\n" repo_cell (Package.name pkg) synopsis))
145
+
pkgs)
146
+
grouped;
147
+
Buffer.add_string buf "\n---\n\n";
148
+
Buffer.add_string buf
149
+
(Fmt.str "_Generated by monopam. %d packages from %d repositories._\n"
150
+
(List.length pkgs) (List.length grouped));
151
+
Buffer.contents buf
152
+
153
+
(** {1 dune-project Generation} *)
154
+
155
+
let collect_external_deps ~fs ~config pkgs =
156
+
let monorepo = Config.Paths.monorepo config in
157
+
let seen = Hashtbl.create 16 in
158
+
let repos =
159
+
List.filter
160
+
(fun pkg ->
161
+
let repo = Package.repo_name pkg in
162
+
if Hashtbl.mem seen repo then false
163
+
else begin
164
+
Hashtbl.add seen repo ();
165
+
true
166
+
end)
167
+
pkgs
168
+
in
169
+
let all_deps =
170
+
List.concat_map
171
+
(fun pkg ->
172
+
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
173
+
Opam_repo.scan_opam_files_for_deps ~fs subtree_dir)
174
+
repos
175
+
|> List.sort_uniq String.compare
176
+
in
177
+
let pkg_names =
178
+
List.concat_map
179
+
(fun pkg ->
180
+
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
181
+
let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in
182
+
try
183
+
Eio.Path.read_dir eio_path
184
+
|> List.filter_map (fun name ->
185
+
if Filename.check_suffix name ".opam" then
186
+
Some (Filename.chop_suffix name ".opam")
187
+
else None)
188
+
with Eio.Io _ -> [])
189
+
repos
190
+
|> List.sort_uniq String.compare
191
+
in
192
+
List.filter (fun dep -> not (List.mem dep pkg_names)) all_deps
193
+
194
+
let generate_dune_project ~fs ~config pkgs =
195
+
let external_deps = collect_external_deps ~fs ~config pkgs in
196
+
let buf = Buffer.create 1024 in
197
+
Buffer.add_string buf "(lang dune 3.20)\n";
198
+
Buffer.add_string buf "(name root)\n";
199
+
Buffer.add_string buf "\n";
200
+
Buffer.add_string buf "(generate_opam_files true)\n";
201
+
Buffer.add_string buf "\n";
202
+
Buffer.add_string buf "(package\n";
203
+
Buffer.add_string buf " (name root)\n";
204
+
Buffer.add_string buf
205
+
" (synopsis \"Monorepo root package with external dependencies\")\n";
206
+
Buffer.add_string buf " (allow_empty)\n";
207
+
Buffer.add_string buf " (depends\n";
208
+
List.iter
209
+
(fun dep -> Buffer.add_string buf (Fmt.str " %s\n" dep))
210
+
external_deps;
211
+
Buffer.add_string buf " ))\n";
212
+
Buffer.contents buf
213
+
214
+
(** {1 File Writers} *)
215
+
216
+
let write_dune_project ~proc ~fs ~config pkgs =
217
+
let monorepo = Config.Paths.monorepo config in
218
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
219
+
let dune_project_path = Eio.Path.(monorepo_eio / "dune-project") in
220
+
let content = generate_dune_project ~fs ~config pkgs in
221
+
let needs_update =
222
+
match Eio.Path.load dune_project_path with
223
+
| existing -> existing <> content
224
+
| exception Eio.Io _ -> true
225
+
in
226
+
if needs_update then begin
227
+
Log.info (fun m -> m "Updating dune-project in monorepo");
228
+
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project_path content;
229
+
Eio.Switch.run (fun sw ->
230
+
let child =
231
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
232
+
[ "git"; "add"; "dune-project" ]
233
+
in
234
+
ignore (Eio.Process.await child));
235
+
Eio.Switch.run (fun sw ->
236
+
let child =
237
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
238
+
[
239
+
"git";
240
+
"commit";
241
+
"-m";
242
+
"Update dune-project with external dependencies";
243
+
]
244
+
in
245
+
ignore (Eio.Process.await child));
246
+
Log.app (fun m ->
247
+
m "Updated dune-project with %d external dependencies"
248
+
(List.length (collect_external_deps ~fs ~config pkgs)))
249
+
end
250
+
251
+
let write_readme ~proc ~fs ~config pkgs =
252
+
let monorepo = Config.Paths.monorepo config in
253
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
254
+
let readme_path = Eio.Path.(monorepo_eio / "README.md") in
255
+
let content = generate_readme pkgs in
256
+
let needs_update =
257
+
match Eio.Path.load readme_path with
258
+
| existing -> existing <> content
259
+
| exception Eio.Io _ -> true
260
+
in
261
+
if needs_update then begin
262
+
Log.info (fun m -> m "Updating README.md in monorepo");
263
+
Eio.Path.save ~create:(`Or_truncate 0o644) readme_path content;
264
+
Eio.Switch.run (fun sw ->
265
+
let child =
266
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
267
+
[ "git"; "add"; "README.md" ]
268
+
in
269
+
ignore (Eio.Process.await child));
270
+
Eio.Switch.run (fun sw ->
271
+
let child =
272
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
273
+
[ "git"; "commit"; "-m"; "Update README.md package index" ]
274
+
in
275
+
ignore (Eio.Process.await child));
276
+
Log.app (fun m -> m "Updated README.md with %d packages" (List.length pkgs))
277
+
end
278
+
279
+
let write_claude_md ~proc ~fs ~config =
280
+
let monorepo = Config.Paths.monorepo config in
281
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
282
+
let claude_path = Eio.Path.(monorepo_eio / "CLAUDE.md") in
283
+
let needs_update =
284
+
match Eio.Path.load claude_path with
285
+
| existing -> existing <> claude_md_content
286
+
| exception Eio.Io _ -> true
287
+
in
288
+
if needs_update then begin
289
+
Log.info (fun m -> m "Updating CLAUDE.md in monorepo");
290
+
Eio.Path.save ~create:(`Or_truncate 0o644) claude_path claude_md_content;
291
+
Eio.Switch.run (fun sw ->
292
+
let child =
293
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
294
+
[ "git"; "add"; "CLAUDE.md" ]
295
+
in
296
+
ignore (Eio.Process.await child));
297
+
Eio.Switch.run (fun sw ->
298
+
let child =
299
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
300
+
[ "git"; "commit"; "-m"; "Update CLAUDE.md usage tips" ]
301
+
in
302
+
ignore (Eio.Process.await child));
303
+
Log.app (fun m -> m "Updated CLAUDE.md")
304
+
end
305
+
306
+
(** {1 Monorepo Initialization} *)
307
+
308
+
let ensure ~proc ~fs ~config =
309
+
let monorepo = Config.Paths.monorepo config in
310
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
311
+
let init_and_commit () =
312
+
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
313
+
let (_ : Git.Repository.t) = Git.Repository.init ~fs monorepo in
314
+
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
315
+
Log.debug (fun m -> m "Creating dune-project file");
316
+
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
317
+
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
318
+
Log.debug (fun m -> m "Creating CLAUDE.md");
319
+
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
320
+
let gitignore = Eio.Path.(monorepo_eio / ".gitignore") in
321
+
Log.debug (fun m -> m "Creating .gitignore");
322
+
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
323
+
Log.debug (fun m -> m "Staging and committing initial files");
324
+
let repo = Git.Repository.open_repo ~fs monorepo in
325
+
Result.bind
326
+
(Git.Repository.add_to_index repo
327
+
[ "dune-project"; "CLAUDE.md"; ".gitignore" ]
328
+
|> Result.map_error (fun (`Msg msg) ->
329
+
Ctx.Git_error (Git_cli.Io_error msg)))
330
+
(fun () ->
331
+
let user =
332
+
match Git_cli.global_git_user () with
333
+
| Some u -> u
334
+
| None ->
335
+
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
336
+
~date:(Int64.of_float (Unix.time ()))
337
+
()
338
+
in
339
+
Git.Repository.commit_index repo ~author:user ~committer:user
340
+
~message:"Initial commit with dune-project, CLAUDE.md, and .gitignore"
341
+
()
342
+
|> Result.map ignore
343
+
|> Result.map_error (fun (`Msg msg) ->
344
+
Ctx.Git_error (Git_cli.Io_error msg)))
345
+
in
346
+
let ensure_file ~filename ~content =
347
+
let file_path = Eio.Path.(monorepo_eio / filename) in
348
+
let exists =
349
+
match Eio.Path.kind ~follow:true file_path with
350
+
| `Regular_file -> true
351
+
| _ | (exception Eio.Io _) -> false
352
+
in
353
+
if not exists then begin
354
+
Log.info (fun m -> m "Adding %s to monorepo" filename);
355
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
356
+
Eio.Switch.run (fun sw ->
357
+
let child =
358
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
359
+
[ "git"; "add"; filename ]
360
+
in
361
+
ignore (Eio.Process.await child));
362
+
Eio.Switch.run (fun sw ->
363
+
let child =
364
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
365
+
[ "git"; "commit"; "-m"; "Add " ^ filename ]
366
+
in
367
+
ignore (Eio.Process.await child))
368
+
end
369
+
in
370
+
let is_directory =
371
+
match Eio.Path.kind ~follow:true monorepo_eio with
372
+
| `Directory -> true
373
+
| _ -> false
374
+
| exception Eio.Io _ -> false
375
+
in
376
+
if is_directory && Git.Repository.is_repo ~fs monorepo then begin
377
+
Log.debug (fun m ->
378
+
m "Monorepo already initialized at %a" Fpath.pp monorepo);
379
+
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
380
+
ensure_file ~filename:".gitignore" ~content:gitignore_content;
381
+
Ok ()
382
+
end
383
+
else begin
384
+
if not is_directory then begin
385
+
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
386
+
Ctx.mkdirs monorepo_eio
387
+
end;
388
+
init_and_commit ()
389
+
end
+53
-2191
lib/monopam.ml
+53
-2191
lib/monopam.ml
···
1
+
(** Monopam - Monorepo package manager.
2
+
3
+
Orchestrates git subtree operations for managing a monorepo of OCaml
4
+
packages synchronized from upstream repositories. *)
5
+
6
+
(** {1 Core Modules} *)
7
+
1
8
module Config = Config
2
9
module Package = Package
3
10
module Opam_repo = Opam_repo
···
17
24
module Fork_join = Fork_join
18
25
module Site = Site
19
26
module Remote_cache = Remote_cache
20
-
module Sync_progress = Sync_progress
27
+
module Opam_sync = Opam_sync
28
+
module Monorepo_pkg = Monorepo_pkg
29
+
module Progress = Sync_progress
21
30
22
-
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
31
+
(** {1 Command Modules} *)
23
32
24
-
module Log = (val Logs.src_log src : Logs.LOG)
33
+
module Ctx = Ctx
34
+
module Init = Init
35
+
module Pull = Pull
36
+
module Push = Push
37
+
module Add = Add
38
+
module Remove = Remove
39
+
module Clean = Clean
40
+
module Diff = Diff
25
41
26
-
(* Timing helper for benchmarking phases *)
27
-
let time_phase name f =
28
-
let t0 = Unix.gettimeofday () in
29
-
let result = f () in
30
-
let t1 = Unix.gettimeofday () in
31
-
Log.debug (fun m -> m "[TIMING] %s: %.3fs" name (t1 -. t0));
32
-
result
42
+
(** {1 Backward-Compatible Exports} *)
33
43
34
-
type error =
44
+
type error = Ctx.error =
35
45
| Config_error of string
36
46
| Repo_error of Opam_repo.error
37
47
| Git_error of Git_cli.error
···
40
50
| Package_not_found of string
41
51
| Claude_error of string
42
52
43
-
let pp_error ppf = function
44
-
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
45
-
| Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
46
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
47
-
| Dirty_state pkgs ->
48
-
Fmt.pf ppf "Dirty packages: %a"
49
-
Fmt.(list ~sep:comma (using Package.name string))
50
-
pkgs
51
-
| Monorepo_dirty -> Fmt.pf ppf "Monorepo has uncommitted changes"
52
-
| Package_not_found name -> Fmt.pf ppf "Package not found: %s" name
53
-
| Claude_error msg -> Fmt.pf ppf "Claude error: %s" msg
53
+
let pp_error = Ctx.pp_error
54
+
let pp_error_with_hint = Ctx.pp_error_with_hint
55
+
let error_hint = Ctx.error_hint
54
56
55
57
type opam_sync_result = Opam_sync.t
56
58
type monorepo_package = Monorepo_pkg.t
59
+
type pull_result = Pull.result
60
+
type diff_entry = Diff.entry
61
+
type diff_result = Diff.result
62
+
type commit_info = Diff.commit_info
63
+
type handle_pull_result = Diff.handle_pull_result
64
+
type cherrypick_result = Diff.cherrypick_result
57
65
58
-
(** Returns a hint string for the given error, or None if no hint is available.
59
-
*)
60
-
let error_hint = function
61
-
| Config_error _ ->
62
-
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
63
-
| Repo_error (Opam_repo.No_dev_repo _) ->
64
-
Some
65
-
"Add a 'dev-repo' field to the package's opam file pointing to a git \
66
-
URL."
67
-
| Repo_error (Opam_repo.Not_git_remote _) ->
68
-
Some "The dev-repo must be a git URL (git+https:// or git://)."
69
-
| Repo_error _ -> None
70
-
| Git_error (Git_cli.Dirty_worktree _) ->
71
-
Some "Commit or stash your changes first: cd <repo> && git status"
72
-
| Git_error (Git_cli.Not_a_repo _) ->
73
-
Some "Run 'monopam sync' to clone missing repositories."
74
-
| Git_error (Git_cli.Subtree_prefix_missing _) ->
75
-
Some "Run 'monopam sync' to set up the subtree."
76
-
| Git_error (Git_cli.Remote_not_found _) ->
77
-
Some "Check that the remote is configured: git remote -v"
78
-
| Git_error (Git_cli.Branch_not_found _) ->
79
-
Some "Check available branches: git branch -a"
80
-
| Git_error (Git_cli.Command_failed (cmd, _))
81
-
when String.starts_with ~prefix:"git push" cmd ->
82
-
Some "Check your network connection and git credentials."
83
-
| Git_error (Git_cli.Command_failed (cmd, _))
84
-
when String.starts_with ~prefix:"git subtree" cmd ->
85
-
Some "Run 'monopam status' to check repository state."
86
-
| Git_error _ -> None
87
-
| Dirty_state _ ->
88
-
Some
89
-
"Commit changes in the monorepo first: cd mono && git add -A && git \
90
-
commit"
91
-
| Monorepo_dirty ->
92
-
Some
93
-
"Commit or stash your changes first: git status && git add -A && git \
94
-
commit"
95
-
| Package_not_found _ ->
96
-
Some "Check available packages: ls opam-repo/packages/"
97
-
| Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg ->
98
-
Some "The Claude API may have returned an unexpected response. Try again."
99
-
| Claude_error _ ->
100
-
Some "Check ANTHROPIC_API_KEY is set. See: https://console.anthropic.com/"
101
-
102
-
(** Pretty-print an error with an optional hint for next steps. *)
103
-
let pp_error_with_hint ppf e =
104
-
pp_error ppf e;
105
-
match error_hint e with
106
-
| Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint
107
-
| None -> ()
108
-
109
-
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
110
-
let dir, _ = fs in
111
-
(dir, "")
112
-
113
-
let discover_packages ~fs ~config () =
114
-
let repo_path = Config.Paths.opam_repo config in
115
-
Log.debug (fun m -> m "Scanning opam repo at %a" Fpath.pp repo_path);
116
-
Opam_repo.scan ~fs repo_path
117
-
|> Result.map_error (fun e -> Repo_error e)
118
-
|> Result.map (fun pkgs ->
119
-
Log.info (fun m -> m "Found %d packages in opam repo" (List.length pkgs));
120
-
pkgs)
121
-
122
-
let package ~fs ~config name =
123
-
Result.bind (discover_packages ~fs ~config ()) (fun pkgs ->
124
-
List.find_opt (fun p -> Package.name p = name) pkgs
125
-
|> Option.to_result ~none:(Package_not_found name))
126
-
127
-
let rec mkdirs path =
128
-
match Eio.Path.kind ~follow:true path with
129
-
| `Directory -> ()
130
-
| _ ->
131
-
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
132
-
Eio.Path.mkdir ~perm:0o755 path
133
-
| exception Eio.Io _ ->
134
-
(* Parent might not exist, try to create it first *)
135
-
let parent = Eio.Path.split path in
136
-
(match parent with
137
-
| Some (parent_path, _) -> mkdirs parent_path
138
-
| None -> ());
139
-
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
140
-
Eio.Path.mkdir ~perm:0o755 path
141
-
142
-
let is_directory ~fs path =
143
-
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
144
-
match Eio.Path.kind ~follow:true eio_path with
145
-
| `Directory -> true
146
-
| _ -> false
147
-
| exception _ -> false
148
-
149
-
let ensure_checkouts_dir ~fs ~config =
150
-
let checkouts = Config.Paths.checkouts config in
151
-
let checkouts_eio = Eio.Path.(fs / Fpath.to_string checkouts) in
152
-
Log.debug (fun m ->
153
-
m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
154
-
mkdirs checkouts_eio
155
-
156
-
let status ~proc ~fs ~config () =
157
-
let fs = fs_typed fs in
158
-
ensure_checkouts_dir ~fs ~config;
159
-
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
66
+
let status ~proc:_ ~fs ~config () =
67
+
let fs = Ctx.fs_typed fs in
68
+
Ctx.ensure_checkouts_dir ~fs ~config;
69
+
Ctx.discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
160
70
|> Result.map (Status.compute_all ~fs ~config)
161
71
162
-
(** Find opam files in monorepo subtrees that aren't registered in the overlay.
163
-
Returns a list of (subtree_name, unregistered_package_name) pairs. *)
164
-
let unregistered_opam_files ~fs ~config pkgs =
165
-
let fs = fs_typed fs in
166
-
let monorepo = Config.Paths.monorepo config in
167
-
let registered_by_repo = Hashtbl.create 16 in
168
-
List.iter
169
-
(fun pkg ->
170
-
let repo = Package.repo_name pkg in
171
-
let name = Package.name pkg in
172
-
let existing =
173
-
try Hashtbl.find registered_by_repo repo with Not_found -> []
174
-
in
175
-
Hashtbl.replace registered_by_repo repo (name :: existing))
176
-
pkgs;
177
-
let seen_repos = Hashtbl.create 16 in
178
-
let repos =
179
-
List.filter
180
-
(fun pkg ->
181
-
let repo = Package.repo_name pkg in
182
-
if Hashtbl.mem seen_repos repo then false
183
-
else begin
184
-
Hashtbl.add seen_repos repo ();
185
-
true
186
-
end)
187
-
pkgs
188
-
in
189
-
let check_opam_file ~repo ~registered name =
190
-
if not (Filename.check_suffix name ".opam") then None
191
-
else
192
-
let pkg_name = Filename.chop_suffix name ".opam" in
193
-
if List.mem pkg_name registered then None else Some (repo, pkg_name)
194
-
in
195
-
List.concat_map
196
-
(fun pkg ->
197
-
let repo = Package.repo_name pkg in
198
-
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
199
-
let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in
200
-
let registered =
201
-
try Hashtbl.find registered_by_repo repo with Not_found -> []
202
-
in
203
-
try
204
-
Eio.Path.read_dir eio_path
205
-
|> List.filter_map (check_opam_file ~repo ~registered)
206
-
with Eio.Io _ -> [])
207
-
repos
208
-
209
-
let branch ~config pkg =
210
-
let default = Config.default_branch in
211
-
match Package.branch pkg with
212
-
| Some b -> b
213
-
| None ->
214
-
Option.bind
215
-
(Config.package_config config (Package.name pkg))
216
-
Config.Package_config.branch
217
-
|> Option.value ~default
218
-
219
-
let ensure_checkout ~proc ~fs ~config pkg =
220
-
let checkouts_root = Config.Paths.checkouts config in
221
-
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
222
-
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
223
-
let branch = branch ~config pkg in
224
-
let do_clone () =
225
-
Log.info (fun m ->
226
-
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
227
-
(Package.dev_repo pkg) branch);
228
-
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
229
-
in
230
-
let is_directory =
231
-
match Eio.Path.kind ~follow:true checkout_eio with
232
-
| `Directory -> true
233
-
| _ -> false
234
-
| exception Eio.Io _ -> false
235
-
in
236
-
if not is_directory then do_clone ()
237
-
else if not (Git.Repository.is_repo ~fs checkout_dir) then do_clone ()
238
-
else begin
239
-
Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
240
-
match Git_cli.fetch ~proc ~fs checkout_dir with
241
-
| Error e -> Error e
242
-
| Ok () ->
243
-
Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
244
-
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
245
-
end
246
-
247
-
(* Group packages by their repository *)
248
-
let group_by_repo pkgs =
249
-
let tbl = Hashtbl.create 16 in
250
-
List.iter
251
-
(fun pkg ->
252
-
let repo = Package.repo_name pkg in
253
-
let existing = try Hashtbl.find tbl repo with Not_found -> [] in
254
-
Hashtbl.replace tbl repo (pkg :: existing))
255
-
pkgs;
256
-
(* Sort repos alphabetically and packages within each repo *)
257
-
Hashtbl.fold
258
-
(fun repo pkgs acc -> (repo, List.sort Package.compare pkgs) :: acc)
259
-
tbl []
260
-
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
261
-
262
-
(* Generate README.md content from discovered packages *)
263
-
let generate_readme pkgs =
264
-
let grouped = group_by_repo pkgs in
265
-
let buf = Buffer.create 4096 in
266
-
Buffer.add_string buf "# Monorepo Package Index\n\n";
267
-
Buffer.add_string buf
268
-
"This monorepo contains the following packages, synchronized from their \
269
-
upstream repositories.\n\n";
270
-
Buffer.add_string buf "| Repository | Package | Synopsis |\n";
271
-
Buffer.add_string buf "|------------|---------|----------|\n";
272
-
List.iter
273
-
(fun (repo, pkgs) ->
274
-
List.iteri
275
-
(fun i pkg ->
276
-
let dev_repo = Uri.to_string (Package.dev_repo pkg) in
277
-
(* Clean up git+ prefix for display *)
278
-
let display_url =
279
-
if String.starts_with ~prefix:"git+" dev_repo then
280
-
String.sub dev_repo 4 (String.length dev_repo - 4)
281
-
else dev_repo
282
-
in
283
-
let repo_cell =
284
-
if i = 0 then Fmt.str "[**%s**](%s)" repo display_url else ""
285
-
in
286
-
let synopsis = Option.value ~default:"" (Package.synopsis pkg) in
287
-
Buffer.add_string buf
288
-
(Fmt.str "| %s | %s | %s |\n" repo_cell (Package.name pkg) synopsis))
289
-
pkgs)
290
-
grouped;
291
-
Buffer.add_string buf "\n---\n\n";
292
-
Buffer.add_string buf
293
-
(Fmt.str "_Generated by monopam. %d packages from %d repositories._\n"
294
-
(List.length pkgs) (List.length grouped));
295
-
Buffer.contents buf
296
-
297
-
let claude_md_content =
298
-
{|# Monorepo Development Guide
299
-
300
-
This is a monorepo managed by `monopam`. Each subdirectory is a git subtree
301
-
from a separate upstream repository.
302
-
303
-
> **Note:** Check `CLAUDE.local.md` (if it exists) for additional local
304
-
> configuration or preferences specific to this workspace.
305
-
306
-
## Quick Reference
307
-
308
-
| Task | Command |
309
-
|------|---------|
310
-
| Check status | `monopam status` |
311
-
| Sync all repos | `monopam sync` |
312
-
| Sync and push upstream | `monopam sync --remote` |
313
-
| Sync one repo | `monopam sync <repo-name>` |
314
-
| Build | `opam exec -- dune build` |
315
-
| Test | `opam exec -- dune test` |
316
-
317
-
## Daily Workflow
318
-
319
-
```bash
320
-
# 1. Check what needs syncing
321
-
monopam status
322
-
323
-
# 2. Sync your monorepo with all upstreams
324
-
monopam sync
325
-
326
-
# 3. Make your changes, build and test
327
-
opam exec -- dune build && opam exec -- dune test
328
-
329
-
# 4. Commit your changes
330
-
git add -A && git commit -m "Description of changes"
331
-
332
-
# 5. Sync and push to upstream remotes
333
-
monopam sync --remote
334
-
```
335
-
336
-
## Understanding Status Output
337
-
338
-
Run `monopam status` to see the sync state:
339
-
340
-
- `local:=` - Monorepo and checkout in sync
341
-
- `local:+N` - Monorepo is N commits ahead (run `monopam sync`)
342
-
- `local:-N` - Checkout is N commits ahead (run `monopam sync`)
343
-
- `local:sync` - Trees differ, needs sync (run `monopam sync`)
344
-
- `remote:=` - Checkout and upstream in sync
345
-
- `remote:+N` - You have N commits to push (run `monopam sync --remote`)
346
-
- `remote:-N` - Upstream has N commits to pull (run `monopam sync`)
347
-
348
-
## Making Changes
349
-
350
-
1. **Edit code** in any subdirectory as normal
351
-
2. **Build and test**: `opam exec -- dune build && opam exec -- dune test`
352
-
3. **Commit** your changes: `git add -A && git commit`
353
-
4. **Sync**: `monopam sync --remote` to push to upstreams
354
-
355
-
## Important Notes
356
-
357
-
- **Always commit before sync**: `monopam sync` only exports committed changes
358
-
- **Check status first**: Run `monopam status` to see what needs attention
359
-
- **One repo per directory**: Each subdirectory maps to exactly one git remote
360
-
361
-
## Troubleshooting
362
-
363
-
### "Dirty packages" Error
364
-
Commit your changes first:
365
-
```bash
366
-
git status && git add -A && git commit -m "Your message"
367
-
```
368
-
369
-
### "local:sync" in Status
370
-
Trees differ but need syncing:
371
-
```bash
372
-
monopam sync
373
-
```
374
-
375
-
### Merge Conflicts
376
-
Resolve conflicts, commit, then sync:
377
-
```bash
378
-
git add -A && git commit -m "Resolve merge conflicts"
379
-
monopam sync
380
-
```
381
-
382
-
### Push Fails
383
-
Check credentials:
384
-
```bash
385
-
cd ../src/<repo-name>
386
-
git push origin main # For better error messages
387
-
```
388
-
389
-
## Getting Help
390
-
391
-
```bash
392
-
monopam --help # Main help
393
-
monopam sync --help # Sync command help
394
-
monopam status --help # Status command help
395
-
```
396
-
|}
397
-
398
-
let gitignore_content = {|_build
399
-
*.install
400
-
root.opam
401
-
|}
402
-
403
-
(** Collect all external dependencies by scanning monorepo subtree directories.
404
-
This scans all .opam files in each subtree directory to find dependencies,
405
-
ensuring we get dependencies from all packages in a directory, not just
406
-
those registered in the opam overlay. Returns a sorted, deduplicated list of
407
-
package names that are dependencies but not packages in the repo itself. *)
408
-
let collect_external_deps ~fs ~config pkgs =
409
-
let monorepo = Config.Paths.monorepo config in
410
-
(* Get unique repos to avoid scanning the same directory multiple times *)
411
-
let seen = Hashtbl.create 16 in
412
-
let repos =
413
-
List.filter
414
-
(fun pkg ->
415
-
let repo = Package.repo_name pkg in
416
-
if Hashtbl.mem seen repo then false
417
-
else begin
418
-
Hashtbl.add seen repo ();
419
-
true
420
-
end)
421
-
pkgs
422
-
in
423
-
(* Scan each subtree directory for .opam files and collect dependencies *)
424
-
let all_deps =
425
-
List.concat_map
426
-
(fun pkg ->
427
-
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
428
-
Opam_repo.scan_opam_files_for_deps ~fs subtree_dir)
429
-
repos
430
-
|> List.sort_uniq String.compare
431
-
in
432
-
(* Get all package names from all .opam files in monorepo *)
433
-
let pkg_names =
434
-
List.concat_map
435
-
(fun pkg ->
436
-
let subtree_dir = Fpath.(monorepo / Package.subtree_prefix pkg) in
437
-
let eio_path = Eio.Path.(fs / Fpath.to_string subtree_dir) in
438
-
try
439
-
Eio.Path.read_dir eio_path
440
-
|> List.filter_map (fun name ->
441
-
if Filename.check_suffix name ".opam" then
442
-
Some (Filename.chop_suffix name ".opam")
443
-
else None)
444
-
with Eio.Io _ -> [])
445
-
repos
446
-
|> List.sort_uniq String.compare
447
-
in
448
-
(* Filter out packages that are in the repo *)
449
-
List.filter (fun dep -> not (List.mem dep pkg_names)) all_deps
450
-
451
-
(** Generate dune-project content for the monorepo root. Lists all external
452
-
dependencies as a virtual package. *)
453
-
let generate_dune_project ~fs ~config pkgs =
454
-
let external_deps = collect_external_deps ~fs ~config pkgs in
455
-
let buf = Buffer.create 1024 in
456
-
Buffer.add_string buf "(lang dune 3.20)\n";
457
-
Buffer.add_string buf "(name root)\n";
458
-
Buffer.add_string buf "\n";
459
-
Buffer.add_string buf "(generate_opam_files true)\n";
460
-
Buffer.add_string buf "\n";
461
-
Buffer.add_string buf "(package\n";
462
-
Buffer.add_string buf " (name root)\n";
463
-
Buffer.add_string buf
464
-
" (synopsis \"Monorepo root package with external dependencies\")\n";
465
-
Buffer.add_string buf " (allow_empty)\n";
466
-
Buffer.add_string buf " (depends\n";
467
-
List.iter
468
-
(fun dep -> Buffer.add_string buf (Fmt.str " %s\n" dep))
469
-
external_deps;
470
-
Buffer.add_string buf " ))\n";
471
-
Buffer.contents buf
472
-
473
-
(** Write dune-project to monorepo with external dependencies. *)
474
-
let write_dune_project ~proc ~fs ~config pkgs =
475
-
let monorepo = Config.Paths.monorepo config in
476
-
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
477
-
let dune_project_path = Eio.Path.(monorepo_eio / "dune-project") in
478
-
let content = generate_dune_project ~fs ~config pkgs in
479
-
(* Check if dune-project already exists with same content *)
480
-
let needs_update =
481
-
match Eio.Path.load dune_project_path with
482
-
| existing -> existing <> content
483
-
| exception Eio.Io _ -> true
484
-
in
485
-
if needs_update then begin
486
-
Log.info (fun m -> m "Updating dune-project in monorepo");
487
-
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project_path content;
488
-
(* Stage and commit the dune-project *)
489
-
Eio.Switch.run (fun sw ->
490
-
let child =
491
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
492
-
[ "git"; "add"; "dune-project" ]
493
-
in
494
-
ignore (Eio.Process.await child));
495
-
Eio.Switch.run (fun sw ->
496
-
let child =
497
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
498
-
[
499
-
"git";
500
-
"commit";
501
-
"-m";
502
-
"Update dune-project with external dependencies";
503
-
]
504
-
in
505
-
ignore (Eio.Process.await child));
506
-
Log.app (fun m ->
507
-
m "Updated dune-project with %d external dependencies"
508
-
(List.length (collect_external_deps ~fs ~config pkgs)))
509
-
end
510
-
511
-
let ensure_monorepo_initialized ~proc ~fs ~config =
512
-
let monorepo = Config.Paths.monorepo config in
513
-
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
514
-
let init_and_commit () =
515
-
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
516
-
let (_ : Git.Repository.t) = Git.Repository.init ~fs monorepo in
517
-
(* Create dune-project file so the monorepo builds *)
518
-
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
519
-
Log.debug (fun m -> m "Creating dune-project file");
520
-
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
521
-
(* Create CLAUDE.md for agent instructions *)
522
-
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
523
-
Log.debug (fun m -> m "Creating CLAUDE.md");
524
-
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
525
-
(* Create .gitignore *)
526
-
let gitignore = Eio.Path.(monorepo_eio / ".gitignore") in
527
-
Log.debug (fun m -> m "Creating .gitignore");
528
-
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
529
-
(* Stage and commit using ocaml-git *)
530
-
Log.debug (fun m -> m "Staging and committing initial files");
531
-
let repo = Git.Repository.open_repo ~fs monorepo in
532
-
Result.bind
533
-
(Git.Repository.add_to_index repo
534
-
[ "dune-project"; "CLAUDE.md"; ".gitignore" ]
535
-
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg)))
536
-
(fun () ->
537
-
let user =
538
-
match Git_cli.global_git_user () with
539
-
| Some u -> u
540
-
| None ->
541
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
542
-
~date:(Int64.of_float (Unix.time ()))
543
-
()
544
-
in
545
-
Git.Repository.commit_index repo ~author:user ~committer:user
546
-
~message:"Initial commit with dune-project, CLAUDE.md, and .gitignore"
547
-
()
548
-
|> Result.map ignore
549
-
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg)))
550
-
in
551
-
let ensure_file ~filename ~content =
552
-
let file_path = Eio.Path.(monorepo_eio / filename) in
553
-
let exists =
554
-
match Eio.Path.kind ~follow:true file_path with
555
-
| `Regular_file -> true
556
-
| _ | (exception Eio.Io _) -> false
557
-
in
558
-
if not exists then begin
559
-
Log.info (fun m -> m "Adding %s to monorepo" filename);
560
-
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
561
-
Eio.Switch.run (fun sw ->
562
-
let child =
563
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
564
-
[ "git"; "add"; filename ]
565
-
in
566
-
ignore (Eio.Process.await child));
567
-
Eio.Switch.run (fun sw ->
568
-
let child =
569
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
570
-
[ "git"; "commit"; "-m"; "Add " ^ filename ]
571
-
in
572
-
ignore (Eio.Process.await child))
573
-
end
574
-
in
575
-
let is_directory =
576
-
match Eio.Path.kind ~follow:true monorepo_eio with
577
-
| `Directory -> true
578
-
| _ -> false
579
-
| exception Eio.Io _ -> false
580
-
in
581
-
if is_directory && Git.Repository.is_repo ~fs monorepo then begin
582
-
Log.debug (fun m ->
583
-
m "Monorepo already initialized at %a" Fpath.pp monorepo);
584
-
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
585
-
ensure_file ~filename:".gitignore" ~content:gitignore_content;
586
-
Ok ()
587
-
end
588
-
else begin
589
-
if not is_directory then begin
590
-
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
591
-
mkdirs monorepo_eio
592
-
end;
593
-
init_and_commit ()
594
-
end
595
-
596
-
(* Write README.md to monorepo with package summary *)
597
-
let write_readme ~proc ~fs ~config pkgs =
598
-
let monorepo = Config.Paths.monorepo config in
599
-
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
600
-
let readme_path = Eio.Path.(monorepo_eio / "README.md") in
601
-
let content = generate_readme pkgs in
602
-
(* Check if README already exists with same content *)
603
-
let needs_update =
604
-
match Eio.Path.load readme_path with
605
-
| existing -> existing <> content
606
-
| exception Eio.Io _ -> true
607
-
in
608
-
if needs_update then begin
609
-
Log.info (fun m -> m "Updating README.md in monorepo");
610
-
Eio.Path.save ~create:(`Or_truncate 0o644) readme_path content;
611
-
(* Stage and commit the README *)
612
-
Eio.Switch.run (fun sw ->
613
-
let child =
614
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
615
-
[ "git"; "add"; "README.md" ]
616
-
in
617
-
ignore (Eio.Process.await child));
618
-
Eio.Switch.run (fun sw ->
619
-
let child =
620
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
621
-
[ "git"; "commit"; "-m"; "Update README.md package index" ]
622
-
in
623
-
ignore (Eio.Process.await child));
624
-
Log.app (fun m -> m "Updated README.md with %d packages" (List.length pkgs))
625
-
end
626
-
627
-
(* Write CLAUDE.md to monorepo with usage tips *)
628
-
let write_claude_md ~proc ~fs ~config =
629
-
let monorepo = Config.Paths.monorepo config in
630
-
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
631
-
let claude_path = Eio.Path.(monorepo_eio / "CLAUDE.md") in
632
-
(* Check if CLAUDE.md already exists with same content *)
633
-
let needs_update =
634
-
match Eio.Path.load claude_path with
635
-
| existing -> existing <> claude_md_content
636
-
| exception Eio.Io _ -> true
637
-
in
638
-
if needs_update then begin
639
-
Log.info (fun m -> m "Updating CLAUDE.md in monorepo");
640
-
Eio.Path.save ~create:(`Or_truncate 0o644) claude_path claude_md_content;
641
-
(* Stage and commit the CLAUDE.md *)
642
-
Eio.Switch.run (fun sw ->
643
-
let child =
644
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
645
-
[ "git"; "add"; "CLAUDE.md" ]
646
-
in
647
-
ignore (Eio.Process.await child));
648
-
Eio.Switch.run (fun sw ->
649
-
let child =
650
-
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
651
-
[ "git"; "commit"; "-m"; "Update CLAUDE.md usage tips" ]
652
-
in
653
-
ignore (Eio.Process.await child));
654
-
Log.app (fun m -> m "Updated CLAUDE.md")
655
-
end
656
-
657
-
(** Check if a host is a tangled server *)
658
-
let is_tangled_host = function
659
-
| Some "tangled.org" | Some "tangled.sh" -> true
660
-
| _ -> false
661
-
662
-
(** Convert a clone URL to a push URL.
663
-
- GitHub HTTPS URLs are converted to SSH format
664
-
- Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using
665
-
the knot server
666
-
- Other URLs are returned unchanged
667
-
668
-
@param knot
669
-
Git push server hostname. Defaults to git.recoil.org if not provided. *)
670
-
let url_to_push_url ?knot uri =
671
-
let scheme = Uri.scheme uri in
672
-
let host = Uri.host uri in
673
-
let path = Uri.path uri in
674
-
match (scheme, host) with
675
-
| Some ("https" | "http"), Some "github.com" ->
676
-
(* https://github.com/user/repo.git -> git@github.com:user/repo.git *)
677
-
let path =
678
-
if String.length path > 0 && path.[0] = '/' then
679
-
String.sub path 1 (String.length path - 1)
680
-
else path
681
-
in
682
-
Fmt.str "git@github.com:%s" path
683
-
| Some ("https" | "http"), _ when is_tangled_host host ->
684
-
(* https://tangled.org/@handle/repo -> git@<knot>:handle/repo *)
685
-
let path =
686
-
if String.length path > 0 && path.[0] = '/' then
687
-
String.sub path 1 (String.length path - 1)
688
-
else path
689
-
in
690
-
(* Strip leading @ from handle if present *)
691
-
let path =
692
-
if String.length path > 0 && path.[0] = '@' then
693
-
String.sub path 1 (String.length path - 1)
694
-
else path
695
-
in
696
-
(* Strip .git suffix if present *)
697
-
let path =
698
-
if String.ends_with ~suffix:".git" path then
699
-
String.sub path 0 (String.length path - 4)
700
-
else path
701
-
in
702
-
(* Use provided knot or default to git.recoil.org *)
703
-
let knot_server = Option.value ~default:"git.recoil.org" knot in
704
-
Fmt.str "git@%s:%s" knot_server path
705
-
| _ ->
706
-
(* Return original URL for other cases *)
707
-
Uri.to_string uri
708
-
709
-
(* Normalize URL for comparison: extract scheme + host + path, strip trailing slashes *)
710
-
let normalize_url_for_comparison uri =
711
-
let scheme = Option.value ~default:"" (Uri.scheme uri) in
712
-
let host = Option.value ~default:"" (Uri.host uri) in
713
-
let path = Uri.path uri in
714
-
(* Strip trailing slash from path *)
715
-
let path =
716
-
if String.length path > 1 && path.[String.length path - 1] = '/' then
717
-
String.sub path 0 (String.length path - 1)
718
-
else path
719
-
in
720
-
Fmt.str "%s://%s%s" scheme host path
721
-
722
-
(* Deduplicate packages by dev-repo, keeping first occurrence of each repo *)
723
-
let unique_repos pkgs =
724
-
let seen = Hashtbl.create 16 in
725
-
List.filter
726
-
(fun pkg ->
727
-
let url = normalize_url_for_comparison (Package.dev_repo pkg) in
728
-
Log.debug (fun m ->
729
-
m "Checking repo URL: %s (from %s)" url (Package.name pkg));
730
-
if Hashtbl.mem seen url then begin
731
-
Log.debug (fun m -> m " -> Already seen, skipping");
732
-
false
733
-
end
734
-
else begin
735
-
Hashtbl.add seen url ();
736
-
Log.debug (fun m -> m " -> New repo, keeping");
737
-
true
738
-
end)
739
-
pkgs
740
-
741
-
(* Result of pulling a single repo *)
742
-
type pull_result = {
743
-
repo_name : string;
744
-
cloned : bool; (* true if newly cloned, false if fetched *)
745
-
commits_pulled : int; (* number of commits pulled, 0 if none or cloned *)
746
-
subtree_added : bool; (* true if subtree was newly added *)
747
-
}
748
-
749
-
let pull_subtree ~proc ~fs ~config pkg =
750
-
let fs = fs_typed fs in
751
-
let monorepo = Config.Paths.monorepo config in
752
-
let checkouts_root = Config.Paths.checkouts config in
753
-
let prefix = Package.subtree_prefix pkg in
754
-
let branch = branch ~config pkg in
755
-
(* Pull from local checkout, not remote URL - ensures push/pull use same source *)
756
-
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
757
-
let url = Uri.of_string (Fpath.to_string checkout_dir) in
758
-
let subtree_exists = is_directory ~fs Fpath.(monorepo / prefix) in
759
-
(* Fetch from checkout and get commit hash *)
760
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
761
-
| Error e -> Error (Git_error e)
762
-
| Ok hash_hex ->
763
-
let git_repo = Git.Repository.open_repo ~fs monorepo in
764
-
let commit = Git.Hash.of_hex hash_hex in
765
-
let user =
766
-
match Git_cli.global_git_user () with
767
-
| Some u -> u
768
-
| None ->
769
-
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
770
-
~date:(Int64.of_float (Unix.time ()))
771
-
()
772
-
in
773
-
if subtree_exists then begin
774
-
Log.info (fun m ->
775
-
m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir);
776
-
let message =
777
-
Fmt.str
778
-
"Merge '%s/' from %s\n\n\
779
-
git-subtree-dir: %s\n\
780
-
git-subtree-mainline: %s\n"
781
-
prefix (Uri.to_string url) prefix hash_hex
782
-
in
783
-
match
784
-
Git.Subtree.merge git_repo ~prefix ~commit ~author:user
785
-
~committer:user ~message ()
786
-
with
787
-
| Ok _ -> Ok false (* not newly added *)
788
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
789
-
end
790
-
else begin
791
-
Log.info (fun m ->
792
-
m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir);
793
-
let message =
794
-
Fmt.str
795
-
"Add '%s/' from %s\n\n\
796
-
git-subtree-dir: %s\n\
797
-
git-subtree-mainline: %s\n"
798
-
prefix (Uri.to_string url) prefix hash_hex
799
-
in
800
-
match
801
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
802
-
~message ()
803
-
with
804
-
| Ok _ -> Ok true (* newly added *)
805
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
806
-
end
807
-
808
-
(* Check if checkout exists and is a repo *)
809
-
let checkout_exists ~fs ~config pkg =
810
-
let checkouts_root = Config.Paths.checkouts config in
811
-
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
812
-
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
813
-
match Eio.Path.kind ~follow:true checkout_eio with
814
-
| `Directory -> Git.Repository.is_repo ~fs checkout_dir
815
-
| _ -> false
816
-
| exception Eio.Io _ -> false
817
-
818
-
(* Get commits behind before fetching *)
819
-
let behind ~proc:_ ~fs ~config pkg =
820
-
let checkouts_root = Config.Paths.checkouts config in
821
-
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
822
-
let branch = branch ~config pkg in
823
-
if not (Git.Repository.is_repo ~fs checkout_dir) then 0
824
-
else
825
-
let repo = Git.Repository.open_repo ~fs checkout_dir in
826
-
match Git.Repository.ahead_behind repo ~branch () with
827
-
| Some ab -> ab.behind
828
-
| None -> 0
829
-
830
-
let pull ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
831
-
let fs_t = fs_typed fs in
832
-
(* Update the opam repo first - clone if needed *)
833
-
let opam_repo = Config.Paths.opam_repo config in
834
-
if Git.Repository.is_repo ~fs:fs_t opam_repo then begin
835
-
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
836
-
let result =
837
-
let ( let* ) = Result.bind in
838
-
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
839
-
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
840
-
in
841
-
match result with
842
-
| Ok () -> ()
843
-
| Error e ->
844
-
Log.warn (fun m ->
845
-
m "Failed to update opam repo: %a" Git_cli.pp_error e)
846
-
end
847
-
else begin
848
-
(* Opam repo doesn't exist - clone it if we have a URL *)
849
-
match opam_repo_url with
850
-
| Some url -> (
851
-
Log.info (fun m ->
852
-
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
853
-
let url = Uri.of_string url in
854
-
let branch = Config.default_branch in
855
-
match Git_cli.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
856
-
| Ok () -> Log.info (fun m -> m "Opam repo cloned successfully")
857
-
| Error e ->
858
-
Log.warn (fun m ->
859
-
m "Failed to clone opam repo: %a" Git_cli.pp_error e))
860
-
| None ->
861
-
Log.info (fun m ->
862
-
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
863
-
opam_repo)
864
-
end;
865
-
(* Ensure directories exist before computing status *)
866
-
ensure_checkouts_dir ~fs:fs_t ~config;
867
-
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
868
-
| Error e -> Error e
869
-
| Ok () -> (
870
-
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
871
-
| Error e -> Error e
872
-
| Ok all_pkgs ->
873
-
let pkgs =
874
-
match packages with
875
-
| [] -> all_pkgs
876
-
| names ->
877
-
List.filter (fun p -> List.mem (Package.name p) names) all_pkgs
878
-
in
879
-
if pkgs = [] && packages <> [] then
880
-
Error (Package_not_found (List.hd packages))
881
-
else begin
882
-
Log.info (fun m ->
883
-
m "Checking status of %d packages" (List.length pkgs));
884
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
885
-
let dirty =
886
-
List.filter Status.has_local_changes statuses
887
-
|> List.map (fun s -> s.Status.package)
888
-
in
889
-
if dirty <> [] then Error (Dirty_state dirty)
890
-
else begin
891
-
(* First, clone/fetch unique repositories *)
892
-
let repos = unique_repos pkgs in
893
-
Log.info (fun m ->
894
-
m "Cloning/fetching %d unique repositories"
895
-
(List.length repos));
896
-
let clone_repos () =
897
-
let total = List.length repos in
898
-
let progress = Tty.Progress.create ~total "Fetch" in
899
-
let rec loop acc = function
900
-
| [] ->
901
-
Tty.Progress.clear progress;
902
-
Ok (List.rev acc)
903
-
| pkg :: rest -> (
904
-
let repo_name = Package.repo_name pkg in
905
-
Tty.Progress.message progress
906
-
(Fmt.str "Fetch: %s (%d/%d)" repo_name
907
-
(List.length acc + 1)
908
-
total);
909
-
Log.info (fun m -> m "Fetching repo %s" repo_name);
910
-
let existed = checkout_exists ~fs:fs_t ~config pkg in
911
-
let behind_before =
912
-
if existed then behind ~proc ~fs:fs_t ~config pkg else 0
913
-
in
914
-
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
915
-
| Error e ->
916
-
Tty.Progress.clear progress;
917
-
Error (Git_error e)
918
-
| Ok () ->
919
-
Tty.Progress.tick progress;
920
-
let result =
921
-
{
922
-
repo_name;
923
-
cloned = not existed;
924
-
commits_pulled = behind_before;
925
-
subtree_added = false;
926
-
}
927
-
in
928
-
loop (result :: acc) rest)
929
-
in
930
-
loop [] repos
931
-
in
932
-
match clone_repos () with
933
-
| Error e -> Error e
934
-
| Ok checkout_results -> (
935
-
(* Then, add/pull subtrees for unique repos only *)
936
-
Log.info (fun m ->
937
-
m "Processing %d unique subtrees" (List.length repos));
938
-
let total = List.length repos in
939
-
let progress = Tty.Progress.create ~total "Subtree" in
940
-
let rec loop results_acc repos_left checkout_results_left =
941
-
match (repos_left, checkout_results_left) with
942
-
| [], [] ->
943
-
Tty.Progress.clear progress;
944
-
Ok (List.rev results_acc)
945
-
| pkg :: rest_repos, cr :: rest_cr -> (
946
-
let name = Package.subtree_prefix pkg in
947
-
Tty.Progress.message progress
948
-
(Fmt.str "Subtree: %s (%d/%d)" name
949
-
(List.length results_acc + 1)
950
-
total);
951
-
Log.info (fun m -> m "Subtree %s" name);
952
-
match pull_subtree ~proc ~fs ~config pkg with
953
-
| Ok subtree_added ->
954
-
Tty.Progress.tick progress;
955
-
let result = { cr with subtree_added } in
956
-
loop (result :: results_acc) rest_repos rest_cr
957
-
| Error e ->
958
-
Tty.Progress.clear progress;
959
-
Error e)
960
-
| _ ->
961
-
Tty.Progress.clear progress;
962
-
Ok (List.rev results_acc)
963
-
in
964
-
match loop [] repos checkout_results with
965
-
| Error e -> Error e
966
-
| Ok results ->
967
-
(* Print summary with checkmarks *)
968
-
let cloned = List.filter (fun r -> r.cloned) results in
969
-
let updated =
970
-
List.filter
971
-
(fun r -> (not r.cloned) && r.commits_pulled > 0)
972
-
results
973
-
in
974
-
let added =
975
-
List.filter (fun r -> r.subtree_added) results
976
-
in
977
-
List.iter
978
-
(fun r ->
979
-
Log.app (fun m -> m " + %s (cloned)" r.repo_name))
980
-
cloned;
981
-
List.iter
982
-
(fun r ->
983
-
Log.app (fun m ->
984
-
m " ✓ %s (%d commits)" r.repo_name
985
-
r.commits_pulled))
986
-
updated;
987
-
List.iter
988
-
(fun r ->
989
-
Log.app (fun m -> m " + %s (added)" r.repo_name))
990
-
added;
991
-
let unchanged =
992
-
List.length results - List.length cloned
993
-
- List.length updated - List.length added
994
-
in
995
-
if cloned = [] && updated = [] && added = [] then
996
-
Log.app (fun m ->
997
-
m " All %d repositories up to date."
998
-
(List.length results))
999
-
else if unchanged > 0 then
1000
-
Log.app (fun m -> m " %d unchanged." unchanged);
1001
-
(* Update README.md, CLAUDE.md, and dune-project *)
1002
-
write_readme ~proc ~fs:fs_t ~config all_pkgs;
1003
-
write_claude_md ~proc ~fs:fs_t ~config;
1004
-
write_dune_project ~proc ~fs:fs_t ~config all_pkgs;
1005
-
Ok ())
1006
-
end
1007
-
end)
1008
-
1009
-
let push_one ~proc ~fs ~config ~clean pkg =
1010
-
let ( let* ) r f =
1011
-
Result.bind (Result.map_error (fun e -> Git_error e) r) f
1012
-
in
1013
-
let fs = fs_typed fs in
1014
-
let monorepo = Config.Paths.monorepo config in
1015
-
let prefix = Package.subtree_prefix pkg in
1016
-
let checkouts_root = Config.Paths.checkouts config in
1017
-
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1018
-
let branch = branch ~config pkg in
1019
-
if not (is_directory ~fs Fpath.(monorepo / prefix)) then begin
1020
-
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
1021
-
Ok ()
1022
-
end
1023
-
else begin
1024
-
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
1025
-
let needs_clone =
1026
-
match Eio.Path.kind ~follow:true checkout_eio with
1027
-
| exception Eio.Io _ -> true
1028
-
| `Directory when Git.Repository.is_repo ~fs checkout_dir -> false
1029
-
| _ -> true
1030
-
in
1031
-
let* () =
1032
-
if needs_clone then begin
1033
-
Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg));
1034
-
ensure_checkout ~proc ~fs:(fs :> _ Eio.Path.t) ~config pkg
1035
-
end
1036
-
else Ok ()
1037
-
in
1038
-
(* Use native subtree split + push to export commits to the checkout.
1039
-
This preserves commit identity, ensuring round-trips converge. *)
1040
-
let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in
1041
-
let git_repo = Git.Repository.open_repo ~fs monorepo in
1042
-
let checkout_repo = Git.Repository.open_repo ~fs checkout_dir in
1043
-
(* Fast path: if tree hashes match, nothing to push *)
1044
-
let mono_tree =
1045
-
Git.Repository.tree_hash_at_path git_repo ~rev:"HEAD" ~path:prefix
1046
-
in
1047
-
let checkout_tree =
1048
-
match Git.Repository.head checkout_repo with
1049
-
| None -> None
1050
-
| Some h -> (
1051
-
match Git.Repository.read checkout_repo h with
1052
-
| Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
1053
-
| _ -> None)
1054
-
in
1055
-
if mono_tree = checkout_tree && mono_tree <> None then begin
1056
-
Log.debug (fun m -> m "Skipping %s (trees match)" prefix);
1057
-
Ok ()
1058
-
end
1059
-
else begin
1060
-
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
1061
-
(* Proactively verify and clear invalid cache before split *)
1062
-
let _checked, errors = Git.Subtree.verify git_repo ~prefix () in
1063
-
if errors <> [] then begin
1064
-
Log.info (fun m ->
1065
-
m "Clearing invalid cache for %s (%d errors)" prefix
1066
-
(List.length errors));
1067
-
Git.Subtree.Cache.clear git_repo ~prefix
1068
-
end;
1069
-
match Git.Repository.read_ref git_repo "HEAD" with
1070
-
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
1071
-
| Some head -> (
1072
-
match Git.Subtree.split git_repo ~prefix ~head () with
1073
-
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
1074
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1075
-
| Ok (Some split_hash) -> (
1076
-
(* Optionally clean history by removing unrelated merge commits *)
1077
-
let final_hash =
1078
-
if clean then (
1079
-
match
1080
-
Git.Subtree.fix git_repo ~prefix ~head:split_hash ()
1081
-
with
1082
-
| Ok (Some h) ->
1083
-
Log.info (fun m -> m "Cleaned history for %s" prefix);
1084
-
h
1085
-
| Ok None -> split_hash
1086
-
| Error (`Msg msg) ->
1087
-
Log.warn (fun m -> m "Failed to clean %s: %s" prefix msg);
1088
-
split_hash)
1089
-
else split_hash
1090
-
in
1091
-
let refspec =
1092
-
Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch
1093
-
in
1094
-
match
1095
-
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
1096
-
~refspec ~force:clean ()
1097
-
with
1098
-
| Ok () -> Ok ()
1099
-
| Error e -> Error (Git_error e)))
1100
-
end
1101
-
end
1102
-
1103
-
let rec push ~proc ~fs ~config ?(packages = []) ?(upstream = false)
1104
-
?(clean = false) ?(force = false) () =
1105
-
let fs_t = fs_typed fs in
1106
-
(* Ensure checkouts directory exists before computing status *)
1107
-
ensure_checkouts_dir ~fs:fs_t ~config;
1108
-
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
1109
-
| Error e -> Error e
1110
-
| Ok all_pkgs ->
1111
-
let pkgs =
1112
-
match packages with
1113
-
| [] -> all_pkgs
1114
-
| names ->
1115
-
List.filter (fun p -> List.mem (Package.name p) names) all_pkgs
1116
-
in
1117
-
if pkgs = [] && packages <> [] then
1118
-
Error (Package_not_found (List.hd packages))
1119
-
else begin
1120
-
Log.info (fun m ->
1121
-
m "Checking status of %d packages" (List.length pkgs));
1122
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
1123
-
let dirty =
1124
-
List.filter Status.has_local_changes statuses
1125
-
|> List.map (fun s -> s.Status.package)
1126
-
in
1127
-
if dirty <> [] then Error (Dirty_state dirty)
1128
-
else begin
1129
-
(* Build status lookup to check which repos need pushing *)
1130
-
let status_by_prefix =
1131
-
List.fold_left
1132
-
(fun acc s ->
1133
-
let prefix = Package.subtree_prefix s.Status.package in
1134
-
(prefix, s) :: acc)
1135
-
[] statuses
1136
-
in
1137
-
let needs_export pkg =
1138
-
let prefix = Package.subtree_prefix pkg in
1139
-
match List.assoc_opt prefix status_by_prefix with
1140
-
| Some s -> not (Status.is_fully_synced s)
1141
-
| None -> true (* conservative: push if no status *)
1142
-
in
1143
-
let all_repos = unique_repos pkgs in
1144
-
(* Filter to only repos that need pushing *)
1145
-
let repos = List.filter needs_export all_repos in
1146
-
let skipped = List.length all_repos - List.length repos in
1147
-
if skipped > 0 then
1148
-
Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
1149
-
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
1150
-
let n_repos = List.length repos in
1151
-
if n_repos = 0 then begin
1152
-
Log.app (fun m -> m "Nothing to push (all repos in sync)");
1153
-
Ok ()
1154
-
end
1155
-
else begin
1156
-
(* Calculate total steps: subtree pushes + remote pushes (if upstream) *)
1157
-
let total = if upstream then n_repos * 2 else n_repos in
1158
-
let progress = Tty.Progress.create ~total "Push" in
1159
-
let update_progress phase name =
1160
-
Tty.Progress.update progress ~phase ~msg:name
1161
-
in
1162
-
(* Phase 1: Subtree pushes (sequential due to git constraints) *)
1163
-
let rec loop pushed_repos = function
1164
-
| [] -> Ok (List.rev pushed_repos)
1165
-
| pkg :: rest -> (
1166
-
let name = Package.subtree_prefix pkg in
1167
-
update_progress "Export" name;
1168
-
Log.debug (fun m -> m "Subtree push %s" name);
1169
-
match push_one ~proc ~fs ~config ~clean pkg with
1170
-
| Ok () -> loop (pkg :: pushed_repos) rest
1171
-
| Error e ->
1172
-
Tty.Progress.clear progress;
1173
-
Error e)
1174
-
in
1175
-
match loop [] repos with
1176
-
| Error e -> Error e
1177
-
| Ok pushed_repos -> (
1178
-
(* Phase 2: Remote pushes (parallel) *)
1179
-
let push_results =
1180
-
if upstream && pushed_repos <> [] then begin
1181
-
Log.info (fun m ->
1182
-
m "Pushing %d repos to upstream (parallel)"
1183
-
(List.length pushed_repos));
1184
-
let checkouts_root = Config.Paths.checkouts config in
1185
-
Eio.Fiber.List.map ~max_fibers:8
1186
-
(fun pkg ->
1187
-
let checkout_dir =
1188
-
Package.checkout_dir ~checkouts_root pkg
1189
-
in
1190
-
let name = Package.repo_name pkg in
1191
-
update_progress "Push" name;
1192
-
let branch = branch ~config pkg in
1193
-
let knot = Config.knot config in
1194
-
let push_url =
1195
-
url_to_push_url ~knot (Package.dev_repo pkg)
1196
-
in
1197
-
Log.info (fun m -> m "Pushing %s to %s" name push_url);
1198
-
let repo =
1199
-
Git.Repository.open_repo ~fs:fs_t checkout_dir
1200
-
in
1201
-
(match
1202
-
Git.Repository.set_push_url repo ~name:"origin"
1203
-
~url:push_url
1204
-
with
1205
-
| Ok () -> ()
1206
-
| Error (`Msg msg) ->
1207
-
Log.warn (fun m ->
1208
-
m "Failed to set push URL: %s" msg));
1209
-
match
1210
-
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
1211
-
checkout_dir
1212
-
with
1213
-
| Ok () -> Ok name
1214
-
| Error e -> Error (name, Git_error e))
1215
-
pushed_repos
1216
-
end
1217
-
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
1218
-
in
1219
-
Tty.Progress.clear progress;
1220
-
(* Print all results at the end *)
1221
-
let successes, failures =
1222
-
List.partition_map
1223
-
(function
1224
-
| Ok name -> Left name | Error (name, _) -> Right name)
1225
-
push_results
1226
-
in
1227
-
List.iter
1228
-
(fun name -> Log.app (fun m -> m " ✓ %s" name))
1229
-
successes;
1230
-
List.iter
1231
-
(fun name -> Log.app (fun m -> m " ✗ %s" name))
1232
-
failures;
1233
-
(* Return first error if any *)
1234
-
match List.find_opt Result.is_error push_results with
1235
-
| Some (Error (_, e)) -> Error e
1236
-
| _ ->
1237
-
if upstream then
1238
-
push_workspace_repos ~proc ~fs:fs_t ~config ~force;
1239
-
Ok ())
1240
-
end
1241
-
end
1242
-
end
1243
-
1244
-
(* Push mono and opam-repo to their remotes if configured *)
1245
-
and push_workspace_repos ~proc ~fs ~config ~force =
1246
-
let push_repo name path =
1247
-
if Git.Repository.is_repo ~fs path then begin
1248
-
let repo = Git.Repository.open_repo ~fs path in
1249
-
match Git.Repository.get_remote_url repo "origin" with
1250
-
| None -> Log.debug (fun m -> m "%s has no origin remote, skipping" name)
1251
-
| Some _ -> (
1252
-
match
1253
-
Git_cli.push_remote ~proc ~fs:(fs :> _ Eio.Path.t) ~force path
1254
-
with
1255
-
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
1256
-
| Error (Git_cli.Command_failed (_, result))
1257
-
when String.starts_with ~prefix:"Everything up-to-date"
1258
-
result.Git_cli.stderr ->
1259
-
Log.app (fun m -> m " ✓ %s (already synced)" name)
1260
-
| Error e -> Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e)
1261
-
)
1262
-
end
1263
-
in
1264
-
let mono = Config.Paths.monorepo config in
1265
-
let opam_repo = Config.Paths.opam_repo config in
1266
-
push_repo "mono" mono;
1267
-
push_repo "opam-repo" opam_repo
1268
-
1269
-
(* Clean empty commits from mono and all checkouts *)
1270
-
1271
-
(** Write new_head to the current branch or HEAD *)
1272
-
let write_cleaned_head repo new_head =
1273
-
match Git.Repository.current_branch repo with
1274
-
| Some branch ->
1275
-
Git.Repository.write_ref repo ("refs/heads/" ^ branch) new_head
1276
-
| None -> Git.Repository.write_ref repo "HEAD" new_head
1277
-
1278
-
(** Apply a fix function and handle the result. Returns Some count on success.
1279
-
*)
1280
-
let apply_fix ~name ~repo ~dry_run ~fix_fn ~issue_count =
1281
-
if dry_run then Some issue_count
1282
-
else
1283
-
match fix_fn () with
1284
-
| Error (`Msg msg) ->
1285
-
Log.warn (fun m -> m " Failed to clean %s: %s" name msg);
1286
-
None
1287
-
| Ok None ->
1288
-
Log.warn (fun m -> m " %s: history became empty" name);
1289
-
None
1290
-
| Ok (Some new_head) ->
1291
-
write_cleaned_head repo new_head;
1292
-
Log.app (fun m -> m " ✓ %s cleaned" name);
1293
-
Some issue_count
1294
-
1295
-
let clean ~proc ~fs ~config ~dry_run ~force () =
1296
-
let fs_t = fs_typed fs in
1297
-
let mono = Config.Paths.monorepo config in
1298
-
let checkouts = Config.Paths.checkouts config in
1299
-
1300
-
let clean_mono () =
1301
-
if not (Git.Repository.is_repo ~fs:fs_t mono) then None
1302
-
else
1303
-
let repo = Git.Repository.open_repo ~fs:fs_t mono in
1304
-
match Git.Repository.head repo with
1305
-
| None -> None
1306
-
| Some head ->
1307
-
let checked, issues = Git.Subtree.check_mono repo ~head () in
1308
-
if issues = [] then None
1309
-
else begin
1310
-
Log.app (fun m ->
1311
-
m "mono: %d empty commits (of %d checked)" (List.length issues)
1312
-
checked);
1313
-
apply_fix ~name:"mono" ~repo ~dry_run
1314
-
~fix_fn:(fun () -> Git.Subtree.fix_mono repo ~head ())
1315
-
~issue_count:(List.length issues)
1316
-
end
1317
-
in
1318
-
1319
-
let clean_checkout name =
1320
-
let path = Fpath.(checkouts / name) in
1321
-
if not (Git.Repository.is_repo ~fs:fs_t path) then None
1322
-
else
1323
-
let repo = Git.Repository.open_repo ~fs:fs_t path in
1324
-
match Git.Repository.head repo with
1325
-
| None -> None
1326
-
| Some head ->
1327
-
let checked, issues = Git.Subtree.check repo ~prefix:name ~head () in
1328
-
if issues = [] then None
1329
-
else begin
1330
-
Log.app (fun m ->
1331
-
m "%s: %d unrelated merges (of %d checked)" name
1332
-
(List.length issues) checked);
1333
-
apply_fix ~name ~repo ~dry_run
1334
-
~fix_fn:(fun () -> Git.Subtree.fix repo ~prefix:name ~head ())
1335
-
~issue_count:(List.length issues)
1336
-
end
1337
-
in
1338
-
1339
-
(* Clean mono first *)
1340
-
let mono_cleaned = clean_mono () in
1341
-
1342
-
(* Clean all checkouts *)
1343
-
let checkouts_path = Eio.Path.(fs_t / Fpath.to_string checkouts) in
1344
-
let checkout_results =
1345
-
try Eio.Path.read_dir checkouts_path |> List.filter_map clean_checkout
1346
-
with Eio.Io _ -> []
1347
-
in
1348
-
1349
-
let total_cleaned =
1350
-
Option.value ~default:0 mono_cleaned
1351
-
+ List.fold_left ( + ) 0 checkout_results
1352
-
in
1353
-
1354
-
if total_cleaned = 0 then begin
1355
-
Log.app (fun m -> m "No empty commits found");
1356
-
Ok ()
1357
-
end
1358
-
else if dry_run then begin
1359
-
Log.app (fun m ->
1360
-
m "Would remove %d commits (use without --dry-run to apply)"
1361
-
total_cleaned);
1362
-
Ok ()
1363
-
end
1364
-
else begin
1365
-
Log.app (fun m -> m "Removed %d commits" total_cleaned);
1366
-
(* Optionally force-push to upstream *)
1367
-
if force then begin
1368
-
Log.app (fun m -> m "Force-pushing cleaned histories to upstream...");
1369
-
(try
1370
-
Eio.Path.read_dir checkouts_path
1371
-
|> List.iter (fun name ->
1372
-
let path = Fpath.(checkouts / name) in
1373
-
if Git.Repository.is_repo ~fs:fs_t path then
1374
-
match
1375
-
Git_cli.push_remote ~proc
1376
-
~fs:(fs_t :> _ Eio.Path.t)
1377
-
~force:true path
1378
-
with
1379
-
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
1380
-
| Error e ->
1381
-
Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e))
1382
-
with Eio.Io _ -> ());
1383
-
Ok ()
1384
-
end
1385
-
else Ok ()
1386
-
end
1387
-
1388
-
(* Thin wrappers to extracted modules *)
72
+
let pull = Pull.pull
73
+
let push = Push.push
74
+
let add = Add.add
75
+
let remove ~proc:_ = Remove.remove
76
+
let clean = Clean.clean
1389
77
let pp_opam_sync_result = Opam_sync.pp
1390
78
1391
79
let sync_opam_files ~fs ~config ?(packages = []) () =
1392
-
match Opam_sync.run ~fs:(fs_typed fs) ~config ~packages () with
80
+
match Opam_sync.run ~fs:(Ctx.fs_typed fs) ~config ~packages () with
1393
81
| Ok result -> Ok result
1394
82
| Error (`Config_error e) -> Error (Config_error e)
1395
83
1396
84
let discover_packages_from_monorepo ~fs ~config ?sources () =
1397
-
match Monorepo_pkg.discover ~fs:(fs_typed fs) ~config ?sources () with
85
+
match Monorepo_pkg.discover ~fs:(Ctx.fs_typed fs) ~config ?sources () with
1398
86
| Ok result -> Ok result
1399
87
| Error (`Config_error e) -> Error (Config_error e)
1400
88
1401
-
let add ~proc ~fs ~config ~package:pkg_name () =
1402
-
let fs_t = fs_typed fs in
1403
-
ensure_checkouts_dir ~fs:fs_t ~config;
1404
-
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
1405
-
| Error e -> Error e
1406
-
| Ok () -> (
1407
-
match package ~fs:(fs_t :> _ Eio.Path.t) ~config pkg_name with
1408
-
| Error e -> Error e
1409
-
| Ok pkg -> (
1410
-
Log.info (fun m -> m "Adding package %s" (Package.name pkg));
1411
-
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
1412
-
| Error e -> Error (Git_error e)
1413
-
| Ok () ->
1414
-
pull_subtree ~proc ~fs ~config pkg |> Result.map (fun _ -> ())))
1415
-
1416
-
let remove ~proc:_ ~fs ~config ~package () =
1417
-
let fs = fs_typed fs in
1418
-
let monorepo = Config.Paths.monorepo config in
1419
-
let prefix = package in
1420
-
if not (is_directory ~fs Fpath.(monorepo / prefix)) then Ok ()
1421
-
else
1422
-
let subtree_path = Eio.Path.(fs / Fpath.to_string monorepo / prefix) in
1423
-
try
1424
-
Eio.Path.rmtree subtree_path;
1425
-
Ok ()
1426
-
with Eio.Io _ as e ->
1427
-
Error (Git_error (Git_cli.Io_error (Printexc.to_string e)))
1428
-
1429
-
(* Changes command - generate weekly changelogs using Claude *)
1430
-
1431
-
let changes ~proc ~fs ~config ~clock ?package ?(weeks = 1) ?(history = 12)
1432
-
?(dry_run = false) () =
1433
-
let fs_t = fs_typed fs in
1434
-
let monorepo = Config.Paths.monorepo config in
1435
-
1436
-
(* Get current time and calculate week boundaries *)
1437
-
let now = Eio.Time.now clock in
1438
-
let now_ptime =
1439
-
match Ptime.of_float_s now with Some t -> t | None -> Ptime.v (0, 0L)
1440
-
(* fallback to epoch *)
1441
-
in
1442
-
1443
-
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
1444
-
| Error e -> Error e
1445
-
| Ok all_pkgs ->
1446
-
let repos = unique_repos all_pkgs in
1447
-
let repos =
1448
-
match package with
1449
-
| None -> repos
1450
-
| Some name -> List.filter (fun p -> Package.repo_name p = name) repos
1451
-
in
1452
-
if repos = [] && package <> None then
1453
-
Error (Package_not_found (Option.get package))
1454
-
else begin
1455
-
Log.info (fun m ->
1456
-
m "Processing changelogs for %d repositories" (List.length repos));
1457
-
1458
-
(* Process each repository *)
1459
-
let all_changes_files = ref [] in
1460
-
let rec process_repos = function
1461
-
| [] -> Ok ()
1462
-
| pkg :: rest -> (
1463
-
let repo_name = Package.repo_name pkg in
1464
-
1465
-
Log.info (fun m -> m "Processing %s" repo_name);
1466
-
1467
-
(* Load existing changes from .changes/<repo>.json *)
1468
-
match Changes.load ~fs:fs_t ~monorepo repo_name with
1469
-
| Error e -> Error (Claude_error e)
1470
-
| Ok changes_file -> (
1471
-
(* Process each week *)
1472
-
let rec process_weeks week_offset updated_cf =
1473
-
if week_offset >= weeks then Ok updated_cf
1474
-
else begin
1475
-
(* Calculate week boundaries *)
1476
-
let offset_seconds =
1477
-
float_of_int (week_offset * 7 * 24 * 60 * 60)
1478
-
in
1479
-
let week_time =
1480
-
match Ptime.of_float_s (now -. offset_seconds) with
1481
-
| Some t -> t
1482
-
| None -> now_ptime
1483
-
in
1484
-
let week_start, week_end =
1485
-
Changes.week_of_ptime week_time
1486
-
in
1487
-
let since_ts, until_ts =
1488
-
Changes.week_timestamps_of_ptime week_time
1489
-
in
1490
-
1491
-
(* Skip if week already has an entry *)
1492
-
if Changes.has_week updated_cf ~week_start then begin
1493
-
Log.info (fun m ->
1494
-
m " Week %s already has entry, skipping" week_start);
1495
-
process_weeks (week_offset + 1) updated_cf
1496
-
end
1497
-
else begin
1498
-
(* Get commits for this week *)
1499
-
let repo = Git.Repository.open_repo ~fs:fs_t monorepo in
1500
-
let commits =
1501
-
match Git.Repository.head repo with
1502
-
| None -> []
1503
-
| Some head ->
1504
-
Git.Repository.log_filtered repo ~since:since_ts
1505
-
~until:until_ts ~path:repo_name head
1506
-
in
1507
-
if commits = [] then begin
1508
-
Log.info (fun m ->
1509
-
m " No commits for week %s" week_start);
1510
-
process_weeks (week_offset + 1) updated_cf
1511
-
end
1512
-
else begin
1513
-
Log.info (fun m ->
1514
-
m " Found %d commits for week %s"
1515
-
(List.length commits) week_start);
1516
-
1517
-
if dry_run then begin
1518
-
Log.app (fun m ->
1519
-
m
1520
-
" [DRY RUN] Would analyze %d commits for %s \
1521
-
week %s"
1522
-
(List.length commits) repo_name week_start);
1523
-
process_weeks (week_offset + 1) updated_cf
1524
-
end
1525
-
else begin
1526
-
(* Analyze commits with Claude *)
1527
-
Eio.Switch.run @@ fun sw ->
1528
-
match
1529
-
Changes.analyze_commits ~sw ~process_mgr:proc
1530
-
~clock ~repository:repo_name ~week_start
1531
-
~week_end commits
1532
-
with
1533
-
| Error e -> Error (Claude_error e)
1534
-
| Ok None ->
1535
-
Log.info (fun m ->
1536
-
m " No user-facing changes for week %s"
1537
-
week_start);
1538
-
process_weeks (week_offset + 1) updated_cf
1539
-
| Ok (Some response) ->
1540
-
Log.app (fun m ->
1541
-
m " Generated changelog for %s week %s"
1542
-
repo_name week_start);
1543
-
(* Create new entry *)
1544
-
let first_hash = (List.hd commits).hash in
1545
-
let last_hash =
1546
-
(List.hd (List.rev commits)).hash
1547
-
in
1548
-
let entry : Changes.weekly_entry =
1549
-
{
1550
-
week_start;
1551
-
week_end;
1552
-
summary = response.Changes.summary;
1553
-
changes = response.Changes.changes;
1554
-
commit_range =
1555
-
{
1556
-
from_hash =
1557
-
String.sub first_hash 0
1558
-
(min 7 (String.length first_hash));
1559
-
to_hash =
1560
-
String.sub last_hash 0
1561
-
(min 7 (String.length last_hash));
1562
-
count = List.length commits;
1563
-
};
1564
-
}
1565
-
in
1566
-
(* Add entry (sorted by date descending) *)
1567
-
let new_entries =
1568
-
entry :: updated_cf.Changes.entries
1569
-
|> List.sort (fun e1 e2 ->
1570
-
String.compare e2.Changes.week_start
1571
-
e1.Changes.week_start)
1572
-
in
1573
-
process_weeks (week_offset + 1)
1574
-
{ updated_cf with entries = new_entries }
1575
-
end
1576
-
end
1577
-
end
1578
-
end
1579
-
in
1580
-
match process_weeks 0 changes_file with
1581
-
| Error e -> Error e
1582
-
| Ok updated_cf -> (
1583
-
(* Save if changed and not dry run *)
1584
-
let save_result =
1585
-
if
1586
-
(not dry_run)
1587
-
&& updated_cf.entries <> changes_file.entries
1588
-
then (
1589
-
match Changes.save ~fs:fs_t ~monorepo updated_cf with
1590
-
| Error e -> Error (Claude_error e)
1591
-
| Ok () ->
1592
-
Log.app (fun m ->
1593
-
m "Saved .changes/%s.json" repo_name);
1594
-
Ok ())
1595
-
else Ok ()
1596
-
in
1597
-
match save_result with
1598
-
| Error e -> Error e
1599
-
| Ok () ->
1600
-
all_changes_files := updated_cf :: !all_changes_files;
1601
-
process_repos rest)))
1602
-
in
1603
-
match process_repos repos with
1604
-
| Error e -> Error e
1605
-
| Ok () ->
1606
-
(* Generate aggregated CHANGES.md *)
1607
-
if (not dry_run) && !all_changes_files <> [] then begin
1608
-
let markdown = Changes.aggregate ~history !all_changes_files in
1609
-
let changes_md_path =
1610
-
Eio.Path.(fs_t / Fpath.to_string monorepo / "CHANGES.md")
1611
-
in
1612
-
Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path
1613
-
markdown;
1614
-
Log.app (fun m -> m "Generated CHANGES.md at monorepo root")
1615
-
end;
1616
-
Ok ()
1617
-
end
1618
-
1619
-
(* Daily changes command - generate daily changelogs using Claude *)
1620
-
1621
-
let changes_daily ~proc ~fs ~config ~clock ?package ?(days = 1) ?(history = 30)
1622
-
?(dry_run = false) ?(aggregate = false) () =
1623
-
let fs_t = fs_typed fs in
1624
-
let monorepo = Config.Paths.monorepo config in
1625
-
1626
-
(* Get current time *)
1627
-
let now = Eio.Time.now clock in
1628
-
let now_ptime =
1629
-
match Ptime.of_float_s now with Some t -> t | None -> Ptime.v (0, 0L)
1630
-
(* fallback to epoch *)
1631
-
in
1632
-
1633
-
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
1634
-
| Error e -> Error e
1635
-
| Ok all_pkgs ->
1636
-
let repos = unique_repos all_pkgs in
1637
-
let repos =
1638
-
match package with
1639
-
| None -> repos
1640
-
| Some name -> List.filter (fun p -> Package.repo_name p = name) repos
1641
-
in
1642
-
if repos = [] && package <> None then
1643
-
Error (Package_not_found (Option.get package))
1644
-
else begin
1645
-
Log.info (fun m ->
1646
-
m "Processing daily changelogs for %d repositories"
1647
-
(List.length repos));
1648
-
1649
-
(* Process each repository *)
1650
-
let all_changes_files = ref [] in
1651
-
let rec process_repos = function
1652
-
| [] -> Ok ()
1653
-
| pkg :: rest -> (
1654
-
let repo_name = Package.repo_name pkg in
1655
-
1656
-
Log.info (fun m -> m "Processing %s" repo_name);
1657
-
1658
-
(* Process each day - with per-day files, we load/save per day *)
1659
-
let rec process_days day_offset =
1660
-
if day_offset >= days then Ok ()
1661
-
else begin
1662
-
(* Calculate day boundaries *)
1663
-
let offset_seconds =
1664
-
float_of_int (day_offset * 24 * 60 * 60)
1665
-
in
1666
-
let day_time =
1667
-
match Ptime.of_float_s (now -. offset_seconds) with
1668
-
| Some t -> t
1669
-
| None -> now_ptime
1670
-
in
1671
-
let date = Changes.date_of_ptime day_time in
1672
-
let is_today = day_offset = 0 in
1673
-
1674
-
(* For past days, skip if file exists at all (already analyzed) *)
1675
-
(* For today, skip only if file has entries (may need to catch new commits) *)
1676
-
let should_skip =
1677
-
if is_today then
1678
-
Changes.daily_exists ~fs:fs_t ~monorepo ~date repo_name
1679
-
&&
1680
-
match
1681
-
Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name
1682
-
with
1683
-
| Ok cf -> Changes.has_day cf ~date
1684
-
| Error _ -> false
1685
-
else Changes.daily_exists ~fs:fs_t ~monorepo ~date repo_name
1686
-
in
1687
-
if should_skip then begin
1688
-
Log.info (fun m ->
1689
-
m " Day %s already processed, skipping" date);
1690
-
(match
1691
-
Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name
1692
-
with
1693
-
| Ok cf -> all_changes_files := cf :: !all_changes_files
1694
-
| Error _ -> ());
1695
-
process_days (day_offset + 1)
1696
-
end
1697
-
else
1698
-
(* Load existing daily changes from .changes/<repo>-<date>.json *)
1699
-
match
1700
-
Changes.load_daily ~fs:fs_t ~monorepo ~date repo_name
1701
-
with
1702
-
| Error e -> Error (Claude_error e)
1703
-
| Ok changes_file ->
1704
-
(* Get commits for this day *)
1705
-
let since_ts, until_ts =
1706
-
Changes.day_timestamps_of_ptime day_time
1707
-
in
1708
-
let repo = Git.Repository.open_repo ~fs:fs_t monorepo in
1709
-
let commits =
1710
-
match Git.Repository.head repo with
1711
-
| None -> []
1712
-
| Some head ->
1713
-
Git.Repository.log_filtered repo ~since:since_ts
1714
-
~until:until_ts ~path:repo_name head
1715
-
in
1716
-
if commits = [] then begin
1717
-
Log.info (fun m -> m " No commits for day %s" date);
1718
-
process_days (day_offset + 1)
1719
-
end
1720
-
else begin
1721
-
Log.info (fun m ->
1722
-
m " Found %d commits for day %s"
1723
-
(List.length commits) date);
1724
-
1725
-
if dry_run then begin
1726
-
Log.app (fun m ->
1727
-
m
1728
-
" [DRY RUN] Would analyze %d commits for %s \
1729
-
on %s"
1730
-
(List.length commits) repo_name date);
1731
-
process_days (day_offset + 1)
1732
-
end
1733
-
else begin
1734
-
(* Analyze commits with Claude *)
1735
-
Eio.Switch.run @@ fun sw ->
1736
-
match
1737
-
Changes.analyze_commits_daily ~sw
1738
-
~process_mgr:proc ~clock ~repository:repo_name
1739
-
~date commits
1740
-
with
1741
-
| Error e -> Error (Claude_error e)
1742
-
| Ok None ->
1743
-
Log.info (fun m ->
1744
-
m " No user-facing changes for day %s" date);
1745
-
process_days (day_offset + 1)
1746
-
| Ok (Some response) -> (
1747
-
Log.app (fun m ->
1748
-
m " Generated changelog for %s on %s"
1749
-
repo_name date);
1750
-
(* Extract unique contributors from commits *)
1751
-
let contributors =
1752
-
commits
1753
-
|> List.map
1754
-
(fun (c : Git.Repository.log_entry) ->
1755
-
c.author)
1756
-
|> List.sort_uniq String.compare
1757
-
in
1758
-
(* Get repo URL from package dev_repo *)
1759
-
let repo_url =
1760
-
let uri = Package.dev_repo pkg in
1761
-
let url = Uri.to_string uri in
1762
-
(* Strip git+ prefix if present for display *)
1763
-
if String.starts_with ~prefix:"git+" url then
1764
-
Some
1765
-
(String.sub url 4 (String.length url - 4))
1766
-
else Some url
1767
-
in
1768
-
(* Create new entry with hour and timestamp *)
1769
-
let first_hash = (List.hd commits).hash in
1770
-
let last_hash =
1771
-
(List.hd (List.rev commits)).hash
1772
-
in
1773
-
let _, ((hour, _, _), _) =
1774
-
Ptime.to_date_time now_ptime
1775
-
in
1776
-
let entry : Changes.daily_entry =
1777
-
{
1778
-
date;
1779
-
hour;
1780
-
timestamp = now_ptime;
1781
-
summary = response.Changes.summary;
1782
-
changes = response.Changes.changes;
1783
-
commit_range =
1784
-
{
1785
-
from_hash =
1786
-
String.sub first_hash 0
1787
-
(min 7 (String.length first_hash));
1788
-
to_hash =
1789
-
String.sub last_hash 0
1790
-
(min 7 (String.length last_hash));
1791
-
count = List.length commits;
1792
-
};
1793
-
contributors;
1794
-
repo_url;
1795
-
}
1796
-
in
1797
-
(* Add entry (sorted by timestamp descending) *)
1798
-
let new_entries =
1799
-
entry :: changes_file.Changes.entries
1800
-
|> List.sort (fun e1 e2 ->
1801
-
Ptime.compare e2.Changes.timestamp
1802
-
e1.Changes.timestamp)
1803
-
in
1804
-
let updated_cf =
1805
-
{
1806
-
changes_file with
1807
-
Changes.entries = new_entries;
1808
-
}
1809
-
in
1810
-
(* Save the per-day file *)
1811
-
match
1812
-
Changes.save_daily ~fs:fs_t ~monorepo ~date
1813
-
updated_cf
1814
-
with
1815
-
| Error e -> Error (Claude_error e)
1816
-
| Ok () ->
1817
-
Log.app (fun m ->
1818
-
m "Saved .changes/%s-%s.json" repo_name
1819
-
date);
1820
-
all_changes_files :=
1821
-
updated_cf :: !all_changes_files;
1822
-
process_days (day_offset + 1))
1823
-
end
1824
-
end
1825
-
end
1826
-
in
1827
-
match process_days 0 with
1828
-
| Error e -> Error e
1829
-
| Ok () -> process_repos rest)
1830
-
in
1831
-
match process_repos repos with
1832
-
| Error e -> Error e
1833
-
| Ok () ->
1834
-
(* Generate aggregated DAILY-CHANGES.md *)
1835
-
if (not dry_run) && !all_changes_files <> [] then begin
1836
-
let raw_markdown =
1837
-
Changes.aggregate_daily ~history !all_changes_files
1838
-
in
1839
-
(* Refine the markdown through Claude for better narrative *)
1840
-
Log.info (fun m -> m "Refining daily changelog with Claude...");
1841
-
let markdown =
1842
-
Eio.Switch.run @@ fun sw ->
1843
-
match
1844
-
Changes.refine_daily_changelog ~sw ~process_mgr:proc ~clock
1845
-
raw_markdown
1846
-
with
1847
-
| Ok refined ->
1848
-
Log.app (fun m ->
1849
-
m "Refined daily changelog for readability");
1850
-
refined
1851
-
| Error e ->
1852
-
Log.warn (fun m ->
1853
-
m "Failed to refine changelog: %s (using raw version)" e);
1854
-
raw_markdown
1855
-
in
1856
-
let changes_md_path =
1857
-
Eio.Path.(fs_t / Fpath.to_string monorepo / "DAILY-CHANGES.md")
1858
-
in
1859
-
Eio.Path.save ~create:(`Or_truncate 0o644) changes_md_path
1860
-
markdown;
1861
-
Log.app (fun m -> m "Generated DAILY-CHANGES.md at monorepo root")
1862
-
end;
1863
-
(* Generate aggregated JSON file if requested *)
1864
-
if (not dry_run) && aggregate then begin
1865
-
let today = Changes.date_of_ptime now_ptime in
1866
-
let git_head =
1867
-
let repo = Git.Repository.open_repo ~fs:fs_t monorepo in
1868
-
match Git.Repository.head repo with
1869
-
| Some hash -> String.sub (Git.Hash.to_hex hash) 0 7
1870
-
| None -> "unknown"
1871
-
in
1872
-
match
1873
-
Changes.generate_aggregated ~fs:fs_t ~monorepo ~date:today
1874
-
~git_head ~now:now_ptime
1875
-
with
1876
-
| Ok () ->
1877
-
Log.app (fun m ->
1878
-
m "Generated aggregated file .changes/%s.json"
1879
-
(String.concat "" (String.split_on_char '-' today)))
1880
-
| Error e ->
1881
-
Log.warn (fun m ->
1882
-
m "Failed to generate aggregated file: %s" e)
1883
-
end;
1884
-
Ok ()
1885
-
end
1886
-
1887
-
(* ==================== Diff ==================== *)
1888
-
1889
-
type diff_entry = {
1890
-
repo_name : string;
1891
-
handle : string;
1892
-
relationship : Forks.relationship;
1893
-
commits : Git.Repository.log_entry list;
1894
-
patches : (string * string) list; (* hash -> patch content *)
1895
-
}
1896
-
1897
-
type diff_result = { entries : diff_entry list; forks : Forks.t }
1898
-
1899
-
let pp_diff_entry ~show_patch ppf entry =
1900
-
let n_commits = List.length entry.commits in
1901
-
Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@,"
1902
-
Fmt.(styled `Bold string)
1903
-
entry.repo_name entry.handle Forks.pp_relationship entry.relationship
1904
-
n_commits
1905
-
(if n_commits = 1 then "" else "s");
1906
-
List.iter
1907
-
(fun (c : Git.Repository.log_entry) ->
1908
-
let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
1909
-
Fmt.pf ppf " %a %s %a@,"
1910
-
Fmt.(styled `Yellow string)
1911
-
short_hash c.subject
1912
-
Fmt.(styled `Faint string)
1913
-
c.author;
1914
-
if show_patch then
1915
-
match List.assoc_opt c.hash entry.patches with
1916
-
| Some patch -> Fmt.pf ppf "@,%s@," patch
1917
-
| None -> ())
1918
-
entry.commits;
1919
-
Fmt.pf ppf "@]"
1920
-
1921
-
let pp_diff_result ~show_patch ppf result =
1922
-
(* First show the summary *)
1923
-
Fmt.pf ppf "%a@." (Forks.pp_summary' ~show_all:false) result.forks;
1924
-
(* Then show diffs for each entry *)
1925
-
if result.entries <> [] then begin
1926
-
Fmt.pf ppf "@[<v>%a@]@."
1927
-
Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch))
1928
-
result.entries
1929
-
end
1930
-
1931
-
(** Check if a string looks like a git commit hash (7+ hex chars) *)
1932
-
let is_commit_sha s =
1933
-
String.length s >= 7
1934
-
&& String.for_all
1935
-
(function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
1936
-
s
1937
-
1938
-
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
1939
-
?(patch = false) () =
1940
-
let checkouts_path = Config.Paths.checkouts config in
1941
-
1942
-
(* Compute fork analysis *)
1943
-
let forks =
1944
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
1945
-
in
1946
-
1947
-
(* Filter repos if specific one requested *)
1948
-
let repos_to_check =
1949
-
match repo with
1950
-
| None -> forks.repos
1951
-
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
1952
-
in
1953
-
1954
-
(* For each repo with actionable status, get commits *)
1955
-
let entries =
1956
-
List.filter_map
1957
-
(fun (r : Forks.repo_analysis) ->
1958
-
(* Find actionable verse sources *)
1959
-
let actionable =
1960
-
List.filter
1961
-
(fun (_, _, rel) ->
1962
-
match rel with
1963
-
| Forks.I_am_behind _ -> true
1964
-
| Forks.Diverged _ -> true
1965
-
| _ -> false)
1966
-
r.verse_sources
1967
-
in
1968
-
match actionable with
1969
-
| [] -> None
1970
-
| sources -> (
1971
-
(* Get commits for each actionable source *)
1972
-
let entries =
1973
-
List.filter_map
1974
-
(fun (handle, _src, rel) ->
1975
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
1976
-
if not (Git.Repository.is_repo ~fs checkout_path) then None
1977
-
else begin
1978
-
let repo = Git.Repository.open_repo ~fs checkout_path in
1979
-
let remote_name = "verse/" ^ handle in
1980
-
let my_ref = "origin/main" in
1981
-
let their_ref = remote_name ^ "/main" in
1982
-
(* Get commits they have that I don't *)
1983
-
match
1984
-
Git.Repository.log_range_refs repo ~base:my_ref
1985
-
~tip:their_ref ~max_count:20 ()
1986
-
with
1987
-
| Error _ -> None
1988
-
| Ok commits when commits = [] -> None
1989
-
| Ok commits ->
1990
-
(* Fetch patches if requested *)
1991
-
let patches =
1992
-
if patch then
1993
-
List.filter_map
1994
-
(fun (c : Git.Repository.log_entry) ->
1995
-
match
1996
-
Git.Repository.show_patch repo ~commit:c.hash
1997
-
with
1998
-
| Ok p -> Some (c.hash, p)
1999
-
| Error _ -> None)
2000
-
commits
2001
-
else []
2002
-
in
2003
-
Some
2004
-
{
2005
-
repo_name = r.repo_name;
2006
-
handle;
2007
-
relationship = rel;
2008
-
commits;
2009
-
patches;
2010
-
}
2011
-
end)
2012
-
sources
2013
-
in
2014
-
match entries with [] -> None | _ -> Some entries))
2015
-
repos_to_check
2016
-
|> List.flatten
2017
-
in
2018
-
{ entries; forks }
2019
-
2020
-
type commit_info = {
2021
-
commit_repo : string;
2022
-
commit_handle : string;
2023
-
commit_hash : string;
2024
-
commit_subject : string;
2025
-
commit_author : string;
2026
-
commit_patch : string;
2027
-
}
2028
-
(** Result of looking up a specific commit *)
2029
-
2030
-
(** Show patch for a specific commit SHA from diff output *)
2031
-
let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) ()
2032
-
=
2033
-
let checkouts_path = Config.Paths.checkouts config in
2034
-
2035
-
(* Compute fork analysis to find which repo has this commit *)
2036
-
let forks =
2037
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
2038
-
in
2039
-
2040
-
(* Search through repos for this commit *)
2041
-
let result =
2042
-
List.find_map
2043
-
(fun (r : Forks.repo_analysis) ->
2044
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2045
-
if not (Git.Repository.is_repo ~fs checkout_path) then None
2046
-
else
2047
-
let repo = Git.Repository.open_repo ~fs checkout_path in
2048
-
(* Check each verse source *)
2049
-
List.find_map
2050
-
(fun (handle, _src, rel) ->
2051
-
match rel with
2052
-
| Forks.I_am_behind _ | Forks.Diverged _ -> (
2053
-
let remote_name = "verse/" ^ handle in
2054
-
let my_ref = "origin/main" in
2055
-
let their_ref = remote_name ^ "/main" in
2056
-
(* Get commits they have that I don't *)
2057
-
match
2058
-
Git.Repository.log_range_refs repo ~base:my_ref
2059
-
~tip:their_ref ~max_count:50 ()
2060
-
with
2061
-
| Error _ -> None
2062
-
| Ok commits -> (
2063
-
(* Check if our sha matches any commit *)
2064
-
let matching =
2065
-
List.find_opt
2066
-
(fun (c : Git.Repository.log_entry) ->
2067
-
String.starts_with ~prefix:sha c.hash
2068
-
|| String.starts_with
2069
-
~prefix:(String.lowercase_ascii sha)
2070
-
(String.lowercase_ascii c.hash))
2071
-
commits
2072
-
in
2073
-
match matching with
2074
-
| None -> None
2075
-
| Some c -> (
2076
-
match
2077
-
Git.Repository.show_patch repo ~commit:c.hash
2078
-
with
2079
-
| Ok patch ->
2080
-
Some
2081
-
{
2082
-
commit_repo = r.repo_name;
2083
-
commit_handle = handle;
2084
-
commit_hash = c.hash;
2085
-
commit_subject = c.subject;
2086
-
commit_author = c.author;
2087
-
commit_patch = patch;
2088
-
}
2089
-
| Error _ -> None)))
2090
-
| _ -> None)
2091
-
r.verse_sources)
2092
-
forks.repos
2093
-
in
2094
-
result
2095
-
2096
-
(* ==================== Pull from Handle ==================== *)
2097
-
2098
-
type handle_pull_result = {
2099
-
repos_pulled : (string * int) list;
2100
-
repos_skipped : string list;
2101
-
repos_failed : (string * string) list;
2102
-
}
2103
-
2104
-
let pp_handle_pull_result ppf result =
2105
-
if result.repos_pulled <> [] then begin
2106
-
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:";
2107
-
List.iter
2108
-
(fun (repo, count) -> Fmt.pf ppf " %s: %d commits@," repo count)
2109
-
result.repos_pulled;
2110
-
Fmt.pf ppf "@]"
2111
-
end;
2112
-
if result.repos_skipped <> [] then
2113
-
Fmt.pf ppf "%a %s@,"
2114
-
Fmt.(styled `Faint string)
2115
-
"Skipped:"
2116
-
(String.concat ", " result.repos_skipped);
2117
-
if result.repos_failed <> [] then begin
2118
-
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:";
2119
-
List.iter
2120
-
(fun (repo, err) -> Fmt.pf ppf " %s: %s@," repo err)
2121
-
result.repos_failed;
2122
-
Fmt.pf ppf "@]"
2123
-
end
2124
-
2125
-
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
2126
-
?(refresh = false) () =
2127
-
let checkouts_path = Config.Paths.checkouts config in
2128
-
2129
-
(* Compute fork analysis *)
2130
-
let forks =
2131
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
2132
-
in
2133
-
2134
-
(* Filter repos if specific one requested *)
2135
-
let repos_to_check =
2136
-
match repo with
2137
-
| None -> forks.repos
2138
-
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
2139
-
in
2140
-
2141
-
(* Find repos where this handle has commits we don't have *)
2142
-
let repos_pulled = ref [] in
2143
-
let repos_skipped = ref [] in
2144
-
let repos_failed = ref [] in
2145
-
2146
-
List.iter
2147
-
(fun (r : Forks.repo_analysis) ->
2148
-
(* Check if this handle has commits for this repo *)
2149
-
let handle_source =
2150
-
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
2151
-
in
2152
-
match handle_source with
2153
-
| None ->
2154
-
(* Handle doesn't have this repo *)
2155
-
()
2156
-
| Some (_, _, rel) ->
2157
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2158
-
if not (Git.Repository.is_repo ~fs checkout_path) then
2159
-
repos_skipped := r.repo_name :: !repos_skipped
2160
-
else begin
2161
-
let git_repo = Git.Repository.open_repo ~fs checkout_path in
2162
-
match rel with
2163
-
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ ->
2164
-
repos_skipped := r.repo_name :: !repos_skipped
2165
-
| Forks.Not_fetched | Forks.Unrelated ->
2166
-
repos_skipped := r.repo_name :: !repos_skipped
2167
-
| Forks.I_am_behind count -> (
2168
-
(* Merge their changes *)
2169
-
let remote_ref = "verse/" ^ handle ^ "/main" in
2170
-
match
2171
-
Git.Repository.merge git_repo ~ref_name:remote_ref
2172
-
~ff_only:true
2173
-
with
2174
-
| Ok () -> repos_pulled := (r.repo_name, count) :: !repos_pulled
2175
-
| Error (`Msg msg) ->
2176
-
repos_failed := (r.repo_name, msg) :: !repos_failed)
2177
-
| Forks.Diverged { their_ahead; _ } -> (
2178
-
(* Merge their changes (may create a merge commit) *)
2179
-
let remote_ref = "verse/" ^ handle ^ "/main" in
2180
-
match
2181
-
Git.Repository.merge git_repo ~ref_name:remote_ref
2182
-
~ff_only:false
2183
-
with
2184
-
| Ok () ->
2185
-
repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled
2186
-
| Error (`Msg msg) ->
2187
-
repos_failed := (r.repo_name, msg) :: !repos_failed)
2188
-
end)
2189
-
repos_to_check;
2190
-
2191
-
Ok
2192
-
{
2193
-
repos_pulled = List.rev !repos_pulled;
2194
-
repos_skipped = List.rev !repos_skipped;
2195
-
repos_failed = List.rev !repos_failed;
2196
-
}
2197
-
2198
-
(* ==================== Cherry-pick ==================== *)
2199
-
2200
-
type cherrypick_result = {
2201
-
repo_name : string;
2202
-
commit_hash : string;
2203
-
commit_subject : string;
2204
-
}
2205
-
2206
-
let pp_cherrypick_result ppf result =
2207
-
let short_hash =
2208
-
String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash))
2209
-
in
2210
-
Fmt.pf ppf "Cherry-picked %a %s into %s@."
2211
-
Fmt.(styled `Yellow string)
2212
-
short_hash result.commit_subject result.repo_name
2213
-
2214
-
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
2215
-
let checkouts_path = Config.Paths.checkouts config in
2216
-
2217
-
(* First, find the commit *)
2218
-
match diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
2219
-
| None ->
2220
-
Error (Config_error (Fmt.str "Commit %s not found in any verse diff" sha))
2221
-
| Some info ->
2222
-
let checkout_path = Fpath.(checkouts_path / info.commit_repo) in
2223
-
if not (Git.Repository.is_repo ~fs checkout_path) then
2224
-
Error
2225
-
(Config_error
2226
-
(Fmt.str "No checkout for repository %s" info.commit_repo))
2227
-
else begin
2228
-
let git_repo = Git.Repository.open_repo ~fs checkout_path in
2229
-
match Git.Repository.cherry_pick git_repo ~commit:info.commit_hash with
2230
-
| Ok _new_hash ->
2231
-
Ok
2232
-
{
2233
-
repo_name = info.commit_repo;
2234
-
commit_hash = info.commit_hash;
2235
-
commit_subject = info.commit_subject;
2236
-
}
2237
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
2238
-
end
89
+
let discover_packages = Ctx.discover_packages
90
+
let package = Ctx.package
91
+
let unregistered_opam_files = Ctx.unregistered_opam_files
92
+
let pp_diff_entry = Diff.pp_entry
93
+
let pp_diff_result = Diff.pp
94
+
let pp_handle_pull_result = Diff.pp_handle_pull_result
95
+
let pp_cherrypick_result = Diff.pp_cherrypick_result
96
+
let is_commit_sha = Diff.is_commit_sha
97
+
let diff = Diff.diff
98
+
let diff_show_commit = Diff.show_commit
99
+
let pull_from_handle = Diff.pull_from_handle
100
+
let cherrypick = Diff.cherrypick
+69
-366
lib/monopam.mli
+69
-366
lib/monopam.mli
···
1
-
(** Monopam - Opam overlay and monorepo manager.
2
-
3
-
Monopam manages synchronization between an opam overlay repository,
4
-
individual git checkouts of packages, and a monorepo using git subtrees.
5
-
6
-
{1 Overview}
7
-
8
-
The typical workflow is:
1
+
(** Monopam - Monorepo package manager.
9
2
10
-
1. {b init} - Initialize configuration and monorepo 2. {b status} - Check
11
-
synchronization state of all packages 3. {b pull} - Fetch from remotes,
12
-
update checkouts, merge to monorepo 4. {b push} - Extract monorepo changes
13
-
back to checkouts
3
+
Orchestrates git subtree operations for managing a monorepo of OCaml
4
+
packages synchronized from upstream repositories.
14
5
15
-
{1 Modules}
6
+
{1 Core Modules}
16
7
17
8
- {!Config} - Configuration management
18
9
- {!Package} - Package metadata
19
10
- {!Opam_repo} - Opam repository scanning
20
11
- {!Git_cli} - Git operations (CLI-based)
21
-
- {!Status} - Status computation *)
12
+
- {!Status} - Status computation
13
+
- {!Changes} - Changelog generation
14
+
- {!Verse} - Verse collaboration registry
15
+
- {!Forks} - Fork relationship analysis
16
+
17
+
{1 Command Modules}
18
+
19
+
- {!Ctx} - Operational context (filesystem, package discovery, checkouts)
20
+
- {!Init} - Monorepo initialization
21
+
- {!Pull} - Pull operations (fetch checkouts, merge subtrees)
22
+
- {!Push} - Push operations (subtree split, export to checkouts)
23
+
- {!Add} - Add packages to monorepo
24
+
- {!Remove} - Remove packages from monorepo
25
+
- {!Clean} - Clean empty commits from history
26
+
- {!Diff} - Verse collaboration diff operations *)
22
27
23
-
(** Re-export modules for convenience. *)
28
+
(** {1 Core Modules} *)
24
29
25
30
module Config = Config
26
31
module Package = Package
···
41
46
module Fork_join = Fork_join
42
47
module Site = Site
43
48
module Remote_cache = Remote_cache
44
-
module Sync_progress = Sync_progress
49
+
module Opam_sync = Opam_sync
50
+
module Monorepo_pkg = Monorepo_pkg
51
+
module Progress = Sync_progress
52
+
53
+
(** {1 Command Modules} *)
54
+
55
+
module Ctx = Ctx
56
+
module Init = Init
57
+
module Pull = Pull
58
+
module Push = Push
59
+
module Add = Add
60
+
module Remove = Remove
61
+
module Clean = Clean
62
+
module Diff = Diff
45
63
46
-
(** {1 High-Level Operations} *)
64
+
(** {1 Backward-Compatible Exports} *)
47
65
48
-
(** Errors from high-level operations. *)
49
-
type error =
50
-
| Config_error of string (** Configuration error *)
51
-
| Repo_error of Opam_repo.error (** Opam repository error *)
52
-
| Git_error of Git_cli.error (** Git operation error *)
66
+
type error = Ctx.error =
67
+
| Config_error of string
68
+
| Repo_error of Opam_repo.error
69
+
| Git_error of Git_cli.error
53
70
| Dirty_state of Package.t list
54
-
(** Operation blocked due to dirty packages *)
55
-
| Monorepo_dirty (** Monorepo has uncommitted changes *)
56
-
| Package_not_found of string (** Named package not found in opam repo *)
57
-
| Claude_error of string (** Claude API or response parsing error *)
71
+
| Monorepo_dirty
72
+
| Package_not_found of string
73
+
| Claude_error of string
58
74
59
75
val pp_error : error Fmt.t
60
-
(** [pp_error] formats errors. *)
61
-
62
76
val pp_error_with_hint : error Fmt.t
63
-
(** [pp_error_with_hint] formats errors with a helpful hint for resolving them.
64
-
*)
65
-
66
77
val error_hint : error -> string option
67
-
(** [error_hint e] returns a hint string for the given error, if available. *)
68
78
69
-
(** {2 Status} *)
79
+
type opam_sync_result = Opam_sync.t
80
+
type monorepo_package = Monorepo_pkg.t
81
+
type pull_result = Pull.result
82
+
type diff_entry = Diff.entry
83
+
type diff_result = Diff.result
84
+
type commit_info = Diff.commit_info
85
+
type handle_pull_result = Diff.handle_pull_result
86
+
type cherrypick_result = Diff.cherrypick_result
70
87
71
88
val status :
72
89
proc:_ Eio.Process.mgr ->
···
74
91
config:Config.t ->
75
92
unit ->
76
93
(Status.t list, error) result
77
-
(** [status ~proc ~fs ~config ()] computes status for all packages discovered in
78
-
the opam repo.
79
-
80
-
@param proc Eio process manager.
81
-
@param fs Eio filesystem.
82
-
@param config Monopam configuration. *)
83
-
84
-
(** {2 Pull} *)
85
94
86
95
val pull :
87
96
proc:_ Eio.Process.mgr ->
···
91
100
?opam_repo_url:string ->
92
101
unit ->
93
102
(unit, error) result
94
-
(** [pull ~proc ~fs ~config ?packages ?opam_repo_url ()] pulls updates from
95
-
remotes.
96
-
97
-
For each package (or the specified packages): 1. Clones or fetches the
98
-
individual checkout 2. Adds or pulls the subtree in the monorepo
99
-
100
-
If the opam-repo doesn't exist locally and [opam_repo_url] is provided,
101
-
clones it from that URL first.
102
-
103
-
Aborts if any checkout or the monorepo has uncommitted changes.
104
-
105
-
@param proc Eio process manager.
106
-
@param fs Eio filesystem.
107
-
@param config Monopam configuration.
108
-
@param package Optional specific package to pull.
109
-
@param opam_repo_url
110
-
Optional URL to clone opam-repo from if it doesn't exist. *)
111
-
112
-
(** {2 Push} *)
113
103
114
104
val push :
115
105
proc:_ Eio.Process.mgr ->
···
121
111
?force:bool ->
122
112
unit ->
123
113
(unit, error) result
124
-
(** [push ~proc ~fs ~config ?packages ?upstream ?clean ?force ()] pushes changes
125
-
from monorepo to checkouts.
126
114
127
-
For each package (or the specified packages) with changes in the monorepo:
128
-
1. Splits the subtree commits 2. If [~clean:true], removes empty commits
129
-
from unrelated subtree merges 3. Pushes to the individual checkout 4. If
130
-
[~upstream:true], also pushes each checkout to its git remote
131
-
132
-
If [~upstream] is false (the default), the user must manually push from
133
-
checkouts to remotes.
115
+
val add :
116
+
proc:_ Eio.Process.mgr ->
117
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
118
+
config:Config.t ->
119
+
package:string ->
120
+
unit ->
121
+
(unit, error) result
134
122
135
-
Aborts if any checkout has uncommitted changes.
136
-
137
-
@param proc Eio process manager.
138
-
@param fs Eio filesystem.
139
-
@param config Monopam configuration.
140
-
@param packages Optional list of packages to push (empty = all).
141
-
@param upstream If true, also push checkouts to their git remotes.
142
-
@param clean If true, clean history by removing unrelated merge commits.
143
-
@param force If true, force push to upstream (use with [--clean]). *)
144
-
145
-
(** {2 Clean} *)
123
+
val remove :
124
+
proc:_ Eio.Process.mgr ->
125
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
126
+
config:Config.t ->
127
+
package:string ->
128
+
unit ->
129
+
(unit, error) result
146
130
147
131
val clean :
148
132
proc:_ Eio.Process.mgr ->
···
152
136
force:bool ->
153
137
unit ->
154
138
(unit, error) result
155
-
(** [clean ~proc ~fs ~config ~dry_run ~force ()] removes empty commits from the
156
-
monorepo and all checkout histories.
157
-
158
-
An empty commit is one where the tree is unchanged from its first parent (no
159
-
actual file changes). These typically result from subtree merge operations.
160
-
161
-
@param proc Eio process manager.
162
-
@param fs Eio filesystem.
163
-
@param config Monopam configuration.
164
-
@param dry_run If true, only report what would be cleaned without changes.
165
-
@param force If true, force-push cleaned checkouts to upstream remotes. *)
166
-
167
-
(** {2 Opam Metadata Sync} *)
168
-
169
-
type opam_sync_result = Opam_sync.t
170
-
(** Result of syncing opam files from monorepo to opam-repo. *)
171
139
172
140
val pp_opam_sync_result : opam_sync_result Fmt.t
173
-
(** [pp_opam_sync_result] formats an opam sync result. *)
174
141
175
142
val sync_opam_files :
176
143
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
178
145
?packages:string list ->
179
146
unit ->
180
147
(opam_sync_result, error) result
181
-
(** [sync_opam_files ~fs ~config ?packages ()] generates opam-repo entries from
182
-
monorepo dune-project files.
183
148
184
-
For each subtree directory in the monorepo: 1. Parses the dune-project to
185
-
extract source/homepage URL 2. For each .opam file in the subtree:
186
-
- Transforms it by removing dune-generated comment
187
-
- Adds dev-repo and url fields derived from dune-project
188
-
- Writes to opam-repo/packages/<name>/<name>.dev/opam 3. Deletes any
189
-
orphaned packages in opam-repo not found in monorepo (only when syncing
190
-
all packages) 4. Stages and commits changes in opam-repo
191
-
192
-
This is a generation-based approach - opam-repo is derived entirely from
193
-
monorepo dune-project and [.opam] files.
194
-
195
-
@param fs Eio filesystem.
196
-
@param config Monopam configuration.
197
-
@param packages Optional list of package/subtree names to sync. *)
198
-
199
-
(** {2 Package Management} *)
200
-
201
-
val add :
202
-
proc:_ Eio.Process.mgr ->
149
+
val discover_packages_from_monorepo :
203
150
fs:Eio.Fs.dir_ty Eio.Path.t ->
204
151
config:Config.t ->
205
-
package:string ->
206
-
unit ->
207
-
(unit, error) result
208
-
(** [add ~proc ~fs ~config ~package ()] adds a package to the monorepo.
209
-
210
-
Clones the checkout if needed and adds the subtree.
211
-
212
-
@param proc Eio process manager.
213
-
@param fs Eio filesystem.
214
-
@param config Monopam configuration.
215
-
@param package Package name to add. *)
216
-
217
-
val remove :
218
-
proc:_ Eio.Process.mgr ->
219
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
220
-
config:Config.t ->
221
-
package:string ->
152
+
?sources:Sources_registry.t ->
222
153
unit ->
223
-
(unit, error) result
224
-
(** [remove ~proc ~fs ~config ~package ()] removes a package from the monorepo.
225
-
226
-
Removes the subtree directory but does not delete the checkout.
227
-
228
-
@param proc Eio process manager.
229
-
@param fs Eio filesystem.
230
-
@param config Monopam configuration.
231
-
@param package Package name to remove. *)
232
-
233
-
(** {1 Package Discovery} *)
154
+
(monorepo_package list, error) result
234
155
235
156
val discover_packages :
236
157
fs:Eio.Fs.dir_ty Eio.Path.t ->
237
158
config:Config.t ->
238
159
unit ->
239
160
(Package.t list, error) result
240
-
(** [discover_packages ~fs ~config ()] scans the opam repo and returns all
241
-
packages.
242
-
243
-
@param fs Eio filesystem.
244
-
@param config Monopam configuration. *)
245
161
246
162
val package :
247
163
fs:Eio.Fs.dir_ty Eio.Path.t ->
248
164
config:Config.t ->
249
165
string ->
250
166
(Package.t, error) result
251
-
(** [package ~fs ~config name] finds a package by name in the opam repo.
252
-
253
-
@param fs Eio filesystem.
254
-
@param config Monopam configuration.
255
-
@param name Package name to find. *)
256
167
257
168
val unregistered_opam_files :
258
169
fs:Eio.Fs.dir_ty Eio.Path.t ->
259
170
config:Config.t ->
260
171
Package.t list ->
261
172
(string * string) list
262
-
(** [unregistered_opam_files ~fs ~config pkgs] finds opam files in monorepo
263
-
subtree directories that aren't registered in the opam overlay.
264
-
265
-
Returns a list of [(repo_name, package_name)] pairs for each unregistered
266
-
[.opam] file found. This helps identify packages that exist in the source
267
-
repositories but aren't being tracked by the overlay.
268
-
269
-
@param fs Eio filesystem.
270
-
@param config Monopam configuration.
271
-
@param pkgs List of packages discovered from the opam overlay. *)
272
-
273
-
type monorepo_package = Monorepo_pkg.t
274
-
(** Information about a package discovered from the monorepo. *)
275
-
276
-
val discover_packages_from_monorepo :
277
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
278
-
config:Config.t ->
279
-
?sources:Sources_registry.t ->
280
-
unit ->
281
-
(monorepo_package list, error) result
282
-
(** [discover_packages_from_monorepo ~fs ~config ?sources ()] scans monorepo
283
-
subtrees and discovers packages from dune-project files.
284
-
285
-
For each subdirectory of the monorepo with a dune-project file: 1. Checks
286
-
sources.toml for URL override 2. Falls back to dune-project source/homepage
287
-
URL 3. For each .opam file in that directory, transforms it with dev-repo
288
-
and url
289
-
290
-
@param fs Eio filesystem.
291
-
@param config Monopam configuration.
292
-
@param sources Optional sources registry for URL overrides. *)
293
-
294
-
(** {1 Changelog Generation} *)
295
-
296
-
val changes :
297
-
proc:_ Eio.Process.mgr ->
298
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
299
-
config:Config.t ->
300
-
clock:float Eio.Time.clock_ty Eio.Resource.t ->
301
-
?package:string ->
302
-
?weeks:int ->
303
-
?history:int ->
304
-
?dry_run:bool ->
305
-
unit ->
306
-
(unit, error) result
307
-
(** [changes ~proc ~fs ~config ~clock ?package ?weeks ?history ?dry_run ()]
308
-
generates weekly changelog entries using Claude AI.
309
-
310
-
For each repository (or the specified package's repository): 1. Loads or
311
-
creates .changes/<repo>.json 2. For each week that doesn't have an entry,
312
-
retrieves git commits 3. Sends commits to Claude for analysis 4. Saves
313
-
changelog entries back to .changes/<repo>.json
314
-
315
-
Also generates an aggregated CHANGES.md at the monorepo root.
316
-
317
-
@param proc Eio process manager.
318
-
@param fs Eio filesystem.
319
-
@param config Monopam configuration.
320
-
@param clock Eio clock for time operations.
321
-
@param package Optional specific repository to process.
322
-
@param weeks Number of past weeks to analyze (default: 1).
323
-
@param history
324
-
Number of recent weeks to include in CHANGES.md (default: 12).
325
-
@param dry_run If true, preview changes without writing files. *)
326
-
327
-
val changes_daily :
328
-
proc:_ Eio.Process.mgr ->
329
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
330
-
config:Config.t ->
331
-
clock:float Eio.Time.clock_ty Eio.Resource.t ->
332
-
?package:string ->
333
-
?days:int ->
334
-
?history:int ->
335
-
?dry_run:bool ->
336
-
?aggregate:bool ->
337
-
unit ->
338
-
(unit, error) result
339
-
(** [changes_daily ~proc ~fs ~config ~clock ?package ?days ?history ?dry_run
340
-
?aggregate ()] generates daily changelog entries using Claude AI.
341
-
342
-
For each repository (or the specified package's repository): 1. Loads or
343
-
creates .changes/<repo>-daily.json 2. For each day that doesn't have an
344
-
entry, retrieves git commits 3. Sends commits to Claude for analysis 4.
345
-
Saves changelog entries back to .changes/<repo>-daily.json
346
-
347
-
Also generates an aggregated DAILY-CHANGES.md at the monorepo root.
348
-
Repositories with no user-facing changes will have blank entries.
349
-
350
-
If [~aggregate:true], also generates a .changes/YYYYMMDD.json file in the
351
-
aggregated format suitable for the monopam_changes library and poe bot.
352
-
353
-
@param proc Eio process manager.
354
-
@param fs Eio filesystem.
355
-
@param config Monopam configuration.
356
-
@param clock Eio clock for time operations.
357
-
@param package Optional specific repository to process.
358
-
@param days Number of past days to analyze (default: 1).
359
-
@param history
360
-
Number of recent days to include in DAILY-CHANGES.md (default: 30).
361
-
@param dry_run If true, preview changes without writing files.
362
-
@param aggregate
363
-
If true, also generate [.changes/YYYYMMDD.json] aggregated file. *)
364
-
365
-
(** {1 Diff} *)
366
-
367
-
type diff_entry = {
368
-
repo_name : string;
369
-
handle : string;
370
-
relationship : Forks.relationship;
371
-
commits : Git.Repository.log_entry list;
372
-
patches : (string * string) list; (** hash -> patch content *)
373
-
}
374
-
(** A diff entry for a single repository showing commits from a verse member. *)
375
-
376
-
type diff_result = { entries : diff_entry list; forks : Forks.t }
377
-
(** Result of computing diffs for repos needing attention. *)
378
173
379
174
val pp_diff_entry : show_patch:bool -> diff_entry Fmt.t
380
-
(** [pp_diff_entry ~show_patch] formats a single diff entry. If [show_patch] is
381
-
true, includes the patch content for each commit. *)
382
-
383
175
val pp_diff_result : show_patch:bool -> diff_result Fmt.t
384
-
(** [pp_diff_result ~show_patch] formats the full diff result. *)
385
-
176
+
val pp_handle_pull_result : handle_pull_result Fmt.t
177
+
val pp_cherrypick_result : cherrypick_result Fmt.t
386
178
val is_commit_sha : string -> bool
387
-
(** [is_commit_sha s] returns true if [s] looks like a git commit hash (7+
388
-
hexadecimal characters). *)
389
179
390
180
val diff :
391
181
proc:_ Eio.Process.mgr ->
···
397
187
?patch:bool ->
398
188
unit ->
399
189
diff_result
400
-
(** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and
401
-
displays diffs for repositories that need attention from verse members.
402
-
403
-
For each repository where a verse member is ahead (I_am_behind or Diverged),
404
-
retrieves the commit log showing what commits they have that you don't.
405
-
406
-
Remote fetches are cached for 1 hour. Use [~refresh:true] to force fresh
407
-
fetches from all remotes.
408
-
409
-
@param proc Eio process manager.
410
-
@param fs Eio filesystem.
411
-
@param config Monopam configuration.
412
-
@param verse_config Verse configuration.
413
-
@param repo Optional specific repository to show diff for.
414
-
@param refresh If true, force fresh fetches ignoring cache (default: false).
415
-
@param patch
416
-
If true, fetch and include patch content for each commit (default: false).
417
-
*)
418
-
419
-
type commit_info = {
420
-
commit_repo : string;
421
-
commit_handle : string;
422
-
commit_hash : string;
423
-
commit_subject : string;
424
-
commit_author : string;
425
-
commit_patch : string;
426
-
}
427
-
(** Result of looking up a specific commit *)
428
190
429
191
val diff_show_commit :
430
192
proc:_ Eio.Process.mgr ->
···
435
197
?refresh:bool ->
436
198
unit ->
437
199
commit_info option
438
-
(** [diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?refresh ()] finds
439
-
and shows the patch for a specific commit SHA from the diff output.
440
-
441
-
Searches through all repos with actionable verse sources to find a commit
442
-
matching the given SHA prefix. Returns [Some commit_info] if found, [None]
443
-
otherwise.
444
-
445
-
@param sha Commit SHA prefix (7+ characters) to look up. *)
446
-
447
-
(** {1 Pull from Verse Members} *)
448
-
449
-
type handle_pull_result = {
450
-
repos_pulled : (string * int) list;
451
-
(** (repo_name, commit_count) for each repo pulled *)
452
-
repos_skipped : string list;
453
-
(** Repos skipped (already in sync or no checkout) *)
454
-
repos_failed : (string * string) list;
455
-
(** (repo_name, error_message) for failures *)
456
-
}
457
-
(** Result of pulling from a handle. *)
458
-
459
-
val pp_handle_pull_result : handle_pull_result Fmt.t
460
-
(** [pp_handle_pull_result] formats a pull result. *)
461
200
462
201
val pull_from_handle :
463
202
proc:_ Eio.Process.mgr ->
···
469
208
?refresh:bool ->
470
209
unit ->
471
210
(handle_pull_result, error) result
472
-
(** [pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?refresh ()]
473
-
pulls commits from a verse member's forks into your local checkouts.
474
-
475
-
For each repository where the handle has commits you don't have: 1. Merges
476
-
their commits into your checkout's main branch 2. The changes are then ready
477
-
to be synced to the monorepo via [sync]
478
-
479
-
If [repo] is specified, only pulls from that repository. Otherwise, pulls
480
-
from all repositories where the handle is ahead.
481
-
482
-
@param handle The verse member handle (e.g., ["avsm.bsky.social"]).
483
-
@param repo Optional specific repository to pull from.
484
-
@param refresh If true, force fresh fetches ignoring cache (default: false).
485
-
*)
486
-
487
-
(** {1 Cherry-pick} *)
488
-
489
-
type cherrypick_result = {
490
-
repo_name : string;
491
-
commit_hash : string;
492
-
commit_subject : string;
493
-
}
494
-
(** Result of cherry-picking a commit. *)
495
-
496
-
val pp_cherrypick_result : cherrypick_result Fmt.t
497
-
(** [pp_cherrypick_result] formats a cherry-pick result. *)
498
211
499
212
val cherrypick :
500
213
proc:_ Eio.Process.mgr ->
···
505
218
?refresh:bool ->
506
219
unit ->
507
220
(cherrypick_result, error) result
508
-
(** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()] applies a
509
-
specific commit from a verse member's fork to your local checkout.
510
-
511
-
Finds the commit in the verse diff output and cherry-picks it into the
512
-
appropriate local checkout. The changes are then ready to be synced to the
513
-
monorepo via [sync].
514
-
515
-
@param sha Commit SHA prefix (7+ characters) to cherry-pick
516
-
@param refresh If true, force fresh fetches ignoring cache (default: false)
517
-
*)
+249
lib/pull.ml
+249
lib/pull.ml
···
1
+
(** Pull operations for syncing upstream changes to the monorepo.
2
+
3
+
Clones/fetches checkouts and merges subtrees from local checkouts. *)
4
+
5
+
let src = Logs.Src.create "monopam.pull" ~doc:"Monopam pull operations"
6
+
7
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
9
+
(** {1 Types} *)
10
+
11
+
type result = {
12
+
repo_name : string;
13
+
cloned : bool;
14
+
commits_pulled : int;
15
+
subtree_added : bool;
16
+
}
17
+
18
+
(** {1 Subtree Operations} *)
19
+
20
+
let subtree ~proc ~fs ~config pkg =
21
+
let fs = Ctx.fs_typed fs in
22
+
let monorepo = Config.Paths.monorepo config in
23
+
let checkouts_root = Config.Paths.checkouts config in
24
+
let prefix = Package.subtree_prefix pkg in
25
+
let branch = Ctx.branch ~config pkg in
26
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
27
+
let url = Uri.of_string (Fpath.to_string checkout_dir) in
28
+
let subtree_exists = Ctx.is_directory ~fs Fpath.(monorepo / prefix) in
29
+
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
30
+
| Error e -> Error (Ctx.Git_error e)
31
+
| Ok hash_hex ->
32
+
let git_repo = Git.Repository.open_repo ~fs monorepo in
33
+
let commit = Git.Hash.of_hex hash_hex in
34
+
let user =
35
+
match Git_cli.global_git_user () with
36
+
| Some u -> u
37
+
| None ->
38
+
Git.User.v ~name:"monopam" ~email:"monopam@localhost"
39
+
~date:(Int64.of_float (Unix.time ()))
40
+
()
41
+
in
42
+
if subtree_exists then begin
43
+
Log.info (fun m ->
44
+
m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir);
45
+
let message =
46
+
Fmt.str
47
+
"Merge '%s/' from %s\n\n\
48
+
git-subtree-dir: %s\n\
49
+
git-subtree-mainline: %s\n"
50
+
prefix (Uri.to_string url) prefix hash_hex
51
+
in
52
+
match
53
+
Git.Subtree.merge git_repo ~prefix ~commit ~author:user
54
+
~committer:user ~message ()
55
+
with
56
+
| Ok _ -> Ok false
57
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
58
+
end
59
+
else begin
60
+
Log.info (fun m ->
61
+
m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir);
62
+
let message =
63
+
Fmt.str
64
+
"Add '%s/' from %s\n\n\
65
+
git-subtree-dir: %s\n\
66
+
git-subtree-mainline: %s\n"
67
+
prefix (Uri.to_string url) prefix hash_hex
68
+
in
69
+
match
70
+
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
71
+
~message ()
72
+
with
73
+
| Ok _ -> Ok true
74
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
75
+
end
76
+
77
+
(** {1 Main Pull Operation} *)
78
+
79
+
let pull ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
80
+
let fs_t = Ctx.fs_typed fs in
81
+
let opam_repo = Config.Paths.opam_repo config in
82
+
if Git.Repository.is_repo ~fs:fs_t opam_repo then begin
83
+
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
84
+
let result =
85
+
let ( let* ) = Result.bind in
86
+
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
87
+
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
88
+
in
89
+
match result with
90
+
| Ok () -> ()
91
+
| Error e ->
92
+
Log.warn (fun m ->
93
+
m "Failed to update opam repo: %a" Git_cli.pp_error e)
94
+
end
95
+
else begin
96
+
match opam_repo_url with
97
+
| Some url -> (
98
+
Log.info (fun m ->
99
+
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
100
+
let url = Uri.of_string url in
101
+
let branch = Config.default_branch in
102
+
match Git_cli.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
103
+
| Ok () -> Log.info (fun m -> m "Opam repo cloned successfully")
104
+
| Error e ->
105
+
Log.warn (fun m ->
106
+
m "Failed to clone opam repo: %a" Git_cli.pp_error e))
107
+
| None ->
108
+
Log.info (fun m ->
109
+
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
110
+
opam_repo)
111
+
end;
112
+
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
113
+
match Init.ensure ~proc ~fs:fs_t ~config with
114
+
| Error e -> Error e
115
+
| Ok () -> (
116
+
match Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
117
+
| Error e -> Error e
118
+
| Ok all_pkgs ->
119
+
let pkgs =
120
+
match packages with
121
+
| [] -> all_pkgs
122
+
| names ->
123
+
List.filter (fun p -> List.mem (Package.name p) names) all_pkgs
124
+
in
125
+
if pkgs = [] && packages <> [] then
126
+
Error (Ctx.Package_not_found (List.hd packages))
127
+
else begin
128
+
Log.info (fun m ->
129
+
m "Checking status of %d packages" (List.length pkgs));
130
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
131
+
let dirty =
132
+
List.filter Status.has_local_changes statuses
133
+
|> List.map (fun s -> s.Status.package)
134
+
in
135
+
if dirty <> [] then Error (Ctx.Dirty_state dirty)
136
+
else begin
137
+
let repos = Ctx.unique_repos pkgs in
138
+
Log.info (fun m ->
139
+
m "Cloning/fetching %d unique repositories"
140
+
(List.length repos));
141
+
let clone_repos () =
142
+
let total = List.length repos in
143
+
let progress = Tty.Progress.create ~total "Fetch" in
144
+
let rec loop acc = function
145
+
| [] ->
146
+
Tty.Progress.clear progress;
147
+
Ok (List.rev acc)
148
+
| pkg :: rest -> (
149
+
let repo_name = Package.repo_name pkg in
150
+
Tty.Progress.message progress
151
+
(Fmt.str "Fetch: %s (%d/%d)" repo_name
152
+
(List.length acc + 1)
153
+
total);
154
+
Log.info (fun m -> m "Fetching repo %s" repo_name);
155
+
let existed = Ctx.checkout_exists ~fs:fs_t ~config pkg in
156
+
let behind_before =
157
+
if existed then Ctx.behind ~fs:fs_t ~config pkg else 0
158
+
in
159
+
match Ctx.ensure_checkout ~proc ~fs:fs_t ~config pkg with
160
+
| Error e ->
161
+
Tty.Progress.clear progress;
162
+
Error (Ctx.Git_error e)
163
+
| Ok () ->
164
+
Tty.Progress.tick progress;
165
+
let result =
166
+
{
167
+
repo_name;
168
+
cloned = not existed;
169
+
commits_pulled = behind_before;
170
+
subtree_added = false;
171
+
}
172
+
in
173
+
loop (result :: acc) rest)
174
+
in
175
+
loop [] repos
176
+
in
177
+
match clone_repos () with
178
+
| Error e -> Error e
179
+
| Ok checkout_results -> (
180
+
Log.info (fun m ->
181
+
m "Processing %d unique subtrees" (List.length repos));
182
+
let total = List.length repos in
183
+
let progress = Tty.Progress.create ~total "Subtree" in
184
+
let rec loop results_acc repos_left checkout_results_left =
185
+
match (repos_left, checkout_results_left) with
186
+
| [], [] ->
187
+
Tty.Progress.clear progress;
188
+
Ok (List.rev results_acc)
189
+
| pkg :: rest_repos, cr :: rest_cr -> (
190
+
let name = Package.subtree_prefix pkg in
191
+
Tty.Progress.message progress
192
+
(Fmt.str "Subtree: %s (%d/%d)" name
193
+
(List.length results_acc + 1)
194
+
total);
195
+
Log.info (fun m -> m "Subtree %s" name);
196
+
match subtree ~proc ~fs ~config pkg with
197
+
| Ok subtree_added ->
198
+
Tty.Progress.tick progress;
199
+
let result = { cr with subtree_added } in
200
+
loop (result :: results_acc) rest_repos rest_cr
201
+
| Error e ->
202
+
Tty.Progress.clear progress;
203
+
Error e)
204
+
| _ ->
205
+
Tty.Progress.clear progress;
206
+
Ok (List.rev results_acc)
207
+
in
208
+
match loop [] repos checkout_results with
209
+
| Error e -> Error e
210
+
| Ok results ->
211
+
let cloned = List.filter (fun r -> r.cloned) results in
212
+
let updated =
213
+
List.filter
214
+
(fun r -> (not r.cloned) && r.commits_pulled > 0)
215
+
results
216
+
in
217
+
let added =
218
+
List.filter (fun r -> r.subtree_added) results
219
+
in
220
+
List.iter
221
+
(fun r ->
222
+
Log.app (fun m -> m " + %s (cloned)" r.repo_name))
223
+
cloned;
224
+
List.iter
225
+
(fun r ->
226
+
Log.app (fun m ->
227
+
m " ✓ %s (%d commits)" r.repo_name
228
+
r.commits_pulled))
229
+
updated;
230
+
List.iter
231
+
(fun r ->
232
+
Log.app (fun m -> m " + %s (added)" r.repo_name))
233
+
added;
234
+
let unchanged =
235
+
List.length results - List.length cloned
236
+
- List.length updated - List.length added
237
+
in
238
+
if cloned = [] && updated = [] && added = [] then
239
+
Log.app (fun m ->
240
+
m " All %d repositories up to date."
241
+
(List.length results))
242
+
else if unchanged > 0 then
243
+
Log.app (fun m -> m " %d unchanged." unchanged);
244
+
Init.write_readme ~proc ~fs:fs_t ~config all_pkgs;
245
+
Init.write_claude_md ~proc ~fs:fs_t ~config;
246
+
Init.write_dune_project ~proc ~fs:fs_t ~config all_pkgs;
247
+
Ok ())
248
+
end
249
+
end)
+261
lib/push.ml
+261
lib/push.ml
···
1
+
(** Push operations for exporting monorepo changes to checkouts and upstream.
2
+
3
+
Uses subtree split to extract commits for each package and pushes to local
4
+
checkouts and optionally to remote upstreams. *)
5
+
6
+
let src = Logs.Src.create "monopam.push" ~doc:"Monopam push operations"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
(** {1 Single Package Push} *)
11
+
12
+
let one ~proc ~fs ~config ~clean pkg =
13
+
let ( let* ) r f =
14
+
Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
15
+
in
16
+
let fs = Ctx.fs_typed fs in
17
+
let monorepo = Config.Paths.monorepo config in
18
+
let prefix = Package.subtree_prefix pkg in
19
+
let checkouts_root = Config.Paths.checkouts config in
20
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
21
+
let branch = Ctx.branch ~config pkg in
22
+
if not (Ctx.is_directory ~fs Fpath.(monorepo / prefix)) then begin
23
+
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
24
+
Ok ()
25
+
end
26
+
else begin
27
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
28
+
let needs_clone =
29
+
match Eio.Path.kind ~follow:true checkout_eio with
30
+
| exception Eio.Io _ -> true
31
+
| `Directory when Git.Repository.is_repo ~fs checkout_dir -> false
32
+
| _ -> true
33
+
in
34
+
let* () =
35
+
if needs_clone then begin
36
+
Log.info (fun m -> m "Creating checkout for %s" (Package.repo_name pkg));
37
+
Ctx.ensure_checkout ~proc ~fs:(fs :> _ Eio.Path.t) ~config pkg
38
+
end
39
+
else Ok ()
40
+
in
41
+
let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in
42
+
let git_repo = Git.Repository.open_repo ~fs monorepo in
43
+
let checkout_repo = Git.Repository.open_repo ~fs checkout_dir in
44
+
let mono_tree =
45
+
Git.Repository.tree_hash_at_path git_repo ~rev:"HEAD" ~path:prefix
46
+
in
47
+
let checkout_tree =
48
+
match Git.Repository.head checkout_repo with
49
+
| None -> None
50
+
| Some h -> (
51
+
match Git.Repository.read checkout_repo h with
52
+
| Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
53
+
| _ -> None)
54
+
in
55
+
if mono_tree = checkout_tree && mono_tree <> None then begin
56
+
Log.debug (fun m -> m "Skipping %s (trees match)" prefix);
57
+
Ok ()
58
+
end
59
+
else begin
60
+
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
61
+
let _checked, errors = Git.Subtree.verify git_repo ~prefix () in
62
+
if errors <> [] then begin
63
+
Log.info (fun m ->
64
+
m "Clearing invalid cache for %s (%d errors)" prefix
65
+
(List.length errors));
66
+
Git.Subtree.Cache.clear git_repo ~prefix
67
+
end;
68
+
match Git.Repository.read_ref git_repo "HEAD" with
69
+
| None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
70
+
| Some head -> (
71
+
match Git.Subtree.split git_repo ~prefix ~head () with
72
+
| Ok None ->
73
+
Error (Ctx.Git_error (Git_cli.Subtree_prefix_missing prefix))
74
+
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
75
+
| Ok (Some split_hash) -> (
76
+
let final_hash =
77
+
if clean then (
78
+
match
79
+
Git.Subtree.fix git_repo ~prefix ~head:split_hash ()
80
+
with
81
+
| Ok (Some h) ->
82
+
Log.info (fun m -> m "Cleaned history for %s" prefix);
83
+
h
84
+
| Ok None -> split_hash
85
+
| Error (`Msg msg) ->
86
+
Log.warn (fun m -> m "Failed to clean %s: %s" prefix msg);
87
+
split_hash)
88
+
else split_hash
89
+
in
90
+
let refspec =
91
+
Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch
92
+
in
93
+
match
94
+
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
95
+
~refspec ~force:clean ()
96
+
with
97
+
| Ok () -> Ok ()
98
+
| Error e -> Error (Ctx.Git_error e)))
99
+
end
100
+
end
101
+
102
+
(** {1 Workspace Repo Push} *)
103
+
104
+
let workspace_repos ~proc ~fs ~config ~force =
105
+
let push_repo name path =
106
+
if Git.Repository.is_repo ~fs path then begin
107
+
let repo = Git.Repository.open_repo ~fs path in
108
+
match Git.Repository.get_remote_url repo "origin" with
109
+
| None -> Log.debug (fun m -> m "%s has no origin remote, skipping" name)
110
+
| Some _ -> (
111
+
match
112
+
Git_cli.push_remote ~proc ~fs:(fs :> _ Eio.Path.t) ~force path
113
+
with
114
+
| Ok () -> Log.app (fun m -> m " ✓ %s" name)
115
+
| Error (Git_cli.Command_failed (_, result))
116
+
when String.starts_with ~prefix:"Everything up-to-date"
117
+
result.Git_cli.stderr ->
118
+
Log.app (fun m -> m " ✓ %s (already synced)" name)
119
+
| Error e -> Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e)
120
+
)
121
+
end
122
+
in
123
+
let mono = Config.Paths.monorepo config in
124
+
let opam_repo = Config.Paths.opam_repo config in
125
+
push_repo "mono" mono;
126
+
push_repo "opam-repo" opam_repo
127
+
128
+
(** {1 Main Push Operation} *)
129
+
130
+
let push ~proc ~fs ~config ?(packages = []) ?(upstream = false) ?(clean = false)
131
+
?(force = false) () =
132
+
let fs_t = Ctx.fs_typed fs in
133
+
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
134
+
match Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
135
+
| Error e -> Error e
136
+
| Ok all_pkgs ->
137
+
let pkgs =
138
+
match packages with
139
+
| [] -> all_pkgs
140
+
| names ->
141
+
List.filter (fun p -> List.mem (Package.name p) names) all_pkgs
142
+
in
143
+
if pkgs = [] && packages <> [] then
144
+
Error (Ctx.Package_not_found (List.hd packages))
145
+
else begin
146
+
Log.info (fun m ->
147
+
m "Checking status of %d packages" (List.length pkgs));
148
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
149
+
let dirty =
150
+
List.filter Status.has_local_changes statuses
151
+
|> List.map (fun s -> s.Status.package)
152
+
in
153
+
if dirty <> [] then Error (Ctx.Dirty_state dirty)
154
+
else begin
155
+
let status_by_prefix =
156
+
List.fold_left
157
+
(fun acc s ->
158
+
let prefix = Package.subtree_prefix s.Status.package in
159
+
(prefix, s) :: acc)
160
+
[] statuses
161
+
in
162
+
let needs_export pkg =
163
+
let prefix = Package.subtree_prefix pkg in
164
+
match List.assoc_opt prefix status_by_prefix with
165
+
| Some s -> not (Status.is_fully_synced s)
166
+
| None -> true
167
+
in
168
+
let all_repos = Ctx.unique_repos pkgs in
169
+
let repos = List.filter needs_export all_repos in
170
+
let skipped = List.length all_repos - List.length repos in
171
+
if skipped > 0 then
172
+
Log.info (fun m -> m "Skipping %d already-synced repos" skipped);
173
+
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
174
+
let n_repos = List.length repos in
175
+
if n_repos = 0 then begin
176
+
Log.app (fun m -> m "Nothing to push (all repos in sync)");
177
+
Ok ()
178
+
end
179
+
else begin
180
+
let total = if upstream then n_repos * 2 else n_repos in
181
+
let progress = Tty.Progress.create ~total "Push" in
182
+
let update_progress phase name =
183
+
Tty.Progress.update progress ~phase ~msg:name
184
+
in
185
+
let rec loop pushed_repos = function
186
+
| [] -> Ok (List.rev pushed_repos)
187
+
| pkg :: rest -> (
188
+
let name = Package.subtree_prefix pkg in
189
+
update_progress "Export" name;
190
+
Log.debug (fun m -> m "Subtree push %s" name);
191
+
match one ~proc ~fs ~config ~clean pkg with
192
+
| Ok () -> loop (pkg :: pushed_repos) rest
193
+
| Error e ->
194
+
Tty.Progress.clear progress;
195
+
Error e)
196
+
in
197
+
match loop [] repos with
198
+
| Error e -> Error e
199
+
| Ok pushed_repos -> (
200
+
let push_results =
201
+
if upstream && pushed_repos <> [] then begin
202
+
Log.info (fun m ->
203
+
m "Pushing %d repos to upstream (parallel)"
204
+
(List.length pushed_repos));
205
+
let checkouts_root = Config.Paths.checkouts config in
206
+
Eio.Fiber.List.map ~max_fibers:8
207
+
(fun pkg ->
208
+
let checkout_dir =
209
+
Package.checkout_dir ~checkouts_root pkg
210
+
in
211
+
let name = Package.repo_name pkg in
212
+
update_progress "Push" name;
213
+
let branch = Ctx.branch ~config pkg in
214
+
let knot = Config.knot config in
215
+
let push_url =
216
+
Ctx.url_to_push_url ~knot (Package.dev_repo pkg)
217
+
in
218
+
Log.info (fun m -> m "Pushing %s to %s" name push_url);
219
+
let repo =
220
+
Git.Repository.open_repo ~fs:fs_t checkout_dir
221
+
in
222
+
(match
223
+
Git.Repository.set_push_url repo ~name:"origin"
224
+
~url:push_url
225
+
with
226
+
| Ok () -> ()
227
+
| Error (`Msg msg) ->
228
+
Log.warn (fun m ->
229
+
m "Failed to set push URL: %s" msg));
230
+
match
231
+
Git_cli.push_remote ~proc ~fs:fs_t ~branch ~force
232
+
checkout_dir
233
+
with
234
+
| Ok () -> Ok name
235
+
| Error e -> Error (name, Ctx.Git_error e))
236
+
pushed_repos
237
+
end
238
+
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
239
+
in
240
+
Tty.Progress.clear progress;
241
+
let successes, failures =
242
+
List.partition_map
243
+
(function
244
+
| Ok name -> Left name | Error (name, _) -> Right name)
245
+
push_results
246
+
in
247
+
List.iter
248
+
(fun name -> Log.app (fun m -> m " ✓ %s" name))
249
+
successes;
250
+
List.iter
251
+
(fun name -> Log.app (fun m -> m " ✗ %s" name))
252
+
failures;
253
+
match List.find_opt Result.is_error push_results with
254
+
| Some (Error (_, e)) -> Error e
255
+
| _ ->
256
+
if upstream then
257
+
workspace_repos ~proc ~fs:fs_t ~config ~force;
258
+
Ok ())
259
+
end
260
+
end
261
+
end
+22
lib/remove.ml
+22
lib/remove.ml
···
1
+
(** Remove a package subtree from the monorepo.
2
+
3
+
Deletes the subtree directory from the monorepo. Does not affect the opam
4
+
overlay or upstream repository. *)
5
+
6
+
let src = Logs.Src.create "monopam.remove" ~doc:"Monopam remove operation"
7
+
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
let remove ~fs ~config ~package () =
11
+
let fs = Ctx.fs_typed fs in
12
+
let monorepo = Config.Paths.monorepo config in
13
+
let prefix = package in
14
+
if not (Ctx.is_directory ~fs Fpath.(monorepo / prefix)) then Ok ()
15
+
else
16
+
let subtree_path = Eio.Path.(fs / Fpath.to_string monorepo / prefix) in
17
+
try
18
+
Log.info (fun m -> m "Removing subtree %s" prefix);
19
+
Eio.Path.rmtree subtree_path;
20
+
Ok ()
21
+
with Eio.Io _ as e ->
22
+
Error (Ctx.Git_error (Git_cli.Io_error (Printexc.to_string e)))