jon.recoil.org
forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Fork: derive default push URL from dune-project metadata
- Add suggest_push_url function to derive push URL from dune-project source field
- Support github, gitlab, tangled, and uri sources
- Convert https URLs to SSH push format (git@...)
- Prompt with suggested URL as default, user can press Enter to accept
- Fix pp_fork_result to not truncate non-SHA strings like "(fresh package)"
- Add Tangled variant to Dune_project.source_info for tangled.sh sources
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
anil.recoil.org
+19
-4
bin/main.ml
+19
-4
bin/main.ml
···
1337
1337
with_verse_config env @@ fun config ->
1338
1338
let fs = Eio.Stdenv.fs env in
1339
1339
let proc = Eio.Stdenv.process_mgr env in
1340
-
(* Prompt for URL if not provided (unless --yes or --dry-run) *)
1340
+
(* Get URL: use provided, or try to derive from dune-project, or prompt *)
1341
1341
let url =
1342
1342
match url with
1343
1343
| Some _ -> url
1344
-
| None when yes || dry_run -> None
1345
1344
| None ->
1346
-
Fmt.pr "Remote push URL (leave empty to skip): %!";
1347
-
prompt_string ""
1345
+
(* Try to get default from dune-project *)
1346
+
let mono_path = Monopam.Config.mono_path config in
1347
+
let subtree_path = Fpath.(mono_path / name) in
1348
+
let knot = Monopam.Config.knot config in
1349
+
let suggested = Monopam.Fork_join.suggest_push_url ~fs ~knot subtree_path in
1350
+
if yes || dry_run then
1351
+
suggested (* Use suggested or None without prompting *)
1352
+
else begin
1353
+
match suggested with
1354
+
| Some default_url ->
1355
+
Fmt.pr "Remote push URL [%s]: %!" default_url;
1356
+
(match prompt_string "" with
1357
+
| None -> Some default_url (* User pressed enter, use default *)
1358
+
| Some entered -> Some entered)
1359
+
| None ->
1360
+
Fmt.pr "Remote push URL (leave empty to skip): %!";
1361
+
prompt_string ""
1362
+
end
1348
1363
in
1349
1364
(* Build the plan *)
1350
1365
match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with
+12
lib/dune_project.ml
+12
lib/dune_project.ml
···
3
3
type source_info =
4
4
| Github of { user : string; repo : string }
5
5
| Gitlab of { user : string; repo : string }
6
+
| Tangled of { host : string; repo : string } (** tangled.org style sources *)
6
7
| Uri of { url : string; branch : string option }
7
8
8
9
type t = {
···
30
31
match String.split_on_char '/' user_repo with
31
32
| [ user; repo ] -> Some (Gitlab { user; repo })
32
33
| _ -> None)
34
+
| Sexp.List [ Sexp.Atom "tangled"; Sexp.Atom host_repo ] -> (
35
+
(* tangled sources: (tangled host.domain/repo) *)
36
+
match String.index_opt host_repo '/' with
37
+
| Some i ->
38
+
let host = String.sub host_repo 0 i in
39
+
let repo = String.sub host_repo (i + 1) (String.length host_repo - i - 1) in
40
+
Some (Tangled { host; repo })
41
+
| None -> None)
33
42
| Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] ->
34
43
(* Check for branch in URI fragment *)
35
44
let uri = Uri.of_string url in
···
112
121
Ok (Printf.sprintf "git+https://github.com/%s/%s.git" user repo)
113
122
| Some (Gitlab { user; repo }) ->
114
123
Ok (Printf.sprintf "git+https://gitlab.com/%s/%s.git" user repo)
124
+
| Some (Tangled { host; repo }) ->
125
+
(* Tangled sources: https://tangled.sh/@handle/repo *)
126
+
Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo)
115
127
| Some (Uri { url; _ }) ->
116
128
Ok (normalize_git_url (ensure_git_suffix url))
117
129
| None -> (
+1
lib/dune_project.mli
+1
lib/dune_project.mli
···
7
7
type source_info =
8
8
| Github of { user : string; repo : string }
9
9
| Gitlab of { user : string; repo : string }
10
+
| Tangled of { host : string; repo : string } (** tangled.sh style sources *)
10
11
| Uri of { url : string; branch : string option }
11
12
12
13
(** Parsed dune-project file. *)
+74
lib/fork_join.ml
+74
lib/fork_join.ml
···
228
228
else if String.starts_with ~prefix:"http://" url then "git+" ^ url
229
229
else url
230
230
231
+
(** Check if host is a tangled host *)
232
+
let is_tangled_host = function
233
+
| Some "tangled.org" | Some "tangled.sh" -> true
234
+
| _ -> false
235
+
236
+
(** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled) *)
237
+
let url_to_push_url ?knot url =
238
+
(* Strip git+ prefix if present *)
239
+
let url =
240
+
if String.starts_with ~prefix:"git+" url then
241
+
String.sub url 4 (String.length url - 4)
242
+
else url
243
+
in
244
+
let uri = Uri.of_string url in
245
+
let scheme = Uri.scheme uri in
246
+
let host = Uri.host uri in
247
+
let path = Uri.path uri in
248
+
match (scheme, host) with
249
+
| Some ("https" | "http"), Some "github.com" ->
250
+
(* https://github.com/user/repo.git -> git@github.com:user/repo.git *)
251
+
let path =
252
+
if String.length path > 0 && path.[0] = '/' then
253
+
String.sub path 1 (String.length path - 1)
254
+
else path
255
+
in
256
+
Printf.sprintf "git@github.com:%s" path
257
+
| Some ("https" | "http"), Some "gitlab.com" ->
258
+
(* https://gitlab.com/user/repo.git -> git@gitlab.com:user/repo.git *)
259
+
let path =
260
+
if String.length path > 0 && path.[0] = '/' then
261
+
String.sub path 1 (String.length path - 1)
262
+
else path
263
+
in
264
+
Printf.sprintf "git@gitlab.com:%s" path
265
+
| Some ("https" | "http"), _ when is_tangled_host host ->
266
+
(* https://tangled.sh/@handle/repo -> git@<knot>:handle/repo *)
267
+
let path =
268
+
if String.length path > 0 && path.[0] = '/' then
269
+
String.sub path 1 (String.length path - 1)
270
+
else path
271
+
in
272
+
(* Strip leading @ from handle if present *)
273
+
let path =
274
+
if String.length path > 0 && path.[0] = '@' then
275
+
String.sub path 1 (String.length path - 1)
276
+
else path
277
+
in
278
+
(* Strip .git suffix if present *)
279
+
let path =
280
+
if String.ends_with ~suffix:".git" path then
281
+
String.sub path 0 (String.length path - 4)
282
+
else path
283
+
in
284
+
(* Use provided knot or default to git.recoil.org *)
285
+
let knot_server = Option.value ~default:"git.recoil.org" knot in
286
+
Printf.sprintf "git@%s:%s" knot_server path
287
+
| _ ->
288
+
(* Return original URL for other cases *)
289
+
url
290
+
291
+
(** Try to get a suggested push URL from dune-project in the subtree *)
292
+
let suggest_push_url ~fs ?knot subtree_path =
293
+
let dune_project_path = Fpath.(subtree_path / "dune-project") in
294
+
let eio_path = Eio.Path.(fs / Fpath.to_string dune_project_path) in
295
+
try
296
+
let content = Eio.Path.load eio_path in
297
+
match Dune_project.parse content with
298
+
| Error _ -> None
299
+
| Ok dune_proj ->
300
+
match Dune_project.dev_repo_url dune_proj with
301
+
| Error _ -> None
302
+
| Ok dev_repo -> Some (url_to_push_url ?knot dev_repo)
303
+
with Eio.Io _ -> None
304
+
231
305
(** Extract name from URL (last path component without .git suffix) *)
232
306
let name_from_url url =
233
307
let uri = Uri.of_string url in
+7
lib/fork_join.mli
+7
lib/fork_join.mli
···
88
88
(** [is_local_path s] returns true if [s] looks like a local filesystem path
89
89
rather than a URL. *)
90
90
91
+
val suggest_push_url : fs:Eio.Fs.dir_ty Eio.Path.t -> ?knot:string -> Fpath.t -> string option
92
+
(** [suggest_push_url ~fs ?knot subtree_path] tries to derive a push URL from the
93
+
dune-project file in the subtree. Returns [Some url] if a source URL can
94
+
be found and converted to SSH push format, [None] otherwise.
95
+
96
+
@param knot Optional git push server for tangled URLs (default: git.recoil.org) *)
97
+
91
98
(** {1 Result Types} *)
92
99
93
100
(** Result of a fork operation. *)