Squashed 'monopam/' changes from 4558db51..f42a95f7 · anil.recoil.org/monopam-myspace@350dac9

+147 -11

bin/main.ml

··· 1259 1259 | Some s -> String.lowercase_ascii (String.trim s) = "y" 1260 1260 | None -> false 1261 1261 1262 + (* Prompt for optional string input *) 1263 + let prompt_string prompt = 1264 + Printf.printf "%s %!" prompt; 1265 + match In_channel.(input_line stdin) with 1266 + | Some s -> 1267 + let s = String.trim s in 1268 + if s = "" then None else Some s 1269 + | None -> None 1270 + 1262 1271 (* Fork command *) 1263 1272 1264 1273 let fork_cmd = ··· 1267 1276 [ 1268 1277 `S Manpage.s_description; 1269 1278 `P 1270 - "Splits a monorepo subdirectory into its own git repository. This \ 1271 - extracts the commit history for the subtree and creates a standalone \ 1272 - repository in src/<name>/."; 1279 + "Splits a monorepo subdirectory into its own git repository and \ 1280 + establishes a proper subtree relationship. This creates src/<name>/ \ 1281 + with the extracted history, then re-adds mono/<name>/ as a subtree."; 1273 1282 `S "FORK MODES"; 1274 1283 `P "The fork command handles two scenarios:"; 1275 1284 `I ("Subtree with history", "For subtrees added via $(b,git subtree add) or \ ··· 1279 1288 history, the command copies the files and creates an initial commit. \ 1280 1289 This is useful for new packages you've developed locally."); 1281 1290 `S "WHAT IT DOES"; 1282 - `P "The fork command:"; 1291 + `P "The fork command performs a complete workflow in one step:"; 1283 1292 `I ("1.", "Analyzes mono/<name>/ to detect fork mode"); 1284 1293 `I ("2.", "Builds an action plan and shows discovery details"); 1285 1294 `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1286 1295 `I ("4.", "Creates a new git repo at src/<name>/"); 1287 - `I ("5.", "Extracts history or copies files based on mode"); 1288 - `I ("6.", "Updates sources.toml with $(b,origin = \"fork\")"); 1296 + `I ("5.", "Extracts history (subtree split) or copies files (fresh package)"); 1297 + `I ("6.", "Removes mono/<name>/ from git and commits"); 1298 + `I ("7.", "Re-adds mono/<name>/ as a proper subtree from src/<name>/"); 1299 + `I ("8.", "Updates sources.toml with $(b,origin = \"fork\")"); 1289 1300 `S "AFTER FORKING"; 1290 - `P "After forking, the subtree will be tracked via src/<name>/:"; 1291 - `I ("1.", "Make changes in mono/<name>/ as usual"); 1292 - `I ("2.", "Run $(b,monopam sync) to push changes to src/<name>/"); 1293 - `I ("3.", "If you provided a URL, push to remote: $(b,cd src/<name> && git push)"); 1301 + `P "After forking, the subtree relationship is fully established:"; 1302 + `I ("-", "mono/<name>/ is now a proper git subtree of src/<name>/"); 1303 + `I ("-", "$(b,monopam sync) will push/pull changes correctly"); 1304 + `I ("-", "No need for manual $(b,git rm) or $(b,monopam rejoin)"); 1305 + `P "To push to a remote:"; 1306 + `Pre "cd src/<name> && git push -u origin main"; 1294 1307 `S Manpage.s_examples; 1295 1308 `P "Fork a subtree with local-only repo:"; 1296 1309 `Pre "monopam fork my-lib"; ··· 1324 1337 with_verse_config env @@ fun config -> 1325 1338 let fs = Eio.Stdenv.fs env in 1326 1339 let proc = Eio.Stdenv.process_mgr env in 1340 + (* Get URL: use provided, or try to derive from dune-project, or prompt *) 1341 + let url = 1342 + match url with 1343 + | Some _ -> url 1344 + | None -> 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 1363 + in 1327 1364 (* Build the plan *) 1328 1365 match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with 1329 1366 | Error e -> ··· 1543 1580 in 1544 1581 Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ yes_arg $ logging_term)) 1545 1582 1583 + (* Rejoin command *) 1584 + 1585 + let rejoin_cmd = 1586 + let doc = "Add a source checkout back into the monorepo as a subtree" in 1587 + let man = 1588 + [ 1589 + `S Manpage.s_description; 1590 + `P 1591 + "Adds an existing src/<name>/ repository back into mono/<name>/ as a \ 1592 + subtree. This is useful after forking a package and removing it from \ 1593 + the monorepo with $(b,git rm)."; 1594 + `S "WORKFLOW"; 1595 + `P "Typical workflow for removing and re-adding a package:"; 1596 + `I ("1.", "Fork the package: $(b,monopam fork my-lib)"); 1597 + `I ("2.", "Remove from monorepo: $(b,git rm -r mono/my-lib && git commit)"); 1598 + `I ("3.", "Work on it in src/my-lib/"); 1599 + `I ("4.", "Re-add to monorepo: $(b,monopam rejoin my-lib)"); 1600 + `S "REQUIREMENTS"; 1601 + `P "For rejoin to work:"; 1602 + `I ("-", "src/<name>/ must exist and be a git repository"); 1603 + `I ("-", "mono/<name>/ must NOT exist (was removed)"); 1604 + `S "WHAT IT DOES"; 1605 + `P "The rejoin command:"; 1606 + `I ("1.", "Verifies src/<name>/ exists and is a git repo"); 1607 + `I ("2.", "Verifies mono/<name>/ does not exist"); 1608 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1609 + `I ("4.", "Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/"); 1610 + `S Manpage.s_examples; 1611 + `P "Re-add a package from src/:"; 1612 + `Pre "monopam rejoin my-lib"; 1613 + `P "Preview what would be done:"; 1614 + `Pre "monopam rejoin my-lib --dry-run"; 1615 + `P "Rejoin without confirmation:"; 1616 + `Pre "monopam rejoin my-lib --yes"; 1617 + ] 1618 + in 1619 + let info = Cmd.info "rejoin" ~doc ~man in 1620 + let name_arg = 1621 + let doc = "Name of the subtree to rejoin (directory name under src/)" in 1622 + Arg.(required & pos 0 (some string) None & info [] ~docv:"NAME" ~doc) 1623 + in 1624 + let dry_run_arg = 1625 + let doc = "Show what would be done without making changes" in 1626 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1627 + in 1628 + let yes_arg = 1629 + let doc = "Assume yes to all prompts (for automation)" in 1630 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1631 + in 1632 + let run name dry_run yes () = 1633 + Eio_main.run @@ fun env -> 1634 + with_verse_config env @@ fun config -> 1635 + let fs = Eio.Stdenv.fs env in 1636 + let proc = Eio.Stdenv.process_mgr env in 1637 + (* Build the plan *) 1638 + match Monopam.Fork_join.plan_rejoin ~proc ~fs ~config ~name ~dry_run () with 1639 + | Error e -> 1640 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1641 + `Error (false, "rejoin failed") 1642 + | Ok plan -> 1643 + (* Print discovery and actions *) 1644 + Fmt.pr "Analyzing rejoin request for '%s'...@.@." name; 1645 + Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery; 1646 + Fmt.pr "@.Actions to perform:@."; 1647 + List.iteri (fun i action -> 1648 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1649 + ) plan.actions; 1650 + Fmt.pr "@."; 1651 + (* Prompt for confirmation unless --yes or --dry-run *) 1652 + let proceed = 1653 + if dry_run then begin 1654 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1655 + true 1656 + end else if yes then 1657 + true 1658 + else 1659 + confirm "Proceed?" 1660 + in 1661 + if not proceed then begin 1662 + Fmt.pr "Cancelled.@."; 1663 + `Ok () 1664 + end else begin 1665 + (* Execute the plan *) 1666 + match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with 1667 + | Ok result -> 1668 + if not dry_run then begin 1669 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1670 + Fmt.pr "@.Next steps:@."; 1671 + Fmt.pr " 1. Commit the changes: git add -A && git commit@."; 1672 + Fmt.pr " 2. Run $(b,monopam sync) to synchronize@." 1673 + end; 1674 + `Ok () 1675 + | Error e -> 1676 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1677 + `Error (false, "rejoin failed") 1678 + end 1679 + in 1680 + Cmd.v info Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term)) 1681 + 1546 1682 (* Site command *) 1547 1683 1548 1684 let site_cmd = ··· 1742 1878 in 1743 1879 let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in 1744 1880 Cmd.group info 1745 - [ init_cmd; status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; devcontainer_cmd; site_cmd ] 1881 + [ init_cmd; status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; rejoin_cmd; devcontainer_cmd; site_cmd ] 1746 1882 1747 1883 let () = exit (Cmd.eval main_cmd)

+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

··· 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. *)

+258 -52

lib/fork_join.ml

··· 5 5 | Git_error of Git.error 6 6 | Subtree_not_found of string 7 7 | Src_already_exists of string 8 + | Src_not_found of string 8 9 | Subtree_already_exists of string 9 10 | No_opam_files of string 10 11 | Verse_error of Verse.error ··· 17 18 | Check_remote_exists of string (** URL - informational check *) 18 19 | Create_directory of Fpath.t 19 20 | Git_init of Fpath.t 21 + | Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *) 20 22 | Git_clone of { url: string; dest: Fpath.t; branch: string } 21 23 | Git_subtree_split of { repo: Fpath.t; prefix: string } 22 24 | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } ··· 27 29 | Copy_directory of { src: Fpath.t; dest: Fpath.t } 28 30 | Git_add_all of Fpath.t 29 31 | Git_commit of { repo: Fpath.t; message: string } 32 + | Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove file/dir from git *) 30 33 | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 31 34 32 35 (** Discovery information gathered during planning *) ··· 52 55 | Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e 53 56 | Subtree_not_found name -> Fmt.pf ppf "Subtree not found in monorepo: %s" name 54 57 | Src_already_exists name -> Fmt.pf ppf "Source checkout already exists: src/%s" name 58 + | Src_not_found name -> Fmt.pf ppf "Source checkout not found: src/%s" name 55 59 | Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name 56 60 | No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name 57 61 | Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e ··· 67 71 Some (Fmt.str "Check that mono/%s exists in your monorepo" name) 68 72 | Src_already_exists name -> 69 73 Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name) 74 + | Src_not_found name -> 75 + Some (Fmt.str "Run 'monopam fork %s' first to create src/%s" name name) 70 76 | Subtree_already_exists name -> 71 77 Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name) 72 78 | No_opam_files name -> ··· 83 89 Fmt.pf ppf "Create directory: %a" Fpath.pp path 84 90 | Git_init path -> 85 91 Fmt.pf ppf "Initialize git repository: %a" Fpath.pp path 92 + | Git_config { repo = _; key; value } -> 93 + Fmt.pf ppf "Set git config %s = %s" key value 86 94 | Git_clone { url; dest; branch } -> 87 95 Fmt.pf ppf "Clone %s (branch: %s) to %a" url branch Fpath.pp dest 88 96 | Git_subtree_split { repo = _; prefix } -> ··· 103 111 Fmt.pf ppf "Stage all changes in %a" Fpath.pp path 104 112 | Git_commit { repo = _; message } -> 105 113 Fmt.pf ppf "Create commit: %s" message 114 + | Git_rm { repo = _; path; recursive = _ } -> 115 + Fmt.pf ppf "Remove '%s' from git" path 106 116 | Update_sources_toml { path = _; name; entry = _ } -> 107 117 Fmt.pf ppf "Update sources.toml for '%s'" name 108 118 ··· 158 168 } 159 169 160 170 let pp_fork_result ppf (r : fork_result) = 171 + (* Only truncate if it looks like a git SHA (40 hex chars), otherwise show full string *) 172 + let commit_display = 173 + if String.length r.split_commit = 40 && 174 + String.for_all (fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) r.split_commit 175 + then String.sub r.split_commit 0 7 176 + else r.split_commit 177 + in 161 178 Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@," 162 - r.name 163 - (String.sub r.split_commit 0 (min 7 (String.length r.split_commit))) 164 - Fpath.pp r.src_path; 179 + r.name commit_display Fpath.pp r.src_path; 165 180 (match r.push_url with 166 181 | Some url -> Fmt.pf ppf " Push URL: %s@," url 167 182 | None -> ()); ··· 216 231 else if String.starts_with ~prefix:"http://" url then "git+" ^ url 217 232 else url 218 233 234 + (** Check if host is a tangled host *) 235 + let is_tangled_host = function 236 + | Some "tangled.org" | Some "tangled.sh" -> true 237 + | _ -> false 238 + 239 + (** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled) *) 240 + let url_to_push_url ?knot url = 241 + (* Strip git+ prefix if present *) 242 + let url = 243 + if String.starts_with ~prefix:"git+" url then 244 + String.sub url 4 (String.length url - 4) 245 + else url 246 + in 247 + let uri = Uri.of_string url in 248 + let scheme = Uri.scheme uri in 249 + let host = Uri.host uri in 250 + let path = Uri.path uri in 251 + match (scheme, host) with 252 + | Some ("https" | "http"), Some "github.com" -> 253 + (* https://github.com/user/repo.git -> git@github.com:user/repo.git *) 254 + let path = 255 + if String.length path > 0 && path.[0] = '/' then 256 + String.sub path 1 (String.length path - 1) 257 + else path 258 + in 259 + Printf.sprintf "git@github.com:%s" path 260 + | Some ("https" | "http"), Some "gitlab.com" -> 261 + (* https://gitlab.com/user/repo.git -> git@gitlab.com:user/repo.git *) 262 + let path = 263 + if String.length path > 0 && path.[0] = '/' then 264 + String.sub path 1 (String.length path - 1) 265 + else path 266 + in 267 + Printf.sprintf "git@gitlab.com:%s" path 268 + | Some ("https" | "http"), _ when is_tangled_host host -> 269 + (* https://tangled.sh/@handle/repo -> git@<knot>:handle/repo *) 270 + let path = 271 + if String.length path > 0 && path.[0] = '/' then 272 + String.sub path 1 (String.length path - 1) 273 + else path 274 + in 275 + (* Strip leading @ from handle if present *) 276 + let path = 277 + if String.length path > 0 && path.[0] = '@' then 278 + String.sub path 1 (String.length path - 1) 279 + else path 280 + in 281 + (* Strip .git suffix if present *) 282 + let path = 283 + if String.ends_with ~suffix:".git" path then 284 + String.sub path 0 (String.length path - 4) 285 + else path 286 + in 287 + (* Use provided knot or default to git.recoil.org *) 288 + let knot_server = Option.value ~default:"git.recoil.org" knot in 289 + Printf.sprintf "git@%s:%s" knot_server path 290 + | _ -> 291 + (* Return original URL for other cases *) 292 + url 293 + 294 + (** Check if a URL is in the user's own namespace (not a true fork) *) 295 + let is_own_namespace ~handle url = 296 + (* Extract user/handle from URL and compare with config handle *) 297 + let url = 298 + if String.starts_with ~prefix:"git+" url then 299 + String.sub url 4 (String.length url - 4) 300 + else url 301 + in 302 + (* For SSH URLs like git@github.com:user/repo.git *) 303 + if String.starts_with ~prefix:"git@" url then 304 + match String.index_opt url ':' with 305 + | Some i -> 306 + let path = String.sub url (i + 1) (String.length url - i - 1) in 307 + (* path is like "user/repo.git" or "handle/repo" *) 308 + (match String.index_opt path '/' with 309 + | Some j -> 310 + let user = String.sub path 0 j in 311 + (* Handle may be like "avsm" or "avsm.bsky.social" - compare first component *) 312 + let handle_first = 313 + match String.index_opt handle '.' with 314 + | Some k -> String.sub handle 0 k 315 + | None -> handle 316 + in 317 + String.equal user handle_first || String.equal user handle 318 + | None -> false) 319 + | None -> false 320 + else 321 + (* For HTTPS URLs like https://github.com/user/repo.git *) 322 + let uri = Uri.of_string url in 323 + let path = Uri.path uri in 324 + let path = 325 + if String.length path > 0 && path.[0] = '/' then 326 + String.sub path 1 (String.length path - 1) 327 + else path 328 + in 329 + (* path is like "user/repo.git" or "@handle/repo" *) 330 + let path = 331 + if String.length path > 0 && path.[0] = '@' then 332 + String.sub path 1 (String.length path - 1) 333 + else path 334 + in 335 + match String.index_opt path '/' with 336 + | Some j -> 337 + let user = String.sub path 0 j in 338 + let handle_first = 339 + match String.index_opt handle '.' with 340 + | Some k -> String.sub handle 0 k 341 + | None -> handle 342 + in 343 + String.equal user handle_first || String.equal user handle 344 + | None -> false 345 + 346 + (** Try to get a suggested push URL from dune-project in the subtree *) 347 + let suggest_push_url ~fs ?knot subtree_path = 348 + let dune_project_path = Fpath.(subtree_path / "dune-project") in 349 + let eio_path = Eio.Path.(fs / Fpath.to_string dune_project_path) in 350 + try 351 + let content = Eio.Path.load eio_path in 352 + match Dune_project.parse content with 353 + | Error _ -> None 354 + | Ok dune_proj -> 355 + match Dune_project.dev_repo_url dune_proj with 356 + | Error _ -> None 357 + | Ok dev_repo -> Some (url_to_push_url ?knot dev_repo) 358 + with Eio.Io _ -> None 359 + 219 360 (** Extract name from URL (last path component without .git suffix) *) 220 361 let name_from_url url = 221 362 let uri = Uri.of_string url in ··· 274 415 275 416 (** {1 Plan Builders} *) 276 417 277 - (** Build a fork plan - handles both subtree and fresh package scenarios *) 418 + (** Build a fork plan - handles both subtree and fresh package scenarios. 419 + 420 + The fork workflow: 421 + 1. Create src/<name>/ with the package content (split or copy) 422 + 2. Remove mono/<name>/ from git 423 + 3. Re-add mono/<name>/ as a proper subtree from src/<name>/ 424 + 425 + This ensures the subtree relationship is properly established for sync. *) 278 426 let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 279 427 let monorepo = Verse_config.mono_path config in 280 428 let checkouts = Verse_config.src_path config in 281 429 let prefix = name in 282 430 let subtree_path = Fpath.(monorepo / prefix) in 283 431 let src_path = Fpath.(checkouts / name) in 432 + let branch = Verse_config.default_branch in 284 433 285 434 (* Gather discovery information *) 286 435 let mono_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in ··· 311 460 else if opam_files = [] then 312 461 Error (No_opam_files name) 313 462 else begin 314 - (* Build actions based on whether we have subtree history *) 315 - let actions = 316 - if has_subtree_hist then begin 317 - (* Subtree fork (existing behavior) *) 318 - let base_actions = [ 463 + (* Build actions for complete fork workflow: 464 + 1. Create src/<name>/ with content 465 + 2. Remove mono/<name>/ and commit 466 + 3. Re-add as subtree from src/<name>/ *) 467 + let create_src_actions = 468 + if has_subtree_hist then 469 + (* Subtree with history: split and push to new repo *) 470 + [ 319 471 Create_directory checkouts; 320 472 Git_subtree_split { repo = monorepo; prefix }; 321 473 Git_init src_path; 474 + (* Allow pushing to checked-out branch (for monopam sync) *) 475 + Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" }; 322 476 Git_add_remote { repo = src_path; name = "mono"; url = Fpath.to_string monorepo }; 323 477 Git_push_ref { repo = monorepo; target = Fpath.to_string src_path; ref_spec = "SPLIT_COMMIT:refs/heads/main" }; 324 - Git_checkout { repo = src_path; branch = "main" }; 325 - ] in 326 - let remote_actions = match push_url with 327 - | Some url -> [ 328 - Git_add_remote { repo = src_path; name = "origin"; url }; 329 - Update_sources_toml { 330 - path = Fpath.(monorepo / "sources.toml"); 331 - name; 332 - entry = Sources_registry.{ 333 - url = normalize_git_url url; 334 - upstream = None; 335 - branch = Some "main"; 336 - reason = None; 337 - origin = Some Fork; 338 - }; 339 - }; 340 - ] 341 - | None -> [] 342 - in 343 - base_actions @ remote_actions 344 - end else begin 345 - (* Fresh package fork (NEW behavior) *) 346 - let base_actions = [ 478 + Git_checkout { repo = src_path; branch }; 479 + ] 480 + else 481 + (* Fresh package: copy files and create initial commit *) 482 + [ 347 483 Create_directory checkouts; 348 484 Create_directory src_path; 349 485 Git_init src_path; 486 + (* Allow pushing to checked-out branch (for monopam sync) *) 487 + Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" }; 488 + Git_branch_rename { repo = src_path; new_name = branch }; 350 489 Copy_directory { src = subtree_path; dest = src_path }; 351 490 Git_add_all src_path; 352 491 Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name }; 353 - ] in 354 - let remote_actions = match push_url with 355 - | Some url -> [ 356 - Git_add_remote { repo = src_path; name = "origin"; url }; 357 - Update_sources_toml { 358 - path = Fpath.(monorepo / "sources.toml"); 359 - name; 360 - entry = Sources_registry.{ 361 - url = normalize_git_url url; 362 - upstream = None; 363 - branch = Some "main"; 364 - reason = None; 365 - origin = Some Fork; 366 - }; 367 - }; 368 - ] 369 - | None -> [] 370 - in 371 - base_actions @ remote_actions 372 - end 492 + ] 493 + in 494 + 495 + (* Add remote if push_url provided *) 496 + let remote_actions = match push_url with 497 + | Some url -> [ Git_add_remote { repo = src_path; name = "origin"; url } ] 498 + | None -> [] 499 + in 500 + 501 + (* Remove from mono and re-add as subtree *) 502 + let rejoin_actions = [ 503 + Git_rm { repo = monorepo; path = prefix; recursive = true }; 504 + Git_commit { repo = monorepo; message = Fmt.str "Remove %s for fork" name }; 505 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 506 + ] in 507 + 508 + (* Update sources.toml only if push_url is a true fork (different namespace) *) 509 + let handle = Verse_config.handle config in 510 + let sources_actions = match push_url with 511 + | Some url when not (is_own_namespace ~handle url) -> [ 512 + Update_sources_toml { 513 + path = Fpath.(monorepo / "sources.toml"); 514 + name; 515 + entry = Sources_registry.{ 516 + url = normalize_git_url url; 517 + upstream = None; 518 + branch = Some branch; 519 + reason = None; 520 + origin = Some Fork; 521 + }; 522 + }; 523 + ] 524 + | Some _ -> [] (* Own namespace - no sources.toml entry needed *) 525 + | None -> [] 373 526 in 527 + 528 + let actions = create_src_actions @ remote_actions @ rejoin_actions @ sources_actions in 374 529 375 530 let result = { 376 531 name; ··· 490 645 Ok { discovery = { discovery with opam_files = opam_preview }; actions; result; dry_run } 491 646 end 492 647 648 + (** Build a rejoin plan - add existing src/<name> back into mono/<name> *) 649 + let plan_rejoin ~proc ~fs ~config ~name ?(dry_run = false) () = 650 + let monorepo = Verse_config.mono_path config in 651 + let checkouts = Verse_config.src_path config in 652 + let prefix = name in 653 + let src_path = Fpath.(checkouts / name) in 654 + 655 + (* Gather discovery information *) 656 + let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 657 + let src_exists = is_directory ~fs src_path in 658 + let src_is_repo = if src_exists then Git.is_repo ~proc ~fs src_path else false in 659 + let opam_files = if src_exists then find_opam_files ~fs src_path else [] in 660 + 661 + let discovery = { 662 + mono_exists = subtree_exists; 663 + src_exists; 664 + has_subtree_history = false; 665 + remote_accessible = None; 666 + opam_files; 667 + local_path_is_repo = Some src_is_repo; 668 + } in 669 + 670 + (* Validation *) 671 + if subtree_exists then 672 + Error (Subtree_already_exists name) 673 + else if not src_exists then 674 + Error (Src_not_found name) 675 + else if not src_is_repo then 676 + Error (Config_error (Fmt.str "src/%s exists but is not a git repository" name)) 677 + else begin 678 + let branch = Verse_config.default_branch in 679 + let actions = [ 680 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 681 + ] in 682 + 683 + let result = { 684 + name; 685 + source_url = Fpath.to_string src_path; 686 + upstream_url = None; 687 + packages_added = opam_files; 688 + from_handle = None; 689 + } in 690 + 691 + Ok { discovery; actions; result; dry_run } 692 + end 693 + 493 694 (** {1 Plan Execution} *) 494 695 495 696 (** State tracked during plan execution *) ··· 508 709 Ok () 509 710 | Git_init path -> 510 711 Git.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e) 712 + | Git_config { repo; key; value } -> 713 + Git.config ~proc ~fs ~key ~value repo |> Result.map_error (fun e -> Git_error e) 511 714 | Git_clone { url; dest; branch } -> 512 715 Git.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest 513 716 |> Result.map_error (fun e -> Git_error e) ··· 556 759 |> Result.map_error (fun e -> Git_error e) 557 760 | Git_commit { repo; message } -> 558 761 Git.commit ~proc ~fs ~message repo 762 + |> Result.map_error (fun e -> Git_error e) 763 + | Git_rm { repo; path; recursive } -> 764 + Git.rm ~proc ~fs ~recursive repo path 559 765 |> Result.map_error (fun e -> Git_error e) 560 766 | Update_sources_toml { path; name; entry } -> 561 767 let sources =

+32

lib/fork_join.mli

··· 20 20 | Git_error of Git.error (** Git operation failed *) 21 21 | Subtree_not_found of string (** Subtree not found in monorepo *) 22 22 | Src_already_exists of string (** Source checkout already exists *) 23 + | Src_not_found of string (** Source checkout not found *) 23 24 | Subtree_already_exists of string (** Subtree already exists in monorepo *) 24 25 | No_opam_files of string (** No .opam files found in subtree *) 25 26 | Verse_error of Verse.error (** Error from verse operations *) ··· 41 42 | Check_remote_exists of string (** URL - informational check *) 42 43 | Create_directory of Fpath.t 43 44 | Git_init of Fpath.t 45 + | Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *) 44 46 | Git_clone of { url: string; dest: Fpath.t; branch: string } 45 47 | Git_subtree_split of { repo: Fpath.t; prefix: string } 46 48 | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } ··· 51 53 | Copy_directory of { src: Fpath.t; dest: Fpath.t } 52 54 | Git_add_all of Fpath.t 53 55 | Git_commit of { repo: Fpath.t; message: string } 56 + | Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove from git *) 54 57 | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 55 58 56 59 (** Discovery information gathered during planning *) ··· 86 89 (** [is_local_path s] returns true if [s] looks like a local filesystem path 87 90 rather than a URL. *) 88 91 92 + val suggest_push_url : fs:Eio.Fs.dir_ty Eio.Path.t -> ?knot:string -> Fpath.t -> string option 93 + (** [suggest_push_url ~fs ?knot subtree_path] tries to derive a push URL from the 94 + dune-project file in the subtree. Returns [Some url] if a source URL can 95 + be found and converted to SSH push format, [None] otherwise. 96 + 97 + @param knot Optional git push server for tangled URLs (default: git.recoil.org) *) 98 + 89 99 (** {1 Result Types} *) 90 100 91 101 (** Result of a fork operation. *) ··· 156 166 @param source Git URL or local filesystem path to join 157 167 @param name Override the subtree directory name (default: derived from source) 158 168 @param upstream Original upstream URL if this is your fork 169 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 170 + 171 + val plan_rejoin : 172 + proc:_ Eio.Process.mgr -> 173 + fs:Eio.Fs.dir_ty Eio.Path.t -> 174 + config:Verse_config.t -> 175 + name:string -> 176 + ?dry_run:bool -> 177 + unit -> 178 + (join_result action_plan, error) result 179 + (** [plan_rejoin ~proc ~fs ~config ~name ?dry_run ()] builds a rejoin plan. 180 + 181 + This is used to add an existing src/<name>/ repository back into mono/<name>/ 182 + as a subtree. Useful after forking a package and removing it from the monorepo. 183 + 184 + Requires: 185 + - src/<name>/ must exist and be a git repository 186 + - mono/<name>/ must not exist 187 + 188 + The plan can be displayed to the user and executed with [execute_join_plan]. 189 + 190 + @param name Name of the subtree (directory name under src/ and mono/) 159 191 @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 160 192 161 193 (** {1 Plan Execution} *)

+9

lib/git.ml

··· 644 644 let cwd = path_to_eio ~fs path in 645 645 run_git_ok ~proc ~cwd [ "commit"; "-m"; message ] |> Result.map ignore 646 646 647 + let rm ~proc ~fs ~recursive path target = 648 + let cwd = path_to_eio ~fs path in 649 + let args = if recursive then [ "rm"; "-r"; target ] else [ "rm"; target ] in 650 + run_git_ok ~proc ~cwd args |> Result.map ignore 651 + 652 + let config ~proc ~fs ~key ~value path = 653 + let cwd = path_to_eio ~fs path in 654 + run_git_ok ~proc ~cwd [ "config"; key; value ] |> Result.map ignore 655 + 647 656 let has_subtree_history ~proc ~fs ~repo ~prefix () = 648 657 (* Check if there's subtree commit history for this prefix. 649 658 Returns true if we can find a subtree-related commit message. *)

+21

lib/git.mli

··· 613 613 (** [commit ~proc ~fs ~message path] creates a commit with the given message 614 614 in the repository at [path]. *) 615 615 616 + val rm : 617 + proc:_ Eio.Process.mgr -> 618 + fs:Eio.Fs.dir_ty Eio.Path.t -> 619 + recursive:bool -> 620 + Fpath.t -> 621 + string -> 622 + (unit, error) result 623 + (** [rm ~proc ~fs ~recursive path target] removes [target] from the git index 624 + in the repository at [path]. If [recursive] is true, removes directories 625 + recursively (git rm -r). *) 626 + 627 + val config : 628 + proc:_ Eio.Process.mgr -> 629 + fs:Eio.Fs.dir_ty Eio.Path.t -> 630 + key:string -> 631 + value:string -> 632 + Fpath.t -> 633 + (unit, error) result 634 + (** [config ~proc ~fs ~key ~value path] sets a git config value in the 635 + repository at [path]. *) 636 + 616 637 val has_subtree_history : 617 638 proc:_ Eio.Process.mgr -> 618 639 fs:Eio.Fs.dir_ty Eio.Path.t ->

+6 -3

lib/monopam.ml

··· 890 890 let pull_subtree ~proc ~fs ~config pkg = 891 891 let fs = fs_typed fs in 892 892 let monorepo = Config.Paths.monorepo config in 893 + let checkouts_root = Config.Paths.checkouts config in 893 894 let prefix = Package.subtree_prefix pkg in 894 895 let branch = get_branch ~config pkg in 895 - let url = Package.dev_repo pkg in 896 + (* Pull from local checkout, not remote URL - ensures push/pull use same source *) 897 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 898 + let url = Uri.of_string (Fpath.to_string checkout_dir) in 896 899 if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then begin 897 - Log.info (fun m -> m "Pulling subtree %s" prefix); 900 + Log.info (fun m -> m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir); 898 901 match Git.Subtree.pull ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with 899 902 | Ok () -> Ok false (* not newly added *) 900 903 | Error e -> Error (Git_error e) 901 904 end 902 905 else begin 903 - Log.info (fun m -> m "Adding subtree %s" prefix); 906 + Log.info (fun m -> m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir); 904 907 match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with 905 908 | Ok () -> Ok true (* newly added *) 906 909 | Error e -> Error (Git_error e)

Configure Feed

Configure Feed