jon.recoil.org
forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
init
anil.recoil.org
+1
.gitignore
+1
.gitignore
···
1
+
_build
+4
bin/dune
+4
bin/dune
+360
bin/main.ml
+360
bin/main.ml
···
1
+
open Cmdliner
2
+
3
+
let setup_logging style_renderer level =
4
+
Fmt_tty.setup_std_outputs ?style_renderer ();
5
+
Logs.set_level level;
6
+
Logs.set_reporter (Logs_fmt.reporter ())
7
+
8
+
let logging_term =
9
+
Term.(const setup_logging $ Fmt_cli.style_renderer () $ Logs_cli.level ())
10
+
11
+
let config_file_arg =
12
+
let doc = "Path to config file. If not specified, searches current directory then XDG locations." in
13
+
Arg.(value & opt (some string) None & info [ "c"; "config" ] ~docv:"FILE" ~doc)
14
+
15
+
let package_arg =
16
+
let doc = "Package name. If not specified, operates on all packages." in
17
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
18
+
19
+
let load_config env config_file =
20
+
let fs = Eio.Stdenv.fs env in
21
+
let cwd = Eio.Stdenv.cwd env in
22
+
match config_file with
23
+
| Some path -> (
24
+
(* If absolute, use fs; if relative, use cwd *)
25
+
let load_path = Fpath.v path in
26
+
if Fpath.is_abs load_path then
27
+
Monopam.Config.load ~fs ~root_fs:fs load_path
28
+
else
29
+
match Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs load_path with
30
+
| Ok c -> Ok c
31
+
| Error msg -> Error msg)
32
+
| None -> (
33
+
(* Try current directory first *)
34
+
let cwd_config = Fpath.v "monopam.toml" in
35
+
match Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs cwd_config with
36
+
| Ok c -> Ok c
37
+
| Error _ ->
38
+
(* Try XDG *)
39
+
let xdg = Xdge.create fs "monopam" in
40
+
match Monopam.Config.load_xdg ~xdg () with
41
+
| Ok c -> Ok c
42
+
| Error msg -> Error msg)
43
+
44
+
let with_config env config_file f =
45
+
match load_config env config_file with
46
+
| Ok config -> f config
47
+
| Error msg ->
48
+
Fmt.epr "Error loading config: %s@." msg;
49
+
`Error (false, "configuration error")
50
+
51
+
(* Status command *)
52
+
53
+
let status_cmd =
54
+
let doc = "Show synchronization status of all packages" in
55
+
let man = [
56
+
`S Manpage.s_description;
57
+
`P "Displays the status of each package discovered in the opam overlay. \
58
+
For each package, shows whether the checkout is clean or has local \
59
+
changes, and whether the subtree is present in the monorepo.";
60
+
`P "Status indicators:";
61
+
`I ("clean", "Checkout matches remote, no local changes");
62
+
`I ("ahead N, behind M", "Checkout has N unpushed commits and is M commits behind remote");
63
+
`I ("present", "Subtree exists in monorepo");
64
+
`I ("missing", "Subtree not yet added to monorepo");
65
+
] in
66
+
let info = Cmd.info "status" ~doc ~man in
67
+
let run config_file () =
68
+
Eio_main.run @@ fun env ->
69
+
with_config env config_file @@ fun config ->
70
+
let fs = Eio.Stdenv.fs env in
71
+
let proc = Eio.Stdenv.process_mgr env in
72
+
match Monopam.status ~proc ~fs ~config () with
73
+
| Ok statuses ->
74
+
Fmt.pr "%a@." Monopam.Status.pp_summary statuses;
75
+
`Ok ()
76
+
| Error e ->
77
+
Fmt.epr "Error: %a@." Monopam.pp_error e;
78
+
`Error (false, "status failed")
79
+
in
80
+
Cmd.v info Term.(ret (const run $ config_file_arg $ logging_term))
81
+
82
+
(* Pull command *)
83
+
84
+
let pull_cmd =
85
+
let doc = "Pull updates from remotes into monorepo" in
86
+
let man = [
87
+
`S Manpage.s_description;
88
+
`P "Fetches the latest changes from git remotes and updates both the \
89
+
individual checkouts and the monorepo subtrees.";
90
+
`P "For each unique repository:";
91
+
`I ("1.", "Clones the repository if not present, or fetches and fast-forward merges");
92
+
`I ("2.", "Adds or pulls the git subtree into the monorepo");
93
+
`P "If a specific package is given, only that package's repository is processed.";
94
+
`P "The operation will fail if any checkout has uncommitted changes.";
95
+
] in
96
+
let info = Cmd.info "pull" ~doc ~man in
97
+
let run config_file package () =
98
+
Eio_main.run @@ fun env ->
99
+
with_config env config_file @@ fun config ->
100
+
let fs = Eio.Stdenv.fs env in
101
+
let proc = Eio.Stdenv.process_mgr env in
102
+
match Monopam.pull ~proc ~fs ~config ?package () with
103
+
| Ok () ->
104
+
Fmt.pr "Pull completed.@.";
105
+
`Ok ()
106
+
| Error e ->
107
+
Fmt.epr "Error: %a@." Monopam.pp_error e;
108
+
`Error (false, "pull failed")
109
+
in
110
+
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
111
+
112
+
(* Push command *)
113
+
114
+
let push_cmd =
115
+
let doc = "Push changes from monorepo to checkouts" in
116
+
let man = [
117
+
`S Manpage.s_description;
118
+
`P "Extracts changes made in the monorepo and merges them into the \
119
+
individual git checkouts using git subtree split.";
120
+
`P "For each unique repository:";
121
+
`I ("1.", "Splits the subtree commits from the monorepo");
122
+
`I ("2.", "Fast-forward merges the split commits into the checkout");
123
+
`P "After running push, you can review the changes in each checkout \
124
+
and manually push them to the git remotes.";
125
+
`P "The operation will fail if any checkout has uncommitted changes.";
126
+
] in
127
+
let info = Cmd.info "push" ~doc ~man in
128
+
let run config_file package () =
129
+
Eio_main.run @@ fun env ->
130
+
with_config env config_file @@ fun config ->
131
+
let fs = Eio.Stdenv.fs env in
132
+
let proc = Eio.Stdenv.process_mgr env in
133
+
match Monopam.push ~proc ~fs ~config ?package () with
134
+
| Ok () ->
135
+
Fmt.pr "Push completed.@.";
136
+
`Ok ()
137
+
| Error e ->
138
+
Fmt.epr "Error: %a@." Monopam.pp_error e;
139
+
`Error (false, "push failed")
140
+
in
141
+
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
142
+
143
+
(* Add command *)
144
+
145
+
let add_cmd =
146
+
let doc = "Add a package to the monorepo" in
147
+
let man = [
148
+
`S Manpage.s_description;
149
+
`P "Adds a single package from the opam overlay to the monorepo.";
150
+
`P "This clones the package's git repository if not already present, \
151
+
then adds it as a git subtree in the monorepo.";
152
+
] in
153
+
let info = Cmd.info "add" ~doc ~man in
154
+
let package_arg =
155
+
let doc = "Package name to add" in
156
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
157
+
in
158
+
let run config_file package () =
159
+
Eio_main.run @@ fun env ->
160
+
with_config env config_file @@ fun config ->
161
+
let fs = Eio.Stdenv.fs env in
162
+
let proc = Eio.Stdenv.process_mgr env in
163
+
match Monopam.add ~proc ~fs ~config ~package () with
164
+
| Ok () ->
165
+
Fmt.pr "Added %s to monorepo.@." package;
166
+
`Ok ()
167
+
| Error e ->
168
+
Fmt.epr "Error: %a@." Monopam.pp_error e;
169
+
`Error (false, "add failed")
170
+
in
171
+
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
172
+
173
+
(* Remove command *)
174
+
175
+
let remove_cmd =
176
+
let doc = "Remove a package from the monorepo" in
177
+
let man = [
178
+
`S Manpage.s_description;
179
+
`P "Removes a package's subtree directory from the monorepo.";
180
+
`P "This does not delete the git checkout - only the subtree in the monorepo.";
181
+
] in
182
+
let info = Cmd.info "remove" ~doc ~man in
183
+
let package_arg =
184
+
let doc = "Package name to remove" in
185
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc)
186
+
in
187
+
let run config_file package () =
188
+
Eio_main.run @@ fun env ->
189
+
with_config env config_file @@ fun config ->
190
+
let fs = Eio.Stdenv.fs env in
191
+
let proc = Eio.Stdenv.process_mgr env in
192
+
match Monopam.remove ~proc ~fs ~config ~package () with
193
+
| Ok () ->
194
+
Fmt.pr "Removed %s from monorepo.@." package;
195
+
`Ok ()
196
+
| Error e ->
197
+
Fmt.epr "Error: %a@." Monopam.pp_error e;
198
+
`Error (false, "remove failed")
199
+
in
200
+
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
201
+
202
+
(* Init command *)
203
+
204
+
let prompt_path ~stdin ~stdout ~cwd prompt ~default =
205
+
let default_str = match default with Some d -> Fmt.str " [%a]" Fpath.pp d | None -> "" in
206
+
Eio.Flow.copy_string (Fmt.str "%s%s: " prompt default_str) stdout;
207
+
let input = String.trim (Eio.Buf_read.line stdin) in
208
+
let input = if input = "" then Option.map Fpath.to_string default else Some input in
209
+
match input with
210
+
| None -> Error "Path is required"
211
+
| Some s ->
212
+
(* Expand tilde *)
213
+
let s =
214
+
if String.length s > 0 && s.[0] = '~' then
215
+
match Sys.getenv_opt "HOME" with
216
+
| Some home ->
217
+
if String.length s = 1 then home
218
+
else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1)
219
+
else s
220
+
| None -> s
221
+
else s
222
+
in
223
+
match Fpath.of_string s with
224
+
| Error (`Msg m) -> Error m
225
+
| Ok path ->
226
+
(* Convert relative to absolute using cwd *)
227
+
let path =
228
+
if Fpath.is_abs path then path
229
+
else Fpath.(cwd // path |> normalize)
230
+
in
231
+
Ok path
232
+
233
+
let init_cmd =
234
+
let doc = "Initialize a new monopam configuration" in
235
+
let man = [
236
+
`S Manpage.s_description;
237
+
`P "Interactively creates a monopam.toml configuration file in the current \
238
+
directory. Prompts for the paths to the opam overlay, checkouts directory, \
239
+
and monorepo directory.";
240
+
`P "All paths must be absolute. You can use ~/ for your home directory, \
241
+
and relative paths will be converted to absolute based on the current \
242
+
working directory.";
243
+
] in
244
+
let info = Cmd.info "init" ~doc ~man in
245
+
let output_arg =
246
+
let doc = "Output path for config file (default: monopam.toml)" in
247
+
Arg.(value & opt string "monopam.toml" & info [ "o"; "output" ] ~docv:"FILE" ~doc)
248
+
in
249
+
let run output () =
250
+
Eio_main.run @@ fun env ->
251
+
let _fs = Eio.Stdenv.fs env in
252
+
let cwd_path = Eio.Stdenv.cwd env in
253
+
let stdin = Eio.Buf_read.of_flow ~max_size:(1024 * 1024) (Eio.Stdenv.stdin env) in
254
+
let stdout = Eio.Stdenv.stdout env in
255
+
(* Get current working directory as Fpath *)
256
+
let cwd =
257
+
let (_, cwd_str) = (cwd_path :> _ Eio.Path.t) in
258
+
match Fpath.of_string cwd_str with
259
+
| Ok p -> p
260
+
| Error _ -> Fpath.v "/"
261
+
in
262
+
Eio.Flow.copy_string "Monopam Configuration Setup\n" stdout;
263
+
Eio.Flow.copy_string "===========================\n\n" stdout;
264
+
Eio.Flow.copy_string "All paths must be absolute. Use ~/ for home directory.\n" stdout;
265
+
Eio.Flow.copy_string "Relative paths will be converted to absolute.\n\n" stdout;
266
+
(* Prompt for opam_repo *)
267
+
let opam_repo = ref None in
268
+
while !opam_repo = None do
269
+
match prompt_path ~stdin ~stdout ~cwd "Path to opam overlay repository" ~default:None with
270
+
| Ok p -> opam_repo := Some p
271
+
| Error msg ->
272
+
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
273
+
done;
274
+
let opam_repo = Option.get !opam_repo in
275
+
(* Prompt for checkouts *)
276
+
let default_checkouts = Fpath.(parent opam_repo / "src") in
277
+
let checkouts = ref None in
278
+
while !checkouts = None do
279
+
match prompt_path ~stdin ~stdout ~cwd "Path for git checkouts" ~default:(Some default_checkouts) with
280
+
| Ok p -> checkouts := Some p
281
+
| Error msg ->
282
+
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
283
+
done;
284
+
let checkouts = Option.get !checkouts in
285
+
(* Prompt for monorepo *)
286
+
let default_monorepo = Fpath.(parent opam_repo / "mono") in
287
+
let monorepo = ref None in
288
+
while !monorepo = None do
289
+
match prompt_path ~stdin ~stdout ~cwd "Path for monorepo" ~default:(Some default_monorepo) with
290
+
| Ok p -> monorepo := Some p
291
+
| Error msg ->
292
+
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
293
+
done;
294
+
let monorepo = Option.get !monorepo in
295
+
(* Prompt for default branch *)
296
+
Eio.Flow.copy_string "Default git branch [main]: " stdout;
297
+
let branch_input = String.trim (Eio.Buf_read.line stdin) in
298
+
let default_branch = if branch_input = "" then "main" else branch_input in
299
+
(* Create config *)
300
+
let config = Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch () in
301
+
(* Save config *)
302
+
let output_path = Fpath.v output in
303
+
match Monopam.Config.save ~fs:(cwd_path :> _ Eio.Path.t) config output_path with
304
+
| Ok () ->
305
+
Eio.Flow.copy_string (Fmt.str "\nConfiguration saved to %s\n" output) stdout;
306
+
Eio.Flow.copy_string "\nYou can now run 'monopam pull' to initialize the monorepo.\n" stdout;
307
+
`Ok ()
308
+
| Error msg ->
309
+
Fmt.epr "Error saving config: %s@." msg;
310
+
`Error (false, "init failed")
311
+
in
312
+
Cmd.v info Term.(ret (const run $ output_arg $ logging_term))
313
+
314
+
(* Main command group *)
315
+
316
+
let main_cmd =
317
+
let doc = "Manage opam overlay with git subtree monorepo" in
318
+
let man =
319
+
[
320
+
`S Manpage.s_description;
321
+
`P
322
+
"Monopam synchronizes packages between an opam overlay repository, \
323
+
individual git checkouts, and a monorepo using git subtrees.";
324
+
`S "DIRECTORY STRUCTURE";
325
+
`P "Monopam manages three directory trees:";
326
+
`I ("opam-repo/", "The opam overlay repository containing package metadata. \
327
+
Each package's opam file specifies a dev-repo URL pointing to its git source.");
328
+
`I ("src/", "Individual git checkouts of each unique repository. Multiple \
329
+
packages may share a checkout if they come from the same dev-repo. \
330
+
Directory names are the repository basename (e.g., ocaml-yaml from \
331
+
https://github.com/foo/ocaml-yaml.git).");
332
+
`I ("mono/", "The monorepo combining all packages as git subtrees. Each \
333
+
subtree directory is named after the repository basename. This is \
334
+
where you make changes that span multiple packages.");
335
+
`S "WORKFLOW";
336
+
`P "The typical workflow is:";
337
+
`I ("1. monopam pull", "Fetch latest from all remotes, update checkouts, \
338
+
merge into monorepo subtrees");
339
+
`I ("2. Edit code", "Make changes in the mono/ directory");
340
+
`I ("3. git commit", "Commit your changes in mono/");
341
+
`I ("4. monopam push", "Extract changes back to individual checkouts");
342
+
`I ("5. Review and push", "Review changes in src/*/, then git push each one");
343
+
`S "CONFIGURATION";
344
+
`P "Run $(b,monopam init) to interactively create a configuration file. \
345
+
Configuration is read from monopam.toml in the current directory \
346
+
or XDG config locations.";
347
+
`P "All paths in the configuration must be absolute. Example:";
348
+
`Pre "opam_repo = \"/home/user/opam-overlay\"\n\
349
+
checkouts = \"/home/user/src\"\n\
350
+
monorepo = \"/home/user/mono\"\n\
351
+
default_branch = \"main\"";
352
+
`S Manpage.s_commands;
353
+
`P "Use $(b,monopam COMMAND --help) for help on a specific command.";
354
+
]
355
+
in
356
+
let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in
357
+
Cmd.group info
358
+
[ init_cmd; status_cmd; pull_cmd; push_cmd; add_cmd; remove_cmd ]
359
+
360
+
let () = exit (Cmd.eval main_cmd)
+28
dune-project
+28
dune-project
···
1
+
(lang dune 3.20)
2
+
(name monopam)
3
+
4
+
(generate_opam_files true)
5
+
6
+
(source (github avsm/monopam))
7
+
(license ISC)
8
+
(authors "Anil Madhavapeddy <anil@recoil.org>")
9
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
10
+
11
+
(package
12
+
(name monopam)
13
+
(synopsis "Manage opam overlays with git subtree monorepos")
14
+
(description "Monopam helps manage an opam overlay by synchronizing packages between individual git checkouts and a monorepo using git subtrees.")
15
+
(depends
16
+
(ocaml (>= 5.2.0))
17
+
(dune (>= 3.20))
18
+
(eio (>= 1.2))
19
+
(eio_main (>= 1.2))
20
+
(tomlt (>= 0.1.0))
21
+
(xdge (>= 0.1.0))
22
+
(opam-file-format (>= 2.1.0))
23
+
(cmdliner (>= 1.3.0))
24
+
(fmt (>= 0.9.0))
25
+
(logs (>= 0.7.0))
26
+
(uri (>= 4.0.0))
27
+
(fpath (>= 0.7.0))
28
+
(odoc :with-doc)))
+177
lib/config.ml
+177
lib/config.ml
···
1
+
module Package_config = struct
2
+
type t = { branch : string option }
3
+
4
+
let branch t = t.branch
5
+
6
+
let codec : t Tomlt.t =
7
+
Tomlt.(
8
+
Table.(
9
+
obj (fun branch -> { branch })
10
+
|> opt_mem "branch" string ~enc:(fun c -> c.branch)
11
+
|> finish))
12
+
end
13
+
14
+
type t = {
15
+
opam_repo : Fpath.t;
16
+
checkouts : Fpath.t;
17
+
monorepo : Fpath.t;
18
+
default_branch : string;
19
+
packages : (string * Package_config.t) list;
20
+
}
21
+
22
+
module Paths = struct
23
+
let opam_repo t = t.opam_repo
24
+
let checkouts t = t.checkouts
25
+
let monorepo t = t.monorepo
26
+
end
27
+
28
+
let default_branch t = t.default_branch
29
+
let package_config t name = List.assoc_opt name t.packages
30
+
31
+
let create ~opam_repo ~checkouts ~monorepo ?(default_branch = "main") () =
32
+
{ opam_repo; checkouts; monorepo; default_branch; packages = [] }
33
+
34
+
let with_package_override t ~name ~branch:b =
35
+
let pkg_config = Package_config.{ branch = Some b } in
36
+
let packages = (name, pkg_config) :: List.remove_assoc name t.packages in
37
+
{ t with packages }
38
+
39
+
let expand_tilde s =
40
+
if String.length s > 0 && s.[0] = '~' then
41
+
match Sys.getenv_opt "HOME" with
42
+
| Some home ->
43
+
if String.length s = 1 then home
44
+
else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1)
45
+
else s
46
+
| None -> s
47
+
else s
48
+
49
+
let fpath_codec : Fpath.t Tomlt.t =
50
+
Tomlt.map
51
+
~dec:(fun s ->
52
+
let s = expand_tilde s in
53
+
match Fpath.of_string s with
54
+
| Ok p -> p
55
+
| Error (`Msg m) -> failwith m)
56
+
~enc:Fpath.to_string Tomlt.string
57
+
58
+
let codec : t Tomlt.t =
59
+
Tomlt.(
60
+
Table.(
61
+
obj
62
+
(fun opam_repo checkouts monorepo default_branch packages ->
63
+
{
64
+
opam_repo;
65
+
checkouts;
66
+
monorepo;
67
+
default_branch = Option.value ~default:"main" default_branch;
68
+
packages;
69
+
})
70
+
|> mem "opam_repo" fpath_codec ~enc:(fun c -> c.opam_repo)
71
+
|> mem "checkouts" fpath_codec ~enc:(fun c -> c.checkouts)
72
+
|> mem "monorepo" fpath_codec ~enc:(fun c -> c.monorepo)
73
+
|> opt_mem "default_branch" string
74
+
~enc:(fun c ->
75
+
if c.default_branch = "main" then None else Some c.default_branch)
76
+
|> keep_unknown
77
+
~enc:(fun c -> c.packages)
78
+
(Mems.assoc Package_config.codec)
79
+
|> finish))
80
+
81
+
type validation_error =
82
+
| Path_not_found of string * Fpath.t
83
+
| Not_a_directory of string * Fpath.t
84
+
| Not_an_opam_repo of Fpath.t
85
+
| Invalid_path of string * string
86
+
| Relative_path of string * Fpath.t
87
+
88
+
let pp_validation_error ppf = function
89
+
| Path_not_found (field, path) ->
90
+
Fmt.pf ppf "%s path does not exist: %a" field Fpath.pp path
91
+
| Not_a_directory (field, path) ->
92
+
Fmt.pf ppf "%s path is not a directory: %a" field Fpath.pp path
93
+
| Not_an_opam_repo path ->
94
+
Fmt.pf ppf
95
+
"opam_repo is not a valid opam repository (missing packages/ directory): %a"
96
+
Fpath.pp path
97
+
| Invalid_path (field, msg) ->
98
+
Fmt.pf ppf "%s has invalid path: %s" field msg
99
+
| Relative_path (field, path) ->
100
+
Fmt.pf ppf "%s must be an absolute path, got: %a\n\
101
+
Hint: Use an absolute path starting with / or ~/" field Fpath.pp path
102
+
103
+
let validate ~fs t =
104
+
(* Get the root filesystem for checking absolute paths *)
105
+
let root_fs =
106
+
let (dir, _) = (fs : _ Eio.Path.t) in
107
+
(dir, "")
108
+
in
109
+
let check_absolute field path =
110
+
if Fpath.is_abs path then Ok ()
111
+
else Error (Relative_path (field, path))
112
+
in
113
+
let check_dir field path =
114
+
let eio_path = Eio.Path.(root_fs / Fpath.to_string path) in
115
+
match Eio.Path.kind ~follow:true eio_path with
116
+
| `Directory -> Ok ()
117
+
| `Regular_file | `Symbolic_link | `Block_device | `Character_special
118
+
| `Fifo | `Socket | `Unknown | `Not_found ->
119
+
Error (Not_a_directory (field, path))
120
+
| exception Eio.Io (Eio.Fs.E (Not_found _), _) ->
121
+
Error (Path_not_found (field, path))
122
+
| exception _ -> Error (Path_not_found (field, path))
123
+
in
124
+
let check_opam_repo path =
125
+
let packages_dir = Fpath.(path / "packages") in
126
+
let eio_path = Eio.Path.(root_fs / Fpath.to_string packages_dir) in
127
+
match Eio.Path.kind ~follow:true eio_path with
128
+
| `Directory -> Ok ()
129
+
| _ -> Error (Not_an_opam_repo path)
130
+
| exception _ -> Error (Not_an_opam_repo path)
131
+
in
132
+
let ( let* ) = Result.bind in
133
+
(* Check all paths are absolute first *)
134
+
let* () = check_absolute "opam_repo" t.opam_repo in
135
+
let* () = check_absolute "checkouts" t.checkouts in
136
+
let* () = check_absolute "monorepo" t.monorepo in
137
+
(* Then check opam_repo exists and is valid *)
138
+
let* () = check_dir "opam_repo" t.opam_repo in
139
+
let* () = check_opam_repo t.opam_repo in
140
+
Ok t
141
+
142
+
let load ~fs ~root_fs path =
143
+
try
144
+
let config = Tomlt_eio.decode_path_exn codec ~fs (Fpath.to_string path) in
145
+
validate ~fs:root_fs config
146
+
|> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e)
147
+
with
148
+
| Eio.Io _ as e -> Error (Printexc.to_string e)
149
+
| Failure msg -> Error (Fmt.str "Invalid config: %s" msg)
150
+
151
+
let load_xdg ~xdg () =
152
+
let config_dir = Xdge.config_dir xdg in
153
+
let config_path = Eio.Path.(config_dir / "config.toml") in
154
+
try
155
+
let config =
156
+
Tomlt_eio.decode_path_exn codec ~fs:config_dir (snd config_path)
157
+
in
158
+
let (dir, _) = config_dir in
159
+
validate ~fs:(dir, "") config
160
+
|> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e)
161
+
with
162
+
| Eio.Io _ as e -> Error (Printexc.to_string e)
163
+
| Failure msg -> Error (Fmt.str "Invalid config: %s" msg)
164
+
165
+
let save ~fs t path =
166
+
try
167
+
Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path);
168
+
Ok ()
169
+
with Eio.Io _ as e -> Error (Printexc.to_string e)
170
+
171
+
let pp ppf t =
172
+
Fmt.pf ppf
173
+
"@[<v>@[<hov 2>paths:@ opam_repo=%a@ checkouts=%a@ monorepo=%a@]@,\
174
+
default_branch=%s@,\
175
+
packages=%d@]"
176
+
Fpath.pp t.opam_repo Fpath.pp t.checkouts Fpath.pp t.monorepo
177
+
t.default_branch (List.length t.packages)
+119
lib/config.mli
+119
lib/config.mli
···
1
+
(** Configuration management for monopam.
2
+
3
+
Configuration is stored in TOML format and loaded from XDG standard
4
+
locations or a user-specified path. The config file specifies paths
5
+
to the opam overlay, individual checkouts, and the monorepo, along
6
+
with optional per-package overrides. *)
7
+
8
+
(** {1 Types} *)
9
+
10
+
(** Per-package configuration overrides. *)
11
+
module Package_config : sig
12
+
(** Package-specific settings. *)
13
+
type t
14
+
15
+
(** [branch t] returns the branch override for this package, if set. *)
16
+
val branch : t -> string option
17
+
end
18
+
19
+
(** The main configuration. *)
20
+
type t
21
+
22
+
(** {1 Paths Configuration} *)
23
+
24
+
(** Path-related accessors. *)
25
+
module Paths : sig
26
+
(** [opam_repo t] returns the path to the opam overlay repository. *)
27
+
val opam_repo : t -> Fpath.t
28
+
29
+
(** [checkouts t] returns the parent directory where individual
30
+
package checkouts are stored. *)
31
+
val checkouts : t -> Fpath.t
32
+
33
+
(** [monorepo t] returns the path to the monorepo directory. *)
34
+
val monorepo : t -> Fpath.t
35
+
end
36
+
37
+
(** {1 Options} *)
38
+
39
+
(** [default_branch t] returns the default git branch to track.
40
+
41
+
Defaults to "main" if not specified. *)
42
+
val default_branch : t -> string
43
+
44
+
(** [package_config t name] returns package-specific configuration
45
+
overrides for the named package, if any exist. *)
46
+
val package_config : t -> string -> Package_config.t option
47
+
48
+
(** {1 Validation} *)
49
+
50
+
(** Errors that can occur when validating configuration paths. *)
51
+
type validation_error =
52
+
| Path_not_found of string * Fpath.t
53
+
(** A configured path does not exist *)
54
+
| Not_a_directory of string * Fpath.t
55
+
(** A configured path is not a directory *)
56
+
| Not_an_opam_repo of Fpath.t
57
+
(** The opam_repo path is not a valid opam repository
58
+
(missing packages/ directory) *)
59
+
| Invalid_path of string * string
60
+
(** A path string could not be parsed *)
61
+
| Relative_path of string * Fpath.t
62
+
(** A configured path is relative but must be absolute *)
63
+
64
+
(** [pp_validation_error] formats validation errors. *)
65
+
val pp_validation_error : validation_error Fmt.t
66
+
67
+
(** {1 Loading and Saving} *)
68
+
69
+
(** [load ~fs ~root_fs path] loads configuration from the specified TOML file.
70
+
71
+
Validates that paths exist and are valid. Supports tilde expansion
72
+
for paths (e.g., [~/src/...]).
73
+
74
+
@param fs The filesystem path for locating the config file
75
+
@param root_fs The root filesystem for validating absolute paths in config
76
+
77
+
Returns [Error msg] if the file cannot be read, parsed, or
78
+
if validation fails. *)
79
+
val load : fs:_ Eio.Path.t -> root_fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
80
+
81
+
(** [load_xdg ~xdg ()] loads configuration from XDG standard locations.
82
+
83
+
Searches for "config.toml" in the monopam XDG config directory.
84
+
Validates that paths exist and are valid. Supports tilde expansion.
85
+
86
+
Returns [Error msg] if no config file is found, parsing fails, or
87
+
if validation fails.
88
+
89
+
@param xdg The Xdge context for "monopam" application *)
90
+
val load_xdg : xdg:Xdge.t -> unit -> (t, string) result
91
+
92
+
(** [save ~fs t path] writes the configuration to the specified path. *)
93
+
val save : fs:_ Eio.Path.t -> t -> Fpath.t -> (unit, string) result
94
+
95
+
(** {1 Construction} *)
96
+
97
+
(** [create ~opam_repo ~checkouts ~monorepo ?default_branch ()] creates
98
+
a new configuration with the specified paths.
99
+
100
+
@param opam_repo Path to the opam overlay repository
101
+
@param checkouts Parent directory for individual git checkouts
102
+
@param monorepo Path to the monorepo
103
+
@param default_branch Default branch to track (default: "main") *)
104
+
val create :
105
+
opam_repo:Fpath.t ->
106
+
checkouts:Fpath.t ->
107
+
monorepo:Fpath.t ->
108
+
?default_branch:string ->
109
+
unit ->
110
+
t
111
+
112
+
(** [with_package_override t ~name ~branch] returns a new config with
113
+
a branch override for the named package. *)
114
+
val with_package_override : t -> name:string -> branch:string -> t
115
+
116
+
(** {1 Pretty Printing} *)
117
+
118
+
(** [pp] is a formatter for configuration. *)
119
+
val pp : t Fmt.t
+13
lib/dune
+13
lib/dune
+179
lib/git.ml
+179
lib/git.ml
···
1
+
type cmd_result = { exit_code : int; stdout : string; stderr : string }
2
+
3
+
type error =
4
+
| Command_failed of string * cmd_result
5
+
| Not_a_repo of Fpath.t
6
+
| Dirty_worktree of Fpath.t
7
+
| Remote_not_found of string
8
+
| Branch_not_found of string
9
+
| Subtree_prefix_exists of string
10
+
| Subtree_prefix_missing of string
11
+
| Io_error of string
12
+
13
+
let pp_error ppf = function
14
+
| Command_failed (cmd, r) ->
15
+
Fmt.pf ppf "Command failed: %s (exit %d)@.stdout: %s@.stderr: %s" cmd
16
+
r.exit_code r.stdout r.stderr
17
+
| Not_a_repo path -> Fmt.pf ppf "Not a git repository: %a" Fpath.pp path
18
+
| Dirty_worktree path ->
19
+
Fmt.pf ppf "Repository has uncommitted changes: %a" Fpath.pp path
20
+
| Remote_not_found name -> Fmt.pf ppf "Remote not found: %s" name
21
+
| Branch_not_found name -> Fmt.pf ppf "Branch not found: %s" name
22
+
| Subtree_prefix_exists prefix ->
23
+
Fmt.pf ppf "Subtree prefix already exists: %s" prefix
24
+
| Subtree_prefix_missing prefix ->
25
+
Fmt.pf ppf "Subtree prefix does not exist: %s" prefix
26
+
| Io_error msg -> Fmt.pf ppf "I/O error: %s" msg
27
+
28
+
let run_git ~proc ~cwd args =
29
+
let cmd = "git" :: args in
30
+
let buf_stdout = Buffer.create 256 in
31
+
let buf_stderr = Buffer.create 256 in
32
+
Eio.Switch.run @@ fun sw ->
33
+
let child =
34
+
Eio.Process.spawn proc ~sw ~cwd
35
+
~stdout:(Eio.Flow.buffer_sink buf_stdout)
36
+
~stderr:(Eio.Flow.buffer_sink buf_stderr)
37
+
cmd
38
+
in
39
+
let exit_status = Eio.Process.await child in
40
+
let exit_code =
41
+
match exit_status with `Exited n -> n | `Signaled n -> 128 + n
42
+
in
43
+
{
44
+
exit_code;
45
+
stdout = Buffer.contents buf_stdout |> String.trim;
46
+
stderr = Buffer.contents buf_stderr |> String.trim;
47
+
}
48
+
49
+
let run_git_ok ~proc ~cwd args =
50
+
let result = run_git ~proc ~cwd args in
51
+
if result.exit_code = 0 then Ok result.stdout
52
+
else Error (Command_failed (String.concat " " ("git" :: args), result))
53
+
54
+
let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
55
+
let (dir, _) = fs in
56
+
(dir, Fpath.to_string path)
57
+
58
+
let is_repo ~proc ~fs path =
59
+
let cwd = path_to_eio ~fs path in
60
+
let result = run_git ~proc ~cwd [ "rev-parse"; "--git-dir" ] in
61
+
result.exit_code = 0
62
+
63
+
let is_dirty ~proc ~fs path =
64
+
let cwd = path_to_eio ~fs path in
65
+
let result = run_git ~proc ~cwd [ "status"; "--porcelain" ] in
66
+
result.exit_code = 0 && result.stdout <> ""
67
+
68
+
let current_branch ~proc ~fs path =
69
+
let cwd = path_to_eio ~fs path in
70
+
let result = run_git ~proc ~cwd [ "symbolic-ref"; "--short"; "HEAD" ] in
71
+
if result.exit_code = 0 then Some result.stdout else None
72
+
73
+
let head_commit ~proc ~fs path =
74
+
let cwd = path_to_eio ~fs path in
75
+
run_git_ok ~proc ~cwd [ "rev-parse"; "HEAD" ]
76
+
77
+
let clone ~proc ~fs ~url ~branch target =
78
+
let parent = Fpath.parent target in
79
+
let cwd = Eio.Path.(fs / Fpath.to_string parent) in
80
+
let target_name = Fpath.basename target in
81
+
let url_str = Uri.to_string url in
82
+
run_git_ok ~proc ~cwd
83
+
[ "clone"; "--branch"; branch; url_str; target_name ]
84
+
|> Result.map ignore
85
+
86
+
let fetch ~proc ~fs ?(remote = "origin") path =
87
+
let cwd = path_to_eio ~fs path in
88
+
run_git_ok ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
89
+
90
+
let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
91
+
let cwd = path_to_eio ~fs path in
92
+
let branch =
93
+
match branch with
94
+
| Some b -> b
95
+
| None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
96
+
in
97
+
let upstream = remote ^ "/" ^ branch in
98
+
run_git_ok ~proc ~cwd [ "merge"; "--ff-only"; upstream ] |> Result.map ignore
99
+
100
+
let pull ~proc ~fs ?(remote = "origin") ?branch path =
101
+
let cwd = path_to_eio ~fs path in
102
+
let args =
103
+
match branch with
104
+
| Some b -> [ "pull"; remote; b ]
105
+
| None -> [ "pull"; remote ]
106
+
in
107
+
run_git_ok ~proc ~cwd args |> Result.map ignore
108
+
109
+
let checkout ~proc ~fs ~branch path =
110
+
let cwd = path_to_eio ~fs path in
111
+
run_git_ok ~proc ~cwd [ "checkout"; branch ] |> Result.map ignore
112
+
113
+
type ahead_behind = { ahead : int; behind : int }
114
+
115
+
let ahead_behind ~proc ~fs ?(remote = "origin") ?branch path =
116
+
let cwd = path_to_eio ~fs path in
117
+
let branch =
118
+
match branch with Some b -> b | None -> Option.value ~default:"HEAD" (current_branch ~proc ~fs path)
119
+
in
120
+
let upstream = remote ^ "/" ^ branch in
121
+
match run_git_ok ~proc ~cwd [ "rev-list"; "--left-right"; "--count"; branch ^ "..." ^ upstream ] with
122
+
| Error e -> Error e
123
+
| Ok output -> (
124
+
match String.split_on_char '\t' output with
125
+
| [ ahead; behind ] ->
126
+
Ok { ahead = int_of_string ahead; behind = int_of_string behind }
127
+
| _ -> Ok { ahead = 0; behind = 0 })
128
+
129
+
module Subtree = struct
130
+
let exists ~fs ~repo ~prefix =
131
+
let path = Eio.Path.(fs / Fpath.to_string repo / prefix) in
132
+
match Eio.Path.kind ~follow:true path with
133
+
| `Directory -> true
134
+
| _ -> false
135
+
| exception _ -> false
136
+
137
+
let add ~proc ~fs ~repo ~prefix ~url ~branch () =
138
+
if exists ~fs ~repo ~prefix then Error (Subtree_prefix_exists prefix)
139
+
else
140
+
let cwd = path_to_eio ~fs repo in
141
+
let url_str = Uri.to_string url in
142
+
run_git_ok ~proc ~cwd
143
+
[ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ]
144
+
|> Result.map ignore
145
+
146
+
let pull ~proc ~fs ~repo ~prefix ~url ~branch () =
147
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
148
+
else
149
+
let cwd = path_to_eio ~fs repo in
150
+
let url_str = Uri.to_string url in
151
+
run_git_ok ~proc ~cwd
152
+
[ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ]
153
+
|> Result.map ignore
154
+
155
+
let push ~proc ~fs ~repo ~prefix ~url ~branch () =
156
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
157
+
else
158
+
let cwd = path_to_eio ~fs repo in
159
+
let url_str = Uri.to_string url in
160
+
run_git_ok ~proc ~cwd
161
+
[ "subtree"; "push"; "--prefix"; prefix; url_str; branch ]
162
+
|> Result.map ignore
163
+
164
+
let split ~proc ~fs ~repo ~prefix () =
165
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
166
+
else
167
+
let cwd = path_to_eio ~fs repo in
168
+
run_git_ok ~proc ~cwd [ "subtree"; "split"; "--prefix"; prefix ]
169
+
end
170
+
171
+
let init ~proc ~fs path =
172
+
let cwd = path_to_eio ~fs (Fpath.parent path) in
173
+
let name = Fpath.basename path in
174
+
run_git_ok ~proc ~cwd [ "init"; name ] |> Result.map ignore
175
+
176
+
let commit_allow_empty ~proc ~fs ~message path =
177
+
let cwd = path_to_eio ~fs path in
178
+
run_git_ok ~proc ~cwd [ "commit"; "--allow-empty"; "-m"; message ]
179
+
|> Result.map ignore
+246
lib/git.mli
+246
lib/git.mli
···
1
+
(** Git operations for monopam.
2
+
3
+
This module provides git operations needed for managing individual
4
+
checkouts and git subtree operations in the monorepo. All operations
5
+
use Eio for process spawning. *)
6
+
7
+
(** {1 Types} *)
8
+
9
+
(** Result of a git command execution. *)
10
+
type cmd_result = {
11
+
exit_code : int;
12
+
stdout : string;
13
+
stderr : string;
14
+
}
15
+
16
+
(** Errors from git operations. *)
17
+
type error =
18
+
| Command_failed of string * cmd_result
19
+
(** Git command failed: (command, result) *)
20
+
| Not_a_repo of Fpath.t
21
+
(** Path is not a git repository *)
22
+
| Dirty_worktree of Fpath.t
23
+
(** Repository has uncommitted changes *)
24
+
| Remote_not_found of string
25
+
(** Named remote does not exist *)
26
+
| Branch_not_found of string
27
+
(** Named branch does not exist *)
28
+
| Subtree_prefix_exists of string
29
+
(** Subtree prefix already exists in repo *)
30
+
| Subtree_prefix_missing of string
31
+
(** Subtree prefix does not exist *)
32
+
| Io_error of string
33
+
(** Filesystem or process error *)
34
+
35
+
(** [pp_error] is a formatter for errors. *)
36
+
val pp_error : error Fmt.t
37
+
38
+
(** {1 Repository Queries} *)
39
+
40
+
(** [is_repo ~proc ~fs path] returns true if path is a git repository. *)
41
+
val is_repo :
42
+
proc:_ Eio.Process.mgr ->
43
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
44
+
Fpath.t ->
45
+
bool
46
+
47
+
(** [is_dirty ~proc ~fs path] returns true if the repository has
48
+
uncommitted changes (staged or unstaged). *)
49
+
val is_dirty :
50
+
proc:_ Eio.Process.mgr ->
51
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
52
+
Fpath.t ->
53
+
bool
54
+
55
+
(** [current_branch ~proc ~fs path] returns the current branch name,
56
+
or [None] if in detached HEAD state. *)
57
+
val current_branch :
58
+
proc:_ Eio.Process.mgr ->
59
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
60
+
Fpath.t ->
61
+
string option
62
+
63
+
(** [head_commit ~proc ~fs path] returns the current HEAD commit hash. *)
64
+
val head_commit :
65
+
proc:_ Eio.Process.mgr ->
66
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
67
+
Fpath.t ->
68
+
(string, error) result
69
+
70
+
(** {1 Basic Operations} *)
71
+
72
+
(** [clone ~proc ~fs ~url ~branch target] clones a repository.
73
+
74
+
@param proc Eio process manager
75
+
@param fs Eio filesystem
76
+
@param url Git remote URL
77
+
@param branch Branch to checkout
78
+
@param target Destination directory *)
79
+
val clone :
80
+
proc:_ Eio.Process.mgr ->
81
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
82
+
url:Uri.t ->
83
+
branch:string ->
84
+
Fpath.t ->
85
+
(unit, error) result
86
+
87
+
(** [fetch ~proc ~fs ?remote path] fetches from the remote.
88
+
89
+
@param remote Remote name (default: "origin") *)
90
+
val fetch :
91
+
proc:_ Eio.Process.mgr ->
92
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
93
+
?remote:string ->
94
+
Fpath.t ->
95
+
(unit, error) result
96
+
97
+
(** [merge_ff ~proc ~fs ?remote ?branch path] performs a fast-forward only
98
+
merge from the remote tracking branch.
99
+
100
+
@param remote Remote name (default: "origin")
101
+
@param branch Branch to merge from (default: current branch) *)
102
+
val merge_ff :
103
+
proc:_ Eio.Process.mgr ->
104
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
105
+
?remote:string ->
106
+
?branch:string ->
107
+
Fpath.t ->
108
+
(unit, error) result
109
+
110
+
(** [pull ~proc ~fs ?remote ?branch path] pulls from the remote.
111
+
112
+
@param remote Remote name (default: "origin")
113
+
@param branch Branch to pull (default: current branch) *)
114
+
val pull :
115
+
proc:_ Eio.Process.mgr ->
116
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
117
+
?remote:string ->
118
+
?branch:string ->
119
+
Fpath.t ->
120
+
(unit, error) result
121
+
122
+
(** [checkout ~proc ~fs ~branch path] checks out the specified branch. *)
123
+
val checkout :
124
+
proc:_ Eio.Process.mgr ->
125
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
126
+
branch:string ->
127
+
Fpath.t ->
128
+
(unit, error) result
129
+
130
+
(** {1 Comparison} *)
131
+
132
+
(** Describes how a local branch relates to its upstream. *)
133
+
type ahead_behind = {
134
+
ahead : int; (** Commits ahead of upstream *)
135
+
behind : int; (** Commits behind upstream *)
136
+
}
137
+
138
+
(** [ahead_behind ~proc ~fs ?remote ?branch path] computes how many
139
+
commits the local branch is ahead/behind the remote.
140
+
141
+
@param remote Remote name (default: "origin")
142
+
@param branch Branch to compare (default: current branch) *)
143
+
val ahead_behind :
144
+
proc:_ Eio.Process.mgr ->
145
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
146
+
?remote:string ->
147
+
?branch:string ->
148
+
Fpath.t ->
149
+
(ahead_behind, error) result
150
+
151
+
(** {1 Subtree Operations} *)
152
+
153
+
(** Operations for git subtree management in the monorepo. *)
154
+
module Subtree : sig
155
+
(** [add ~proc ~fs ~repo ~prefix ~url ~branch ()] adds a new subtree
156
+
to the repository.
157
+
158
+
@param repo Path to the monorepo
159
+
@param prefix Subdirectory for the subtree
160
+
@param url Git remote URL for the subtree source
161
+
@param branch Branch to add *)
162
+
val add :
163
+
proc:_ Eio.Process.mgr ->
164
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
165
+
repo:Fpath.t ->
166
+
prefix:string ->
167
+
url:Uri.t ->
168
+
branch:string ->
169
+
unit ->
170
+
(unit, error) result
171
+
172
+
(** [pull ~proc ~fs ~repo ~prefix ~url ~branch ()] pulls updates from
173
+
the remote into the subtree.
174
+
175
+
@param repo Path to the monorepo
176
+
@param prefix Subdirectory of the subtree
177
+
@param url Git remote URL
178
+
@param branch Branch to pull *)
179
+
val pull :
180
+
proc:_ Eio.Process.mgr ->
181
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
182
+
repo:Fpath.t ->
183
+
prefix:string ->
184
+
url:Uri.t ->
185
+
branch:string ->
186
+
unit ->
187
+
(unit, error) result
188
+
189
+
(** [push ~proc ~fs ~repo ~prefix ~url ~branch ()] pushes subtree
190
+
changes to the remote.
191
+
192
+
This extracts commits that affected the subtree and pushes them
193
+
to the specified remote/branch.
194
+
195
+
@param repo Path to the monorepo
196
+
@param prefix Subdirectory of the subtree
197
+
@param url Git remote URL
198
+
@param branch Branch to push to *)
199
+
val push :
200
+
proc:_ Eio.Process.mgr ->
201
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
202
+
repo:Fpath.t ->
203
+
prefix:string ->
204
+
url:Uri.t ->
205
+
branch:string ->
206
+
unit ->
207
+
(unit, error) result
208
+
209
+
(** [split ~proc ~fs ~repo ~prefix ()] extracts commits for a subtree
210
+
into a standalone branch.
211
+
212
+
Returns the commit hash of the split branch head. *)
213
+
val split :
214
+
proc:_ Eio.Process.mgr ->
215
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
216
+
repo:Fpath.t ->
217
+
prefix:string ->
218
+
unit ->
219
+
(string, error) result
220
+
221
+
(** [exists ~fs ~repo ~prefix] returns true if the subtree prefix
222
+
directory exists in the repository. *)
223
+
val exists :
224
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
225
+
repo:Fpath.t ->
226
+
prefix:string ->
227
+
bool
228
+
end
229
+
230
+
(** {1 Initialization} *)
231
+
232
+
(** [init ~proc ~fs path] initializes a new git repository. *)
233
+
val init :
234
+
proc:_ Eio.Process.mgr ->
235
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
236
+
Fpath.t ->
237
+
(unit, error) result
238
+
239
+
(** [commit_allow_empty ~proc ~fs ~message path] creates a commit,
240
+
even if there are no changes. Useful for initializing a repository. *)
241
+
val commit_allow_empty :
242
+
proc:_ Eio.Process.mgr ->
243
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
244
+
message:string ->
245
+
Fpath.t ->
246
+
(unit, error) result
+543
lib/monopam.ml
+543
lib/monopam.ml
···
1
+
module Config = Config
2
+
module Package = Package
3
+
module Opam_repo = Opam_repo
4
+
module Git = Git
5
+
module Status = Status
6
+
7
+
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
8
+
module Log = (val Logs.src_log src : Logs.LOG)
9
+
10
+
type error =
11
+
| Config_error of string
12
+
| Repo_error of Opam_repo.error
13
+
| Git_error of Git.error
14
+
| Dirty_state of Package.t list
15
+
| Package_not_found of string
16
+
17
+
let pp_error ppf = function
18
+
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
19
+
| Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
20
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
21
+
| Dirty_state pkgs ->
22
+
Fmt.pf ppf "Dirty packages: %a"
23
+
Fmt.(list ~sep:comma (using Package.name string))
24
+
pkgs
25
+
| Package_not_found name -> Fmt.pf ppf "Package not found: %s" name
26
+
27
+
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
28
+
let (dir, _) = fs in
29
+
(dir, "")
30
+
31
+
let discover_packages ~fs ~config () =
32
+
let repo_path = Config.Paths.opam_repo config in
33
+
Log.debug (fun m -> m "Scanning opam repo at %a" Fpath.pp repo_path);
34
+
match Opam_repo.scan ~fs repo_path with
35
+
| Ok pkgs ->
36
+
Log.info (fun m -> m "Found %d packages in opam repo" (List.length pkgs));
37
+
Ok pkgs
38
+
| Error e -> Error (Repo_error e)
39
+
40
+
let find_package ~fs ~config name =
41
+
match discover_packages ~fs ~config () with
42
+
| Error e -> Error e
43
+
| Ok pkgs -> (
44
+
match List.find_opt (fun p -> Package.name p = name) pkgs with
45
+
| Some p -> Ok p
46
+
| None -> Error (Package_not_found name))
47
+
48
+
let rec mkdirs path =
49
+
match Eio.Path.kind ~follow:true path with
50
+
| `Directory -> ()
51
+
| _ ->
52
+
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
53
+
Eio.Path.mkdir ~perm:0o755 path
54
+
| exception Eio.Io _ ->
55
+
(* Parent might not exist, try to create it first *)
56
+
let parent = Eio.Path.split path in
57
+
(match parent with
58
+
| Some (parent_path, _) -> mkdirs parent_path
59
+
| None -> ());
60
+
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
61
+
Eio.Path.mkdir ~perm:0o755 path
62
+
63
+
let ensure_checkouts_dir ~fs ~config =
64
+
let checkouts = Config.Paths.checkouts config in
65
+
let checkouts_eio = Eio.Path.(fs / Fpath.to_string checkouts) in
66
+
Log.debug (fun m -> m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
67
+
mkdirs checkouts_eio
68
+
69
+
let status ~proc ~fs ~config () =
70
+
let fs = fs_typed fs in
71
+
(* Ensure checkouts directory exists before computing status *)
72
+
ensure_checkouts_dir ~fs ~config;
73
+
match discover_packages ~fs:(fs :> _ Eio.Path.t) ~config () with
74
+
| Error e -> Error e
75
+
| Ok pkgs -> Ok (Status.compute_all ~proc ~fs ~config pkgs)
76
+
77
+
let get_branch ~config pkg =
78
+
match Package.branch pkg with
79
+
| Some b -> b
80
+
| None -> (
81
+
match Config.package_config config (Package.name pkg) with
82
+
| Some pc -> Option.value ~default:(Config.default_branch config) (Config.Package_config.branch pc)
83
+
| None -> Config.default_branch config)
84
+
85
+
let ensure_checkout ~proc ~fs ~config pkg =
86
+
let checkouts_root = Config.Paths.checkouts config in
87
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
88
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
89
+
let branch = get_branch ~config pkg in
90
+
let do_clone () =
91
+
Log.info (fun m -> m "Cloning %s from %a (branch: %s)"
92
+
(Package.repo_name pkg) Uri.pp (Package.dev_repo pkg) branch);
93
+
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
94
+
in
95
+
let is_directory =
96
+
match Eio.Path.kind ~follow:true checkout_eio with
97
+
| `Directory -> true
98
+
| _ -> false
99
+
| exception Eio.Io _ -> false
100
+
in
101
+
if not is_directory then do_clone ()
102
+
else if not (Git.is_repo ~proc ~fs checkout_dir) then do_clone ()
103
+
else begin
104
+
Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
105
+
match Git.fetch ~proc ~fs checkout_dir with
106
+
| Error e -> Error e
107
+
| Ok () ->
108
+
Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
109
+
Git.merge_ff ~proc ~fs ~branch checkout_dir
110
+
end
111
+
112
+
let claude_md_content = {|# Monorepo Development Guide
113
+
114
+
This is a monorepo managed by `monopam`. Each subdirectory is a git subtree
115
+
from a separate upstream repository.
116
+
117
+
## Making Changes
118
+
119
+
1. Edit code in any subdirectory as normal
120
+
2. Build and test: `opam exec -- dune build` and `opam exec -- dune test`
121
+
3. Commit your changes to this monorepo with git
122
+
123
+
## Exporting Changes to Upstream
124
+
125
+
After committing changes here, they must be exported to the individual
126
+
repositories before they can be pushed upstream:
127
+
128
+
```
129
+
monopam push
130
+
```
131
+
132
+
This extracts your commits into the individual checkouts in `../src/`.
133
+
You then review and push each one manually:
134
+
135
+
```
136
+
cd ../src/<repo-name>
137
+
git log --oneline -5 # review the changes
138
+
git push origin main # push to upstream
139
+
```
140
+
141
+
## Pulling Updates from Upstream
142
+
143
+
To fetch the latest changes from all upstream repositories:
144
+
145
+
```
146
+
monopam pull
147
+
```
148
+
149
+
This updates both the checkouts and merges changes into this monorepo.
150
+
151
+
## Important Notes
152
+
153
+
- **Always commit before push**: `monopam push` only exports committed changes
154
+
- **Check status first**: Run `monopam status` to see which repos have changes
155
+
- **One repo per directory**: Each subdirectory maps to exactly one git remote
156
+
- **Shared repos**: Multiple opam packages may live in the same subdirectory
157
+
if they share an upstream repository
158
+
159
+
## Troubleshooting
160
+
161
+
If `monopam push` fails with "dirty state", you have uncommitted changes.
162
+
Commit or stash them first.
163
+
164
+
If merge conflicts occur during `monopam pull`, resolve them in this monorepo,
165
+
commit, then the next pull will succeed.
166
+
|}
167
+
168
+
let ensure_monorepo_initialized ~proc ~fs ~config =
169
+
let monorepo = Config.Paths.monorepo config in
170
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
171
+
let init_and_commit () =
172
+
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
173
+
match Git.init ~proc ~fs monorepo with
174
+
| Error e -> Error (Git_error e)
175
+
| Ok () ->
176
+
(* Create dune-project file so the monorepo builds *)
177
+
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
178
+
Log.debug (fun m -> m "Creating dune-project file");
179
+
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
180
+
(* Create CLAUDE.md for agent instructions *)
181
+
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
182
+
Log.debug (fun m -> m "Creating CLAUDE.md");
183
+
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
184
+
(* Stage the files *)
185
+
Log.debug (fun m -> m "Staging initial files");
186
+
Eio.Switch.run (fun sw ->
187
+
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
188
+
[ "git"; "add"; "dune-project"; "CLAUDE.md" ] in
189
+
ignore (Eio.Process.await child));
190
+
(* Commit *)
191
+
Log.debug (fun m -> m "Creating initial commit in monorepo");
192
+
match Git.commit_allow_empty ~proc ~fs ~message:"Initial commit with dune-project and CLAUDE.md" monorepo with
193
+
| Ok () -> Ok ()
194
+
| Error e -> Error (Git_error e)
195
+
in
196
+
let ensure_claude_md () =
197
+
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
198
+
let exists =
199
+
match Eio.Path.kind ~follow:true claude_md with
200
+
| `Regular_file -> true
201
+
| _ -> false
202
+
| exception Eio.Io _ -> false
203
+
in
204
+
if not exists then begin
205
+
Log.info (fun m -> m "Adding CLAUDE.md to monorepo");
206
+
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
207
+
Eio.Switch.run (fun sw ->
208
+
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
209
+
[ "git"; "add"; "CLAUDE.md" ] in
210
+
ignore (Eio.Process.await child));
211
+
Eio.Switch.run (fun sw ->
212
+
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
213
+
[ "git"; "commit"; "-m"; "Add CLAUDE.md" ] in
214
+
ignore (Eio.Process.await child))
215
+
end
216
+
in
217
+
let is_directory =
218
+
match Eio.Path.kind ~follow:true monorepo_eio with
219
+
| `Directory -> true
220
+
| _ -> false
221
+
| exception Eio.Io _ -> false
222
+
in
223
+
if is_directory && Git.is_repo ~proc ~fs monorepo then begin
224
+
Log.debug (fun m -> m "Monorepo already initialized at %a" Fpath.pp monorepo);
225
+
ensure_claude_md ();
226
+
Ok ()
227
+
end else begin
228
+
if not is_directory then begin
229
+
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
230
+
mkdirs monorepo_eio
231
+
end;
232
+
init_and_commit ()
233
+
end
234
+
235
+
(* Normalize URL for comparison: extract scheme + host + path, strip trailing slashes *)
236
+
let normalize_url_for_comparison uri =
237
+
let scheme = Option.value ~default:"" (Uri.scheme uri) in
238
+
let host = Option.value ~default:"" (Uri.host uri) in
239
+
let path = Uri.path uri in
240
+
(* Strip trailing slash from path *)
241
+
let path =
242
+
if String.length path > 1 && path.[String.length path - 1] = '/' then
243
+
String.sub path 0 (String.length path - 1)
244
+
else path
245
+
in
246
+
Printf.sprintf "%s://%s%s" scheme host path
247
+
248
+
(* Deduplicate packages by dev-repo, keeping first occurrence of each repo *)
249
+
let unique_repos pkgs =
250
+
let seen = Hashtbl.create 16 in
251
+
List.filter (fun pkg ->
252
+
let url = normalize_url_for_comparison (Package.dev_repo pkg) in
253
+
Log.debug (fun m -> m "Checking repo URL: %s (from %s)" url (Package.name pkg));
254
+
if Hashtbl.mem seen url then begin
255
+
Log.debug (fun m -> m " -> Already seen, skipping");
256
+
false
257
+
end else begin
258
+
Hashtbl.add seen url ();
259
+
Log.debug (fun m -> m " -> New repo, keeping");
260
+
true
261
+
end) pkgs
262
+
263
+
(* Result of pulling a single repo *)
264
+
type pull_result = {
265
+
repo_name : string;
266
+
cloned : bool; (* true if newly cloned, false if fetched *)
267
+
commits_pulled : int; (* number of commits pulled, 0 if none or cloned *)
268
+
subtree_added : bool; (* true if subtree was newly added *)
269
+
}
270
+
271
+
let pull_subtree ~proc ~fs ~config pkg =
272
+
let fs = fs_typed fs in
273
+
let monorepo = Config.Paths.monorepo config in
274
+
let prefix = Package.subtree_prefix pkg in
275
+
let branch = get_branch ~config pkg in
276
+
let url = Package.dev_repo pkg in
277
+
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then begin
278
+
Log.info (fun m -> m "Pulling subtree %s" prefix);
279
+
match Git.Subtree.pull ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
280
+
| Ok () -> Ok false (* not newly added *)
281
+
| Error e -> Error (Git_error e)
282
+
end else begin
283
+
Log.info (fun m -> m "Adding subtree %s" prefix);
284
+
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
285
+
| Ok () -> Ok true (* newly added *)
286
+
| Error e -> Error (Git_error e)
287
+
end
288
+
289
+
(* Check if checkout exists and is a repo *)
290
+
let checkout_exists ~proc ~fs ~config pkg =
291
+
let checkouts_root = Config.Paths.checkouts config in
292
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
293
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
294
+
match Eio.Path.kind ~follow:true checkout_eio with
295
+
| `Directory -> Git.is_repo ~proc ~fs checkout_dir
296
+
| _ -> false
297
+
| exception Eio.Io _ -> false
298
+
299
+
(* Get commits behind before fetching *)
300
+
let get_behind ~proc ~fs ~config pkg =
301
+
let checkouts_root = Config.Paths.checkouts config in
302
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
303
+
let branch = get_branch ~config pkg in
304
+
match Git.ahead_behind ~proc ~fs ~branch checkout_dir with
305
+
| Ok ab -> ab.behind
306
+
| Error _ -> 0
307
+
308
+
let pull ~proc ~fs ~config ?package () =
309
+
let fs_t = fs_typed fs in
310
+
(* Update the opam repo first *)
311
+
let opam_repo = Config.Paths.opam_repo config in
312
+
if Git.is_repo ~proc ~fs:fs_t opam_repo then begin
313
+
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
314
+
let result =
315
+
let ( let* ) = Result.bind in
316
+
let* () = Git.fetch ~proc ~fs:fs_t opam_repo in
317
+
Git.merge_ff ~proc ~fs:fs_t opam_repo
318
+
in
319
+
match result with
320
+
| Ok () -> ()
321
+
| Error e -> Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
322
+
end;
323
+
(* Ensure directories exist before computing status *)
324
+
ensure_checkouts_dir ~fs:fs_t ~config;
325
+
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
326
+
| Error e -> Error e
327
+
| Ok () ->
328
+
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
329
+
| Error e -> Error e
330
+
| Ok all_pkgs ->
331
+
let pkgs =
332
+
match package with
333
+
| None -> all_pkgs
334
+
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
335
+
in
336
+
if pkgs = [] && package <> None then
337
+
Error (Package_not_found (Option.get package))
338
+
else begin
339
+
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
340
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
341
+
let dirty =
342
+
List.filter Status.has_local_changes statuses
343
+
|> List.map (fun s -> s.Status.package)
344
+
in
345
+
if dirty <> [] then Error (Dirty_state dirty)
346
+
else begin
347
+
(* First, clone/fetch unique repositories *)
348
+
let repos = unique_repos pkgs in
349
+
Log.info (fun m -> m "Cloning/fetching %d unique repositories" (List.length repos));
350
+
let clone_repos () =
351
+
let total = List.length repos in
352
+
let rec loop i acc = function
353
+
| [] -> Ok (List.rev acc)
354
+
| pkg :: rest ->
355
+
let repo_name = Package.repo_name pkg in
356
+
Log.info (fun m -> m "[%d/%d] Fetching repo %s" i total repo_name);
357
+
let existed = checkout_exists ~proc ~fs:fs_t ~config pkg in
358
+
let behind_before =
359
+
if existed then get_behind ~proc ~fs:fs_t ~config pkg else 0
360
+
in
361
+
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
362
+
| Error e -> Error (Git_error e)
363
+
| Ok () ->
364
+
let result = {
365
+
repo_name;
366
+
cloned = not existed;
367
+
commits_pulled = behind_before;
368
+
subtree_added = false; (* will be updated later *)
369
+
} in
370
+
loop (i + 1) (result :: acc) rest
371
+
in
372
+
loop 1 [] repos
373
+
in
374
+
match clone_repos () with
375
+
| Error e -> Error e
376
+
| Ok checkout_results ->
377
+
(* Then, add/pull subtrees for unique repos only *)
378
+
Log.info (fun m -> m "Processing %d unique subtrees" (List.length repos));
379
+
let total = List.length repos in
380
+
let rec loop i results_acc repos_left checkout_results_left =
381
+
match repos_left, checkout_results_left with
382
+
| [], [] -> Ok (List.rev results_acc)
383
+
| pkg :: rest_repos, cr :: rest_cr ->
384
+
Log.info (fun m -> m "[%d/%d] Subtree %s" i total (Package.subtree_prefix pkg));
385
+
(match pull_subtree ~proc ~fs ~config pkg with
386
+
| Ok subtree_added ->
387
+
let result = { cr with subtree_added } in
388
+
loop (i + 1) (result :: results_acc) rest_repos rest_cr
389
+
| Error e -> Error e)
390
+
| _ -> Ok (List.rev results_acc) (* mismatched lengths, shouldn't happen *)
391
+
in
392
+
match loop 1 [] repos checkout_results with
393
+
| Error e -> Error e
394
+
| Ok results ->
395
+
(* Print summary *)
396
+
let cloned = List.filter (fun r -> r.cloned) results in
397
+
let updated = List.filter (fun r -> not r.cloned && r.commits_pulled > 0) results in
398
+
let added = List.filter (fun r -> r.subtree_added) results in
399
+
if cloned <> [] then begin
400
+
Log.app (fun m -> m "Cloned %d new repositories:" (List.length cloned));
401
+
List.iter (fun r -> Log.app (fun m -> m " + %s" r.repo_name)) cloned
402
+
end;
403
+
if updated <> [] then begin
404
+
Log.app (fun m -> m "Updated %d repositories:" (List.length updated));
405
+
List.iter (fun r ->
406
+
Log.app (fun m -> m " ~ %s (%d new commits)" r.repo_name r.commits_pulled)
407
+
) updated
408
+
end;
409
+
if added <> [] then begin
410
+
Log.app (fun m -> m "Added %d new subtrees:" (List.length added));
411
+
List.iter (fun r -> Log.app (fun m -> m " + %s" r.repo_name)) added
412
+
end;
413
+
let unchanged = List.length results - List.length cloned - List.length updated in
414
+
if cloned = [] && updated = [] && added = [] then
415
+
Log.app (fun m -> m "All %d repositories up to date." (List.length results))
416
+
else if unchanged > 0 then
417
+
Log.app (fun m -> m "%d repositories unchanged." unchanged);
418
+
Ok ()
419
+
end
420
+
end
421
+
422
+
let run_git_in ~proc ~cwd args =
423
+
Eio.Switch.run @@ fun sw ->
424
+
let buf_stdout = Buffer.create 256 in
425
+
let buf_stderr = Buffer.create 256 in
426
+
let child =
427
+
Eio.Process.spawn proc ~sw ~cwd
428
+
~stdout:(Eio.Flow.buffer_sink buf_stdout)
429
+
~stderr:(Eio.Flow.buffer_sink buf_stderr)
430
+
("git" :: args)
431
+
in
432
+
match Eio.Process.await child with
433
+
| `Exited 0 -> Ok (Buffer.contents buf_stdout |> String.trim)
434
+
| _ ->
435
+
let result = Git.{
436
+
exit_code = 1;
437
+
stdout = Buffer.contents buf_stdout;
438
+
stderr = Buffer.contents buf_stderr;
439
+
} in
440
+
Error (Git.Command_failed (String.concat " " ("git" :: args), result))
441
+
442
+
let push_one ~proc ~fs ~config pkg =
443
+
let ( let* ) r f = Result.bind (Result.map_error (fun e -> Git_error e) r) f in
444
+
let fs = fs_typed fs in
445
+
let monorepo = Config.Paths.monorepo config in
446
+
let prefix = Package.subtree_prefix pkg in
447
+
let checkouts_root = Config.Paths.checkouts config in
448
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
449
+
let branch = get_branch ~config pkg in
450
+
let sync_branch = "monopam-sync" in
451
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then begin
452
+
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
453
+
Ok ()
454
+
end else begin
455
+
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
456
+
match Eio.Path.kind ~follow:true checkout_eio with
457
+
| exception Eio.Io _ ->
458
+
Log.debug (fun m -> m "Checkout %a does not exist, skipping" Fpath.pp checkout_dir);
459
+
Ok ()
460
+
| `Directory when Git.is_repo ~proc ~fs checkout_dir ->
461
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
462
+
let checkout_path = Fpath.to_string checkout_dir in
463
+
(* Push subtree to a sync branch (avoids "branch is checked out" error) *)
464
+
Log.info (fun m -> m "Pushing subtree %s to checkout" prefix);
465
+
let* _ = run_git_in ~proc ~cwd:monorepo_eio
466
+
[ "subtree"; "push"; "--prefix"; prefix; checkout_path; sync_branch ] in
467
+
(* Merge sync branch into the target branch in checkout *)
468
+
Log.debug (fun m -> m "Merging %s into %s" sync_branch branch);
469
+
let* _ = run_git_in ~proc ~cwd:checkout_eio [ "merge"; "--ff-only"; sync_branch ] in
470
+
(* Delete the sync branch *)
471
+
Log.debug (fun m -> m "Cleaning up %s branch" sync_branch);
472
+
ignore (run_git_in ~proc ~cwd:checkout_eio [ "branch"; "-d"; sync_branch ]);
473
+
Ok ()
474
+
| _ ->
475
+
Log.debug (fun m -> m "Checkout %a is not a git repo, skipping" Fpath.pp checkout_dir);
476
+
Ok ()
477
+
end
478
+
479
+
let push ~proc ~fs ~config ?package () =
480
+
let fs_t = fs_typed fs in
481
+
(* Ensure checkouts directory exists before computing status *)
482
+
ensure_checkouts_dir ~fs:fs_t ~config;
483
+
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
484
+
| Error e -> Error e
485
+
| Ok all_pkgs ->
486
+
let pkgs =
487
+
match package with
488
+
| None -> all_pkgs
489
+
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
490
+
in
491
+
if pkgs = [] && package <> None then
492
+
Error (Package_not_found (Option.get package))
493
+
else begin
494
+
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
495
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
496
+
let dirty =
497
+
List.filter Status.has_local_changes statuses
498
+
|> List.map (fun s -> s.Status.package)
499
+
in
500
+
if dirty <> [] then Error (Dirty_state dirty)
501
+
else begin
502
+
let repos = unique_repos pkgs in
503
+
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
504
+
let total = List.length repos in
505
+
let rec loop i = function
506
+
| [] -> Ok ()
507
+
| pkg :: rest ->
508
+
Log.info (fun m -> m "[%d/%d] Processing %s" i total (Package.subtree_prefix pkg));
509
+
match push_one ~proc ~fs ~config pkg with
510
+
| Ok () -> loop (i + 1) rest
511
+
| Error e -> Error e
512
+
in
513
+
loop 1 repos
514
+
end
515
+
end
516
+
517
+
let add ~proc ~fs ~config ~package () =
518
+
let fs_t = fs_typed fs in
519
+
ensure_checkouts_dir ~fs:fs_t ~config;
520
+
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
521
+
| Error e -> Error e
522
+
| Ok () ->
523
+
match find_package ~fs:(fs_t :> _ Eio.Path.t) ~config package with
524
+
| Error e -> Error e
525
+
| Ok pkg ->
526
+
Log.info (fun m -> m "Adding package %s" (Package.name pkg));
527
+
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
528
+
| Error e -> Error (Git_error e)
529
+
| Ok () ->
530
+
pull_subtree ~proc ~fs ~config pkg
531
+
|> Result.map (fun _ -> ())
532
+
533
+
let remove ~proc:_ ~fs ~config ~package () =
534
+
let fs = fs_typed fs in
535
+
let monorepo = Config.Paths.monorepo config in
536
+
let prefix = package in
537
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then Ok ()
538
+
else
539
+
let subtree_path = Eio.Path.(fs / Fpath.to_string monorepo / prefix) in
540
+
try
541
+
Eio.Path.rmtree subtree_path;
542
+
Ok ()
543
+
with Eio.Io _ as e -> Error (Git_error (Git.Io_error (Printexc.to_string e)))
+171
lib/monopam.mli
+171
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
5
+
subtrees.
6
+
7
+
{1 Overview}
8
+
9
+
The typical workflow is:
10
+
11
+
1. {b init} - Initialize configuration and monorepo
12
+
2. {b status} - Check synchronization state of all packages
13
+
3. {b pull} - Fetch from remotes, update checkouts, merge to monorepo
14
+
4. {b push} - Extract monorepo changes back to checkouts
15
+
16
+
{1 Modules}
17
+
18
+
- {!Config} - Configuration management
19
+
- {!Package} - Package metadata
20
+
- {!Opam_repo} - Opam repository scanning
21
+
- {!Git} - Git operations
22
+
- {!Status} - Status computation *)
23
+
24
+
(** Re-export modules for convenience. *)
25
+
26
+
module Config = Config
27
+
module Package = Package
28
+
module Opam_repo = Opam_repo
29
+
module Git = Git
30
+
module Status = Status
31
+
32
+
(** {1 High-Level Operations} *)
33
+
34
+
(** Errors from high-level operations. *)
35
+
type error =
36
+
| Config_error of string
37
+
(** Configuration error *)
38
+
| Repo_error of Opam_repo.error
39
+
(** Opam repository error *)
40
+
| Git_error of Git.error
41
+
(** Git operation error *)
42
+
| Dirty_state of Package.t list
43
+
(** Operation blocked due to dirty packages *)
44
+
| Package_not_found of string
45
+
(** Named package not found in opam repo *)
46
+
47
+
(** [pp_error] formats errors. *)
48
+
val pp_error : error Fmt.t
49
+
50
+
(** {2 Status} *)
51
+
52
+
(** [status ~proc ~fs ~config ()] computes status for all packages
53
+
discovered in the opam repo.
54
+
55
+
@param proc Eio process manager
56
+
@param fs Eio filesystem
57
+
@param config Monopam configuration *)
58
+
val status :
59
+
proc:_ Eio.Process.mgr ->
60
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
61
+
config:Config.t ->
62
+
unit ->
63
+
(Status.t list, error) result
64
+
65
+
(** {2 Pull} *)
66
+
67
+
(** [pull ~proc ~fs ~config ?package ()] pulls updates from remotes.
68
+
69
+
For each package (or the specified package):
70
+
1. Clones or fetches the individual checkout
71
+
2. Adds or pulls the subtree in the monorepo
72
+
73
+
Aborts if any checkout or the monorepo has uncommitted changes.
74
+
75
+
@param proc Eio process manager
76
+
@param fs Eio filesystem
77
+
@param config Monopam configuration
78
+
@param package Optional specific package to pull *)
79
+
val pull :
80
+
proc:_ Eio.Process.mgr ->
81
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
82
+
config:Config.t ->
83
+
?package:string ->
84
+
unit ->
85
+
(unit, error) result
86
+
87
+
(** {2 Push} *)
88
+
89
+
(** [push ~proc ~fs ~config ?package ()] pushes changes from monorepo
90
+
to checkouts.
91
+
92
+
For each package (or the specified package) with changes in the
93
+
monorepo:
94
+
1. Splits the subtree commits
95
+
2. Pushes to the individual checkout
96
+
97
+
The user must manually push from checkouts to remotes.
98
+
99
+
Aborts if any checkout has uncommitted changes.
100
+
101
+
@param proc Eio process manager
102
+
@param fs Eio filesystem
103
+
@param config Monopam configuration
104
+
@param package Optional specific package to push *)
105
+
val push :
106
+
proc:_ Eio.Process.mgr ->
107
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
108
+
config:Config.t ->
109
+
?package:string ->
110
+
unit ->
111
+
(unit, error) result
112
+
113
+
(** {2 Package Management} *)
114
+
115
+
(** [add ~proc ~fs ~config ~package ()] adds a package to the monorepo.
116
+
117
+
Clones the checkout if needed and adds the subtree.
118
+
119
+
@param proc Eio process manager
120
+
@param fs Eio filesystem
121
+
@param config Monopam configuration
122
+
@param package Package name to add *)
123
+
val add :
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
130
+
131
+
(** [remove ~proc ~fs ~config ~package ()] removes a package from the
132
+
monorepo.
133
+
134
+
Removes the subtree directory but does not delete the checkout.
135
+
136
+
@param proc Eio process manager
137
+
@param fs Eio filesystem
138
+
@param config Monopam configuration
139
+
@param package Package name to remove *)
140
+
val remove :
141
+
proc:_ Eio.Process.mgr ->
142
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
143
+
config:Config.t ->
144
+
package:string ->
145
+
unit ->
146
+
(unit, error) result
147
+
148
+
(** {1 Package Discovery} *)
149
+
150
+
(** [discover_packages ~fs ~config ()] scans the opam repo and returns
151
+
all packages.
152
+
153
+
@param fs Eio filesystem
154
+
@param config Monopam configuration *)
155
+
val discover_packages :
156
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
157
+
config:Config.t ->
158
+
unit ->
159
+
(Package.t list, error) result
160
+
161
+
(** [find_package ~fs ~config name] finds a package by name in the
162
+
opam repo.
163
+
164
+
@param fs Eio filesystem
165
+
@param config Monopam configuration
166
+
@param name Package name to find *)
167
+
val find_package :
168
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
169
+
config:Config.t ->
170
+
string ->
171
+
(Package.t, error) result
+129
lib/opam_repo.ml
+129
lib/opam_repo.ml
···
1
+
type error =
2
+
| Multiple_versions of string * string list
3
+
| No_dev_repo of string
4
+
| Invalid_dev_repo of string * string
5
+
| Not_git_remote of string * string
6
+
| Parse_error of string * string
7
+
| Io_error of string
8
+
9
+
let pp_error ppf = function
10
+
| Multiple_versions (name, versions) ->
11
+
Fmt.pf ppf "Package %s has multiple versions: %a" name
12
+
Fmt.(list ~sep:comma string)
13
+
versions
14
+
| No_dev_repo name -> Fmt.pf ppf "Package %s has no dev-repo field" name
15
+
| Invalid_dev_repo (name, url) ->
16
+
Fmt.pf ppf "Package %s has invalid dev-repo: %s" name url
17
+
| Not_git_remote (name, url) ->
18
+
Fmt.pf ppf "Package %s dev-repo is not a git URL: %s" name url
19
+
| Parse_error (path, msg) -> Fmt.pf ppf "Failed to parse %s: %s" path msg
20
+
| Io_error msg -> Fmt.pf ppf "I/O error: %s" msg
21
+
22
+
let has_prefix prefix s =
23
+
String.length s >= String.length prefix &&
24
+
String.sub s 0 (String.length prefix) = prefix
25
+
26
+
let has_suffix suffix s =
27
+
String.length s >= String.length suffix &&
28
+
String.sub s (String.length s - String.length suffix) (String.length suffix) = suffix
29
+
30
+
let is_git_url url =
31
+
String.length url > 0 &&
32
+
(has_prefix "git+" url || has_prefix "git://" url ||
33
+
has_prefix "git@" url || has_suffix ".git" url)
34
+
35
+
let normalize_git_url url =
36
+
let url =
37
+
if has_prefix "git+" url then
38
+
String.sub url 4 (String.length url - 4)
39
+
else url
40
+
in
41
+
Uri.of_string url
42
+
43
+
module OP = OpamParserTypes.FullPos
44
+
45
+
let extract_string_value (v : OP.value) : string option =
46
+
match v.pelem with OP.String s -> Some s | _ -> None
47
+
48
+
let find_dev_repo (items : OP.opamfile_item list) : string option =
49
+
List.find_map
50
+
(fun (item : OP.opamfile_item) ->
51
+
match item.pelem with
52
+
| OP.Variable (name, value) when name.pelem = "dev-repo" ->
53
+
extract_string_value value
54
+
| _ -> None)
55
+
items
56
+
57
+
let parse_package_path (path : Fpath.t) : (string * string) option =
58
+
let segs = Fpath.segs path in
59
+
let rec find_after_packages = function
60
+
| [] -> None
61
+
| "packages" :: name :: name_version :: _ -> (
62
+
match String.split_on_char '.' name_version with
63
+
| [ n; v ] when n = name -> Some (name, v)
64
+
| n :: rest when n = name -> Some (name, String.concat "." rest)
65
+
| _ -> None)
66
+
| _ :: rest -> find_after_packages rest
67
+
in
68
+
find_after_packages segs
69
+
70
+
let load_package ~fs opam_file_path =
71
+
let path_str = Fpath.to_string opam_file_path in
72
+
match parse_package_path opam_file_path with
73
+
| None -> Error (Parse_error (path_str, "Cannot determine package name/version"))
74
+
| Some (name, version) -> (
75
+
try
76
+
let eio_path = Eio.Path.(fs / path_str) in
77
+
let content = Eio.Path.load eio_path in
78
+
let opamfile = OpamParser.FullPos.string content path_str in
79
+
match find_dev_repo opamfile.file_contents with
80
+
| None -> Error (No_dev_repo name)
81
+
| Some url ->
82
+
if not (is_git_url url) then Error (Not_git_remote (name, url))
83
+
else
84
+
let dev_repo = normalize_git_url url in
85
+
Ok (Package.create ~name ~version ~dev_repo ())
86
+
with
87
+
| Eio.Io _ as e -> Error (Io_error (Printexc.to_string e))
88
+
| exn -> Error (Parse_error (path_str, Printexc.to_string exn)))
89
+
90
+
let list_dirs ~fs path =
91
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
92
+
try
93
+
Eio.Path.read_dir eio_path
94
+
|> List.filter (fun name ->
95
+
let child = Eio.Path.(eio_path / name) in
96
+
match Eio.Path.kind ~follow:false child with
97
+
| `Directory -> true
98
+
| _ -> false)
99
+
with Eio.Io _ -> []
100
+
101
+
let scan_all ~fs repo_path =
102
+
let packages_dir = Fpath.(repo_path / "packages") in
103
+
let package_names = list_dirs ~fs packages_dir in
104
+
let packages, errors =
105
+
List.fold_left
106
+
(fun (pkgs, errs) name ->
107
+
let pkg_dir = Fpath.(packages_dir / name) in
108
+
let versions = list_dirs ~fs pkg_dir in
109
+
match versions with
110
+
| [] -> (pkgs, errs)
111
+
| [ version_dir ] -> (
112
+
let opam_path = Fpath.(pkg_dir / version_dir / "opam") in
113
+
match load_package ~fs opam_path with
114
+
| Ok pkg -> (pkg :: pkgs, errs)
115
+
| Error e -> (pkgs, e :: errs))
116
+
| _ :: _ :: _ as vs ->
117
+
(pkgs, Multiple_versions (name, vs) :: errs))
118
+
([], []) package_names
119
+
in
120
+
(List.rev packages, List.rev errors)
121
+
122
+
let scan ~fs repo_path =
123
+
match scan_all ~fs repo_path with
124
+
| pkgs, [] -> Ok pkgs
125
+
| _, err :: _ -> Error err
126
+
127
+
let validate_repo ~fs repo_path =
128
+
let _, errors = scan_all ~fs repo_path in
129
+
errors
+91
lib/opam_repo.mli
+91
lib/opam_repo.mli
···
1
+
(** Opam repository scanning and package discovery.
2
+
3
+
This module scans an opam overlay repository to discover packages
4
+
and extract their git remote URLs. It enforces the monopam constraints:
5
+
- Only one version per package is allowed
6
+
- Only git remotes are allowed (no archive URLs) *)
7
+
8
+
(** {1 Types} *)
9
+
10
+
(** Errors that can occur during repository scanning. *)
11
+
type error =
12
+
| Multiple_versions of string * string list
13
+
(** Package has multiple versions: (name, versions) *)
14
+
| No_dev_repo of string
15
+
(** Package has no dev-repo field *)
16
+
| Invalid_dev_repo of string * string
17
+
(** Package has invalid dev-repo: (name, url) *)
18
+
| Not_git_remote of string * string
19
+
(** Package dev-repo is not a git URL: (name, url) *)
20
+
| Parse_error of string * string
21
+
(** Failed to parse opam file: (path, message) *)
22
+
| Io_error of string
23
+
(** Filesystem error *)
24
+
25
+
(** [pp_error] is a formatter for errors. *)
26
+
val pp_error : error Fmt.t
27
+
28
+
(** {1 Scanning} *)
29
+
30
+
(** [scan ~fs repo_path] scans the opam repository at [repo_path] and
31
+
returns all discovered packages.
32
+
33
+
The repository is expected to have the standard opam layout:
34
+
[repo_path/packages/<name>/<name.version>/opam]
35
+
36
+
Validates that:
37
+
- Each package has exactly one version
38
+
- Each package has a dev-repo field
39
+
- The dev-repo is a git URL (starts with "git+" or ends with ".git")
40
+
41
+
@param fs Eio filesystem capability
42
+
@param repo_path Path to the opam repository root *)
43
+
val scan :
44
+
fs:_ Eio.Path.t ->
45
+
Fpath.t ->
46
+
(Package.t list, error) result
47
+
48
+
(** [scan_all ~fs repo_path] scans the repository and returns all
49
+
packages, collecting errors instead of failing on the first one.
50
+
51
+
Returns a pair of (valid packages, errors encountered). *)
52
+
val scan_all :
53
+
fs:_ Eio.Path.t ->
54
+
Fpath.t ->
55
+
Package.t list * error list
56
+
57
+
(** {1 Individual Package Loading} *)
58
+
59
+
(** [load_package ~fs opam_file_path] loads a single package from its
60
+
opam file path.
61
+
62
+
@param fs Eio filesystem capability
63
+
@param opam_file_path Full path to the opam file *)
64
+
val load_package :
65
+
fs:_ Eio.Path.t ->
66
+
Fpath.t ->
67
+
(Package.t, error) result
68
+
69
+
(** {1 Validation} *)
70
+
71
+
(** [validate_repo ~fs repo_path] validates the entire repository
72
+
without loading packages. Returns a list of validation errors.
73
+
74
+
This is useful for checking repository health before operations. *)
75
+
val validate_repo :
76
+
fs:_ Eio.Path.t ->
77
+
Fpath.t ->
78
+
error list
79
+
80
+
(** [is_git_url url] returns true if the URL is a valid git remote.
81
+
82
+
Accepts URLs starting with "git+" or "git://" or ending with ".git",
83
+
as well as SSH-style URLs like "git\@github.com:...". *)
84
+
val is_git_url : string -> bool
85
+
86
+
(** [normalize_git_url url] normalizes a git URL by removing the "git+"
87
+
prefix if present.
88
+
89
+
For example, "git+https://example.com/repo.git" becomes
90
+
"https://example.com/repo.git". *)
91
+
val normalize_git_url : string -> Uri.t
+32
lib/package.ml
+32
lib/package.ml
···
1
+
type t = {
2
+
name : string;
3
+
version : string;
4
+
dev_repo : Uri.t;
5
+
branch : string option;
6
+
}
7
+
8
+
let create ~name ~version ~dev_repo ?branch () = { name; version; dev_repo; branch }
9
+
let name t = t.name
10
+
let version t = t.version
11
+
let dev_repo t = t.dev_repo
12
+
let branch t = t.branch
13
+
14
+
let repo_name t =
15
+
(* Extract basename from dev-repo URL, stripping .git suffix *)
16
+
let path = Uri.path t.dev_repo in
17
+
let basename = Filename.basename path in
18
+
if Filename.check_suffix basename ".git" then
19
+
Filename.chop_suffix basename ".git"
20
+
else
21
+
basename
22
+
23
+
let checkout_dir ~checkouts_root t = Fpath.(checkouts_root / repo_name t)
24
+
let subtree_prefix t = repo_name t
25
+
let compare a b = String.compare a.name b.name
26
+
let equal a b = String.equal a.name b.name
27
+
28
+
let same_repo a b = Uri.equal a.dev_repo b.dev_repo
29
+
30
+
let pp ppf t =
31
+
Fmt.pf ppf "@[<hov 2>{ name = %S;@ version = %S;@ dev_repo = %a;@ branch = %a }@]"
32
+
t.name t.version Uri.pp t.dev_repo Fmt.(option ~none:(any "None") string) t.branch
+79
lib/package.mli
+79
lib/package.mli
···
1
+
(** Package metadata and operations.
2
+
3
+
A package represents a single opam package discovered from the opam
4
+
overlay repository. It contains the package name, version, git remote
5
+
URL, and optional configuration overrides. *)
6
+
7
+
(** {1 Types} *)
8
+
9
+
(** A package discovered from the opam overlay. *)
10
+
type t
11
+
12
+
(** {1 Constructors} *)
13
+
14
+
(** [create ~name ~version ~dev_repo ?branch ()] creates a new package.
15
+
16
+
@param name The opam package name
17
+
@param version The package version (e.g., "dev")
18
+
@param dev_repo The git remote URL from the opam file's dev-repo field
19
+
@param branch Optional branch override; defaults to repository default *)
20
+
val create :
21
+
name:string ->
22
+
version:string ->
23
+
dev_repo:Uri.t ->
24
+
?branch:string ->
25
+
unit ->
26
+
t
27
+
28
+
(** {1 Accessors} *)
29
+
30
+
(** [name t] returns the package name. *)
31
+
val name : t -> string
32
+
33
+
(** [version t] returns the package version string. *)
34
+
val version : t -> string
35
+
36
+
(** [dev_repo t] returns the git remote URI. *)
37
+
val dev_repo : t -> Uri.t
38
+
39
+
(** [branch t] returns the branch to track, if explicitly set. *)
40
+
val branch : t -> string option
41
+
42
+
(** [repo_name t] returns the repository name extracted from the dev-repo URL.
43
+
44
+
This is the basename of the URL path with any ".git" suffix removed.
45
+
For example, "https://github.com/foo/bar.git" returns "bar". *)
46
+
val repo_name : t -> string
47
+
48
+
(** {1 Derived Paths} *)
49
+
50
+
(** [checkout_dir ~checkouts_root t] returns the expected path for this
51
+
package's git checkout, based on the repository name.
52
+
53
+
For a package with dev-repo "https://example.com/foo/bar.git" and
54
+
checkouts_root "/home/user/src", this returns "/home/user/src/bar".
55
+
56
+
Multiple packages from the same repository will share the same checkout. *)
57
+
val checkout_dir : checkouts_root:Fpath.t -> t -> Fpath.t
58
+
59
+
(** [subtree_prefix t] returns the subdirectory name used in the monorepo.
60
+
61
+
This is the repository name (same as [repo_name t]), so multiple packages
62
+
from the same repository share the same subtree directory. *)
63
+
val subtree_prefix : t -> string
64
+
65
+
(** {1 Comparison} *)
66
+
67
+
(** [compare a b] compares packages by name. *)
68
+
val compare : t -> t -> int
69
+
70
+
(** [equal a b] returns true if packages have the same name. *)
71
+
val equal : t -> t -> bool
72
+
73
+
(** [same_repo a b] returns true if packages share the same dev-repo URL. *)
74
+
val same_repo : t -> t -> bool
75
+
76
+
(** {1 Pretty Printing} *)
77
+
78
+
(** [pp] is a formatter for packages. *)
79
+
val pp : t Fmt.t
+98
lib/status.ml
+98
lib/status.ml
···
1
+
type checkout_status =
2
+
| Missing
3
+
| Not_a_repo
4
+
| Dirty
5
+
| Clean of Git.ahead_behind
6
+
7
+
type subtree_status = Not_added | Present
8
+
9
+
type t = {
10
+
package : Package.t;
11
+
checkout : checkout_status;
12
+
subtree : subtree_status;
13
+
}
14
+
15
+
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
16
+
let (dir, _) = fs in
17
+
(dir, "")
18
+
19
+
let compute ~proc ~fs ~config pkg =
20
+
let checkouts_root = Config.Paths.checkouts config in
21
+
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
22
+
let monorepo = Config.Paths.monorepo config in
23
+
let prefix = Package.subtree_prefix pkg in
24
+
let fs_t = fs_typed fs in
25
+
let fs_dir =
26
+
let (dir, _) = fs in
27
+
(dir, Fpath.to_string checkout_dir)
28
+
in
29
+
let checkout =
30
+
match Eio.Path.kind ~follow:true fs_dir with
31
+
| exception Eio.Io _ -> Missing
32
+
| `Directory ->
33
+
if not (Git.is_repo ~proc ~fs:fs_t checkout_dir) then Not_a_repo
34
+
else if Git.is_dirty ~proc ~fs:fs_t checkout_dir then Dirty
35
+
else (
36
+
match Git.ahead_behind ~proc ~fs:fs_t checkout_dir with
37
+
| Ok ab -> Clean ab
38
+
| Error _ -> Clean { ahead = 0; behind = 0 })
39
+
| _ -> Missing
40
+
in
41
+
let subtree =
42
+
if Git.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present
43
+
else Not_added
44
+
in
45
+
{ package = pkg; checkout; subtree }
46
+
47
+
let compute_all ~proc ~fs ~config packages =
48
+
List.map (compute ~proc ~fs ~config) packages
49
+
50
+
let is_checkout_clean t =
51
+
match t.checkout with Clean _ -> true | _ -> false
52
+
53
+
let has_local_changes t =
54
+
match t.checkout with Dirty -> true | _ -> false
55
+
56
+
let needs_pull t =
57
+
match t.checkout with Clean ab -> ab.behind > 0 | _ -> false
58
+
59
+
let needs_push t =
60
+
match t.checkout with Clean ab -> ab.ahead > 0 | _ -> false
61
+
62
+
let is_fully_synced t =
63
+
match (t.checkout, t.subtree) with
64
+
| Clean ab, Present -> ab.ahead = 0 && ab.behind = 0
65
+
| _ -> false
66
+
67
+
let filter_actionable statuses =
68
+
List.filter
69
+
(fun t ->
70
+
match t.checkout with
71
+
| Missing | Not_a_repo | Dirty -> true
72
+
| Clean ab -> ab.ahead > 0 || ab.behind > 0 || t.subtree = Not_added)
73
+
statuses
74
+
75
+
let pp_checkout_status ppf = function
76
+
| Missing -> Fmt.string ppf "missing"
77
+
| Not_a_repo -> Fmt.string ppf "not a repo"
78
+
| Dirty -> Fmt.string ppf "dirty"
79
+
| Clean ab ->
80
+
if ab.ahead = 0 && ab.behind = 0 then Fmt.string ppf "clean"
81
+
else Fmt.pf ppf "ahead %d, behind %d" ab.ahead ab.behind
82
+
83
+
let pp_subtree_status ppf = function
84
+
| Not_added -> Fmt.string ppf "not added"
85
+
| Present -> Fmt.string ppf "present"
86
+
87
+
let pp ppf t =
88
+
Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
89
+
pp_checkout_status t.checkout pp_subtree_status t.subtree
90
+
91
+
let pp_summary ppf statuses =
92
+
let total = List.length statuses in
93
+
let clean = List.filter is_checkout_clean statuses |> List.length in
94
+
let synced = List.filter is_fully_synced statuses |> List.length in
95
+
Fmt.pf ppf "@[<v>Packages: %d total, %d clean checkouts, %d fully synced@,@,%a@]"
96
+
total clean synced
97
+
Fmt.(list ~sep:cut pp)
98
+
statuses
+101
lib/status.mli
+101
lib/status.mli
···
1
+
(** Status computation and display.
2
+
3
+
This module computes the synchronization status of packages across
4
+
the three locations: git remote, individual checkout, and monorepo
5
+
subtree. *)
6
+
7
+
(** {1 Types} *)
8
+
9
+
(** Status of an individual checkout relative to its remote. *)
10
+
type checkout_status =
11
+
| Missing
12
+
(** Checkout directory does not exist *)
13
+
| Not_a_repo
14
+
(** Directory exists but is not a git repository *)
15
+
| Dirty
16
+
(** Has uncommitted changes *)
17
+
| Clean of Git.ahead_behind
18
+
(** Clean with ahead/behind info relative to remote *)
19
+
20
+
(** Status of a subtree in the monorepo. *)
21
+
type subtree_status =
22
+
| Not_added
23
+
(** Subtree has not been added to monorepo *)
24
+
| Present
25
+
(** Subtree exists in monorepo *)
26
+
27
+
(** Combined status for a package. *)
28
+
type t = {
29
+
package : Package.t;
30
+
checkout : checkout_status;
31
+
subtree : subtree_status;
32
+
}
33
+
34
+
(** {1 Status Computation} *)
35
+
36
+
(** [compute ~proc ~fs ~config pkg] computes the status of a single package.
37
+
38
+
@param proc Eio process manager
39
+
@param fs Eio filesystem
40
+
@param config Monopam configuration
41
+
@param pkg Package to check *)
42
+
val compute :
43
+
proc:_ Eio.Process.mgr ->
44
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
45
+
config:Config.t ->
46
+
Package.t ->
47
+
t
48
+
49
+
(** [compute_all ~proc ~fs ~config packages] computes status for all
50
+
packages in parallel.
51
+
52
+
@param proc Eio process manager
53
+
@param fs Eio filesystem
54
+
@param config Monopam configuration
55
+
@param packages List of packages to check *)
56
+
val compute_all :
57
+
proc:_ Eio.Process.mgr ->
58
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
59
+
config:Config.t ->
60
+
Package.t list ->
61
+
t list
62
+
63
+
(** {1 Predicates} *)
64
+
65
+
(** [is_checkout_clean t] returns true if the checkout is clean
66
+
(exists, is a repo, and has no uncommitted changes). *)
67
+
val is_checkout_clean : t -> bool
68
+
69
+
(** [has_local_changes t] returns true if either the checkout or
70
+
subtree has uncommitted local changes. *)
71
+
val has_local_changes : t -> bool
72
+
73
+
(** [needs_pull t] returns true if the checkout is behind the remote. *)
74
+
val needs_pull : t -> bool
75
+
76
+
(** [needs_push t] returns true if the checkout is ahead of the remote. *)
77
+
val needs_push : t -> bool
78
+
79
+
(** [is_fully_synced t] returns true if the package is fully in sync
80
+
across all locations. *)
81
+
val is_fully_synced : t -> bool
82
+
83
+
(** {1 Filtering} *)
84
+
85
+
(** [filter_actionable statuses] returns only packages that need action
86
+
(dirty, ahead, behind, or missing subtree). *)
87
+
val filter_actionable : t list -> t list
88
+
89
+
(** {1 Pretty Printing} *)
90
+
91
+
(** [pp_checkout_status] formats checkout status. *)
92
+
val pp_checkout_status : checkout_status Fmt.t
93
+
94
+
(** [pp_subtree_status] formats subtree status. *)
95
+
val pp_subtree_status : subtree_status Fmt.t
96
+
97
+
(** [pp] formats a single package status. *)
98
+
val pp : t Fmt.t
99
+
100
+
(** [pp_summary] formats a summary of all package statuses. *)
101
+
val pp_summary : t list Fmt.t
+41
monopam.opam
+41
monopam.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Manage opam overlays with git subtree monorepos"
4
+
description:
5
+
"Monopam helps manage an opam overlay by synchronizing packages between individual git checkouts and a monorepo using git subtrees."
6
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
7
+
authors: ["Anil Madhavapeddy <anil@recoil.org>"]
8
+
license: "ISC"
9
+
homepage: "https://github.com/avsm/monopam"
10
+
bug-reports: "https://github.com/avsm/monopam/issues"
11
+
depends: [
12
+
"ocaml" {>= "5.2.0"}
13
+
"dune" {>= "3.20" & >= "3.20"}
14
+
"eio" {>= "1.2"}
15
+
"eio_main" {>= "1.2"}
16
+
"tomlt" {>= "0.1.0"}
17
+
"xdge" {>= "0.1.0"}
18
+
"opam-file-format" {>= "2.1.0"}
19
+
"cmdliner" {>= "1.3.0"}
20
+
"fmt" {>= "0.9.0"}
21
+
"logs" {>= "0.7.0"}
22
+
"uri" {>= "4.0.0"}
23
+
"fpath" {>= "0.7.0"}
24
+
"odoc" {with-doc}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
dev-repo: "git+https://github.com/avsm/monopam.git"
41
+
x-maintenance-intent: ["(latest)"]