+144 -74

bin/main.ml

reviewed

··· 24 24 let doc = "Package name. If not specified, operates on all packages." in 25 25 Arg.(value & pos 0 (some string) None & info [] ~docv:"PACKAGE" ~doc) 26 26 27 27 - (* Load config from opamverse.toml and convert to Monopam.Config *) 27 27 + (* Load config from opamverse.toml *) 28 28 let load_config env = 29 29 let fs = Eio.Stdenv.fs env in 30 30 - match Monopam.Verse_config.load ~fs () with 31 31 - | Error msg -> Error msg 32 32 - | Ok verse_config -> 33 33 - (* Convert Verse_config to Monopam.Config *) 34 34 - let opam_repo = Monopam.Verse_config.opam_repo_path verse_config in 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 38 - let base_config = 39 39 - Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch () 40 40 - in 41 41 - (* Apply package overrides from verse config *) 42 42 - let config = 43 43 - List.fold_left 44 44 - (fun cfg (name, override) -> 45 45 - let open Monopam.Verse_config in 46 46 - Monopam.Config.with_package_override cfg ~name ?branch:override.branch 47 47 - ()) 48 48 - base_config 49 49 - (Monopam.Verse_config.packages verse_config) 50 50 - in 51 51 - Ok config 30 30 + Monopam.Config.load ~fs () 52 31 53 32 let with_config env f = 54 33 match load_config env with ··· 1273 1252 in 1274 1253 Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term)) 1275 1254 1255 1255 + (* Confirmation prompt *) 1256 1256 + let confirm prompt = 1257 1257 + Printf.printf "%s [y/N] %!" prompt; 1258 1258 + match In_channel.(input_line stdin) with 1259 1259 + | Some s -> String.lowercase_ascii (String.trim s) = "y" 1260 1260 + | None -> false 1261 1261 + 1276 1262 (* Fork command *) 1277 1263 1278 1264 let fork_cmd = ··· 1284 1270 "Splits a monorepo subdirectory into its own git repository. This \ 1285 1271 extracts the commit history for the subtree and creates a standalone \ 1286 1272 repository in src/<name>/."; 1273 1273 + `S "FORK MODES"; 1274 1274 + `P "The fork command handles two scenarios:"; 1275 1275 + `I ("Subtree with history", "For subtrees added via $(b,git subtree add) or \ 1276 1276 + $(b,monopam join), the command uses $(b,git subtree split) to extract \ 1277 1277 + the full commit history into the new repository."); 1278 1278 + `I ("Fresh package", "For packages created directly in mono/ without subtree \ 1279 1279 + history, the command copies the files and creates an initial commit. \ 1280 1280 + This is useful for new packages you've developed locally."); 1287 1281 `S "WHAT IT DOES"; 1288 1282 `P "The fork command:"; 1289 1289 - `I ("1.", "Validates mono/<name>/ exists as a subtree"); 1290 1290 - `I ("2.", "Uses $(b,git subtree split) to extract history"); 1291 1291 - `I ("3.", "Creates a new git repo at src/<name>/"); 1292 1292 - `I ("4.", "Pushes the extracted history to the new repo"); 1293 1293 - `I ("5.", "Updates sources.toml with $(b,origin = \"fork\")"); 1294 1294 - `I ("6.", "Auto-discovers packages from .opam files"); 1283 1283 + `I ("1.", "Analyzes mono/<name>/ to detect fork mode"); 1284 1284 + `I ("2.", "Builds an action plan and shows discovery details"); 1285 1285 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1286 1286 + `I ("4.", "Creates a new git repo at src/<name>/"); 1287 1287 + `I ("5.", "Extracts history or copies files based on mode"); 1288 1288 + `I ("6.", "Updates sources.toml with $(b,origin = \"fork\")"); 1295 1289 `S "AFTER FORKING"; 1296 1290 `P "After forking, the subtree will be tracked via src/<name>/:"; 1297 1291 `I ("1.", "Make changes in mono/<name>/ as usual"); ··· 1304 1298 `Pre "monopam fork my-lib git@github.com:me/my-lib.git"; 1305 1299 `P "Preview what would be done:"; 1306 1300 `Pre "monopam fork my-lib --dry-run"; 1301 1301 + `P "Fork without confirmation:"; 1302 1302 + `Pre "monopam fork my-lib --yes"; 1307 1303 ] 1308 1304 in 1309 1305 let info = Cmd.info "fork" ~doc ~man in ··· 1319 1315 let doc = "Show what would be done without making changes" in 1320 1316 Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1321 1317 in 1322 1322 - let run name url dry_run () = 1318 1318 + let yes_arg = 1319 1319 + let doc = "Assume yes to all prompts (for automation)" in 1320 1320 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1321 1321 + in 1322 1322 + let run name url dry_run yes () = 1323 1323 Eio_main.run @@ fun env -> 1324 1324 with_verse_config env @@ fun config -> 1325 1325 let fs = Eio.Stdenv.fs env in 1326 1326 let proc = Eio.Stdenv.process_mgr env in 1327 1327 - match Monopam.Fork_join.fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with 1328 1328 - | Ok result -> 1329 1329 - if dry_run then begin 1330 1330 - Fmt.pr "Would fork subtree '%s':@." result.name; 1331 1331 - Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_created; 1332 1332 - Fmt.pr " Destination: %a@." Fpath.pp result.src_path; 1333 1333 - match url with 1334 1334 - | Some u -> Fmt.pr " Push URL: %s@." u 1335 1335 - | None -> () 1336 1336 - end else begin 1337 1337 - Fmt.pr "%a@." Monopam.Fork_join.pp_fork_result result; 1338 1338 - Fmt.pr "@.Next steps:@."; 1339 1339 - Fmt.pr " 1. Review the new repo: cd src/%s@." result.name; 1340 1340 - match url with 1341 1341 - | Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@." 1342 1342 - | None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@." 1343 1343 - end; 1344 1344 - `Ok () 1327 1327 + (* Build the plan *) 1328 1328 + match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with 1345 1329 | Error e -> 1346 1330 Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1347 1331 `Error (false, "fork failed") 1332 1332 + | Ok plan -> 1333 1333 + (* Print discovery and actions *) 1334 1334 + Fmt.pr "Analyzing fork request for '%s'...@.@." name; 1335 1335 + Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery; 1336 1336 + (match url with 1337 1337 + | Some u -> Fmt.pr " Remote URL: %s@." u 1338 1338 + | None -> ()); 1339 1339 + Fmt.pr "@.Actions to perform:@."; 1340 1340 + List.iteri (fun i action -> 1341 1341 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1342 1342 + ) plan.actions; 1343 1343 + Fmt.pr "@."; 1344 1344 + (* Prompt for confirmation unless --yes or --dry-run *) 1345 1345 + let proceed = 1346 1346 + if dry_run then begin 1347 1347 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1348 1348 + true 1349 1349 + end else if yes then 1350 1350 + true 1351 1351 + else 1352 1352 + confirm "Proceed?" 1353 1353 + in 1354 1354 + if not proceed then begin 1355 1355 + Fmt.pr "Cancelled.@."; 1356 1356 + `Ok () 1357 1357 + end else begin 1358 1358 + (* Execute the plan *) 1359 1359 + match Monopam.Fork_join.execute_fork_plan ~proc ~fs plan with 1360 1360 + | Ok result -> 1361 1361 + if not dry_run then begin 1362 1362 + Fmt.pr "%a@." Monopam.Fork_join.pp_fork_result result; 1363 1363 + Fmt.pr "@.Next steps:@."; 1364 1364 + Fmt.pr " 1. Review the new repo: cd src/%s@." result.name; 1365 1365 + match url with 1366 1366 + | Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@." 1367 1367 + | None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@." 1368 1368 + end; 1369 1369 + `Ok () 1370 1370 + | Error e -> 1371 1371 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1372 1372 + `Error (false, "fork failed") 1373 1373 + end 1348 1374 in 1349 1349 - Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ logging_term)) 1375 1375 + Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term)) 1350 1376 1351 1377 (* Join command *) 1352 1378 ··· 1358 1384 `P 1359 1385 "Clones an external git repository and adds it as a subtree in the \ 1360 1386 monorepo. This is the inverse of $(b,monopam fork)."; 1387 1387 + `S "JOIN MODES"; 1388 1388 + `P "The join command handles multiple scenarios:"; 1389 1389 + `I ("URL join", "Clone from a git URL and add as subtree (default)."); 1390 1390 + `I ("Local directory join", "Import from a local filesystem path. If the \ 1391 1391 + path is a git repo, uses it directly. If not, initializes a new repo."); 1392 1392 + `I ("Verse join", "Join from a verse member's repository using $(b,--from)."); 1361 1393 `S "WHAT IT DOES"; 1362 1394 `P "The join command:"; 1363 1363 - `I ("1.", "Derives subtree name from URL (or uses --as)"); 1364 1364 - `I ("2.", "Validates mono/<name>/ does not exist"); 1365 1365 - `I ("3.", "Clones the repository to src/<name>/"); 1366 1366 - `I ("4.", "Uses $(b,git subtree add) to bring into monorepo"); 1367 1367 - `I ("5.", "Updates sources.toml with $(b,origin = \"join\")"); 1368 1368 - `I ("6.", "Auto-discovers packages from .opam files"); 1395 1395 + `I ("1.", "Analyzes the source (URL or local path)"); 1396 1396 + `I ("2.", "Builds an action plan and shows discovery details"); 1397 1397 + `I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)"); 1398 1398 + `I ("4.", "Clones/copies the repository to src/<name>/"); 1399 1399 + `I ("5.", "Uses $(b,git subtree add) to bring into monorepo"); 1400 1400 + `I ("6.", "Updates sources.toml with $(b,origin = \"join\")"); 1369 1401 `S "JOINING FROM VERSE"; 1370 1402 `P "To join a package from a verse member, use $(b,--from):"; 1371 1403 `Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp"; ··· 1382 1414 `S Manpage.s_examples; 1383 1415 `P "Join a repository:"; 1384 1416 `Pre "monopam join https://github.com/someone/some-lib"; 1417 1417 + `P "Join from a local directory:"; 1418 1418 + `Pre "monopam join /path/to/local/repo --as my-lib"; 1385 1419 `P "Join with explicit name using --url:"; 1386 1420 `Pre "monopam join --url https://tangled.org/handle/sortal sortal"; 1387 1421 `P "Join with a custom name using --as:"; ··· 1392 1426 `Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git"; 1393 1427 `P "Preview what would be done:"; 1394 1428 `Pre "monopam join https://github.com/someone/lib --dry-run"; 1429 1429 + `P "Join without confirmation:"; 1430 1430 + `Pre "monopam join https://github.com/someone/lib --yes"; 1395 1431 ] 1396 1432 in 1397 1433 let info = Cmd.info "join" ~doc ~man in 1398 1434 let url_or_pkg_arg = 1399 1399 - let doc = "Git URL to join, or subtree name (when using --url)" in 1400 1400 - Arg.(required & pos 0 (some string) None & info [] ~docv:"URL|NAME" ~doc) 1435 1435 + let doc = "Git URL, local path, or subtree name (when using --url)" in 1436 1436 + Arg.(required & pos 0 (some string) None & info [] ~docv:"SOURCE" ~doc) 1401 1437 in 1402 1438 let as_arg = 1403 1439 let doc = "Override subtree directory name" in ··· 1419 1455 let doc = "Show what would be done without making changes" in 1420 1456 Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1421 1457 in 1422 1422 - let run url_or_pkg as_name upstream from fork_url dry_run () = 1458 1458 + let yes_arg = 1459 1459 + let doc = "Assume yes to all prompts (for automation)" in 1460 1460 + Arg.(value & flag & info [ "yes"; "y" ] ~doc) 1461 1461 + in 1462 1462 + let run url_or_pkg as_name upstream from fork_url dry_run yes () = 1423 1463 Eio_main.run @@ fun env -> 1424 1464 with_verse_config env @@ fun config -> 1425 1465 let fs = Eio.Stdenv.fs env in ··· 1427 1467 match from with 1428 1468 | Some handle -> 1429 1469 (* Join from verse member - requires --url for your fork *) 1470 1470 + (* Uses legacy API as it involves verse-specific operations *) 1430 1471 (match fork_url with 1431 1472 | None -> 1432 1473 Fmt.epr "Error: --url is required when using --from@."; ··· 1451 1492 Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1452 1493 `Error (false, "join failed")) 1453 1494 | None -> 1454 1454 - (* Normal join from URL - use --url if provided, otherwise positional arg *) 1455 1455 - let url = match fork_url with Some u -> u | None -> url_or_pkg in 1495 1495 + (* Normal join from URL or local path - use plan-based workflow *) 1496 1496 + let source = match fork_url with Some u -> u | None -> url_or_pkg in 1456 1497 let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in 1457 1457 - match Monopam.Fork_join.join ~proc ~fs ~config ~url ?name ?upstream ~dry_run () with 1458 1458 - | Ok result -> 1459 1459 - if dry_run then begin 1460 1460 - Fmt.pr "Would join '%s':@." result.name; 1461 1461 - Fmt.pr " Source: %s@." result.source_url; 1462 1462 - Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url; 1463 1463 - Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added 1464 1464 - end else begin 1465 1465 - Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1466 1466 - Fmt.pr "@.Next steps:@."; 1467 1467 - Fmt.pr " 1. Run $(b,monopam sync) to synchronize@." 1468 1468 - end; 1469 1469 - `Ok () 1498 1498 + (* Build the plan *) 1499 1499 + match Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream ~dry_run () with 1470 1500 | Error e -> 1471 1501 Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1472 1502 `Error (false, "join failed") 1503 1503 + | Ok plan -> 1504 1504 + (* Print discovery and actions *) 1505 1505 + let is_local = Monopam.Fork_join.is_local_path source in 1506 1506 + Fmt.pr "Analyzing join request...@.@."; 1507 1507 + Fmt.pr "Discovery:@."; 1508 1508 + Fmt.pr " Source: %s (%s)@." source 1509 1509 + (if is_local then "local directory" else "remote URL"); 1510 1510 + Fmt.pr "%a" Monopam.Fork_join.pp_discovery plan.discovery; 1511 1511 + Fmt.pr "@.Actions to perform:@."; 1512 1512 + List.iteri (fun i action -> 1513 1513 + Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action 1514 1514 + ) plan.actions; 1515 1515 + Fmt.pr "@."; 1516 1516 + (* Prompt for confirmation unless --yes or --dry-run *) 1517 1517 + let proceed = 1518 1518 + if dry_run then begin 1519 1519 + Fmt.pr "(dry-run mode - no changes will be made)@."; 1520 1520 + true 1521 1521 + end else if yes then 1522 1522 + true 1523 1523 + else 1524 1524 + confirm "Proceed?" 1525 1525 + in 1526 1526 + if not proceed then begin 1527 1527 + Fmt.pr "Cancelled.@."; 1528 1528 + `Ok () 1529 1529 + end else begin 1530 1530 + (* Execute the plan *) 1531 1531 + match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with 1532 1532 + | Ok result -> 1533 1533 + if not dry_run then begin 1534 1534 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1535 1535 + Fmt.pr "@.Next steps:@."; 1536 1536 + Fmt.pr " 1. Run $(b,monopam sync) to synchronize@." 1537 1537 + end; 1538 1538 + `Ok () 1539 1539 + | Error e -> 1540 1540 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1541 1541 + `Error (false, "join failed") 1542 1542 + end 1473 1543 in 1474 1474 - Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ logging_term)) 1544 1544 + 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)) 1475 1545 1476 1546 (* Site command *) 1477 1547

+190 -91

lib/config.ml

reviewed

··· 1 1 + (** Unified configuration for monopam. 2 2 + 3 3 + Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml *) 4 4 + 5 5 + let app_name = "monopam" 6 6 + 7 7 + (** {1 Package Overrides} *) 8 8 + 1 9 module Package_config = struct 2 10 type t = { branch : string option } 3 11 ··· 11 19 |> finish)) 12 20 end 13 21 22 22 + (** {1 Paths Configuration} *) 23 23 + 24 24 + type paths = { 25 25 + mono : string; (** Monorepo directory (default: "mono") *) 26 26 + src : string; (** Source checkouts directory (default: "src") *) 27 27 + verse : string; (** Verse directory (default: "verse") *) 28 28 + } 29 29 + 30 30 + let default_paths = { mono = "mono"; src = "src"; verse = "verse" } 31 31 + 32 32 + (** {1 Main Configuration Type} *) 33 33 + 14 34 type t = { 15 15 - opam_repo : Fpath.t; 16 16 - checkouts : Fpath.t; 17 17 - monorepo : Fpath.t; 18 18 - default_branch : string; 35 35 + (* Workspace structure *) 36 36 + root : Fpath.t; 37 37 + paths : paths; 38 38 + (* Identity *) 39 39 + handle : string; 40 40 + knot : string; (** Git push server hostname (e.g., "git.recoil.org") *) 41 41 + (* Package overrides *) 19 42 packages : (string * Package_config.t) list; 20 43 } 21 44 45 45 + (** {1 Accessors} *) 46 46 + 47 47 + let root t = t.root 48 48 + let handle t = t.handle 49 49 + let knot t = t.knot 50 50 + let paths t = t.paths 51 51 + let packages t = t.packages 52 52 + let package_config t name = List.assoc_opt name t.packages 53 53 + 54 54 + (* Derived paths *) 55 55 + let default_branch = "main" 56 56 + let mono_path t = Fpath.(t.root / t.paths.mono) 57 57 + let src_path t = Fpath.(t.root / t.paths.src) 58 58 + let opam_repo_path t = Fpath.(t.root / "opam-repo") 59 59 + let verse_path t = Fpath.(t.root / t.paths.verse) 60 60 + 61 61 + (* Aliases for backwards compatibility with old Config.Paths module *) 22 62 module Paths = struct 23 23 - let opam_repo t = t.opam_repo 24 24 - let checkouts t = t.checkouts 25 25 - let monorepo t = t.monorepo 63 63 + let opam_repo = opam_repo_path 64 64 + let checkouts = src_path 65 65 + let monorepo = mono_path 26 66 end 27 67 28 28 - let default_branch t = t.default_branch 29 29 - let package_config t name = List.assoc_opt name t.packages 68 68 + (** {1 XDG Paths} *) 69 69 + 70 70 + let xdg_config_home () = 71 71 + match Sys.getenv_opt "XDG_CONFIG_HOME" with 72 72 + | Some dir when dir <> "" -> Fpath.v dir 73 73 + | _ -> ( 74 74 + match Sys.getenv_opt "HOME" with 75 75 + | Some home -> Fpath.(v home / ".config") 76 76 + | None -> Fpath.v "/tmp") 77 77 + 78 78 + let xdg_data_home () = 79 79 + match Sys.getenv_opt "XDG_DATA_HOME" with 80 80 + | Some dir when dir <> "" -> Fpath.v dir 81 81 + | _ -> ( 82 82 + match Sys.getenv_opt "HOME" with 83 83 + | Some home -> Fpath.(v home / ".local" / "share") 84 84 + | None -> Fpath.v "/tmp") 85 85 + 86 86 + let xdg_cache_home () = 87 87 + match Sys.getenv_opt "XDG_CACHE_HOME" with 88 88 + | Some dir when dir <> "" -> Fpath.v dir 89 89 + | _ -> 90 90 + match Sys.getenv_opt "HOME" with 91 91 + | Some home -> Fpath.(v home / ".cache") 92 92 + | None -> Fpath.v "/tmp" 93 93 + 94 94 + let config_dir () = Fpath.(xdg_config_home () / app_name) 95 95 + let data_dir () = Fpath.(xdg_data_home () / app_name) 96 96 + let cache_dir () = Fpath.(xdg_cache_home () / app_name) 97 97 + let config_file () = Fpath.(config_dir () / "opamverse.toml") 98 98 + let registry_path () = Fpath.(data_dir () / "opamverse-registry") 99 99 + 100 100 + (** {1 Construction} *) 101 101 + 102 102 + (** Derive knot (git push server) from handle. 103 103 + E.g., "anil.recoil.org" -> "git.recoil.org" *) 104 104 + let default_knot_from_handle handle = 105 105 + match String.index_opt handle '.' with 106 106 + | None -> "git." ^ handle (* fallback *) 107 107 + | Some i -> 108 108 + let domain = String.sub handle (i + 1) (String.length handle - i - 1) in 109 109 + "git." ^ domain 30 110 31 31 - let create ~opam_repo ~checkouts ~monorepo ?(default_branch = "main") () = 32 32 - { opam_repo; checkouts; monorepo; default_branch; packages = [] } 111 111 + let create ~root ~handle ?knot ?(packages = []) ?(paths = default_paths) () = 112 112 + let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in 113 113 + { root; handle; knot; packages; paths } 33 114 34 115 let with_package_override t ~name ?branch:branch_opt () = 35 116 let existing = List.assoc_opt name t.packages in ··· 40 121 let pkg_config = Package_config.{ branch = new_branch } in 41 122 let packages = (name, pkg_config) :: List.remove_assoc name t.packages in 42 123 { t with packages } 124 124 + 125 125 + (** {1 TOML Codecs} *) 43 126 44 127 let expand_tilde s = 45 128 if String.length s > 0 && s.[0] = '~' then ··· 58 141 match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m) 59 142 ~enc:Fpath.to_string Tomlt.string 60 143 61 61 - let codec : t Tomlt.t = 144 144 + let paths_codec : paths Tomlt.t = 145 145 + Tomlt.( 146 146 + Table.( 147 147 + obj (fun mono src verse -> 148 148 + { mono = Option.value ~default:default_paths.mono mono; 149 149 + src = Option.value ~default:default_paths.src src; 150 150 + verse = Option.value ~default:default_paths.verse verse }) 151 151 + |> opt_mem "mono" string ~enc:(fun p -> Some p.mono) 152 152 + |> opt_mem "src" string ~enc:(fun p -> Some p.src) 153 153 + |> opt_mem "verse" string ~enc:(fun p -> Some p.verse) 154 154 + |> finish)) 155 155 + 156 156 + (* TOML structure: 157 157 + [workspace] 158 158 + root = "~/tangled" 159 159 + 160 160 + [identity] 161 161 + handle = "anil.recoil.org" 162 162 + knot = "git.recoil.org" 163 163 + 164 164 + [paths] 165 165 + mono = "mono" 166 166 + src = "src" 167 167 + 168 168 + [packages.braid] 169 169 + branch = "backport-fix" 170 170 + *) 171 171 + 172 172 + type workspace_section = { w_root : Fpath.t } 173 173 + type identity_section = { i_handle : string; i_knot : string option } 174 174 + 175 175 + let default_knot = "git.recoil.org" 176 176 + 177 177 + let workspace_codec : workspace_section Tomlt.t = 178 178 + Tomlt.( 179 179 + Table.( 180 180 + obj (fun w_root -> { w_root }) 181 181 + |> mem "root" fpath_codec ~enc:(fun w -> w.w_root) 182 182 + |> finish)) 183 183 + 184 184 + let identity_codec : identity_section Tomlt.t = 62 185 Tomlt.( 63 186 Table.( 64 64 - obj (fun opam_repo checkouts monorepo default_branch packages -> 65 65 - { 66 66 - opam_repo; 67 67 - checkouts; 68 68 - monorepo; 69 69 - default_branch = Option.value ~default:"main" default_branch; 70 70 - packages; 71 71 - }) 72 72 - |> mem "opam_repo" fpath_codec ~enc:(fun c -> c.opam_repo) 73 73 - |> mem "checkouts" fpath_codec ~enc:(fun c -> c.checkouts) 74 74 - |> mem "monorepo" fpath_codec ~enc:(fun c -> c.monorepo) 75 75 - |> opt_mem "default_branch" string ~enc:(fun c -> 76 76 - if c.default_branch = "main" then None else Some c.default_branch) 77 77 - |> keep_unknown 78 78 - ~enc:(fun c -> c.packages) 187 187 + obj (fun i_handle i_knot -> { i_handle; i_knot }) 188 188 + |> mem "handle" string ~enc:(fun i -> i.i_handle) 189 189 + |> opt_mem "knot" string ~enc:(fun i -> i.i_knot) 190 190 + |> finish)) 191 191 + 192 192 + (* Codec for the [packages] table which contains subtree->override mappings *) 193 193 + let packages_table_codec : (string * Package_config.t) list Tomlt.t = 194 194 + Tomlt.( 195 195 + Table.( 196 196 + obj (fun pkgs -> pkgs) 197 197 + |> keep_unknown ~enc:(fun pkgs -> pkgs) 79 198 (Mems.assoc Package_config.codec) 80 199 |> finish)) 81 200 201 201 + let codec : t Tomlt.t = 202 202 + Tomlt.( 203 203 + Table.( 204 204 + obj (fun workspace identity packages paths -> 205 205 + let packages = Option.value ~default:[] packages in 206 206 + let paths = Option.value ~default:default_paths paths in 207 207 + let knot = Option.value ~default:default_knot identity.i_knot in 208 208 + { root = workspace.w_root; handle = identity.i_handle; knot; packages; paths }) 209 209 + |> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root }) 210 210 + |> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle; i_knot = Some t.knot }) 211 211 + |> opt_mem "packages" packages_table_codec 212 212 + ~enc:(fun t -> if t.packages = [] then None else Some t.packages) 213 213 + |> opt_mem "paths" paths_codec 214 214 + ~enc:(fun t -> if t.paths = default_paths then None else Some t.paths) 215 215 + |> finish)) 216 216 + 217 217 + (** {1 Validation} *) 218 218 + 82 219 type validation_error = 83 220 | Path_not_found of string * Fpath.t 84 221 | Not_a_directory of string * Fpath.t ··· 103 240 Hint: Use an absolute path starting with / or ~/" 104 241 field Fpath.pp path 105 242 106 106 - let validate ~fs t = 107 107 - (* Get the root filesystem for checking absolute paths *) 108 108 - let root_fs = 109 109 - let dir, _ = (fs : _ Eio.Path.t) in 110 110 - (dir, "") 111 111 - in 112 112 - let check_absolute field path = 113 113 - if Fpath.is_abs path then Ok () else Error (Relative_path (field, path)) 114 114 - in 115 115 - let check_dir field path = 116 116 - let eio_path = Eio.Path.(root_fs / Fpath.to_string path) in 117 117 - match Eio.Path.kind ~follow:true eio_path with 118 118 - | `Directory -> Ok () 119 119 - | `Regular_file | `Symbolic_link | `Block_device | `Character_special 120 120 - | `Fifo | `Socket | `Unknown | `Not_found -> 121 121 - Error (Not_a_directory (field, path)) 122 122 - | exception Eio.Io (Eio.Fs.E (Not_found _), _) -> 123 123 - Error (Path_not_found (field, path)) 124 124 - | exception _ -> Error (Path_not_found (field, path)) 125 125 - in 126 126 - let check_opam_repo path = 127 127 - let packages_dir = Fpath.(path / "packages") in 128 128 - let eio_path = Eio.Path.(root_fs / Fpath.to_string packages_dir) in 129 129 - match Eio.Path.kind ~follow:true eio_path with 130 130 - | `Directory -> Ok () 131 131 - | _ -> Error (Not_an_opam_repo path) 132 132 - | exception _ -> Error (Not_an_opam_repo path) 133 133 - in 134 134 - let ( let* ) = Result.bind in 135 135 - (* Check all paths are absolute first *) 136 136 - let* () = check_absolute "opam_repo" t.opam_repo in 137 137 - let* () = check_absolute "checkouts" t.checkouts in 138 138 - let* () = check_absolute "monorepo" t.monorepo in 139 139 - (* Then check opam_repo exists and is valid *) 140 140 - let* () = check_dir "opam_repo" t.opam_repo in 141 141 - let* () = check_opam_repo t.opam_repo in 142 142 - Ok t 243 243 + (** {1 Loading and Saving} *) 143 244 144 144 - let load ~fs ~root_fs path = 145 145 - try 146 146 - let config = Tomlt_eio.decode_path_exn codec ~fs (Fpath.to_string path) in 147 147 - validate ~fs:root_fs config 148 148 - |> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e) 149 149 - with 150 150 - | Eio.Io _ as e -> Error (Printexc.to_string e) 151 151 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 152 152 - 153 153 - let load_xdg ~xdg () = 154 154 - let config_dir = Xdge.config_dir xdg in 155 155 - let config_path = Eio.Path.(config_dir / "config.toml") in 156 156 - try 157 157 - let config = 158 158 - Tomlt_eio.decode_path_exn codec ~fs:config_dir (snd config_path) 159 159 - in 160 160 - let dir, _ = config_dir in 161 161 - validate ~fs:(dir, "") config 162 162 - |> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e) 163 163 - with 164 164 - | Eio.Io _ as e -> Error (Printexc.to_string e) 165 165 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 245 245 + let load ~fs () = 246 246 + let path = config_file () in 247 247 + let path_str = Fpath.to_string path in 248 248 + let eio_path = Eio.Path.(fs / path_str) in 249 249 + match Eio.Path.kind ~follow:true eio_path with 250 250 + | `Regular_file -> ( 251 251 + try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with 252 252 + | Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg) 253 253 + | exn -> Error (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn))) 254 254 + | _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 255 255 + | exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str) 166 256 167 167 - let save ~fs t path = 257 257 + let save ~fs t = 258 258 + let dir = config_dir () in 259 259 + let path = config_file () in 168 260 try 261 261 + (* Ensure XDG config directory exists *) 262 262 + let dir_path = Eio.Path.(fs / Fpath.to_string dir) in 263 263 + (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ()); 169 264 Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path); 170 265 Ok () 171 266 with Eio.Io _ as e -> Error (Printexc.to_string e) 172 267 268 268 + (** {1 Pretty Printing} *) 269 269 + 173 270 let pp ppf t = 174 271 Fmt.pf ppf 175 175 - "@[<v>@[<hov 2>paths:@ opam_repo=%a@ checkouts=%a@ monorepo=%a@]@,\ 176 176 - default_branch=%s@,\ 272 272 + "@[<v>@[<hov 2>workspace:@ root=%a@]@,\ 273 273 + @[<hov 2>identity:@ handle=%s@ knot=%s@]@,\ 274 274 + @[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\ 177 275 packages=%d@]" 178 178 - Fpath.pp t.opam_repo Fpath.pp t.checkouts Fpath.pp t.monorepo 179 179 - t.default_branch (List.length t.packages) 276 276 + Fpath.pp t.root t.handle t.knot 277 277 + t.paths.mono t.paths.src t.paths.verse 278 278 + (List.length t.packages)

+117 -67

lib/config.mli

reviewed

··· 1 1 - (** Configuration management for monopam. 1 1 + (** Unified configuration for monopam. 2 2 3 3 - Configuration is stored in TOML format and loaded from XDG standard 4 4 - locations or a user-specified path. The config file specifies paths to the 5 5 - opam overlay, individual checkouts, and the monorepo, along with optional 6 6 - per-package overrides. *) 3 3 + Configuration is stored in TOML format at [~/.config/monopam/opamverse.toml]. 4 4 + 5 5 + The config stores: 6 6 + - Workspace root and custom paths 7 7 + - User identity (handle, knot) 8 8 + - Per-package overrides 9 9 + 10 10 + Standard paths derived from root: 11 11 + - [mono/] - user's monorepo 12 12 + - [src/] - git checkouts for subtrees 13 13 + - [opam-repo/] - opam overlay repository 14 14 + - [verse/] - other members' monorepos *) 7 15 8 16 (** {1 Types} *) 9 17 ··· 16 24 (** [branch t] returns the branch override for this package, if set. *) 17 25 end 18 26 27 27 + (** Configurable paths within the workspace. 28 28 + 29 29 + By default, paths are: 30 30 + - [mono = "mono"] - monorepo directory 31 31 + - [src = "src"] - source checkouts directory 32 32 + - [verse = "verse"] - verse directory 33 33 + 34 34 + Set [mono = "."] to have packages at the root level. *) 35 35 + type paths = { 36 36 + mono : string; (** Monorepo directory (default: "mono") *) 37 37 + src : string; (** Source checkouts directory (default: "src") *) 38 38 + verse : string; (** Verse directory (default: "verse") *) 39 39 + } 40 40 + 41 41 + val default_paths : paths 42 42 + (** Default paths configuration. *) 43 43 + 19 44 type t 20 45 (** The main configuration. *) 21 46 22 22 - (** {1 Paths Configuration} *) 47 47 + (** {1 Accessors} *) 23 48 24 24 - (** Path-related accessors. *) 25 25 - module Paths : sig 26 26 - val opam_repo : t -> Fpath.t 27 27 - (** [opam_repo t] returns the path to the opam overlay repository. *) 28 28 - 29 29 - val checkouts : t -> Fpath.t 30 30 - (** [checkouts t] returns the parent directory where individual package 31 31 - checkouts are stored. *) 49 49 + val root : t -> Fpath.t 50 50 + (** [root t] returns the workspace root directory. *) 32 51 33 33 - val monorepo : t -> Fpath.t 34 34 - (** [monorepo t] returns the path to the monorepo directory. *) 35 35 - end 52 52 + val handle : t -> string 53 53 + (** [handle t] returns the user's handle. *) 36 54 37 37 - (** {1 Options} *) 55 55 + val knot : t -> string 56 56 + (** [knot t] returns the git push server hostname (e.g., "git.recoil.org"). 57 57 + Used for converting tangled URLs to SSH push URLs. *) 38 58 39 39 - val default_branch : t -> string 40 40 - (** [default_branch t] returns the default git branch to track. 59 59 + val paths : t -> paths 60 60 + (** [paths t] returns the paths configuration. *) 41 61 42 42 - Defaults to "main" if not specified. *) 62 62 + val packages : t -> (string * Package_config.t) list 63 63 + (** [packages t] returns the list of package overrides. *) 43 64 44 65 val package_config : t -> string -> Package_config.t option 45 66 (** [package_config t name] returns package-specific configuration overrides for 46 67 the named package, if any exist. *) 47 68 48 48 - (** {1 Validation} *) 69 69 + (** {1 Derived Paths} *) 49 70 50 50 - (** Errors that can occur when validating configuration paths. *) 51 51 - type validation_error = 52 52 - | Path_not_found of string * Fpath.t (** A configured path does not exist *) 53 53 - | Not_a_directory of string * Fpath.t 54 54 - (** A configured path is not a directory *) 55 55 - | Not_an_opam_repo of Fpath.t 56 56 - (** The opam_repo path is not a valid opam repository (missing packages/ 57 57 - directory) *) 58 58 - | Invalid_path of string * string (** A path string could not be parsed *) 59 59 - | Relative_path of string * Fpath.t 60 60 - (** A configured path is relative but must be absolute *) 71 71 + val default_branch : string 72 72 + (** Default git branch, always ["main"]. *) 61 73 62 62 - val pp_validation_error : validation_error Fmt.t 63 63 - (** [pp_validation_error] formats validation errors. *) 74 74 + val mono_path : t -> Fpath.t 75 75 + (** [mono_path t] returns the path to the user's monorepo. *) 64 76 65 65 - (** {1 Loading and Saving} *) 77 77 + val src_path : t -> Fpath.t 78 78 + (** [src_path t] returns the path to git checkouts. *) 66 79 67 67 - val load : 68 68 - fs:_ Eio.Path.t -> root_fs:_ Eio.Path.t -> Fpath.t -> (t, string) result 69 69 - (** [load ~fs ~root_fs path] loads configuration from the specified TOML file. 80 80 + val opam_repo_path : t -> Fpath.t 81 81 + (** [opam_repo_path t] returns the path to the opam overlay. *) 70 82 71 71 - Validates that paths exist and are valid. Supports tilde expansion for paths 72 72 - (e.g., [~/src/...]). 83 83 + val verse_path : t -> Fpath.t 84 84 + (** [verse_path t] returns the path to tracked members' monorepos. *) 73 85 74 74 - @param fs The filesystem path for locating the config file 75 75 - @param root_fs The root filesystem for validating absolute paths in config 86 86 + (** {1 Backwards Compatibility} *) 76 87 77 77 - Returns [Error msg] if the file cannot be read, parsed, or if validation 78 78 - fails. *) 88 88 + (** Path accessors using old naming convention. *) 89 89 + module Paths : sig 90 90 + val opam_repo : t -> Fpath.t 91 91 + (** Alias for [opam_repo_path]. *) 79 92 80 80 - val load_xdg : xdg:Xdge.t -> unit -> (t, string) result 81 81 - (** [load_xdg ~xdg ()] loads configuration from XDG standard locations. 93 93 + val checkouts : t -> Fpath.t 94 94 + (** Alias for [src_path]. *) 82 95 83 83 - Searches for "config.toml" in the monopam XDG config directory. Validates 84 84 - that paths exist and are valid. Supports tilde expansion. 96 96 + val monorepo : t -> Fpath.t 97 97 + (** Alias for [mono_path]. *) 98 98 + end 85 99 86 86 - Returns [Error msg] if no config file is found, parsing fails, or if 87 87 - validation fails. 100 100 + (** {1 XDG Paths} *) 88 101 89 89 - @param xdg The Xdge context for "monopam" application *) 102 102 + val config_dir : unit -> Fpath.t 103 103 + (** [config_dir ()] returns the XDG config directory for monopam 104 104 + (~/.config/monopam). *) 105 105 + 106 106 + val data_dir : unit -> Fpath.t 107 107 + (** [data_dir ()] returns the XDG data directory for monopam 108 108 + (~/.local/share/monopam). *) 109 109 + 110 110 + val cache_dir : unit -> Fpath.t 111 111 + (** [cache_dir ()] returns the XDG cache directory for monopam 112 112 + (~/.cache/monopam). *) 113 113 + 114 114 + val config_file : unit -> Fpath.t 115 115 + (** [config_file ()] returns the path to the config file 116 116 + (~/.config/monopam/opamverse.toml). *) 90 117 91 91 - val save : fs:_ Eio.Path.t -> t -> Fpath.t -> (unit, string) result 92 92 - (** [save ~fs t path] writes the configuration to the specified path. *) 118 118 + val registry_path : unit -> Fpath.t 119 119 + (** [registry_path ()] returns the path to the cloned registry git repo 120 120 + (~/.local/share/monopam/opamverse-registry). *) 93 121 94 122 (** {1 Construction} *) 95 123 96 124 val create : 97 97 - opam_repo:Fpath.t -> 98 98 - checkouts:Fpath.t -> 99 99 - monorepo:Fpath.t -> 100 100 - ?default_branch:string -> 125 125 + root:Fpath.t -> 126 126 + handle:string -> 127 127 + ?knot:string -> 128 128 + ?packages:(string * Package_config.t) list -> 129 129 + ?paths:paths -> 101 130 unit -> 102 131 t 103 103 - (** [create ~opam_repo ~checkouts ~monorepo ?default_branch ()] creates a new 104 104 - configuration with the specified paths. 132 132 + (** [create ~root ~handle ?knot ?packages ?paths ()] creates a new configuration. 105 133 106 106 - @param opam_repo Path to the opam overlay repository 107 107 - @param checkouts Parent directory for individual git checkouts 108 108 - @param monorepo Path to the monorepo 109 109 - @param default_branch Default branch to track (default: "main") *) 134 134 + @param root Workspace root directory (absolute path) 135 135 + @param handle User's handle 136 136 + @param knot Git push server hostname. If not provided, derived from handle 137 137 + @param packages Optional list of package overrides 138 138 + @param paths Optional custom paths configuration *) 110 139 111 140 val with_package_override : t -> name:string -> ?branch:string -> unit -> t 112 141 (** [with_package_override t ~name ?branch ()] returns a new config 113 113 - with overrides for the named package. 142 142 + with overrides for the named package. *) 114 143 115 115 - @param branch Override the git branch for this package 144 144 + (** {1 Validation} *) 116 145 117 117 - Note: For dev-repo URL overrides, use [sources.toml] in the monorepo root. *) 146 146 + type validation_error = 147 147 + | Path_not_found of string * Fpath.t 148 148 + | Not_a_directory of string * Fpath.t 149 149 + | Not_an_opam_repo of Fpath.t 150 150 + | Invalid_path of string * string 151 151 + | Relative_path of string * Fpath.t 152 152 + 153 153 + val pp_validation_error : validation_error Fmt.t 154 154 + (** [pp_validation_error] formats validation errors. *) 155 155 + 156 156 + (** {1 Loading and Saving} *) 157 157 + 158 158 + val load : fs:_ Eio.Path.t -> unit -> (t, string) result 159 159 + (** [load ~fs ()] loads the configuration from the XDG config file. 160 160 + 161 161 + @param fs Eio filesystem *) 162 162 + 163 163 + val save : fs:_ Eio.Path.t -> t -> (unit, string) result 164 164 + (** [save ~fs config] saves the configuration to the XDG config file. 165 165 + 166 166 + @param fs Eio filesystem 167 167 + @param config Configuration to save *) 118 168 119 169 (** {1 Pretty Printing} *) 120 170

+482

lib/fork_join.ml

reviewed

··· 8 8 | Subtree_already_exists of string 9 9 | No_opam_files of string 10 10 | Verse_error of Verse.error 11 11 + | User_cancelled 12 12 + 13 13 + (** {1 Action Types} *) 14 14 + 15 15 + (** An action to be performed during fork/join *) 16 16 + type action = 17 17 + | Check_remote_exists of string (** URL - informational check *) 18 18 + | Create_directory of Fpath.t 19 19 + | Git_init of Fpath.t 20 20 + | Git_clone of { url: string; dest: Fpath.t; branch: string } 21 21 + | Git_subtree_split of { repo: Fpath.t; prefix: string } 22 22 + | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } 23 23 + | Git_add_remote of { repo: Fpath.t; name: string; url: string } 24 24 + | Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string } 25 25 + | Git_checkout of { repo: Fpath.t; branch: string } 26 26 + | Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *) 27 27 + | Copy_directory of { src: Fpath.t; dest: Fpath.t } 28 28 + | Git_add_all of Fpath.t 29 29 + | Git_commit of { repo: Fpath.t; message: string } 30 30 + | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 31 31 + 32 32 + (** Discovery information gathered during planning *) 33 33 + type discovery = { 34 34 + mono_exists: bool; 35 35 + src_exists: bool; 36 36 + has_subtree_history: bool; (** Can we git subtree split? *) 37 37 + remote_accessible: bool option; (** None = not checked, Some = result *) 38 38 + opam_files: string list; 39 39 + local_path_is_repo: bool option; (** For join from local dir *) 40 40 + } 41 41 + 42 42 + (** A complete action plan *) 43 43 + type 'a action_plan = { 44 44 + discovery: discovery; 45 45 + actions: action list; 46 46 + result: 'a; (** What we'll return on success *) 47 47 + dry_run: bool; 48 48 + } 11 49 12 50 let pp_error ppf = function 13 51 | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg ··· 17 55 | Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name 18 56 | No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name 19 57 | Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e 58 58 + | User_cancelled -> Fmt.pf ppf "Operation cancelled by user" 20 59 21 60 let error_hint = function 22 61 | Config_error _ -> ··· 33 72 | No_opam_files name -> 34 73 Some (Fmt.str "Add a .opam file to mono/%s before forking" name) 35 74 | Verse_error e -> Verse.error_hint e 75 75 + | User_cancelled -> None 76 76 + 77 77 + (** {1 Pretty Printers for Actions and Discovery} *) 78 78 + 79 79 + let pp_action ppf = function 80 80 + | Check_remote_exists url -> 81 81 + Fmt.pf ppf "Check remote accessible: %s" url 82 82 + | Create_directory path -> 83 83 + Fmt.pf ppf "Create directory: %a" Fpath.pp path 84 84 + | Git_init path -> 85 85 + Fmt.pf ppf "Initialize git repository: %a" Fpath.pp path 86 86 + | Git_clone { url; dest; branch } -> 87 87 + Fmt.pf ppf "Clone %s (branch: %s) to %a" url branch Fpath.pp dest 88 88 + | Git_subtree_split { repo = _; prefix } -> 89 89 + Fmt.pf ppf "Split subtree history for '%s'" prefix 90 90 + | Git_subtree_add { repo = _; prefix; url; branch } -> 91 91 + Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix (Uri.to_string url) branch 92 92 + | Git_add_remote { repo = _; name; url } -> 93 93 + Fmt.pf ppf "Add remote '%s' -> %s" name url 94 94 + | Git_push_ref { repo = _; target; ref_spec } -> 95 95 + Fmt.pf ppf "Push %s to %s" ref_spec target 96 96 + | Git_checkout { repo = _; branch } -> 97 97 + Fmt.pf ppf "Checkout branch '%s'" branch 98 98 + | Git_branch_rename { repo = _; new_name } -> 99 99 + Fmt.pf ppf "Rename current branch to '%s'" new_name 100 100 + | Copy_directory { src; dest } -> 101 101 + Fmt.pf ppf "Copy files from %a to %a" Fpath.pp src Fpath.pp dest 102 102 + | Git_add_all path -> 103 103 + Fmt.pf ppf "Stage all changes in %a" Fpath.pp path 104 104 + | Git_commit { repo = _; message } -> 105 105 + Fmt.pf ppf "Create commit: %s" message 106 106 + | Update_sources_toml { path = _; name; entry = _ } -> 107 107 + Fmt.pf ppf "Update sources.toml for '%s'" name 108 108 + 109 109 + let pp_discovery ppf d = 110 110 + Fmt.pf ppf "@[<v>"; 111 111 + Fmt.pf ppf " mono/<name>/: %s@," 112 112 + (if d.mono_exists then "exists" else "does not exist"); 113 113 + Fmt.pf ppf " src/<name>/: %s@," 114 114 + (if d.src_exists then "exists" else "does not exist"); 115 115 + Fmt.pf ppf " Subtree history: %s@," 116 116 + (if d.has_subtree_history then "present" else "none (fresh package)"); 117 117 + (match d.remote_accessible with 118 118 + | None -> () 119 119 + | Some true -> Fmt.pf ppf " Remote accessible: yes@," 120 120 + | Some false -> Fmt.pf ppf " Remote accessible: no@,"); 121 121 + (match d.local_path_is_repo with 122 122 + | None -> () 123 123 + | Some true -> Fmt.pf ppf " Is git repo: yes@," 124 124 + | Some false -> Fmt.pf ppf " Is git repo: no@,"); 125 125 + if d.opam_files <> [] then 126 126 + Fmt.pf ppf " Packages found: %a@," Fmt.(list ~sep:(any ", ") string) d.opam_files; 127 127 + Fmt.pf ppf "@]" 128 128 + 129 129 + let pp_action_plan : type a. a Fmt.t -> a action_plan Fmt.t = fun pp_result ppf plan -> 130 130 + Fmt.pf ppf "@[<v>Discovery:@,%a@,@,Actions to perform:@," pp_discovery plan.discovery; 131 131 + List.iteri (fun i action -> 132 132 + Fmt.pf ppf " %d. %a@," (i + 1) pp_action action 133 133 + ) plan.actions; 134 134 + if plan.dry_run then 135 135 + Fmt.pf ppf "@,(dry-run mode - no changes will be made)@,"; 136 136 + Fmt.pf ppf "@,Expected result:@, %a@]" pp_result plan.result 36 137 37 138 let pp_error_with_hint ppf e = 38 139 pp_error ppf e; ··· 130 231 match String.rindex_opt path '/' with 131 232 | Some i -> String.sub path (i + 1) (String.length path - i - 1) 132 233 | None -> path 234 234 + 235 235 + (** {1 Detection Functions} *) 236 236 + 237 237 + (** Determine if input is a local path or URL *) 238 238 + let is_local_path s = 239 239 + (* It's a URL if it starts with a scheme or looks like SSH URL *) 240 240 + not (String.starts_with ~prefix:"http://" s || 241 241 + String.starts_with ~prefix:"https://" s || 242 242 + String.starts_with ~prefix:"git://" s || 243 243 + String.starts_with ~prefix:"git@" s || 244 244 + String.starts_with ~prefix:"ssh://" s || 245 245 + String.starts_with ~prefix:"git+" s) 246 246 + 247 247 + (** Copy a directory tree recursively *) 248 248 + let copy_directory ~fs ~src ~dest = 249 249 + let src_eio = Eio.Path.(fs / Fpath.to_string src) in 250 250 + let dest_eio = Eio.Path.(fs / Fpath.to_string dest) in 251 251 + let rec copy_rec src_path dest_path = 252 252 + match Eio.Path.kind ~follow:false src_path with 253 253 + | `Directory -> 254 254 + (try Eio.Path.mkdirs ~perm:0o755 dest_path with Eio.Io _ -> ()); 255 255 + List.iter (fun name -> 256 256 + (* Skip .git directory to avoid copying git internals *) 257 257 + if name <> ".git" then begin 258 258 + let src_child = Eio.Path.(src_path / name) in 259 259 + let dest_child = Eio.Path.(dest_path / name) in 260 260 + copy_rec src_child dest_child 261 261 + end 262 262 + ) (Eio.Path.read_dir src_path) 263 263 + | `Regular_file -> 264 264 + let content = Eio.Path.load src_path in 265 265 + Eio.Path.save ~create:(`Or_truncate 0o644) dest_path content 266 266 + | `Symbolic_link -> 267 267 + (* Read symlink target and recreate it *) 268 268 + let target = Eio.Path.read_link src_path in 269 269 + (try Unix.symlink target (snd dest_path) with _ -> ()) 270 270 + | _ -> () (* Skip other file types *) 271 271 + | exception _ -> () 272 272 + in 273 273 + copy_rec src_eio dest_eio 274 274 + 275 275 + (** {1 Plan Builders} *) 276 276 + 277 277 + (** Build a fork plan - handles both subtree and fresh package scenarios *) 278 278 + let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 279 279 + let monorepo = Verse_config.mono_path config in 280 280 + let checkouts = Verse_config.src_path config in 281 281 + let prefix = name in 282 282 + let subtree_path = Fpath.(monorepo / prefix) in 283 283 + let src_path = Fpath.(checkouts / name) in 284 284 + 285 285 + (* Gather discovery information *) 286 286 + let mono_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 287 287 + let src_exists = is_directory ~fs src_path in 288 288 + let has_subtree_hist = 289 289 + if mono_exists then Git.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix () 290 290 + else false 291 291 + in 292 292 + let opam_files = 293 293 + if mono_exists then find_opam_files ~fs subtree_path 294 294 + else [] 295 295 + in 296 296 + 297 297 + let discovery = { 298 298 + mono_exists; 299 299 + src_exists; 300 300 + has_subtree_history = has_subtree_hist; 301 301 + remote_accessible = None; (* Could check if push_url is accessible *) 302 302 + opam_files; 303 303 + local_path_is_repo = None; 304 304 + } in 305 305 + 306 306 + (* Validation *) 307 307 + if not mono_exists then 308 308 + Error (Subtree_not_found name) 309 309 + else if src_exists then 310 310 + Error (Src_already_exists name) 311 311 + else if opam_files = [] then 312 312 + Error (No_opam_files name) 313 313 + else begin 314 314 + (* Build actions based on whether we have subtree history *) 315 315 + let actions = 316 316 + if has_subtree_hist then begin 317 317 + (* Subtree fork (existing behavior) *) 318 318 + let base_actions = [ 319 319 + Create_directory checkouts; 320 320 + Git_subtree_split { repo = monorepo; prefix }; 321 321 + Git_init src_path; 322 322 + Git_add_remote { repo = src_path; name = "mono"; url = Fpath.to_string monorepo }; 323 323 + Git_push_ref { repo = monorepo; target = Fpath.to_string src_path; ref_spec = "SPLIT_COMMIT:refs/heads/main" }; 324 324 + Git_checkout { repo = src_path; branch = "main" }; 325 325 + ] in 326 326 + let remote_actions = match push_url with 327 327 + | Some url -> [ 328 328 + Git_add_remote { repo = src_path; name = "origin"; url }; 329 329 + Update_sources_toml { 330 330 + path = Fpath.(monorepo / "sources.toml"); 331 331 + name; 332 332 + entry = Sources_registry.{ 333 333 + url = normalize_git_url url; 334 334 + upstream = None; 335 335 + branch = Some "main"; 336 336 + reason = None; 337 337 + origin = Some Fork; 338 338 + }; 339 339 + }; 340 340 + ] 341 341 + | None -> [] 342 342 + in 343 343 + base_actions @ remote_actions 344 344 + end else begin 345 345 + (* Fresh package fork (NEW behavior) *) 346 346 + let base_actions = [ 347 347 + Create_directory checkouts; 348 348 + Create_directory src_path; 349 349 + Git_init src_path; 350 350 + Copy_directory { src = subtree_path; dest = src_path }; 351 351 + Git_add_all src_path; 352 352 + Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name }; 353 353 + ] in 354 354 + let remote_actions = match push_url with 355 355 + | Some url -> [ 356 356 + Git_add_remote { repo = src_path; name = "origin"; url }; 357 357 + Update_sources_toml { 358 358 + path = Fpath.(monorepo / "sources.toml"); 359 359 + name; 360 360 + entry = Sources_registry.{ 361 361 + url = normalize_git_url url; 362 362 + upstream = None; 363 363 + branch = Some "main"; 364 364 + reason = None; 365 365 + origin = Some Fork; 366 366 + }; 367 367 + }; 368 368 + ] 369 369 + | None -> [] 370 370 + in 371 371 + base_actions @ remote_actions 372 372 + end 373 373 + in 374 374 + 375 375 + let result = { 376 376 + name; 377 377 + split_commit = if has_subtree_hist then "(will be computed)" else "(fresh package)"; 378 378 + src_path; 379 379 + push_url; 380 380 + packages_created = opam_files; 381 381 + } in 382 382 + 383 383 + Ok { discovery; actions; result; dry_run } 384 384 + end 385 385 + 386 386 + (** Build a join plan - handles both URL and local path *) 387 387 + let plan_join ~proc ~fs ~config ~source ?name ?upstream ?(dry_run = false) () = 388 388 + let is_local = is_local_path source in 389 389 + let name = match name with Some n -> n | None -> name_from_url source in 390 390 + let monorepo = Verse_config.mono_path config in 391 391 + let checkouts = Verse_config.src_path config in 392 392 + let prefix = name in 393 393 + let src_path = Fpath.(checkouts / name) in 394 394 + 395 395 + (* Gather discovery information *) 396 396 + let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in 397 397 + let src_exists = is_directory ~fs src_path in 398 398 + let local_is_repo = 399 399 + if is_local then begin 400 400 + match Fpath.of_string source with 401 401 + | Ok path -> Some (Git.is_repo ~proc ~fs path) 402 402 + | Error _ -> Some false 403 403 + end else None 404 404 + in 405 405 + 406 406 + let discovery = { 407 407 + mono_exists = subtree_exists; 408 408 + src_exists; 409 409 + has_subtree_history = false; 410 410 + remote_accessible = None; 411 411 + opam_files = []; (* Will be discovered after join *) 412 412 + local_path_is_repo = local_is_repo; 413 413 + } in 414 414 + 415 415 + (* Validation *) 416 416 + if subtree_exists then 417 417 + Error (Subtree_already_exists name) 418 418 + else begin 419 419 + let branch = Verse_config.default_branch in 420 420 + let actions = 421 421 + if is_local then begin 422 422 + (* Join from local directory *) 423 423 + match Fpath.of_string source with 424 424 + | Error (`Msg msg) -> raise (Invalid_argument msg) 425 425 + | Ok local_path -> 426 426 + let has_repo = Option.value ~default:false local_is_repo in 427 427 + if has_repo then 428 428 + (* Local git repo - use it directly *) 429 429 + [ 430 430 + Create_directory checkouts; 431 431 + Copy_directory { src = local_path; dest = src_path }; 432 432 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 433 433 + ] 434 434 + else 435 435 + (* Local directory without git - init and commit first *) 436 436 + [ 437 437 + Create_directory checkouts; 438 438 + Create_directory src_path; 439 439 + Git_init src_path; 440 440 + Copy_directory { src = local_path; dest = src_path }; 441 441 + Git_add_all src_path; 442 442 + Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name }; 443 443 + Git_branch_rename { repo = src_path; new_name = branch }; (* Ensure branch is named correctly *) 444 444 + Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch }; 445 445 + ] 446 446 + end else begin 447 447 + (* Join from URL (existing behavior) *) 448 448 + let url_uri = Uri.of_string source in 449 449 + let base_actions = [ 450 450 + Create_directory checkouts; 451 451 + Git_clone { url = source; dest = src_path; branch }; 452 452 + Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch }; 453 453 + ] in 454 454 + let sources_actions = match upstream with 455 455 + | Some _ -> 456 456 + [Update_sources_toml { 457 457 + path = Fpath.(monorepo / "sources.toml"); 458 458 + name; 459 459 + entry = Sources_registry.{ 460 460 + url = normalize_git_url source; 461 461 + upstream = Option.map normalize_git_url upstream; 462 462 + branch = Some branch; 463 463 + reason = None; 464 464 + origin = Some Join; 465 465 + }; 466 466 + }] 467 467 + | None -> [] 468 468 + in 469 469 + base_actions @ sources_actions 470 470 + end 471 471 + in 472 472 + 473 473 + (* Peek at opam files if local *) 474 474 + let opam_preview = 475 475 + if is_local then 476 476 + match Fpath.of_string source with 477 477 + | Ok path -> find_opam_files ~fs path 478 478 + | Error _ -> [] 479 479 + else [] 480 480 + in 481 481 + 482 482 + let result = { 483 483 + name; 484 484 + source_url = source; 485 485 + upstream_url = upstream; 486 486 + packages_added = opam_preview; 487 487 + from_handle = None; 488 488 + } in 489 489 + 490 490 + Ok { discovery = { discovery with opam_files = opam_preview }; actions; result; dry_run } 491 491 + end 492 492 + 493 493 + (** {1 Plan Execution} *) 494 494 + 495 495 + (** State tracked during plan execution *) 496 496 + type exec_state = { 497 497 + mutable split_commit: string option; 498 498 + } 499 499 + 500 500 + (** Execute a single action *) 501 501 + let execute_action ~proc ~fs ~state action = 502 502 + match action with 503 503 + | Check_remote_exists _url -> 504 504 + (* Informational only - always succeeds *) 505 505 + Ok () 506 506 + | Create_directory path -> 507 507 + ensure_dir ~fs path; 508 508 + Ok () 509 509 + | Git_init path -> 510 510 + Git.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e) 511 511 + | Git_clone { url; dest; branch } -> 512 512 + Git.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest 513 513 + |> Result.map_error (fun e -> Git_error e) 514 514 + | Git_subtree_split { repo; prefix } -> 515 515 + Git.Subtree.split ~proc ~fs ~repo ~prefix () 516 516 + |> Result.map (fun commit -> state.split_commit <- Some commit) 517 517 + |> Result.map_error (fun e -> Git_error e) 518 518 + | Git_subtree_add { repo; prefix; url; branch } -> 519 519 + Git.Subtree.add ~proc ~fs ~repo ~prefix ~url ~branch () 520 520 + |> Result.map_error (fun e -> Git_error e) 521 521 + | Git_add_remote { repo; name; url } -> 522 522 + Git.add_remote ~proc ~fs ~name ~url repo 523 523 + |> Result.map_error (fun e -> Git_error e) 524 524 + | Git_push_ref { repo; target; ref_spec } -> 525 525 + (* Replace SPLIT_COMMIT placeholder with actual commit if available *) 526 526 + let ref_spec = 527 527 + match state.split_commit with 528 528 + | Some commit -> String.concat "" (String.split_on_char 'S' (String.concat commit (String.split_on_char 'S' ref_spec))) 529 529 + |> fun s -> if String.starts_with ~prefix:"PLIT_COMMIT" s then 530 530 + Option.value ~default:ref_spec state.split_commit ^ String.sub s 11 (String.length s - 11) 531 531 + else s 532 532 + | None -> ref_spec 533 533 + in 534 534 + (* Better replacement: look for SPLIT_COMMIT literal *) 535 535 + let ref_spec = 536 536 + match state.split_commit with 537 537 + | Some commit -> 538 538 + if String.length ref_spec >= 12 && String.sub ref_spec 0 12 = "SPLIT_COMMIT" then 539 539 + commit ^ String.sub ref_spec 12 (String.length ref_spec - 12) 540 540 + else ref_spec 541 541 + | None -> ref_spec 542 542 + in 543 543 + Git.push_ref ~proc ~fs ~repo ~target ~ref_spec () 544 544 + |> Result.map_error (fun e -> Git_error e) 545 545 + | Git_checkout { repo; branch } -> 546 546 + Git.checkout ~proc ~fs ~branch repo 547 547 + |> Result.map_error (fun e -> Git_error e) 548 548 + | Git_branch_rename { repo; new_name } -> 549 549 + Git.branch_rename ~proc ~fs ~new_name repo 550 550 + |> Result.map_error (fun e -> Git_error e) 551 551 + | Copy_directory { src; dest } -> 552 552 + copy_directory ~fs ~src ~dest; 553 553 + Ok () 554 554 + | Git_add_all path -> 555 555 + Git.add_all ~proc ~fs path 556 556 + |> Result.map_error (fun e -> Git_error e) 557 557 + | Git_commit { repo; message } -> 558 558 + Git.commit ~proc ~fs ~message repo 559 559 + |> Result.map_error (fun e -> Git_error e) 560 560 + | Update_sources_toml { path; name; entry } -> 561 561 + let sources = 562 562 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with 563 563 + | Ok s -> s 564 564 + | Error _ -> Sources_registry.empty 565 565 + in 566 566 + let sources = Sources_registry.add sources ~subtree:name entry in 567 567 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with 568 568 + | Ok () -> Ok () 569 569 + | Error msg -> Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))) 570 570 + 571 571 + (** Execute a complete fork action plan *) 572 572 + let execute_fork_plan ~proc ~fs plan = 573 573 + if plan.dry_run then 574 574 + Ok plan.result 575 575 + else begin 576 576 + let state = { split_commit = None } in 577 577 + let rec run_actions = function 578 578 + | [] -> Ok () 579 579 + | action :: rest -> 580 580 + match execute_action ~proc ~fs ~state action with 581 581 + | Error e -> Error e 582 582 + | Ok () -> run_actions rest 583 583 + in 584 584 + match run_actions plan.actions with 585 585 + | Error e -> Error e 586 586 + | Ok () -> 587 587 + (* Update result with actual split commit if available *) 588 588 + let result : fork_result = 589 589 + match state.split_commit with 590 590 + | Some commit -> { plan.result with split_commit = commit } 591 591 + | None -> plan.result 592 592 + in 593 593 + Ok result 594 594 + end 595 595 + 596 596 + (** Execute a complete join action plan *) 597 597 + let execute_join_plan ~proc ~fs plan = 598 598 + if plan.dry_run then 599 599 + Ok plan.result 600 600 + else begin 601 601 + let state = { split_commit = None } in 602 602 + let rec run_actions = function 603 603 + | [] -> Ok () 604 604 + | action :: rest -> 605 605 + match execute_action ~proc ~fs ~state action with 606 606 + | Error e -> Error e 607 607 + | Ok () -> run_actions rest 608 608 + in 609 609 + match run_actions plan.actions with 610 610 + | Error e -> Error e 611 611 + | Ok () -> Ok plan.result 612 612 + end 613 613 + 614 614 + (** {1 Legacy API (using plans internally)} *) 133 615 134 616 let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 135 617 let monorepo = Verse_config.mono_path config in

+145 -14

lib/fork_join.mli

reviewed

··· 4 4 - Fork: Split a monorepo subtree into its own repository in src/ 5 5 - Join: Bring an external repository into the monorepo as a subtree 6 6 7 7 - Both operations update sources.toml to track the origin of each source. *) 7 7 + Both operations update sources.toml to track the origin of each source. 8 8 + 9 9 + The module supports an action-based workflow where commands: 10 10 + 1. Analyze current state 11 11 + 2. Build a list of actions with reasoning 12 12 + 3. Display the plan with discovery details 13 13 + 4. Prompt for confirmation (or skip with [--yes]) 14 14 + 5. Execute actions sequentially *) 8 15 9 16 (** {1 Error Types} *) 10 17 ··· 16 23 | Subtree_already_exists of string (** Subtree already exists in monorepo *) 17 24 | No_opam_files of string (** No .opam files found in subtree *) 18 25 | Verse_error of Verse.error (** Error from verse operations *) 26 26 + | User_cancelled (** User declined to proceed *) 19 27 20 28 val pp_error : error Fmt.t 21 29 (** [pp_error] formats errors. *) ··· 26 34 val error_hint : error -> string option 27 35 (** [error_hint e] returns a hint string for the given error, if available. *) 28 36 29 29 - (** {1 Fork Operations} *) 37 37 + (** {1 Action Types} *) 38 38 + 39 39 + (** An action to be performed during fork/join *) 40 40 + type action = 41 41 + | Check_remote_exists of string (** URL - informational check *) 42 42 + | Create_directory of Fpath.t 43 43 + | Git_init of Fpath.t 44 44 + | Git_clone of { url: string; dest: Fpath.t; branch: string } 45 45 + | Git_subtree_split of { repo: Fpath.t; prefix: string } 46 46 + | Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string } 47 47 + | Git_add_remote of { repo: Fpath.t; name: string; url: string } 48 48 + | Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string } 49 49 + | Git_checkout of { repo: Fpath.t; branch: string } 50 50 + | Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *) 51 51 + | Copy_directory of { src: Fpath.t; dest: Fpath.t } 52 52 + | Git_add_all of Fpath.t 53 53 + | Git_commit of { repo: Fpath.t; message: string } 54 54 + | Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry } 55 55 + 56 56 + (** Discovery information gathered during planning *) 57 57 + type discovery = { 58 58 + mono_exists: bool; (** Does mono/<name>/ exist? *) 59 59 + src_exists: bool; (** Does src/<name>/ exist? *) 60 60 + has_subtree_history: bool; (** Can we git subtree split? *) 61 61 + remote_accessible: bool option; (** None = not checked, Some = result *) 62 62 + opam_files: string list; (** Package names found from .opam files *) 63 63 + local_path_is_repo: bool option; (** For join from local dir *) 64 64 + } 65 65 + 66 66 + (** A complete action plan *) 67 67 + type 'a action_plan = { 68 68 + discovery: discovery; 69 69 + actions: action list; 70 70 + result: 'a; (** What we'll return on success *) 71 71 + dry_run: bool; 72 72 + } 73 73 + 74 74 + val pp_action : action Fmt.t 75 75 + (** [pp_action] formats a single action. *) 76 76 + 77 77 + val pp_discovery : discovery Fmt.t 78 78 + (** [pp_discovery] formats discovery information. *) 79 79 + 80 80 + val pp_action_plan : 'a Fmt.t -> 'a action_plan Fmt.t 81 81 + (** [pp_action_plan pp_result] formats a complete action plan. *) 82 82 + 83 83 + (** {1 Detection Functions} *) 84 84 + 85 85 + val is_local_path : string -> bool 86 86 + (** [is_local_path s] returns true if [s] looks like a local filesystem path 87 87 + rather than a URL. *) 88 88 + 89 89 + (** {1 Result Types} *) 30 90 31 91 (** Result of a fork operation. *) 32 92 type fork_result = { ··· 40 100 val pp_fork_result : fork_result Fmt.t 41 101 (** [pp_fork_result] formats a fork result. *) 42 102 103 103 + (** Result of a join operation. *) 104 104 + type join_result = { 105 105 + name : string; (** Subtree/repository name *) 106 106 + source_url : string; (** URL the repository was cloned from *) 107 107 + upstream_url : string option; (** Original upstream if this is a fork *) 108 108 + packages_added : string list; (** Package names from .opam files *) 109 109 + from_handle : string option; (** Verse handle if joined from verse *) 110 110 + } 111 111 + 112 112 + val pp_join_result : join_result Fmt.t 113 113 + (** [pp_join_result] formats a join result. *) 114 114 + 115 115 + (** {1 Plan Builders} *) 116 116 + 117 117 + val plan_fork : 118 118 + proc:_ Eio.Process.mgr -> 119 119 + fs:Eio.Fs.dir_ty Eio.Path.t -> 120 120 + config:Verse_config.t -> 121 121 + name:string -> 122 122 + ?push_url:string -> 123 123 + ?dry_run:bool -> 124 124 + unit -> 125 125 + (fork_result action_plan, error) result 126 126 + (** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork plan. 127 127 + 128 128 + This analyzes the current state and builds a list of actions to: 129 129 + - For subtrees with history: split subtree, create repo, push history 130 130 + - For fresh packages: create repo, copy files, initial commit 131 131 + 132 132 + The plan can be displayed to the user and executed with [execute_fork_plan]. 133 133 + 134 134 + @param name Name of the subtree to fork (directory name under mono/) 135 135 + @param push_url Optional remote URL to add as origin for pushing 136 136 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 137 137 + 138 138 + val plan_join : 139 139 + proc:_ Eio.Process.mgr -> 140 140 + fs:Eio.Fs.dir_ty Eio.Path.t -> 141 141 + config:Verse_config.t -> 142 142 + source:string -> 143 143 + ?name:string -> 144 144 + ?upstream:string -> 145 145 + ?dry_run:bool -> 146 146 + unit -> 147 147 + (join_result action_plan, error) result 148 148 + (** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a join plan. 149 149 + 150 150 + This analyzes the source (URL or local path) and builds a list of actions to: 151 151 + - For URLs: clone repo, add subtree 152 152 + - For local directories: copy/init repo, add subtree 153 153 + 154 154 + The plan can be displayed to the user and executed with [execute_join_plan]. 155 155 + 156 156 + @param source Git URL or local filesystem path to join 157 157 + @param name Override the subtree directory name (default: derived from source) 158 158 + @param upstream Original upstream URL if this is your fork 159 159 + @param dry_run If true, mark plan as dry-run (execute will skip actions) *) 160 160 + 161 161 + (** {1 Plan Execution} *) 162 162 + 163 163 + val execute_fork_plan : 164 164 + proc:_ Eio.Process.mgr -> 165 165 + fs:Eio.Fs.dir_ty Eio.Path.t -> 166 166 + fork_result action_plan -> 167 167 + (fork_result, error) result 168 168 + (** [execute_fork_plan ~proc ~fs plan] executes a fork action plan. 169 169 + 170 170 + Returns the fork result with the actual split commit (if applicable). 171 171 + If the plan is marked as dry-run, returns the plan's result without 172 172 + executing any actions. *) 173 173 + 174 174 + val execute_join_plan : 175 175 + proc:_ Eio.Process.mgr -> 176 176 + fs:Eio.Fs.dir_ty Eio.Path.t -> 177 177 + join_result action_plan -> 178 178 + (join_result, error) result 179 179 + (** [execute_join_plan ~proc ~fs plan] executes a join action plan. 180 180 + 181 181 + If the plan is marked as dry-run, returns the plan's result without 182 182 + executing any actions. *) 183 183 + 184 184 + (** {1 Fork Operations} *) 185 185 + 43 186 val fork : 44 187 proc:_ Eio.Process.mgr -> 45 188 fs:Eio.Fs.dir_ty Eio.Path.t -> ··· 66 209 @param dry_run If true, validate and report what would be done *) 67 210 68 211 (** {1 Join Operations} *) 69 69 - 70 70 - (** Result of a join operation. *) 71 71 - type join_result = { 72 72 - name : string; (** Subtree/repository name *) 73 73 - source_url : string; (** URL the repository was cloned from *) 74 74 - upstream_url : string option; (** Original upstream if this is a fork *) 75 75 - packages_added : string list; (** Package names from .opam files *) 76 76 - from_handle : string option; (** Verse handle if joined from verse *) 77 77 - } 78 78 - 79 79 - val pp_join_result : join_result Fmt.t 80 80 - (** [pp_join_result] formats a join result. *) 81 212 82 213 val join : 83 214 proc:_ Eio.Process.mgr ->

+17

lib/git.ml

reviewed

··· 635 635 stdout = Buffer.contents buf_stdout; 636 636 stderr = Buffer.contents buf_stderr; 637 637 } )) 638 638 + 639 639 + let add_all ~proc ~fs path = 640 640 + let cwd = path_to_eio ~fs path in 641 641 + run_git_ok ~proc ~cwd [ "add"; "-A" ] |> Result.map ignore 642 642 + 643 643 + let commit ~proc ~fs ~message path = 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 647 + let has_subtree_history ~proc ~fs ~repo ~prefix () = 648 648 + (* Check if there's subtree commit history for this prefix. 649 649 + Returns true if we can find a subtree-related commit message. *) 650 650 + subtree_last_upstream_commit ~proc ~fs ~repo ~prefix () |> Option.is_some 651 651 + 652 652 + let branch_rename ~proc ~fs ~new_name path = 653 653 + let cwd = path_to_eio ~fs path in 654 654 + run_git_ok ~proc ~cwd [ "branch"; "-M"; new_name ] |> Result.map ignore

+37

lib/git.mli

reviewed

··· 595 595 596 596 Uses [git apply] to apply the diff. Returns [Ok ()] if the diff was applied 597 597 successfully or was empty, [Error] if the apply failed. *) 598 598 + 599 599 + val add_all : 600 600 + proc:_ Eio.Process.mgr -> 601 601 + fs:Eio.Fs.dir_ty Eio.Path.t -> 602 602 + Fpath.t -> 603 603 + (unit, error) result 604 604 + (** [add_all ~proc ~fs path] stages all changes (git add -A) in the repository 605 605 + at [path]. *) 606 606 + 607 607 + val commit : 608 608 + proc:_ Eio.Process.mgr -> 609 609 + fs:Eio.Fs.dir_ty Eio.Path.t -> 610 610 + message:string -> 611 611 + Fpath.t -> 612 612 + (unit, error) result 613 613 + (** [commit ~proc ~fs ~message path] creates a commit with the given message 614 614 + in the repository at [path]. *) 615 615 + 616 616 + val has_subtree_history : 617 617 + proc:_ Eio.Process.mgr -> 618 618 + fs:Eio.Fs.dir_ty Eio.Path.t -> 619 619 + repo:Fpath.t -> 620 620 + prefix:string -> 621 621 + unit -> 622 622 + bool 623 623 + (** [has_subtree_history ~proc ~fs ~repo ~prefix ()] returns true if the 624 624 + prefix has subtree commit history (i.e., was added via git subtree add). 625 625 + Returns false for fresh local packages that were never part of a subtree. *) 626 626 + 627 627 + val branch_rename : 628 628 + proc:_ Eio.Process.mgr -> 629 629 + fs:Eio.Fs.dir_ty Eio.Path.t -> 630 630 + new_name:string -> 631 631 + Fpath.t -> 632 632 + (unit, error) result 633 633 + (** [branch_rename ~proc ~fs ~new_name path] renames the current branch 634 634 + to [new_name] in the repository at [path]. Uses [git branch -M]. *)

+2 -2

lib/monopam.ml

reviewed

··· 349 349 Ok (List.rev packages) 350 350 351 351 let get_branch ~config pkg = 352 352 - let default = Config.default_branch config in 352 352 + let default = Config.default_branch in 353 353 match Package.branch pkg with 354 354 | Some b -> b 355 355 | None -> ··· 948 948 Log.info (fun m -> 949 949 m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo); 950 950 let url = Uri.of_string url in 951 951 - let branch = Config.default_branch config in 951 951 + let branch = Config.default_branch in 952 952 match Git.clone ~proc ~fs:fs_t ~url ~branch opam_repo with 953 953 | Ok () -> Log.info (fun m -> m "Opam repo cloned successfully") 954 954 | Error e ->

+6 -195

lib/verse_config.ml

reviewed

··· 1 1 - let app_name = "monopam" 2 2 - 3 3 - (** Package-level override for vendored packages *) 4 4 - type package_override = { 5 5 - branch : string option; (** Override branch *) 6 6 - } 1 1 + (** Verse_config is now an alias for Config. 7 2 8 8 - (* Simplified config: just root and handle. Paths are hardcoded. *) 9 9 - type t = { 10 10 - root : Fpath.t; 11 11 - handle : string; 12 12 - knot : string; (** Git push server hostname (e.g., "git.recoil.org") *) 13 13 - packages : (string * package_override) list; (** Per-subtree overrides *) 14 14 - } 3 3 + This module is kept for backwards compatibility. 4 4 + All functionality has been unified into Config. *) 15 5 16 16 - let root t = t.root 17 17 - let handle t = t.handle 18 18 - let knot t = t.knot 19 19 - let packages t = t.packages 6 6 + include Config 20 7 21 21 - (* Hardcoded paths derived from root *) 22 22 - let default_branch = "main" 23 23 - let mono_path t = Fpath.(t.root / "mono") 24 24 - let src_path t = Fpath.(t.root / "src") 25 25 - let opam_repo_path t = Fpath.(t.root / "opam-repo") 26 26 - let verse_path t = Fpath.(t.root / "verse") 27 27 - 28 28 - (* Compute XDG directories following XDG Base Directory Specification *) 29 29 - let xdg_config_home () = 30 30 - match Sys.getenv_opt "XDG_CONFIG_HOME" with 31 31 - | Some dir when dir <> "" -> Fpath.v dir 32 32 - | _ -> ( 33 33 - match Sys.getenv_opt "HOME" with 34 34 - | Some home -> Fpath.(v home / ".config") 35 35 - | None -> Fpath.v "/tmp") 36 36 - 37 37 - let xdg_data_home () = 38 38 - match Sys.getenv_opt "XDG_DATA_HOME" with 39 39 - | Some dir when dir <> "" -> Fpath.v dir 40 40 - | _ -> ( 41 41 - match Sys.getenv_opt "HOME" with 42 42 - | Some home -> Fpath.(v home / ".local" / "share") 43 43 - | None -> Fpath.v "/tmp") 44 44 - 45 45 - let xdg_cache_home () = 46 46 - match Sys.getenv_opt "XDG_CACHE_HOME" with 47 47 - | Some dir when dir <> "" -> Fpath.v dir 48 48 - | _ -> 49 49 - match Sys.getenv_opt "HOME" with 50 50 - | Some home -> Fpath.(v home / ".cache") 51 51 - | None -> Fpath.v "/tmp" 52 52 - 53 53 - let config_dir () = Fpath.(xdg_config_home () / app_name) 54 54 - let data_dir () = Fpath.(xdg_data_home () / app_name) 55 55 - let cache_dir () = Fpath.(xdg_cache_home () / app_name) 56 56 - let config_file () = Fpath.(config_dir () / "opamverse.toml") 57 57 - let registry_path () = Fpath.(data_dir () / "opamverse-registry") 58 58 - 59 59 - (** Derive knot (git push server) from handle. 60 60 - E.g., "anil.recoil.org" -> "git.recoil.org" *) 61 61 - let default_knot_from_handle handle = 62 62 - match String.index_opt handle '.' with 63 63 - | None -> "git." ^ handle (* fallback *) 64 64 - | Some i -> 65 65 - let domain = String.sub handle (i + 1) (String.length handle - i - 1) in 66 66 - "git." ^ domain 67 67 - 68 68 - let create ~root ~handle ?knot ?(packages = []) () = 69 69 - let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in 70 70 - { root; handle; knot; packages } 71 71 - 72 72 - let expand_tilde s = 73 73 - if String.length s > 0 && s.[0] = '~' then 74 74 - match Sys.getenv_opt "HOME" with 75 75 - | Some home -> 76 76 - if String.length s = 1 then home 77 77 - else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1) 78 78 - else s 79 79 - | None -> s 80 80 - else s 81 81 - 82 82 - let fpath_codec : Fpath.t Tomlt.t = 83 83 - Tomlt.map 84 84 - ~dec:(fun s -> 85 85 - let s = expand_tilde s in 86 86 - match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m) 87 87 - ~enc:Fpath.to_string Tomlt.string 88 88 - 89 89 - (* TOML structure: 90 90 - [workspace] 91 91 - root = "~/tangled" 92 92 - 93 93 - [identity] 94 94 - handle = "anil.recoil.org" 95 95 - knot = "git.recoil.org" 96 96 - 97 97 - # Optional package overrides (branch only; URL overrides go in sources.toml) 98 98 - [packages.braid] 99 99 - branch = "backport-fix" 100 100 - *) 101 101 - 102 102 - type workspace_section = { w_root : Fpath.t } 103 103 - type identity_section = { i_handle : string; i_knot : string option } 104 104 - 105 105 - let default_knot = "git.recoil.org" 106 106 - 107 107 - let workspace_codec : workspace_section Tomlt.t = 108 108 - Tomlt.( 109 109 - Table.( 110 110 - obj (fun w_root -> { w_root }) 111 111 - |> mem "root" fpath_codec ~enc:(fun w -> w.w_root) 112 112 - |> finish)) 113 113 - 114 114 - let identity_codec : identity_section Tomlt.t = 115 115 - Tomlt.( 116 116 - Table.( 117 117 - obj (fun i_handle i_knot -> { i_handle; i_knot }) 118 118 - |> mem "handle" string ~enc:(fun i -> i.i_handle) 119 119 - |> opt_mem "knot" string ~enc:(fun i -> i.i_knot) 120 120 - |> finish)) 121 121 - 122 122 - let package_override_codec : package_override Tomlt.t = 123 123 - Tomlt.( 124 124 - Table.( 125 125 - obj (fun branch -> { branch }) 126 126 - |> opt_mem "branch" string ~enc:(fun p -> p.branch) 127 127 - |> finish)) 128 128 - 129 129 - (* Codec for the [packages] table which contains subtree->override mappings *) 130 130 - let packages_table_codec : (string * package_override) list Tomlt.t = 131 131 - Tomlt.( 132 132 - Table.( 133 133 - obj (fun pkgs -> pkgs) 134 134 - |> keep_unknown ~enc:(fun pkgs -> pkgs) 135 135 - (Mems.assoc package_override_codec) 136 136 - |> finish)) 137 137 - 138 138 - (* Internal codec that tracks whether knot was present in the file *) 139 139 - type loaded_config = { config : t; knot_was_missing : bool } 140 140 - 141 141 - let internal_codec : loaded_config Tomlt.t = 142 142 - Tomlt.( 143 143 - Table.( 144 144 - obj (fun workspace identity packages -> 145 145 - let packages = Option.value ~default:[] packages in 146 146 - let knot_was_missing = Option.is_none identity.i_knot in 147 147 - let knot = Option.value ~default:default_knot identity.i_knot in 148 148 - { config = { root = workspace.w_root; handle = identity.i_handle; knot; packages }; 149 149 - knot_was_missing }) 150 150 - |> mem "workspace" workspace_codec ~enc:(fun lc -> { w_root = lc.config.root }) 151 151 - |> mem "identity" identity_codec ~enc:(fun lc -> { i_handle = lc.config.handle; i_knot = Some lc.config.knot }) 152 152 - |> opt_mem "packages" packages_table_codec 153 153 - ~enc:(fun lc -> if lc.config.packages = [] then None else Some lc.config.packages) 154 154 - |> finish)) 155 155 - 156 156 - (* Public codec for encoding only *) 157 157 - let codec : t Tomlt.t = 158 158 - Tomlt.( 159 159 - Table.( 160 160 - obj (fun workspace identity packages -> 161 161 - let packages = Option.value ~default:[] packages in 162 162 - let knot = Option.value ~default:default_knot identity.i_knot in 163 163 - { root = workspace.w_root; handle = identity.i_handle; knot; packages }) 164 164 - |> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root }) 165 165 - |> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle; i_knot = Some t.knot }) 166 166 - |> opt_mem "packages" packages_table_codec 167 167 - ~enc:(fun t -> if t.packages = [] then None else Some t.packages) 168 168 - |> finish)) 169 169 - 170 170 - let save ~fs t = 171 171 - let dir = config_dir () in 172 172 - let path = config_file () in 173 173 - try 174 174 - (* Ensure XDG config directory exists *) 175 175 - let dir_path = Eio.Path.(fs / Fpath.to_string dir) in 176 176 - (try Eio.Path.mkdirs ~perm:0o755 dir_path with Eio.Io _ -> ()); 177 177 - Tomlt_eio.encode_path codec t ~fs (Fpath.to_string path); 178 178 - Ok () 179 179 - with Eio.Io _ as e -> Error (Printexc.to_string e) 180 180 - 181 181 - let load ~fs () = 182 182 - let path = config_file () in 183 183 - let path_str = Fpath.to_string path in 184 184 - try 185 185 - let loaded = Tomlt_eio.decode_path_exn internal_codec ~fs path_str in 186 186 - (* If knot was missing from the config file, write it back with the default *) 187 187 - if loaded.knot_was_missing then begin 188 188 - Logs.info (fun m -> m "Adding default knot=%s to config" default_knot); 189 189 - ignore (save ~fs loaded.config) 190 190 - end; 191 191 - Ok loaded.config 192 192 - with 193 193 - | Eio.Io _ as e -> Error (Printexc.to_string e) 194 194 - | Failure msg -> Error (Fmt.str "Invalid config: %s" msg) 195 195 - 196 196 - let pp ppf t = 197 197 - Fmt.pf ppf "@[<v>workspace:@, root: %a@,identity:@, handle: %s@, knot: %s@]" Fpath.pp 198 198 - t.root t.handle t.knot 8 8 + (** Legacy type alias for package overrides *) 9 9 + type package_override = Config.Package_config.t

+8 -114

lib/verse_config.mli

reviewed

··· 1 1 - (** Opamverse workspace configuration. 2 2 - 3 3 - Configuration is stored in the XDG config directory at 4 4 - [~/.config/monopam/opamverse.toml]. 5 5 - 6 6 - The config stores just the workspace root and user's handle. All paths are 7 7 - derived from the root: 8 8 - - [mono/] - user's monorepo 9 9 - - [src/] - git checkouts for subtrees 10 10 - - [opam-repo/] - opam overlay repository 11 11 - - [verse/] - other members' monorepos *) 12 12 - 13 13 - (** {1 Types} *) 14 14 - 15 15 - (** Package-level override for vendored packages. 16 16 - 17 17 - Note: For dev-repo URL overrides, use [sources.toml] in the monorepo root instead. 18 18 - This type only supports branch overrides. *) 19 19 - type package_override = { 20 20 - branch : string option; (** Override git branch *) 21 21 - } 22 22 - 23 23 - type t 24 24 - (** Opamverse workspace configuration. *) 25 25 - 26 26 - (** {1 Accessors} *) 27 27 - 28 28 - val root : t -> Fpath.t 29 29 - (** [root t] returns the workspace root directory. *) 30 30 - 31 31 - val handle : t -> string 32 32 - (** [handle t] returns the user's tangled handle. *) 33 33 - 34 34 - val knot : t -> string 35 35 - (** [knot t] returns the git push server hostname (e.g., "git.recoil.org"). 36 36 - Used for converting tangled URLs to SSH push URLs. *) 37 37 - 38 38 - val packages : t -> (string * package_override) list 39 39 - (** [packages t] returns the list of package overrides. 40 40 - Each entry is [(subtree_name, override)] where subtree_name is the 41 41 - directory name in the monorepo (e.g., "braid" for mono/braid/). 42 42 - 43 43 - Use this to override git branches. For dev-repo URL overrides, 44 44 - use [sources.toml] in the monorepo root instead. *) 45 45 - 46 46 - (** {1 Derived Paths} *) 47 47 - 48 48 - val default_branch : string 49 49 - (** Default git branch, always ["main"]. *) 50 50 - 51 51 - val mono_path : t -> Fpath.t 52 52 - (** [mono_path t] returns the path to the user's monorepo ([root/mono/]). *) 53 53 - 54 54 - val src_path : t -> Fpath.t 55 55 - (** [src_path t] returns the path to git checkouts ([root/src/]). *) 56 56 - 57 57 - val opam_repo_path : t -> Fpath.t 58 58 - (** [opam_repo_path t] returns the path to the opam overlay ([root/opam-repo/]). 59 59 - *) 60 60 - 61 61 - val verse_path : t -> Fpath.t 62 62 - (** [verse_path t] returns the path to tracked members' monorepos 63 63 - ([root/verse/]). *) 1 1 + (** Verse_config is now an alias for Config. 64 2 65 65 - (** {1 XDG Paths} *) 3 3 + This module is kept for backwards compatibility. 4 4 + All functionality has been unified into Config. 66 5 67 67 - val config_dir : unit -> Fpath.t 68 68 - (** [config_dir ()] returns the XDG config directory for monopam 69 69 - (~/.config/monopam). *) 6 6 + @deprecated Use {!Config} directly. *) 70 7 71 71 - val data_dir : unit -> Fpath.t 72 72 - (** [data_dir ()] returns the XDG data directory for monopam 73 73 - (~/.local/share/monopam). *) 8 8 + include module type of Config 74 9 75 75 - val cache_dir : unit -> Fpath.t 76 76 - (** [cache_dir ()] returns the XDG cache directory for monopam 77 77 - (~/.cache/monopam). Used for non-essential cached data like fetch timestamps. *) 78 78 - 79 79 - val config_file : unit -> Fpath.t 80 80 - (** [config_file ()] returns the path to the opamverse config file 81 81 - (~/.config/monopam/opamverse.toml). *) 82 82 - 83 83 - val registry_path : unit -> Fpath.t 84 84 - (** [registry_path ()] returns the path to the cloned registry git repo 85 85 - (~/.local/share/monopam/opamverse-registry). *) 86 86 - 87 87 - (** {1 Loading and Saving} *) 88 88 - 89 89 - val load : fs:Eio.Fs.dir_ty Eio.Path.t -> unit -> (t, string) result 90 90 - (** [load ~fs ()] loads the workspace configuration from the XDG config file. 91 91 - 92 92 - @param fs Eio filesystem *) 93 93 - 94 94 - val save : fs:Eio.Fs.dir_ty Eio.Path.t -> t -> (unit, string) result 95 95 - (** [save ~fs config] saves the configuration to the XDG config file. 96 96 - 97 97 - @param fs Eio filesystem 98 98 - @param config Configuration to save *) 99 99 - 100 100 - val create : 101 101 - root:Fpath.t -> 102 102 - handle:string -> 103 103 - ?knot:string -> 104 104 - ?packages:(string * package_override) list -> 105 105 - unit -> 106 106 - t 107 107 - (** [create ~root ~handle ?knot ?packages ()] creates a new configuration. 108 108 - 109 109 - @param root Workspace root directory (absolute path) 110 110 - @param handle User's tangled handle 111 111 - @param knot Git push server hostname (e.g., "git.recoil.org"). If not provided, 112 112 - derived from handle (e.g., "anil.recoil.org" -> "git.recoil.org") 113 113 - @param packages Optional list of package overrides for vendored packages *) 114 114 - 115 115 - (** {1 Pretty Printing} *) 116 116 - 117 117 - val pp : t Fmt.t 118 118 - (** [pp] formats a workspace configuration. *) 10 10 + (** Legacy type alias for package overrides. 11 11 + @deprecated Use {!Config.Package_config.t} instead. *) 12 12 + type package_override = Config.Package_config.t