forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Add git retry logic, sources registry, and configurable knot
Git operations:
- Add retry logic with exponential backoff for HTTP 5xx errors
- Retry on RPC failures, curl errors, connection issues
- 3 retries with 2s/4s/8s delays before failing
- Apply to clone, fetch, pull, push, and subtree operations
Sources registry (sources.toml):
- New module for tracking package URL overrides
- default_url_base for deriving URLs from subtree names
- Per-package entries with url, upstream, branch, reason
Verse config:
- Add knot field for git push server (e.g., "git.recoil.org")
- Default to "git.recoil.org" if not present in config
- Auto-write knot to config file if missing
URL handling:
- Remove hardcoded anil.recoil.org references
- Derive git push server from handle or use configured knot
- Generic SSH URL normalization in forks.ml
Sync resilience:
- Skip failed clones in merge/subtree phases instead of crashing
- Track successfully fetched repos separately from failures
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+1118
-176
+14
-3
bin/main.ml
+14
-3
bin/main.ml
···
35
35
let checkouts = Monopam.Verse_config.src_path verse_config in
36
36
let monorepo = Monopam.Verse_config.mono_path verse_config in
37
37
let default_branch = Monopam.Verse_config.default_branch in
38
-
Ok
39
-
(Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch
40
-
())
38
+
let base_config =
39
+
Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch ()
40
+
in
41
+
(* Apply package overrides from verse config *)
42
+
let config =
43
+
List.fold_left
44
+
(fun cfg (name, override) ->
45
+
let open Monopam.Verse_config in
46
+
Monopam.Config.with_package_override cfg ~name
47
+
?branch:override.branch ?dev_repo:override.dev_repo ())
48
+
base_config
49
+
(Monopam.Verse_config.packages verse_config)
50
+
in
51
+
Ok config
41
52
42
53
let with_config env f =
43
54
match load_config env with
+2
dune-project
+2
dune-project
+1
-3
lib/changes_query.ml
+1
-3
lib/changes_query.ml
···
42
42
let format_repo_link repo url_opt =
43
43
match url_opt with
44
44
| Some url -> Printf.sprintf "[%s](%s)" repo url
45
-
| None ->
46
-
Printf.sprintf "[%s](https://tangled.org/@anil.recoil.org/%s.git)" repo
47
-
repo
45
+
| None -> repo (* No URL available, just use repo name *)
48
46
49
47
let format_for_zulip ~entries ~include_date ~date =
50
48
if entries = [] then "No changes to report."
+14
-4
lib/config.ml
+14
-4
lib/config.ml
···
1
1
module Package_config = struct
2
-
type t = { branch : string option }
2
+
type t = {
3
+
branch : string option;
4
+
dev_repo : string option; (** Override dev-repo URL for vendored packages *)
5
+
}
3
6
4
7
let branch t = t.branch
8
+
let dev_repo t = t.dev_repo
5
9
6
10
let codec : t Tomlt.t =
7
11
Tomlt.(
8
12
Table.(
9
-
obj (fun branch -> { branch })
13
+
obj (fun branch dev_repo -> { branch; dev_repo })
10
14
|> opt_mem "branch" string ~enc:(fun c -> c.branch)
15
+
|> opt_mem "dev_repo" string ~enc:(fun c -> c.dev_repo)
11
16
|> finish))
12
17
end
13
18
···
31
36
let create ~opam_repo ~checkouts ~monorepo ?(default_branch = "main") () =
32
37
{ opam_repo; checkouts; monorepo; default_branch; packages = [] }
33
38
34
-
let with_package_override t ~name ~branch:b =
35
-
let pkg_config = Package_config.{ branch = Some b } in
39
+
let with_package_override t ~name ?branch:branch_opt ?dev_repo:dev_repo_opt () =
40
+
let existing = List.assoc_opt name t.packages in
41
+
let existing_branch = Option.bind existing Package_config.branch in
42
+
let existing_dev_repo = Option.bind existing Package_config.dev_repo in
43
+
let new_branch = match branch_opt with Some _ -> branch_opt | None -> existing_branch in
44
+
let new_dev_repo = match dev_repo_opt with Some _ -> dev_repo_opt | None -> existing_dev_repo in
45
+
let pkg_config = Package_config.{ branch = new_branch; dev_repo = new_dev_repo } in
36
46
let packages = (name, pkg_config) :: List.remove_assoc name t.packages in
37
47
{ t with packages }
38
48
+13
-3
lib/config.mli
+13
-3
lib/config.mli
···
14
14
15
15
val branch : t -> string option
16
16
(** [branch t] returns the branch override for this package, if set. *)
17
+
18
+
val dev_repo : t -> string option
19
+
(** [dev_repo t] returns the dev-repo URL override for this package, if set.
20
+
Use this to override the source URL for vendored packages. *)
17
21
end
18
22
19
23
type t
···
108
112
@param monorepo Path to the monorepo
109
113
@param default_branch Default branch to track (default: "main") *)
110
114
111
-
val with_package_override : t -> name:string -> branch:string -> t
112
-
(** [with_package_override t ~name ~branch] returns a new config with a branch
113
-
override for the named package. *)
115
+
val with_package_override :
116
+
t -> name:string -> ?branch:string -> ?dev_repo:string -> unit -> t
117
+
(** [with_package_override t ~name ?branch ?dev_repo ()] returns a new config
118
+
with overrides for the named package.
119
+
120
+
@param branch Override the git branch for this package
121
+
@param dev_repo Override the dev-repo URL for vendored packages.
122
+
Use this when you've forked someone else's project and want the opam-repo
123
+
to point to your fork instead of the original. *)
114
124
115
125
(** {1 Pretty Printing} *)
116
126
+3
-1
lib/dune
+3
-1
lib/dune
+136
lib/dune_project.ml
+136
lib/dune_project.ml
···
1
+
(** Dune project file parsing. *)
2
+
3
+
type source_info =
4
+
| Github of { user : string; repo : string }
5
+
| Gitlab of { user : string; repo : string }
6
+
| Uri of { url : string; branch : string option }
7
+
8
+
type t = {
9
+
name : string;
10
+
source : source_info option;
11
+
homepage : string option;
12
+
packages : string list;
13
+
}
14
+
15
+
module Sexp = Sexplib0.Sexp
16
+
17
+
(** Extract string from a Sexp.Atom, or None if it's a List *)
18
+
let atom_string = function
19
+
| Sexp.Atom s -> Some s
20
+
| Sexp.List _ -> None
21
+
22
+
(** Parse source stanza: (source (github user/repo)) or (source (uri "url")) *)
23
+
let parse_source_inner sexp =
24
+
match sexp with
25
+
| Sexp.List [ Sexp.Atom "github"; Sexp.Atom user_repo ] -> (
26
+
match String.split_on_char '/' user_repo with
27
+
| [ user; repo ] -> Some (Github { user; repo })
28
+
| _ -> None)
29
+
| Sexp.List [ Sexp.Atom "gitlab"; Sexp.Atom user_repo ] -> (
30
+
match String.split_on_char '/' user_repo with
31
+
| [ user; repo ] -> Some (Gitlab { user; repo })
32
+
| _ -> None)
33
+
| Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] ->
34
+
(* Check for branch in URI fragment *)
35
+
let uri = Uri.of_string url in
36
+
let branch = Uri.fragment uri in
37
+
let url_without_fragment =
38
+
Uri.with_fragment uri None |> Uri.to_string
39
+
in
40
+
Some (Uri { url = url_without_fragment; branch })
41
+
| Sexp.Atom url ->
42
+
(* Single atom URL (unlikely but handle it) *)
43
+
let uri = Uri.of_string url in
44
+
let branch = Uri.fragment uri in
45
+
let url_without_fragment =
46
+
Uri.with_fragment uri None |> Uri.to_string
47
+
in
48
+
Some (Uri { url = url_without_fragment; branch })
49
+
| _ -> None
50
+
51
+
(** Find name in (package (name foo) ...) stanza *)
52
+
let rec find_package_name = function
53
+
| [] -> None
54
+
| Sexp.List [ Sexp.Atom "name"; Sexp.Atom name ] :: _ -> Some name
55
+
| _ :: rest -> find_package_name rest
56
+
57
+
(** Extract all package names from parsed sexps *)
58
+
let extract_packages sexps =
59
+
List.filter_map
60
+
(function
61
+
| Sexp.List (Sexp.Atom "package" :: rest) -> find_package_name rest
62
+
| _ -> None)
63
+
sexps
64
+
65
+
(** Find a simple string field like (name foo) or (homepage "url") *)
66
+
let find_string_field name sexps =
67
+
List.find_map
68
+
(function
69
+
| Sexp.List [ Sexp.Atom n; value ] when n = name -> atom_string value
70
+
| _ -> None)
71
+
sexps
72
+
73
+
(** Find source field: (source ...) *)
74
+
let find_source sexps =
75
+
List.find_map
76
+
(function
77
+
| Sexp.List [ Sexp.Atom "source"; inner ] -> parse_source_inner inner
78
+
| _ -> None)
79
+
sexps
80
+
81
+
let parse content =
82
+
match Parsexp.Many.parse_string content with
83
+
| Error err ->
84
+
Error (Printf.sprintf "S-expression parse error: %s"
85
+
(Parsexp.Parse_error.message err))
86
+
| Ok sexps -> (
87
+
match find_string_field "name" sexps with
88
+
| None -> Error "dune-project missing (name ...) stanza"
89
+
| Some name ->
90
+
let source = find_source sexps in
91
+
let homepage = find_string_field "homepage" sexps in
92
+
let packages = extract_packages sexps in
93
+
Ok { name; source; homepage; packages })
94
+
95
+
(** Normalize a URL to have git+ prefix *)
96
+
let normalize_git_url url =
97
+
if String.starts_with ~prefix:"git+" url then url
98
+
else if String.starts_with ~prefix:"git@" url then "git+" ^ url
99
+
else if String.starts_with ~prefix:"https://" url then "git+" ^ url
100
+
else if String.starts_with ~prefix:"http://" url then
101
+
"git+https" ^ String.sub url 4 (String.length url - 4)
102
+
else "git+" ^ url
103
+
104
+
(** Ensure URL ends with .git *)
105
+
let ensure_git_suffix url =
106
+
if String.ends_with ~suffix:".git" url then url
107
+
else url ^ ".git"
108
+
109
+
let dev_repo_url t =
110
+
match t.source with
111
+
| Some (Github { user; repo }) ->
112
+
Ok (Printf.sprintf "git+https://github.com/%s/%s.git" user repo)
113
+
| Some (Gitlab { user; repo }) ->
114
+
Ok (Printf.sprintf "git+https://gitlab.com/%s/%s.git" user repo)
115
+
| Some (Uri { url; _ }) ->
116
+
Ok (normalize_git_url (ensure_git_suffix url))
117
+
| None -> (
118
+
match t.homepage with
119
+
| Some homepage ->
120
+
Ok (normalize_git_url (ensure_git_suffix homepage))
121
+
| None ->
122
+
Error
123
+
(Printf.sprintf
124
+
"Package %s must declare source or homepage in dune-project"
125
+
t.name))
126
+
127
+
let url_with_branch t =
128
+
match dev_repo_url t with
129
+
| Error e -> Error e
130
+
| Ok url ->
131
+
let branch =
132
+
match t.source with
133
+
| Some (Uri { branch = Some b; _ }) -> b
134
+
| _ -> "main"
135
+
in
136
+
Ok (url ^ "#" ^ branch)
+41
lib/dune_project.mli
+41
lib/dune_project.mli
···
1
+
(** Dune project file parsing.
2
+
3
+
Parse dune-project s-expressions to extract package metadata needed
4
+
for generating opam-repo entries. *)
5
+
6
+
(** Source information from dune-project. *)
7
+
type source_info =
8
+
| Github of { user : string; repo : string }
9
+
| Gitlab of { user : string; repo : string }
10
+
| Uri of { url : string; branch : string option }
11
+
12
+
(** Parsed dune-project file. *)
13
+
type t = {
14
+
name : string; (** Project name from (name ...) stanza *)
15
+
source : source_info option; (** Source from (source ...) stanza *)
16
+
homepage : string option; (** Homepage from (homepage ...) stanza *)
17
+
packages : string list; (** Package names from (package (name ...)) stanzas *)
18
+
}
19
+
20
+
val parse : string -> (t, string) result
21
+
(** [parse content] parses a dune-project file content and extracts metadata.
22
+
Returns [Error msg] if parsing fails or required fields are missing. *)
23
+
24
+
val dev_repo_url : t -> (string, string) result
25
+
(** [dev_repo_url t] derives the dev-repo URL from the parsed dune-project.
26
+
Returns a URL suitable for the opam dev-repo field (e.g., "git+https://...").
27
+
28
+
URL derivation logic:
29
+
- [Github {user; repo}] -> "git+https://github.com/user/repo.git"
30
+
- [Gitlab {user; repo}] -> "git+https://gitlab.com/user/repo.git"
31
+
- [Uri {url; _}] -> url normalized with git+ prefix
32
+
- No source but homepage present -> homepage normalized with git+ prefix
33
+
- Neither source nor homepage -> Error *)
34
+
35
+
val url_with_branch : t -> (string, string) result
36
+
(** [url_with_branch t] derives the URL with branch fragment for the opam url section.
37
+
Returns a URL with #branch suffix (e.g., "git+https://...#main").
38
+
39
+
Branch derivation:
40
+
- [Uri {url; branch = Some b}] -> url#b
41
+
- Otherwise -> url#main *)
+8
-2
lib/forks.ml
+8
-2
lib/forks.ml
···
322
322
"https://github.com/" ^ String.sub s 15 (String.length s - 15)
323
323
else if String.starts_with ~prefix:"git@gitlab.com:" s then
324
324
"https://gitlab.com/" ^ String.sub s 15 (String.length s - 15)
325
-
else if String.starts_with ~prefix:"git@git.recoil.org:" s then
326
-
"https://git.recoil.org/" ^ String.sub s 19 (String.length s - 19)
325
+
else if String.starts_with ~prefix:"git@git." s then
326
+
(* Generic git.<domain>: pattern - convert git@git.<domain>:path to https://git.<domain>/path *)
327
+
match String.index_opt s ':' with
328
+
| Some colon_pos ->
329
+
let host = String.sub s 4 (colon_pos - 4) in (* "git.<domain>" *)
330
+
let path = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in
331
+
"https://" ^ host ^ "/" ^ path
332
+
| None -> s
327
333
else s
328
334
in
329
335
(* Strip .git suffix *)
+72
-9
lib/git.ml
+72
-9
lib/git.ml
···
51
51
if result.exit_code = 0 then Ok result.stdout
52
52
else Error (Command_failed (String.concat " " ("git" :: args), result))
53
53
54
+
(** Helper for substring check *)
55
+
let string_contains ~needle haystack =
56
+
let needle_len = String.length needle in
57
+
let haystack_len = String.length haystack in
58
+
if needle_len > haystack_len then false
59
+
else
60
+
let rec check i =
61
+
if i + needle_len > haystack_len then false
62
+
else if String.sub haystack i needle_len = needle then true
63
+
else check (i + 1)
64
+
in
65
+
check 0
66
+
67
+
(** Check if an error is a retryable HTTP server error (5xx) or network error *)
68
+
let is_retryable_error result =
69
+
let stderr = result.stderr in
70
+
(* Common patterns for HTTP 5xx errors in git output *)
71
+
String.length stderr > 0 &&
72
+
(string_contains ~needle:"500" stderr ||
73
+
string_contains ~needle:"502" stderr ||
74
+
string_contains ~needle:"503" stderr ||
75
+
string_contains ~needle:"504" stderr ||
76
+
string_contains ~needle:"HTTP 5" stderr ||
77
+
string_contains ~needle:"http 5" stderr ||
78
+
string_contains ~needle:"Internal Server Error" stderr ||
79
+
string_contains ~needle:"Bad Gateway" stderr ||
80
+
string_contains ~needle:"Service Unavailable" stderr ||
81
+
string_contains ~needle:"Gateway Timeout" stderr ||
82
+
(* RPC failures (common git smart HTTP errors) *)
83
+
string_contains ~needle:"RPC failed" stderr ||
84
+
string_contains ~needle:"curl" stderr ||
85
+
string_contains ~needle:"unexpected disconnect" stderr ||
86
+
string_contains ~needle:"the remote end hung up" stderr ||
87
+
string_contains ~needle:"early EOF" stderr ||
88
+
(* Connection errors *)
89
+
string_contains ~needle:"Connection refused" stderr ||
90
+
string_contains ~needle:"Connection reset" stderr ||
91
+
string_contains ~needle:"Connection timed out" stderr ||
92
+
string_contains ~needle:"Could not resolve host" stderr ||
93
+
string_contains ~needle:"Failed to connect" stderr ||
94
+
string_contains ~needle:"Network is unreachable" stderr ||
95
+
string_contains ~needle:"Temporary failure" stderr)
96
+
97
+
(** Run a git command with retry logic for network errors.
98
+
Retries up to [max_retries] times with exponential backoff starting at [initial_delay_ms]. *)
99
+
let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3) ?(initial_delay_ms = 2000) args =
100
+
let rec attempt n delay_ms =
101
+
let result = run_git ~proc ~cwd args in
102
+
if result.exit_code = 0 then Ok result.stdout
103
+
else if n < max_retries && is_retryable_error result then begin
104
+
(* Log the retry *)
105
+
Logs.warn (fun m ->
106
+
m "Git command failed with retryable error, retrying in %dms (%d/%d): %s"
107
+
delay_ms (n + 1) max_retries result.stderr);
108
+
(* Sleep before retry - convert ms to seconds for Unix.sleepf *)
109
+
Unix.sleepf (float_of_int delay_ms /. 1000.0);
110
+
(* Exponential backoff: double the delay for next attempt *)
111
+
attempt (n + 1) (delay_ms * 2)
112
+
end
113
+
else Error (Command_failed (String.concat " " ("git" :: args), result))
114
+
in
115
+
attempt 0 initial_delay_ms
116
+
54
117
let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
55
118
let dir, _ = fs in
56
119
(dir, Fpath.to_string path)
···
85
148
let cwd = Eio.Path.(fs / Fpath.to_string parent) in
86
149
let target_name = Fpath.basename target in
87
150
let url_str = Uri.to_string url in
88
-
run_git_ok ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
151
+
run_git_ok_with_retry ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
89
152
|> Result.map ignore
90
153
91
154
let fetch ~proc ~fs ?(remote = "origin") path =
92
155
let cwd = path_to_eio ~fs path in
93
-
run_git_ok ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
156
+
run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] |> Result.map ignore
94
157
95
158
let fetch_all ~proc ~fs path =
96
159
let cwd = path_to_eio ~fs path in
97
-
run_git_ok ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore
160
+
run_git_ok_with_retry ~proc ~cwd [ "fetch"; "--all" ] |> Result.map ignore
98
161
99
162
let merge_ff ~proc ~fs ?(remote = "origin") ?branch path =
100
163
let cwd = path_to_eio ~fs path in
···
113
176
| Some b -> [ "pull"; remote; b ]
114
177
| None -> [ "pull"; remote ]
115
178
in
116
-
run_git_ok ~proc ~cwd args |> Result.map ignore
179
+
run_git_ok_with_retry ~proc ~cwd args |> Result.map ignore
117
180
118
181
let fetch_and_reset ~proc ~fs ?(remote = "origin") ~branch path =
119
182
let cwd = path_to_eio ~fs path in
120
-
match run_git_ok ~proc ~cwd [ "fetch"; remote ] with
183
+
match run_git_ok_with_retry ~proc ~cwd [ "fetch"; remote ] with
121
184
| Error e -> Error e
122
185
| Ok _ ->
123
186
let upstream = remote ^ "/" ^ branch in
···
161
224
else
162
225
let cwd = path_to_eio ~fs repo in
163
226
let url_str = Uri.to_string url in
164
-
run_git_ok ~proc ~cwd
227
+
run_git_ok_with_retry ~proc ~cwd
165
228
[ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ]
166
229
|> Result.map ignore
167
230
···
170
233
else
171
234
let cwd = path_to_eio ~fs repo in
172
235
let url_str = Uri.to_string url in
173
-
run_git_ok ~proc ~cwd
236
+
run_git_ok_with_retry ~proc ~cwd
174
237
[ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ]
175
238
|> Result.map ignore
176
239
···
179
242
else
180
243
let cwd = path_to_eio ~fs repo in
181
244
let url_str = Uri.to_string url in
182
-
run_git_ok ~proc ~cwd
245
+
run_git_ok_with_retry ~proc ~cwd
183
246
[ "subtree"; "push"; "--prefix"; prefix; url_str; branch ]
184
247
|> Result.map ignore
185
248
···
207
270
| Some b -> b
208
271
| None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
209
272
in
210
-
run_git_ok ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
273
+
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
211
274
212
275
let set_push_url ~proc ~fs ?(remote = "origin") ~url path =
213
276
let cwd = path_to_eio ~fs path in
+360
-121
lib/monopam.ml
+360
-121
lib/monopam.ml
···
11
11
module Forks = Forks
12
12
module Doctor = Doctor
13
13
module Feature = Feature
14
+
module Dune_project = Dune_project
15
+
module Opam_transform = Opam_transform
16
+
module Sources_registry = Sources_registry
14
17
15
18
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
16
19
···
178
181
with Eio.Io _ -> [])
179
182
repos
180
183
184
+
(** Information about a package discovered from the monorepo. *)
185
+
type monorepo_package = {
186
+
pkg_name : string;
187
+
subtree : string;
188
+
dev_repo : string;
189
+
url_src : string;
190
+
opam_content : string;
191
+
}
192
+
193
+
(** Discover packages from monorepo subtrees by parsing dune-project files.
194
+
If [sources] is provided, it overrides the dev-repo URL for matching subtrees. *)
195
+
let discover_packages_from_monorepo ~fs ~config ?(sources = Sources_registry.empty) () =
196
+
let fs = fs_typed fs in
197
+
let monorepo = Config.Paths.monorepo config in
198
+
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
199
+
200
+
(* List all subdirectories of monorepo *)
201
+
let subdirs =
202
+
try
203
+
Eio.Path.read_dir monorepo_eio
204
+
|> List.filter (fun name ->
205
+
let child = Eio.Path.(monorepo_eio / name) in
206
+
match Eio.Path.kind ~follow:false child with
207
+
| `Directory -> true
208
+
| _ -> false)
209
+
with Eio.Io _ -> []
210
+
in
211
+
212
+
Log.debug (fun m -> m "Found %d subdirectories in monorepo" (List.length subdirs));
213
+
214
+
(* Process each subdirectory *)
215
+
let packages, errors =
216
+
List.fold_left
217
+
(fun (pkgs, errs) subtree ->
218
+
let subtree_path = Eio.Path.(monorepo_eio / subtree) in
219
+
let dune_project_path = Eio.Path.(subtree_path / "dune-project") in
220
+
221
+
(* Check if dune-project exists *)
222
+
match Eio.Path.kind ~follow:false dune_project_path with
223
+
| `Regular_file -> (
224
+
(* Parse dune-project *)
225
+
let content =
226
+
try Some (Eio.Path.load dune_project_path)
227
+
with Eio.Io _ -> None
228
+
in
229
+
match content with
230
+
| None -> (pkgs, errs)
231
+
| Some content -> (
232
+
match Dune_project.parse content with
233
+
| Error msg ->
234
+
Log.warn (fun m ->
235
+
m "Failed to parse %s/dune-project: %s" subtree msg);
236
+
(pkgs, msg :: errs)
237
+
| Ok dune_proj -> (
238
+
(* Find all .opam files in subtree first - we need them for opam-repo fallback *)
239
+
let opam_files =
240
+
try
241
+
Eio.Path.read_dir subtree_path
242
+
|> List.filter (fun name ->
243
+
Filename.check_suffix name ".opam")
244
+
with Eio.Io _ -> []
245
+
in
246
+
247
+
(* URL resolution order:
248
+
1. sources.toml override
249
+
2. dune-project source/homepage
250
+
3. existing opam-repo dev-repo (fallback) *)
251
+
(* URL resolution order:
252
+
1. Explicit sources.toml entry for this subtree
253
+
2. dune-project source/homepage
254
+
3. sources.toml default_url_base + subtree name *)
255
+
let sources_override = Sources_registry.find sources ~subtree in
256
+
257
+
let derive_from_dune () =
258
+
match
259
+
( Dune_project.dev_repo_url dune_proj,
260
+
Dune_project.url_with_branch dune_proj )
261
+
with
262
+
| Ok dev_repo, Ok url_src -> Some (dev_repo, url_src)
263
+
| Error _, _ | _, Error _ -> None
264
+
in
265
+
266
+
let derive_from_default_base () =
267
+
(* Use default_url_base from sources.toml to construct URL *)
268
+
match Sources_registry.derive_url sources ~subtree with
269
+
| Some dev_repo ->
270
+
Log.debug (fun m ->
271
+
m "Using default_url_base for %s: %s" subtree dev_repo);
272
+
Some (dev_repo, dev_repo ^ "#main")
273
+
| None -> None
274
+
in
275
+
276
+
let dev_repo_and_url =
277
+
match sources_override with
278
+
| Some entry ->
279
+
(* Use explicit sources.toml entry *)
280
+
let dev_repo = entry.Sources_registry.url in
281
+
let branch =
282
+
match entry.Sources_registry.branch with
283
+
| Some b -> b
284
+
| None -> (
285
+
(* Try to get branch from dune-project, default to main *)
286
+
match dune_proj.source with
287
+
| Some (Dune_project.Uri { branch = Some b; _ }) -> b
288
+
| _ -> "main")
289
+
in
290
+
Log.debug (fun m ->
291
+
m "Using sources.toml entry for %s: %s" subtree dev_repo);
292
+
Some (dev_repo, dev_repo ^ "#" ^ branch)
293
+
| None -> (
294
+
match derive_from_dune () with
295
+
| Some result -> Some result
296
+
| None -> (
297
+
match derive_from_default_base () with
298
+
| Some result -> Some result
299
+
| None ->
300
+
Log.warn (fun m ->
301
+
m "Cannot derive dev-repo for %s (no source in dune-project or sources.toml)" subtree);
302
+
None))
303
+
in
304
+
match dev_repo_and_url with
305
+
| None -> (pkgs, "Cannot derive dev-repo" :: errs)
306
+
| Some (dev_repo, url_src) ->
307
+
Log.debug (fun m ->
308
+
m "Found %d opam files in %s" (List.length opam_files)
309
+
subtree);
310
+
(* Transform each opam file *)
311
+
let new_pkgs =
312
+
List.filter_map
313
+
(fun opam_file ->
314
+
let pkg_name =
315
+
Filename.chop_suffix opam_file ".opam"
316
+
in
317
+
let opam_path =
318
+
Eio.Path.(subtree_path / opam_file)
319
+
in
320
+
try
321
+
let raw_content = Eio.Path.load opam_path in
322
+
let opam_content =
323
+
Opam_transform.transform ~content:raw_content
324
+
~dev_repo ~url_src
325
+
in
326
+
Some
327
+
{ pkg_name; subtree; dev_repo; url_src; opam_content }
328
+
with Eio.Io _ -> None)
329
+
opam_files
330
+
in
331
+
(new_pkgs @ pkgs, errs))))
332
+
| _ ->
333
+
(* No dune-project, skip *)
334
+
Log.debug (fun m -> m "No dune-project in %s, skipping" subtree);
335
+
(pkgs, errs)
336
+
| exception Eio.Io _ ->
337
+
(pkgs, errs))
338
+
([], []) subdirs
339
+
in
340
+
341
+
if errors <> [] then
342
+
Log.warn (fun m ->
343
+
m "Encountered %d errors during monorepo discovery" (List.length errors));
344
+
345
+
Log.info (fun m ->
346
+
m "Discovered %d packages from monorepo" (List.length packages));
347
+
Ok (List.rev packages)
348
+
181
349
let get_branch ~config pkg =
182
350
let default = Config.default_branch config in
183
351
match Package.branch pkg with
···
628
796
Log.app (fun m -> m "Updated CLAUDE.md")
629
797
end
630
798
799
+
(** Extract domain from a handle (e.g., "anil.recoil.org" -> "recoil.org") *)
800
+
let domain_from_handle handle =
801
+
match String.index_opt handle '.' with
802
+
| None -> handle (* No dot, return as-is *)
803
+
| Some i -> String.sub handle (i + 1) (String.length handle - i - 1)
804
+
631
805
(** Convert a clone URL to a push URL.
632
806
- GitHub HTTPS URLs are converted to SSH format
633
-
- Tangled URLs (tangled.org) are converted to git.recoil.org SSH format
634
-
- Other URLs are returned unchanged *)
635
-
let url_to_push_url uri =
807
+
- Tangled URLs (tangled.org) are converted to SSH format using the knot server
808
+
- Other URLs are returned unchanged
809
+
@param knot Optional git push server hostname. If not provided, derived from handle in URL. *)
810
+
let url_to_push_url ?knot uri =
636
811
let scheme = Uri.scheme uri in
637
812
let host = Uri.host uri in
638
813
let path = Uri.path uri in
···
646
821
in
647
822
Printf.sprintf "git@github.com:%s" path
648
823
| Some ("https" | "http"), Some "tangled.org" ->
649
-
(* https://tangled.org/@anil.recoil.org/foo -> git@git.recoil.org:anil.recoil.org/foo *)
824
+
(* https://tangled.org/@handle/repo -> git@<knot>:handle/repo *)
650
825
let path =
651
826
if String.length path > 0 && path.[0] = '/' then
652
827
String.sub path 1 (String.length path - 1)
653
828
else path
654
829
in
655
-
(* Strip leading @ from username if present *)
830
+
(* Strip leading @ from handle if present *)
656
831
let path =
657
832
if String.length path > 0 && path.[0] = '@' then
658
833
String.sub path 1 (String.length path - 1)
···
664
839
String.sub path 0 (String.length path - 4)
665
840
else path
666
841
in
667
-
Printf.sprintf "git@git.recoil.org:%s" path
842
+
(* Use provided knot or derive from handle in URL *)
843
+
let knot_server =
844
+
match knot with
845
+
| Some k -> k
846
+
| None ->
847
+
(* Extract handle from path and derive knot *)
848
+
let handle =
849
+
match String.index_opt path '/' with
850
+
| None -> path
851
+
| Some i -> String.sub path 0 i
852
+
in
853
+
"git." ^ domain_from_handle handle
854
+
in
855
+
Printf.sprintf "git@%s:%s" knot_server path
668
856
| _ ->
669
857
(* Return original URL for other cases *)
670
858
Uri.to_string uri
···
1413
1601
m " Pulled: %d cloned, %d updated, %d unchanged"
1414
1602
(List.length cloned) (List.length updated) unchanged);
1415
1603
1604
+
(* Filter repos to only those that were successfully fetched *)
1605
+
let success_names =
1606
+
List.map (fun (name, _, _) -> name) fetch_successes
1607
+
in
1608
+
let successfully_fetched =
1609
+
List.filter
1610
+
(fun pkg -> List.mem (Package.repo_name pkg) success_names)
1611
+
repos
1612
+
in
1613
+
1416
1614
(* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *)
1417
1615
Log.app (fun m -> m " Merging checkouts...");
1418
1616
let merge_errs = ref [] in
···
1428
1626
error = e;
1429
1627
}
1430
1628
:: !merge_errs)
1431
-
repos;
1629
+
successfully_fetched;
1432
1630
1433
1631
(* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *)
1434
1632
(* Check if monorepo has local modifications first *)
···
1445
1643
end
1446
1644
else begin
1447
1645
Log.app (fun m -> m " Updating subtrees...");
1646
+
let fetched_count = List.length successfully_fetched in
1448
1647
List.iteri
1449
1648
(fun i pkg ->
1450
1649
Log.info (fun m ->
1451
-
m "[%d/%d] Subtree %s" (i + 1) total
1650
+
m "[%d/%d] Subtree %s" (i + 1) fetched_count
1452
1651
(Package.subtree_prefix pkg));
1453
1652
match pull_subtree ~proc ~fs ~config pkg with
1454
1653
| Ok _ -> ()
···
1461
1660
}
1462
1661
:: !subtree_errs
1463
1662
| Error _ -> ())
1464
-
repos
1663
+
successfully_fetched
1465
1664
end;
1466
1665
( fetch_errs,
1467
1666
unchanged,
···
1565
1764
(* Read file contents safely, returning None if file doesn't exist *)
1566
1765
let read_file_opt path = try Some (Eio.Path.load path) with Eio.Io _ -> None
1567
1766
1568
-
(* Sync a single package's opam file from monorepo to opam-repo *)
1569
-
let sync_opam_file ~proc ~fs ~config pkg =
1570
-
let monorepo = Config.Paths.monorepo config in
1767
+
(* List all package directories in opam-repo/packages/ *)
1768
+
let list_opam_repo_packages ~fs ~config =
1571
1769
let opam_repo = Config.Paths.opam_repo config in
1572
-
let name = Package.name pkg in
1573
-
let subtree_prefix = Package.subtree_prefix pkg in
1574
-
let version = Package.version pkg in
1770
+
let packages_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages") in
1771
+
try
1772
+
Eio.Path.read_dir packages_dir
1773
+
|> List.filter (fun name ->
1774
+
let child = Eio.Path.(packages_dir / name) in
1775
+
match Eio.Path.kind ~follow:false child with
1776
+
| `Directory -> true
1777
+
| _ -> false)
1778
+
with Eio.Io _ -> []
1575
1779
1576
-
(* Source: monorepo/<subtree>/<name>.opam *)
1577
-
let src_path =
1578
-
Eio.Path.(fs / Fpath.to_string monorepo / subtree_prefix / (name ^ ".opam"))
1579
-
in
1580
-
1581
-
(* Destination: opam-repo/packages/<name>/<name>.<version>/opam *)
1582
-
let pkg_dir =
1583
-
Fpath.(opam_repo / "packages" / name / (name ^ "." ^ version))
1584
-
in
1585
-
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
1586
-
1587
-
match read_file_opt src_path with
1588
-
| None ->
1589
-
(* No opam file in monorepo subtree *)
1590
-
`Missing name
1591
-
| Some src_content ->
1592
-
let dst_content = read_file_opt dst_path in
1593
-
if Some src_content = dst_content then `Unchanged name
1594
-
else begin
1595
-
(* Create destination directory if needed *)
1596
-
let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in
1597
-
(try mkdirs pkg_dir_eio with _ -> ());
1598
-
(* Write the opam file *)
1599
-
Log.info (fun m -> m "Syncing %s.opam to opam-repo" name);
1600
-
Eio.Path.save ~create:(`Or_truncate 0o644) dst_path src_content;
1601
-
(* Stage the change *)
1602
-
let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in
1603
-
let rel_path =
1604
-
Printf.sprintf "packages/%s/%s.%s/opam" name name version
1780
+
(* Delete a package directory from opam-repo *)
1781
+
let delete_opam_repo_package ~proc ~fs ~config name =
1782
+
let opam_repo = Config.Paths.opam_repo config in
1783
+
let pkg_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages" / name) in
1784
+
try
1785
+
Eio.Path.rmtree pkg_dir;
1786
+
(* Stage the deletion *)
1787
+
let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in
1788
+
let rel_path = Printf.sprintf "packages/%s" name in
1789
+
Eio.Switch.run (fun sw ->
1790
+
let child =
1791
+
Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio
1792
+
[ "git"; "add"; "-A"; rel_path ]
1605
1793
in
1606
-
Eio.Switch.run (fun sw ->
1607
-
let child =
1608
-
Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio
1609
-
[ "git"; "add"; rel_path ]
1610
-
in
1611
-
ignore (Eio.Process.await child));
1612
-
`Synced name
1613
-
end
1794
+
ignore (Eio.Process.await child));
1795
+
Log.info (fun m -> m "Deleted orphaned package %s from opam-repo" name);
1796
+
true
1797
+
with Eio.Io _ ->
1798
+
Log.warn (fun m -> m "Failed to delete package %s" name);
1799
+
false
1614
1800
1615
-
(* Sync opam files for all packages *)
1801
+
(* Sync opam files for all packages - generation-based approach *)
1616
1802
let sync_opam_files ~proc ~fs ~config ?package () =
1617
1803
let fs = fs_typed fs in
1618
-
match discover_packages ~fs:(fs :> _ Eio.Path.t) ~config () with
1804
+
1805
+
(* Load sources.toml for URL overrides *)
1806
+
let monorepo = Config.Paths.monorepo config in
1807
+
let sources_path = Fpath.(monorepo / "sources.toml") in
1808
+
let sources =
1809
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
1810
+
| Ok s ->
1811
+
let count = List.length (Sources_registry.to_list s) in
1812
+
if count > 0 then
1813
+
Log.info (fun m -> m "Loaded %d source overrides from sources.toml" count);
1814
+
s
1815
+
| Error msg ->
1816
+
Log.warn (fun m -> m "Failed to load sources.toml: %s" msg);
1817
+
Sources_registry.empty
1818
+
in
1819
+
1820
+
(* Discover packages from monorepo *)
1821
+
match discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources () with
1619
1822
| Error e -> Error e
1620
1823
| Ok all_pkgs ->
1824
+
(* Filter to specific package/subtree if requested *)
1621
1825
let pkgs =
1622
1826
match package with
1623
1827
| None -> all_pkgs
1624
-
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
1828
+
| Some name ->
1829
+
List.filter
1830
+
(fun p -> p.pkg_name = name || p.subtree = name)
1831
+
all_pkgs
1625
1832
in
1626
-
if pkgs = [] && package <> None then
1627
-
Error (Package_not_found (Option.get package))
1628
-
else begin
1629
-
Log.app (fun m ->
1630
-
m "Syncing opam files for %d packages..." (List.length pkgs));
1631
-
let synced = ref [] in
1632
-
let unchanged = ref [] in
1633
-
let missing = ref [] in
1634
-
let orphaned = ref [] in
1635
1833
1636
-
(* Check each package *)
1637
-
List.iter
1638
-
(fun pkg ->
1639
-
(* Check if the subtree exists in monorepo *)
1640
-
let monorepo = Config.Paths.monorepo config in
1641
-
let subtree_prefix = Package.subtree_prefix pkg in
1642
-
let subtree_exists =
1643
-
Git.Subtree.exists ~fs ~repo:monorepo ~prefix:subtree_prefix
1644
-
in
1645
-
1646
-
if not subtree_exists then
1647
-
(* Subtree doesn't exist - package is orphaned in opam-repo *)
1648
-
orphaned := Package.name pkg :: !orphaned
1649
-
else
1650
-
match sync_opam_file ~proc ~fs ~config pkg with
1651
-
| `Synced name -> synced := name :: !synced
1652
-
| `Unchanged name -> unchanged := name :: !unchanged
1653
-
| `Missing name -> missing := name :: !missing)
1654
-
pkgs;
1834
+
Log.app (fun m ->
1835
+
m "Generating opam-repo entries for %d packages..." (List.length pkgs));
1655
1836
1656
-
let result =
1657
-
{
1658
-
synced = List.rev !synced;
1659
-
unchanged = List.rev !unchanged;
1660
-
missing = List.rev !missing;
1661
-
orphaned = List.rev !orphaned;
1662
-
}
1663
-
in
1837
+
let opam_repo = Config.Paths.opam_repo config in
1838
+
let synced = ref [] in
1839
+
let unchanged = ref [] in
1664
1840
1665
-
(* Commit if there were changes *)
1666
-
if result.synced <> [] then begin
1667
-
let opam_repo = Config.Paths.opam_repo config in
1668
-
let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in
1669
-
let msg =
1670
-
Printf.sprintf "Sync opam files from monorepo (%d packages)"
1671
-
(List.length result.synced)
1841
+
(* Generate each package *)
1842
+
List.iter
1843
+
(fun pkg ->
1844
+
(* Destination: opam-repo/packages/<name>/<name>.dev/opam *)
1845
+
let pkg_dir =
1846
+
Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
1672
1847
in
1673
-
Eio.Switch.run (fun sw ->
1674
-
let child =
1675
-
Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio
1676
-
[ "git"; "commit"; "-m"; msg ]
1677
-
in
1678
-
ignore (Eio.Process.await child));
1679
-
Log.app (fun m -> m "Committed opam sync: %s" msg)
1680
-
end;
1848
+
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
1681
1849
1682
-
(* Report orphaned packages *)
1683
-
if result.orphaned <> [] then begin
1684
-
Log.warn (fun m ->
1685
-
m
1686
-
"Found %d orphaned packages in opam-repo (subtree missing from \
1687
-
monorepo):"
1688
-
(List.length result.orphaned));
1850
+
let dst_content = read_file_opt dst_path in
1851
+
if Some pkg.opam_content = dst_content then
1852
+
unchanged := pkg.pkg_name :: !unchanged
1853
+
else begin
1854
+
(* Create destination directory if needed *)
1855
+
let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in
1856
+
(try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ());
1857
+
(* Write the opam file *)
1858
+
Log.info (fun m -> m "Generating %s.opam in opam-repo" pkg.pkg_name);
1859
+
Eio.Path.save ~create:(`Or_truncate 0o644) dst_path pkg.opam_content;
1860
+
(* Stage the change *)
1861
+
let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in
1862
+
let rel_path =
1863
+
Printf.sprintf "packages/%s/%s.dev/opam" pkg.pkg_name pkg.pkg_name
1864
+
in
1865
+
Eio.Switch.run (fun sw ->
1866
+
let child =
1867
+
Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio
1868
+
[ "git"; "add"; rel_path ]
1869
+
in
1870
+
ignore (Eio.Process.await child));
1871
+
synced := pkg.pkg_name :: !synced
1872
+
end)
1873
+
pkgs;
1874
+
1875
+
(* Find and delete orphaned packages *)
1876
+
let generated_names =
1877
+
List.map (fun p -> p.pkg_name) pkgs
1878
+
|> List.sort_uniq String.compare
1879
+
in
1880
+
let existing_packages = list_opam_repo_packages ~fs ~config in
1881
+
let orphaned =
1882
+
List.filter
1883
+
(fun name -> not (List.mem name generated_names))
1884
+
existing_packages
1885
+
in
1886
+
1887
+
(* Delete orphans only if we're doing a full sync (no package filter) *)
1888
+
let deleted =
1889
+
if package = None then begin
1689
1890
List.iter
1690
-
(fun name -> Log.warn (fun m -> m " %s" name))
1691
-
result.orphaned;
1692
-
Log.warn (fun m ->
1693
-
m "To remove, delete from opam-repo/packages/ and commit.")
1694
-
end;
1891
+
(fun name ->
1892
+
Log.info (fun m -> m "Removing orphaned package: %s" name);
1893
+
ignore (delete_opam_repo_package ~proc ~fs ~config name))
1894
+
orphaned;
1895
+
orphaned
1896
+
end
1897
+
else []
1898
+
in
1695
1899
1696
-
Log.app (fun m -> m "%a" pp_opam_sync_result result);
1697
-
Ok result
1698
-
end
1900
+
let result =
1901
+
{
1902
+
synced = List.rev !synced;
1903
+
unchanged = List.rev !unchanged;
1904
+
missing = []; (* No longer used in generation-based approach *)
1905
+
orphaned = deleted;
1906
+
}
1907
+
in
1908
+
1909
+
(* Commit if there were changes *)
1910
+
if result.synced <> [] || result.orphaned <> [] then begin
1911
+
let opam_repo_eio = Eio.Path.(fs / Fpath.to_string opam_repo) in
1912
+
let msg =
1913
+
let parts = [] in
1914
+
let parts =
1915
+
if result.synced <> [] then
1916
+
Printf.sprintf "updated %d" (List.length result.synced) :: parts
1917
+
else parts
1918
+
in
1919
+
let parts =
1920
+
if result.orphaned <> [] then
1921
+
Printf.sprintf "removed %d" (List.length result.orphaned) :: parts
1922
+
else parts
1923
+
in
1924
+
Printf.sprintf "Sync opam files from monorepo (%s packages)"
1925
+
(String.concat ", " parts)
1926
+
in
1927
+
Eio.Switch.run (fun sw ->
1928
+
let child =
1929
+
Eio.Process.spawn proc ~sw ~cwd:opam_repo_eio
1930
+
[ "git"; "commit"; "-m"; msg ]
1931
+
in
1932
+
ignore (Eio.Process.await child));
1933
+
Log.app (fun m -> m "Committed opam sync: %s" msg)
1934
+
end;
1935
+
1936
+
Log.app (fun m -> m "%a" pp_opam_sync_result result);
1937
+
Ok result
1699
1938
1700
1939
let add ~proc ~fs ~config ~package () =
1701
1940
let fs_t = fs_typed fs in
+43
-10
lib/monopam.mli
+43
-10
lib/monopam.mli
···
35
35
module Forks = Forks
36
36
module Doctor = Doctor
37
37
module Feature = Feature
38
+
module Dune_project = Dune_project
39
+
module Opam_transform = Opam_transform
40
+
module Sources_registry = Sources_registry
38
41
39
42
(** {1 High-Level Operations} *)
40
43
···
212
215
?package:string ->
213
216
unit ->
214
217
(opam_sync_result, error) result
215
-
(** [sync_opam_files ~proc ~fs ~config ?package ()] synchronizes .opam files
216
-
from monorepo subtrees to the opam-repo overlay.
218
+
(** [sync_opam_files ~proc ~fs ~config ?package ()] generates opam-repo entries
219
+
from monorepo dune-project files.
217
220
218
-
For each package (or the specified package): 1. Checks if the subtree exists
219
-
in the monorepo 2. If subtree missing, reports as orphaned (needs manual
220
-
removal) 3. Reads the .opam file from the monorepo subtree 4. Compares with
221
-
the opam-repo version 5. If different, copies monorepo → opam-repo (local
222
-
always wins) 6. Stages and commits changes in opam-repo
221
+
For each subtree directory in the monorepo:
222
+
1. Parses the dune-project to extract source/homepage URL
223
+
2. For each .opam file in the subtree:
224
+
- Transforms it by removing dune-generated comment
225
+
- Adds dev-repo and url fields derived from dune-project
226
+
- Writes to opam-repo/packages/<name>/<name>.dev/opam
227
+
3. Deletes any orphaned packages in opam-repo not found in monorepo
228
+
4. Stages and commits changes in opam-repo
223
229
224
-
Orphaned packages (in opam-repo but subtree missing from monorepo) are
225
-
reported with a warning suggesting manual removal.
230
+
This is a generation-based approach - opam-repo is derived entirely from
231
+
monorepo dune-project and .opam files.
226
232
227
233
@param proc Eio process manager
228
234
@param fs Eio filesystem
229
235
@param config Monopam configuration
230
-
@param package Optional specific package to sync *)
236
+
@param package Optional specific subtree to sync *)
231
237
232
238
(** {2 Package Management} *)
233
239
···
302
308
@param fs Eio filesystem
303
309
@param config Monopam configuration
304
310
@param pkgs List of packages discovered from the opam overlay *)
311
+
312
+
(** Information about a package discovered from the monorepo. *)
313
+
type monorepo_package = {
314
+
pkg_name : string; (** Package name (from .opam filename) *)
315
+
subtree : string; (** Subtree directory name *)
316
+
dev_repo : string; (** dev-repo URL derived from dune-project *)
317
+
url_src : string; (** url src with branch (e.g., "git+https://...#main") *)
318
+
opam_content : string; (** Transformed opam file content ready to write *)
319
+
}
320
+
321
+
val discover_packages_from_monorepo :
322
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
323
+
config:Config.t ->
324
+
?sources:Sources_registry.t ->
325
+
unit ->
326
+
(monorepo_package list, error) result
327
+
(** [discover_packages_from_monorepo ~fs ~config ?sources ()] scans monorepo
328
+
subtrees and discovers packages from dune-project files.
329
+
330
+
For each subdirectory of the monorepo with a dune-project file:
331
+
1. Checks sources.toml for URL override
332
+
2. Falls back to dune-project source/homepage URL
333
+
3. For each .opam file in that directory, transforms it with dev-repo and url
334
+
335
+
@param fs Eio filesystem
336
+
@param config Monopam configuration
337
+
@param sources Optional sources registry for URL overrides *)
305
338
306
339
(** {1 Changelog Generation} *)
307
340
+78
lib/opam_transform.ml
+78
lib/opam_transform.ml
···
1
+
(** Transform dune-generated opam files for opam-repo overlay. *)
2
+
3
+
(** Remove the "generated by dune" comment from the first line *)
4
+
let strip_dune_comment content =
5
+
let lines = String.split_on_char '\n' content in
6
+
match lines with
7
+
| first :: rest
8
+
when String.starts_with ~prefix:"# This file is generated by dune"
9
+
(String.trim first) ->
10
+
String.concat "\n" rest
11
+
| _ -> content
12
+
13
+
(** Remove existing dev-repo line if present *)
14
+
let remove_dev_repo_line content =
15
+
let lines = String.split_on_char '\n' content in
16
+
let lines =
17
+
List.filter
18
+
(fun line ->
19
+
let trimmed = String.trim line in
20
+
not (String.starts_with ~prefix:"dev-repo:" trimmed))
21
+
lines
22
+
in
23
+
String.concat "\n" lines
24
+
25
+
(** Remove existing url { ... } section if present *)
26
+
let remove_url_section content =
27
+
let lines = String.split_on_char '\n' content in
28
+
let rec process lines in_url_block acc =
29
+
match lines with
30
+
| [] -> List.rev acc
31
+
| line :: rest ->
32
+
let trimmed = String.trim line in
33
+
if in_url_block then
34
+
(* Inside url { ... }, skip until we see } *)
35
+
if String.starts_with ~prefix:"}" trimmed then
36
+
process rest false acc
37
+
else process rest true acc
38
+
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed
39
+
then
40
+
(* Start of url block *)
41
+
if String.ends_with ~suffix:"}" trimmed then
42
+
(* Single-line url block, skip it *)
43
+
process rest false acc
44
+
else process rest true acc
45
+
else process rest false (line :: acc)
46
+
in
47
+
String.concat "\n" (process lines false [])
48
+
49
+
(** Trim trailing blank lines and ensure single trailing newline *)
50
+
let normalize_ending content =
51
+
let lines = String.split_on_char '\n' content in
52
+
let rec trim_trailing = function
53
+
| [] -> []
54
+
| [ "" ] -> []
55
+
| "" :: rest -> (
56
+
match trim_trailing rest with [] -> [] | trimmed -> "" :: trimmed)
57
+
| x :: rest -> x :: trim_trailing rest
58
+
in
59
+
let lines = List.rev (trim_trailing (List.rev lines)) in
60
+
String.concat "\n" lines
61
+
62
+
let transform ~content ~dev_repo ~url_src =
63
+
(* Step 1: Strip the dune comment *)
64
+
let content = strip_dune_comment content in
65
+
66
+
(* Step 2: Remove any existing dev-repo and url sections *)
67
+
let content = remove_dev_repo_line content in
68
+
let content = remove_url_section content in
69
+
70
+
(* Step 3: Normalize ending *)
71
+
let content = normalize_ending content in
72
+
73
+
(* Step 4: Append dev-repo and url section *)
74
+
let dev_repo_line = Printf.sprintf {|dev-repo: "%s"|} dev_repo in
75
+
let url_section =
76
+
Printf.sprintf "url {\n src: \"%s\"\n}" url_src
77
+
in
78
+
content ^ "\n" ^ dev_repo_line ^ "\n" ^ url_section ^ "\n"
+18
lib/opam_transform.mli
+18
lib/opam_transform.mli
···
1
+
(** Transform dune-generated opam files for opam-repo overlay.
2
+
3
+
Dune generates .opam files from dune-project, but these need to be
4
+
transformed before being placed in the opam-repo overlay:
5
+
- Remove the "generated by dune" comment
6
+
- Add dev-repo field with the git repository URL
7
+
- Add url section with source URL and branch *)
8
+
9
+
val transform : content:string -> dev_repo:string -> url_src:string -> string
10
+
(** [transform ~content ~dev_repo ~url_src] transforms a dune-generated opam file.
11
+
12
+
- Removes the "# This file is generated by dune" comment if present
13
+
- Adds or replaces the [dev-repo] field with [dev_repo]
14
+
- Adds or replaces the [url { src: "..." }] section with [url_src]
15
+
16
+
@param content The original opam file content
17
+
@param dev_repo The dev-repo URL (e.g., "git+https://github.com/user/repo.git")
18
+
@param url_src The url src URL with branch (e.g., "git+https://...#main") *)
+118
lib/sources_registry.ml
+118
lib/sources_registry.ml
···
1
+
(** Sources registry for tracking forked/vendored package URLs. *)
2
+
3
+
type entry = {
4
+
url : string;
5
+
upstream : string option;
6
+
branch : string option;
7
+
reason : string option;
8
+
}
9
+
10
+
type t = {
11
+
default_url_base : string option;
12
+
entries : (string * entry) list;
13
+
}
14
+
15
+
let empty = { default_url_base = None; entries = [] }
16
+
17
+
let default_url_base t = t.default_url_base
18
+
19
+
let with_default_url_base t base =
20
+
{ t with default_url_base = Some base }
21
+
22
+
let find t ~subtree = List.assoc_opt subtree t.entries
23
+
24
+
let derive_url t ~subtree =
25
+
match find t ~subtree with
26
+
| Some entry -> Some entry.url
27
+
| None ->
28
+
(* Use default_url_base to construct URL from subtree name *)
29
+
Option.map (fun base ->
30
+
let base =
31
+
if String.ends_with ~suffix:"/" base then
32
+
String.sub base 0 (String.length base - 1)
33
+
else base
34
+
in
35
+
base ^ "/" ^ subtree
36
+
) t.default_url_base
37
+
38
+
let add t ~subtree entry =
39
+
{ t with entries = (subtree, entry) :: List.remove_assoc subtree t.entries }
40
+
41
+
let remove t ~subtree =
42
+
{ t with entries = List.remove_assoc subtree t.entries }
43
+
44
+
let to_list t = t.entries
45
+
46
+
let of_list entries = { default_url_base = None; entries }
47
+
48
+
(* TOML structure:
49
+
default_url_base = "git+https://tangled.org/anil.recoil.org"
50
+
51
+
[braid]
52
+
url = "git+https://github.com/avsm/braid"
53
+
upstream = "git+https://github.com/mtelvers/braid"
54
+
reason = "Maintenance fork"
55
+
56
+
[eio]
57
+
url = "git+https://github.com/myorg/eio"
58
+
branch = "backport-5.1"
59
+
*)
60
+
61
+
let entry_codec : entry Tomlt.t =
62
+
Tomlt.(
63
+
Table.(
64
+
obj (fun url upstream branch reason -> { url; upstream; branch; reason })
65
+
|> mem "url" string ~enc:(fun e -> e.url)
66
+
|> opt_mem "upstream" string ~enc:(fun e -> e.upstream)
67
+
|> opt_mem "branch" string ~enc:(fun e -> e.branch)
68
+
|> opt_mem "reason" string ~enc:(fun e -> e.reason)
69
+
|> finish))
70
+
71
+
let codec : t Tomlt.t =
72
+
Tomlt.(
73
+
Table.(
74
+
obj (fun default_url_base entries ->
75
+
{ default_url_base; entries })
76
+
|> opt_mem "default_url_base" string ~enc:(fun t -> t.default_url_base)
77
+
|> keep_unknown ~enc:(fun t -> t.entries) (Mems.assoc entry_codec)
78
+
|> finish))
79
+
80
+
let load ~fs path =
81
+
let path_str = Fpath.to_string path in
82
+
let eio_path = Eio.Path.(fs / path_str) in
83
+
(* Check if file exists *)
84
+
match Eio.Path.kind ~follow:true eio_path with
85
+
| `Regular_file -> (
86
+
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
87
+
| Failure msg -> Error (Printf.sprintf "Invalid sources.toml: %s" msg)
88
+
| exn -> Error (Printf.sprintf "Error loading sources.toml: %s" (Printexc.to_string exn)))
89
+
| _ -> Ok empty (* File doesn't exist, return empty registry *)
90
+
| exception _ -> Ok empty
91
+
92
+
let save ~fs path t =
93
+
let path_str = Fpath.to_string path in
94
+
try
95
+
Tomlt_eio.encode_path codec t ~fs path_str;
96
+
Ok ()
97
+
with exn -> Error (Printexc.to_string exn)
98
+
99
+
let pp_entry ppf e =
100
+
Fmt.pf ppf "@[<hov 2>url: %s" e.url;
101
+
Option.iter (fun u -> Fmt.pf ppf "@ upstream: %s" u) e.upstream;
102
+
Option.iter (fun b -> Fmt.pf ppf "@ branch: %s" b) e.branch;
103
+
Option.iter (fun r -> Fmt.pf ppf "@ reason: %s" r) e.reason;
104
+
Fmt.pf ppf "@]"
105
+
106
+
let pp ppf t =
107
+
(match t.default_url_base with
108
+
| Some base -> Fmt.pf ppf "default_url_base: %s@," base
109
+
| None -> ());
110
+
if t.entries = [] then Fmt.pf ppf "(no source overrides)"
111
+
else begin
112
+
Fmt.pf ppf "@[<v>";
113
+
List.iter
114
+
(fun (subtree, entry) ->
115
+
Fmt.pf ppf "@[<v 2>[%s]@,%a@]@," subtree pp_entry entry)
116
+
t.entries;
117
+
Fmt.pf ppf "@]"
118
+
end
+68
lib/sources_registry.mli
+68
lib/sources_registry.mli
···
1
+
(** Sources registry for tracking forked/vendored package URLs.
2
+
3
+
The sources.toml file in the monorepo root tracks packages where
4
+
the dev-repo URL differs from what's declared in dune-project.
5
+
This is typically used for:
6
+
- Forked packages (our fork URL vs upstream)
7
+
- Vendored packages (local copy, custom URL)
8
+
- Packages without source in dune-project
9
+
10
+
The registry also supports a [default_url_base] field that is used
11
+
to derive URLs for subtrees without explicit entries:
12
+
{v
13
+
default_url_base = "git+https://tangled.org/anil.recoil.org"
14
+
v}
15
+
For a subtree named "ocaml-foo", this would produce:
16
+
[git+https://tangled.org/anil.recoil.org/ocaml-foo] *)
17
+
18
+
(** A source entry for a subtree. *)
19
+
type entry = {
20
+
url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
21
+
upstream : string option; (** Original upstream URL if this is a fork *)
22
+
branch : string option; (** Override branch (default: main) *)
23
+
reason : string option; (** Why we have a custom source *)
24
+
}
25
+
26
+
(** The sources registry - maps subtree names to source entries. *)
27
+
type t
28
+
29
+
val empty : t
30
+
(** Empty registry. *)
31
+
32
+
val default_url_base : t -> string option
33
+
(** [default_url_base t] returns the default URL base for deriving URLs. *)
34
+
35
+
val with_default_url_base : t -> string -> t
36
+
(** [with_default_url_base t base] sets the default URL base. *)
37
+
38
+
val find : t -> subtree:string -> entry option
39
+
(** [find t ~subtree] looks up the source entry for a subtree. *)
40
+
41
+
val derive_url : t -> subtree:string -> string option
42
+
(** [derive_url t ~subtree] derives a URL for a subtree.
43
+
First checks for an explicit entry, then uses default_url_base if set. *)
44
+
45
+
val add : t -> subtree:string -> entry -> t
46
+
(** [add t ~subtree entry] adds or replaces an entry. *)
47
+
48
+
val remove : t -> subtree:string -> t
49
+
(** [remove t ~subtree] removes an entry. *)
50
+
51
+
val to_list : t -> (string * entry) list
52
+
(** [to_list t] returns all entries as an association list. *)
53
+
54
+
val of_list : (string * entry) list -> t
55
+
(** [of_list entries] creates a registry from an association list. *)
56
+
57
+
val load : fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
58
+
(** [load ~fs path] loads a sources.toml file. Returns empty registry
59
+
if file doesn't exist. *)
60
+
61
+
val save : fs:_ Eio.Path.t -> Fpath.t -> t -> (unit, string) result
62
+
(** [save ~fs path t] writes the registry to a TOML file. *)
63
+
64
+
val pp_entry : entry Fmt.t
65
+
(** Pretty-print a single entry. *)
66
+
67
+
val pp : t Fmt.t
68
+
(** Pretty-print the registry. *)
+98
-17
lib/verse_config.ml
+98
-17
lib/verse_config.ml
···
1
1
let app_name = "monopam"
2
2
3
+
(** Package-level override for vendored packages *)
4
+
type package_override = {
5
+
dev_repo : string option; (** Override dev-repo URL *)
6
+
branch : string option; (** Override branch *)
7
+
}
8
+
3
9
(* Simplified config: just root and handle. Paths are hardcoded. *)
4
-
type t = { root : Fpath.t; handle : string }
10
+
type t = {
11
+
root : Fpath.t;
12
+
handle : string;
13
+
knot : string; (** Git push server hostname (e.g., "git.recoil.org") *)
14
+
packages : (string * package_override) list; (** Per-subtree overrides *)
15
+
}
5
16
6
17
let root t = t.root
7
18
let handle t = t.handle
19
+
let knot t = t.knot
20
+
let packages t = t.packages
8
21
9
22
(* Hardcoded paths derived from root *)
10
23
let default_branch = "main"
···
43
56
let cache_dir () = Fpath.(xdg_cache_home () / app_name)
44
57
let config_file () = Fpath.(config_dir () / "opamverse.toml")
45
58
let registry_path () = Fpath.(data_dir () / "opamverse-registry")
46
-
let create ~root ~handle () = { root; handle }
59
+
60
+
(** Derive knot (git push server) from handle.
61
+
E.g., "anil.recoil.org" -> "git.recoil.org" *)
62
+
let default_knot_from_handle handle =
63
+
match String.index_opt handle '.' with
64
+
| None -> "git." ^ handle (* fallback *)
65
+
| Some i ->
66
+
let domain = String.sub handle (i + 1) (String.length handle - i - 1) in
67
+
"git." ^ domain
68
+
69
+
let create ~root ~handle ?knot ?(packages = []) () =
70
+
let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in
71
+
{ root; handle; knot; packages }
47
72
48
73
let expand_tilde s =
49
74
if String.length s > 0 && s.[0] = '~' then
···
62
87
match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m)
63
88
~enc:Fpath.to_string Tomlt.string
64
89
65
-
(* Simplified TOML structure:
90
+
(* TOML structure:
66
91
[workspace]
67
92
root = "~/tangled"
68
93
69
94
[identity]
70
95
handle = "anil.recoil.org"
96
+
knot = "git.recoil.org"
97
+
98
+
# Optional package overrides for vendored projects
99
+
[packages.braid]
100
+
dev_repo = "git+https://github.com/avsm/braid"
71
101
*)
72
102
73
103
type workspace_section = { w_root : Fpath.t }
74
-
type identity_section = { i_handle : string }
104
+
type identity_section = { i_handle : string; i_knot : string option }
105
+
106
+
let default_knot = "git.recoil.org"
75
107
76
108
let workspace_codec : workspace_section Tomlt.t =
77
109
Tomlt.(
···
83
115
let identity_codec : identity_section Tomlt.t =
84
116
Tomlt.(
85
117
Table.(
86
-
obj (fun i_handle -> { i_handle })
118
+
obj (fun i_handle i_knot -> { i_handle; i_knot })
87
119
|> mem "handle" string ~enc:(fun i -> i.i_handle)
120
+
|> opt_mem "knot" string ~enc:(fun i -> i.i_knot)
88
121
|> finish))
89
122
123
+
let package_override_codec : package_override Tomlt.t =
124
+
Tomlt.(
125
+
Table.(
126
+
obj (fun dev_repo branch -> { dev_repo; branch })
127
+
|> opt_mem "dev_repo" string ~enc:(fun p -> p.dev_repo)
128
+
|> opt_mem "branch" string ~enc:(fun p -> p.branch)
129
+
|> finish))
130
+
131
+
(* Codec for the [packages] table which contains subtree->override mappings *)
132
+
let packages_table_codec : (string * package_override) list Tomlt.t =
133
+
Tomlt.(
134
+
Table.(
135
+
obj (fun pkgs -> pkgs)
136
+
|> keep_unknown ~enc:(fun pkgs -> pkgs)
137
+
(Mems.assoc package_override_codec)
138
+
|> finish))
139
+
140
+
(* Internal codec that tracks whether knot was present in the file *)
141
+
type loaded_config = { config : t; knot_was_missing : bool }
142
+
143
+
let internal_codec : loaded_config Tomlt.t =
144
+
Tomlt.(
145
+
Table.(
146
+
obj (fun workspace identity packages ->
147
+
let packages = Option.value ~default:[] packages in
148
+
let knot_was_missing = Option.is_none identity.i_knot in
149
+
let knot = Option.value ~default:default_knot identity.i_knot in
150
+
{ config = { root = workspace.w_root; handle = identity.i_handle; knot; packages };
151
+
knot_was_missing })
152
+
|> mem "workspace" workspace_codec ~enc:(fun lc -> { w_root = lc.config.root })
153
+
|> mem "identity" identity_codec ~enc:(fun lc -> { i_handle = lc.config.handle; i_knot = Some lc.config.knot })
154
+
|> opt_mem "packages" packages_table_codec
155
+
~enc:(fun lc -> if lc.config.packages = [] then None else Some lc.config.packages)
156
+
|> finish))
157
+
158
+
(* Public codec for encoding only *)
90
159
let codec : t Tomlt.t =
91
160
Tomlt.(
92
161
Table.(
93
-
obj (fun workspace identity ->
94
-
{ root = workspace.w_root; handle = identity.i_handle })
162
+
obj (fun workspace identity packages ->
163
+
let packages = Option.value ~default:[] packages in
164
+
let knot = Option.value ~default:default_knot identity.i_knot in
165
+
{ root = workspace.w_root; handle = identity.i_handle; knot; packages })
95
166
|> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root })
96
-
|> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle })
167
+
|> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle; i_knot = Some t.knot })
168
+
|> opt_mem "packages" packages_table_codec
169
+
~enc:(fun t -> if t.packages = [] then None else Some t.packages)
97
170
|> finish))
98
-
99
-
let load ~fs () =
100
-
let path = config_file () in
101
-
let path_str = Fpath.to_string path in
102
-
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
103
-
| Eio.Io _ as e -> Error (Printexc.to_string e)
104
-
| Failure msg -> Error (Fmt.str "Invalid config: %s" msg)
105
171
106
172
let save ~fs t =
107
173
let dir = config_dir () in
···
114
180
Ok ()
115
181
with Eio.Io _ as e -> Error (Printexc.to_string e)
116
182
183
+
let load ~fs () =
184
+
let path = config_file () in
185
+
let path_str = Fpath.to_string path in
186
+
try
187
+
let loaded = Tomlt_eio.decode_path_exn internal_codec ~fs path_str in
188
+
(* If knot was missing from the config file, write it back with the default *)
189
+
if loaded.knot_was_missing then begin
190
+
Logs.info (fun m -> m "Adding default knot=%s to config" default_knot);
191
+
ignore (save ~fs loaded.config)
192
+
end;
193
+
Ok loaded.config
194
+
with
195
+
| Eio.Io _ as e -> Error (Printexc.to_string e)
196
+
| Failure msg -> Error (Fmt.str "Invalid config: %s" msg)
197
+
117
198
let pp ppf t =
118
-
Fmt.pf ppf "@[<v>workspace:@, root: %a@,identity:@, handle: %s@]" Fpath.pp
119
-
t.root t.handle
199
+
Fmt.pf ppf "@[<v>workspace:@, root: %a@,identity:@, handle: %s@, knot: %s@]" Fpath.pp
200
+
t.root t.handle t.knot
+29
-3
lib/verse_config.mli
+29
-3
lib/verse_config.mli
···
12
12
13
13
(** {1 Types} *)
14
14
15
+
(** Package-level override for vendored packages. *)
16
+
type package_override = {
17
+
dev_repo : string option; (** Override dev-repo URL for opam-repo generation *)
18
+
branch : string option; (** Override git branch *)
19
+
}
20
+
15
21
type t
16
22
(** Opamverse workspace configuration. *)
17
23
···
22
28
23
29
val handle : t -> string
24
30
(** [handle t] returns the user's tangled handle. *)
31
+
32
+
val knot : t -> string
33
+
(** [knot t] returns the git push server hostname (e.g., "git.recoil.org").
34
+
Used for converting tangled URLs to SSH push URLs. *)
35
+
36
+
val packages : t -> (string * package_override) list
37
+
(** [packages t] returns the list of package overrides.
38
+
Each entry is [(subtree_name, override)] where subtree_name is the
39
+
directory name in the monorepo (e.g., "braid" for mono/braid/).
40
+
41
+
Use this to override dev-repo URLs for vendored packages. *)
25
42
26
43
(** {1 Derived Paths} *)
27
44
···
77
94
@param fs Eio filesystem
78
95
@param config Configuration to save *)
79
96
80
-
val create : root:Fpath.t -> handle:string -> unit -> t
81
-
(** [create ~root ~handle ()] creates a new configuration.
97
+
val create :
98
+
root:Fpath.t ->
99
+
handle:string ->
100
+
?knot:string ->
101
+
?packages:(string * package_override) list ->
102
+
unit ->
103
+
t
104
+
(** [create ~root ~handle ?knot ?packages ()] creates a new configuration.
82
105
83
106
@param root Workspace root directory (absolute path)
84
-
@param handle User's tangled handle *)
107
+
@param handle User's tangled handle
108
+
@param knot Git push server hostname (e.g., "git.recoil.org"). If not provided,
109
+
derived from handle (e.g., "anil.recoil.org" -> "git.recoil.org")
110
+
@param packages Optional list of package overrides for vendored packages *)
85
111
86
112
(** {1 Pretty Printing} *)
87
113