WIP: various improvements across packages · gazagnaire.org/monopam@15a6706

+8 -3

bin/main.ml

··· 228 228 in 229 229 let run package remote skip_push skip_pull () = 230 230 Eio_main.run @@ fun env -> 231 + Eio.Switch.run @@ fun sw -> 231 232 with_config env @@ fun config -> 232 233 let fs = Eio.Stdenv.fs env in 233 234 let proc = Eio.Stdenv.process_mgr env in 235 + let xdg = Xdge.create fs "monopam" in 234 236 match 235 - Monopam.sync ~proc ~fs ~config ?package ~remote ~skip_push ~skip_pull () 237 + Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package ~remote ~skip_push 238 + ~skip_pull () 236 239 with 237 240 | Ok summary -> 238 241 if summary.errors = [] then `Ok () ··· 1069 1072 in 1070 1073 let run package json no_sync quiet () = 1071 1074 Eio_main.run @@ fun env -> 1075 + Eio.Switch.run @@ fun sw -> 1072 1076 with_config env @@ fun config -> 1073 1077 with_verse_config env @@ fun verse_config -> 1074 1078 let fs = Eio.Stdenv.fs env in 1075 1079 let proc = Eio.Stdenv.process_mgr env in 1076 1080 let clock = Eio.Stdenv.clock env in 1081 + let xdg = Xdge.create fs "monopam" in 1077 1082 (* Run sync before analysis unless --no-sync is specified *) 1078 1083 if (not no_sync) && not quiet then begin 1079 1084 Fmt.pr "Syncing workspace before analysis...@."; 1080 - match Monopam.sync ~proc ~fs ~config ?package () with 1085 + match Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () with 1081 1086 | Ok _summary -> () 1082 1087 | Error e -> 1083 1088 Fmt.pr "Warning: sync failed: %a@." Monopam.pp_error_with_hint e; ··· 1085 1090 end 1086 1091 else if not no_sync then begin 1087 1092 (* Quiet mode but still sync - just don't print progress *) 1088 - let _ = Monopam.sync ~proc ~fs ~config ?package () in 1093 + let _ = Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () in 1089 1094 () 1090 1095 end; 1091 1096 let report =

+72 -21

lib/fork_join.ml

··· 459 459 let branch = Verse_config.default_branch in 460 460 461 461 (* Gather discovery information *) 462 - let mono_exists = Git_cli.Subtree.exists ~fs ~repo:monorepo ~prefix in 462 + let mono_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in 463 463 let src_exists = is_directory ~fs src_path in 464 464 let has_subtree_hist = 465 465 if mono_exists then ··· 612 612 let src_path = Fpath.(checkouts / name) in 613 613 614 614 (* Gather discovery information *) 615 - let subtree_exists = Git_cli.Subtree.exists ~fs ~repo:monorepo ~prefix in 615 + let subtree_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in 616 616 let src_exists = is_directory ~fs src_path in 617 617 let local_is_repo = 618 618 if is_local then begin ··· 754 754 let src_path = Fpath.(checkouts / name) in 755 755 756 756 (* Gather discovery information *) 757 - let subtree_exists = Git_cli.Subtree.exists ~fs ~repo:monorepo ~prefix in 757 + let subtree_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in 758 758 let src_exists = is_directory ~fs src_path in 759 759 let src_is_repo = 760 760 if src_exists then Git_cli.is_repo ~proc ~fs src_path else false ··· 828 828 Git_cli.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest 829 829 |> Result.map_error (fun e -> Git_error e) 830 830 | Git_subtree_split { repo; prefix } -> 831 - Git_cli.Subtree.split ~proc ~fs ~repo ~prefix () 832 - |> Result.map (fun commit -> state.split_commit <- Some commit) 833 - |> Result.map_error (fun e -> Git_error e) 831 + let repo_path = Fpath.to_string repo in 832 + let git_repo = Git.Repository.open_repo ~fs repo_path in 833 + (match Git.Repository.read_ref git_repo "HEAD" with 834 + | None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found")) 835 + | Some head -> ( 836 + match Git.Subtree.split git_repo ~prefix ~head () with 837 + | Ok None -> 838 + Error (Git_error (Git_cli.Subtree_prefix_missing prefix)) 839 + | Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg)) 840 + | Ok (Some split_hash) -> 841 + state.split_commit <- Some (Git.Hash.to_hex split_hash); 842 + Ok ())) 834 843 | Git_subtree_add { repo; prefix; url; branch } -> 835 - Git_cli.Subtree.add ~proc ~fs ~repo ~prefix ~url ~branch () 836 - |> Result.map_error (fun e -> Git_error e) 844 + (* Fetch the branch first to get the commit *) 845 + (match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with 846 + | Error e -> Error (Git_error e) 847 + | Ok hash_hex -> 848 + let repo_path = Fpath.to_string repo in 849 + let git_repo = Git.Repository.open_repo ~fs repo_path in 850 + let commit = Git.Hash.of_hex hash_hex in 851 + let user = 852 + Git.User.make ~name:"monopam" ~email:"monopam@localhost" 853 + ~date:(Int64.of_float (Unix.time ())) () 854 + in 855 + let message = 856 + Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix 857 + (Uri.to_string url) prefix 858 + in 859 + (match 860 + Git.Subtree.add git_repo ~prefix ~commit ~author:user 861 + ~committer:user ~message () 862 + with 863 + | Ok _ -> Ok () 864 + | Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg)))) 837 865 | Git_add_remote { repo; name; url } -> 838 866 Git_cli.add_remote ~proc ~fs ~name ~url repo 839 867 |> Result.map_error (fun e -> Git_error e) ··· 945 973 let subtree_path = Fpath.(monorepo / prefix) in 946 974 let src_path = Fpath.(checkouts / name) in 947 975 (* Validate: mono/<name>/ must exist *) 948 - if not (Git_cli.Subtree.exists ~fs ~repo:monorepo ~prefix) then 976 + if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then 949 977 Error (Subtree_not_found name) (* Validate: src/<name>/ must not exist *) 950 978 else if is_directory ~fs src_path then Error (Src_already_exists name) 951 979 else begin ··· 963 991 } 964 992 else begin 965 993 (* Split the subtree to get history *) 966 - match Git_cli.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with 967 - | Error e -> Error (Git_error e) 968 - | Ok split_commit -> ( 994 + let repo_path = Fpath.to_string monorepo in 995 + let git_repo = Git.Repository.open_repo ~fs repo_path in 996 + match Git.Repository.read_ref git_repo "HEAD" with 997 + | None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found")) 998 + | Some head -> ( 999 + match Git.Subtree.split git_repo ~prefix ~head () with 1000 + | Ok None -> 1001 + Error (Git_error (Git_cli.Subtree_prefix_missing prefix)) 1002 + | Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg)) 1003 + | Ok (Some split_hash) -> 1004 + let split_commit = Git.Hash.to_hex split_hash in 1005 + ( 969 1006 (* Ensure src/ exists *) 970 1007 ensure_dir ~fs checkouts; 971 1008 (* Initialize new git repo at src/<name>/ *) ··· 1055 1092 src_path; 1056 1093 push_url; 1057 1094 packages_created = packages; 1058 - }))))) 1095 + })))))) 1059 1096 end 1060 1097 end 1061 1098 ··· 1067 1104 let subtree_path = Fpath.(monorepo / prefix) in 1068 1105 let src_path = Fpath.(checkouts / name) in 1069 1106 (* Validate: mono/<name>/ must not exist *) 1070 - if Git_cli.Subtree.exists ~fs ~repo:monorepo ~prefix then 1107 + if Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix then 1071 1108 Error (Subtree_already_exists name) 1072 1109 else if dry_run then 1073 1110 Ok ··· 1087 1124 match Git_cli.clone ~proc ~fs ~url:uri ~branch src_path with 1088 1125 | Error e -> Error (Git_error e) 1089 1126 | Ok () -> ( 1090 - (* Add subtree to monorepo *) 1091 - match 1092 - Git_cli.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch 1093 - () 1094 - with 1127 + (* Add subtree to monorepo - first fetch to get the commit *) 1128 + match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch () with 1095 1129 | Error e -> Error (Git_error e) 1096 - | Ok () -> 1130 + | Ok hash_hex -> 1131 + let repo_path = Fpath.to_string monorepo in 1132 + let git_repo = Git.Repository.open_repo ~fs repo_path in 1133 + let commit = Git.Hash.of_hex hash_hex in 1134 + let user = 1135 + Git.User.make ~name:"monopam" ~email:"monopam@localhost" 1136 + ~date:(Int64.of_float (Unix.time ())) () 1137 + in 1138 + let message = 1139 + Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix url 1140 + prefix 1141 + in 1142 + (match 1143 + Git.Subtree.add git_repo ~prefix ~commit ~author:user 1144 + ~committer:user ~message () 1145 + with 1146 + | Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg)) 1147 + | Ok _ -> 1097 1148 (* Find .opam files in the new subtree *) 1098 1149 let packages = find_opam_files ~fs subtree_path in 1099 1150 (* Only update sources.toml if there's an upstream to track *) ··· 1137 1188 upstream_url = upstream; 1138 1189 packages_added = packages; 1139 1190 from_handle = None; 1140 - }) 1191 + })) 1141 1192 end 1142 1193 1143 1194 let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url

+15

lib/git_cli.ml

··· 667 667 let branch_rename ~proc ~fs ~new_name path = 668 668 let cwd = path_to_eio ~fs path in 669 669 run_git_ok ~proc ~cwd [ "branch"; "-M"; new_name ] |> Result.map ignore 670 + 671 + let ls_remote_head ~proc ~fs ?(remote = "origin") ?(branch = "main") path = 672 + let cwd = path_to_eio ~fs path in 673 + match 674 + run_git_ok ~proc ~cwd 675 + [ "ls-remote"; "--heads"; remote; Printf.sprintf "refs/heads/%s" branch ] 676 + with 677 + | Error _ -> None 678 + | Ok output -> 679 + if String.trim output = "" then None 680 + else 681 + (* Output format: "hash\trefs/heads/branch" *) 682 + match String.split_on_char '\t' (String.trim output) with 683 + | hash :: _ -> Some hash 684 + | [] -> None

+49 -70

lib/git_cli.mli

··· 167 167 @param remote Remote name (default: "origin") 168 168 @param branch Branch to compare (default: current branch) *) 169 169 170 - (** {1 Subtree Operations} *) 171 - 172 - (** Operations for git subtree management in the monorepo. *) 173 - module Subtree : sig 174 - val add : 175 - proc:_ Eio.Process.mgr -> 176 - fs:Eio.Fs.dir_ty Eio.Path.t -> 177 - repo:Fpath.t -> 178 - prefix:string -> 179 - url:Uri.t -> 180 - branch:string -> 181 - unit -> 182 - (unit, error) result 183 - (** [add ~proc ~fs ~repo ~prefix ~url ~branch ()] adds a new subtree to the 184 - repository. 185 - 186 - @param repo Path to the monorepo 187 - @param prefix Subdirectory for the subtree 188 - @param url Git remote URL for the subtree source 189 - @param branch Branch to add *) 190 - 191 - val pull : 192 - proc:_ Eio.Process.mgr -> 193 - fs:Eio.Fs.dir_ty Eio.Path.t -> 194 - repo:Fpath.t -> 195 - prefix:string -> 196 - url:Uri.t -> 197 - branch:string -> 198 - unit -> 199 - (unit, error) result 200 - (** [pull ~proc ~fs ~repo ~prefix ~url ~branch ()] pulls updates from the 201 - remote into the subtree. 202 - 203 - @param repo Path to the monorepo 204 - @param prefix Subdirectory of the subtree 205 - @param url Git remote URL 206 - @param branch Branch to pull *) 207 - 208 - val push : 209 - proc:_ Eio.Process.mgr -> 210 - fs:Eio.Fs.dir_ty Eio.Path.t -> 211 - repo:Fpath.t -> 212 - prefix:string -> 213 - url:Uri.t -> 214 - branch:string -> 215 - unit -> 216 - (unit, error) result 217 - (** [push ~proc ~fs ~repo ~prefix ~url ~branch ()] pushes subtree changes to 218 - the remote. 170 + (** {1 Subtree Helper Operations} *) 219 171 220 - This extracts commits that affected the subtree and pushes them to the 221 - specified remote/branch. 172 + val fetch_url : 173 + proc:_ Eio.Process.mgr -> 174 + fs:Eio.Fs.dir_ty Eio.Path.t -> 175 + repo:Fpath.t -> 176 + url:Uri.t -> 177 + branch:string -> 178 + unit -> 179 + (string, error) result 180 + (** [fetch_url ~proc ~fs ~repo ~url ~branch ()] fetches a branch from a URL 181 + and returns the commit hash of FETCH_HEAD. 222 182 223 - @param repo Path to the monorepo 224 - @param prefix Subdirectory of the subtree 225 - @param url Git remote URL 226 - @param branch Branch to push to *) 183 + @param repo Path to the local repository 184 + @param url Git remote URL to fetch from 185 + @param branch Branch to fetch *) 227 186 228 - val split : 229 - proc:_ Eio.Process.mgr -> 230 - fs:Eio.Fs.dir_ty Eio.Path.t -> 231 - repo:Fpath.t -> 232 - prefix:string -> 233 - unit -> 234 - (string, error) result 235 - (** [split ~proc ~fs ~repo ~prefix ()] extracts commits for a subtree into a 236 - standalone branch. 187 + val push_refspec : 188 + proc:_ Eio.Process.mgr -> 189 + fs:Eio.Fs.dir_ty Eio.Path.t -> 190 + repo:Fpath.t -> 191 + url:Uri.t -> 192 + refspec:string -> 193 + unit -> 194 + (unit, error) result 195 + (** [push_refspec ~proc ~fs ~repo ~url ~refspec ()] pushes a refspec to a URL. 237 196 238 - Returns the commit hash of the split branch head. *) 197 + @param repo Path to the local repository 198 + @param url Git remote URL to push to 199 + @param refspec Git refspec (e.g. "hash:refs/heads/branch") *) 239 200 240 - val exists : 241 - fs:Eio.Fs.dir_ty Eio.Path.t -> repo:Fpath.t -> prefix:string -> bool 242 - (** [exists ~fs ~repo ~prefix] returns true if the subtree prefix directory 243 - exists in the repository. *) 244 - end 201 + val subtree_prefix_exists : 202 + fs:Eio.Fs.dir_ty Eio.Path.t -> repo:Fpath.t -> prefix:string -> bool 203 + (** [subtree_prefix_exists ~fs ~repo ~prefix] returns true if the subtree 204 + prefix directory exists in the repository. *) 245 205 246 206 (** {1 Initialization} *) 247 207 ··· 656 616 (unit, error) result 657 617 (** [branch_rename ~proc ~fs ~new_name path] renames the current branch to 658 618 [new_name] in the repository at [path]. Uses [git branch -M]. *) 619 + 620 + (** {1 Remote Queries} *) 621 + 622 + val ls_remote_head : 623 + proc:_ Eio.Process.mgr -> 624 + fs:Eio.Fs.dir_ty Eio.Path.t -> 625 + ?remote:string -> 626 + ?branch:string -> 627 + Fpath.t -> 628 + string option 629 + (** [ls_remote_head ~proc ~fs ?remote ?branch path] queries the remote for the 630 + HEAD ref of a branch without fetching any objects. 631 + 632 + This is much faster than [fetch] and can be used to check if there are any 633 + new commits to fetch. Returns [None] if the branch doesn't exist or the 634 + remote is unreachable. 635 + 636 + @param remote Remote name (default: "origin") 637 + @param branch Branch name (default: "main") *)

+223 -80

lib/monopam.ml

··· 21 21 22 22 module Log = (val Logs.src_log src : Logs.LOG) 23 23 24 + (* Timing helper for benchmarking phases *) 25 + let time_phase name f = 26 + let t0 = Unix.gettimeofday () in 27 + let result = f () in 28 + let t1 = Unix.gettimeofday () in 29 + Log.debug (fun m -> m "[TIMING] %s: %.3fs" name (t1 -. t0)); 30 + result 31 + 24 32 type error = 25 33 | Config_error of string 26 34 | Repo_error of Opam_repo.error ··· 1384 1392 end 1385 1393 1386 1394 (* Fetch a single checkout - safe for parallel execution *) 1387 - let fetch_checkout_safe ~proc ~fs ~config pkg = 1395 + (** Remote HEAD cache with O(1) in-memory lookup and disk persistence. 1396 + File format: one entry per line "url:branch hash timestamp" *) 1397 + module Remote_cache : sig 1398 + type t 1399 + 1400 + val create : xdg:Xdge.t -> now:(unit -> float) -> t 1401 + val get : t -> url:Uri.t -> branch:string -> string option 1402 + val set : t -> url:Uri.t -> branch:string -> hash:string -> unit 1403 + end = struct 1404 + type entry = { hash : string; expires : float } 1405 + type t = { tbl : (string, entry) Hashtbl.t; xdg : Xdge.t; now : unit -> float } 1406 + 1407 + let ttl = 300.0 (* 5 minutes *) 1408 + let filename = "remote-heads" 1409 + let cache_file xdg = Eio.Path.(Xdge.cache_dir xdg / filename) 1410 + let make_key url branch = Fmt.str "%s:%s" (Uri.to_string url) branch 1411 + 1412 + let parse_line line = 1413 + match String.split_on_char ' ' line with 1414 + | [ key; hash; ts ] -> Some (key, hash, float_of_string ts) 1415 + | _ -> None 1416 + 1417 + let load_from_disk xdg = 1418 + let tbl = Hashtbl.create 32 in 1419 + (try 1420 + Eio.Path.load (cache_file xdg) 1421 + |> String.split_on_char '\n' 1422 + |> List.iter (fun line -> 1423 + match parse_line line with 1424 + | Some (key, hash, ts) -> 1425 + Hashtbl.replace tbl key { hash; expires = ts +. ttl } 1426 + | None -> ()) 1427 + with _ -> ()); 1428 + tbl 1429 + 1430 + let save_to_disk t = 1431 + let now = t.now () in 1432 + let lines = 1433 + Hashtbl.fold 1434 + (fun key entry acc -> 1435 + if entry.expires > now then 1436 + let ts = entry.expires -. ttl in 1437 + Fmt.str "%s %s %.0f" key entry.hash ts :: acc 1438 + else acc) 1439 + t.tbl [] 1440 + in 1441 + let content = String.concat "\n" lines ^ "\n" in 1442 + try Eio.Path.save ~create:(`Or_truncate 0o644) (cache_file t.xdg) content 1443 + with _ -> () 1444 + 1445 + let create ~xdg ~now = 1446 + let tbl = load_from_disk xdg in 1447 + { tbl; xdg; now } 1448 + 1449 + let get t ~url ~branch = 1450 + let key = make_key url branch in 1451 + let now = t.now () in 1452 + match Hashtbl.find_opt t.tbl key with 1453 + | Some entry when entry.expires > now -> 1454 + Log.debug (fun m -> m "Cache hit for %s (expires in %.0fs)" key (entry.expires -. now)); 1455 + Some entry.hash 1456 + | Some entry -> 1457 + Log.debug (fun m -> m "Cache expired for %s (%.0fs ago)" key (now -. entry.expires)); 1458 + None 1459 + | None -> 1460 + Log.debug (fun m -> m "Cache miss for %s (not found)" key); 1461 + None 1462 + 1463 + let set t ~url ~branch ~hash = 1464 + let key = make_key url branch in 1465 + let expires = t.now () +. ttl in 1466 + Hashtbl.replace t.tbl key { hash; expires }; 1467 + save_to_disk t 1468 + end 1469 + 1470 + let fetch_checkout_safe ~sw ~env ~proc ~fs ~config ~cache ~get_session pkg = 1471 + let repo = Package.repo_name pkg in 1388 1472 let checkouts_root = Config.Paths.checkouts config in 1389 1473 let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1390 1474 let branch = get_branch ~config pkg in 1391 - (* Get commits behind before fetching *) 1392 - let behind_before = 1393 - match Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir with 1394 - | Ok ab -> ab.behind 1395 - | Error _ -> 0 1475 + let remote_url = Package.dev_repo pkg in 1476 + let local_head = 1477 + Git_cli.rev_parse ~proc ~fs ~rev:(Fmt.str "origin/%s" branch) checkout_dir 1478 + |> Result.to_option 1396 1479 in 1397 - Log.info (fun m -> m "Fetching %s (all remotes)" (Package.repo_name pkg)); 1398 - match Git_cli.fetch_all ~proc ~fs checkout_dir with 1399 - | Error e -> Error e 1400 - | Ok () -> 1401 - (* Get commits behind after fetching *) 1402 - let behind_after = 1403 - match Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir with 1404 - | Ok ab -> ab.behind 1405 - | Error _ -> 0 1480 + (* Check if we can skip fetch entirely *) 1481 + let remote_matches_local hash = 1482 + match local_head with Some h -> hash = h | None -> false 1483 + in 1484 + (* Step 1: Try cached remote HEAD - O(1) hashtbl lookup *) 1485 + match Remote_cache.get cache ~url:remote_url ~branch with 1486 + | Some cached when remote_matches_local cached -> 1487 + Log.debug (fun m -> m "Skipping fetch for %s (cached)" repo); 1488 + Ok 0 1489 + | _ -> ( 1490 + (* Step 2: Query remote HEAD via HTTP (lazily creates session) *) 1491 + let remote = 1492 + time_phase (Fmt.str "ls-remote:%s" repo) (fun () -> 1493 + Git.Remote.get_remote_head ~session:(get_session ()) ~sw ~env remote_url ~branch) 1406 1494 in 1407 - Ok (behind_after - behind_before) 1495 + Option.iter 1496 + (fun h -> 1497 + Remote_cache.set cache ~url:remote_url ~branch ~hash:(Git.Hash.to_hex h)) 1498 + remote; 1499 + match remote with 1500 + | Some h when remote_matches_local (Git.Hash.to_hex h) -> 1501 + Log.debug (fun m -> m "Skipping fetch for %s (remote unchanged)" repo); 1502 + Ok 0 1503 + | _ -> 1504 + (* Step 3: Do full git fetch *) 1505 + let get_behind () = 1506 + Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir 1507 + |> Result.map (fun (ab : Git_cli.ahead_behind) -> ab.behind) 1508 + |> Result.value ~default:0 1509 + in 1510 + let behind_before = get_behind () in 1511 + Log.info (fun m -> m "Fetching %s (all remotes)" repo); 1512 + Git_cli.fetch_all ~proc ~fs checkout_dir 1513 + |> Result.map (fun () -> get_behind () - behind_before)) 1408 1514 1409 1515 (* Merge checkout to latest - must be sequential *) 1410 1516 let merge_checkout_safe ~proc ~fs ~config pkg = ··· 1643 1749 Error (Git_error e) 1644 1750 end))) 1645 1751 1646 - let sync ~proc ~fs ~config ?package ?(remote = false) ?(skip_push = false) 1647 - ?(skip_pull = false) () = 1752 + let sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?(remote = false) 1753 + ?(skip_push = false) ?(skip_pull = false) ?(skip_verse = false) () = 1648 1754 let fs_t = fs_typed fs in 1755 + (* Create remote HEAD cache with O(1) lookup - loaded once, persisted on updates *) 1756 + let cache = Remote_cache.create ~xdg ~now:(fun () -> Eio.Time.now env#clock) in 1757 + (* Lazily create HTTP session to avoid TLS cert loading if cache hits *) 1758 + let session_ref = ref None in 1759 + let get_session () = 1760 + match !session_ref with 1761 + | Some s -> s 1762 + | None -> 1763 + let s = Requests.create ~sw env in 1764 + session_ref := Some s; 1765 + s 1766 + in 1649 1767 1650 - (* Step 0: Sync verse members if verse config exists and not skipping pull *) 1651 - (if not skip_pull then 1768 + (* Step 0: Sync verse members if verse config exists and not skipping 1769 + Skip verse sync when syncing a specific package for faster operations *) 1770 + let should_skip_verse = skip_pull || skip_verse || Option.is_some package in 1771 + (if not should_skip_verse then 1652 1772 match Verse_config.load ~fs:fs_t () with 1653 1773 | Error _ -> () (* No verse config = skip *) 1654 1774 | Ok verse_config -> ( 1655 1775 Log.app (fun m -> m "Syncing verse members..."); 1656 - match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with 1657 - | Ok () -> () 1658 - | Error e -> Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e))); 1776 + time_phase "verse-sync" (fun () -> 1777 + match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with 1778 + | Ok () -> () 1779 + | Error e -> 1780 + Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e)))); 1659 1781 1660 1782 (* Clone from verse registry if repos don't exist *) 1661 1783 match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with 1662 1784 | Error e -> Error e 1663 1785 | Ok () -> ( 1664 - (* Update the opam repo first - clone if needed *) 1786 + (* Update the opam repo first - clone if needed 1787 + Skip when syncing a single package for faster operations *) 1665 1788 let opam_repo = Config.Paths.opam_repo config in 1666 - if (not skip_pull) && Git_cli.is_repo ~proc ~fs:fs_t opam_repo then begin 1789 + let skip_opam_repo = Option.is_some package in 1790 + if (not skip_pull) && (not skip_opam_repo) && Git_cli.is_repo ~proc ~fs:fs_t opam_repo then begin 1667 1791 Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo); 1668 - let result = 1669 - let ( let* ) = Result.bind in 1670 - let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in 1671 - Git_cli.merge_ff ~proc ~fs:fs_t opam_repo 1672 - in 1673 - match result with 1674 - | Ok () -> () 1675 - | Error e -> 1676 - Log.warn (fun m -> 1677 - m "Failed to update opam repo: %a" Git_cli.pp_error e) 1792 + time_phase "opam-repo-fetch" (fun () -> 1793 + let result = 1794 + let ( let* ) = Result.bind in 1795 + let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in 1796 + Git_cli.merge_ff ~proc ~fs:fs_t opam_repo 1797 + in 1798 + match result with 1799 + | Ok () -> () 1800 + | Error e -> 1801 + Log.warn (fun m -> 1802 + m "Failed to update opam repo: %a" Git_cli.pp_error e)) 1678 1803 end; 1679 1804 (* Ensure directories exist *) 1680 1805 ensure_checkouts_dir ~fs:fs_t ~config; 1681 1806 match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with 1682 1807 | Error e -> Error e 1683 1808 | Ok () -> 1684 - (* Check for uncommitted changes in monorepo *) 1685 - let monorepo = Config.Paths.monorepo config in 1686 - if Git_cli.is_dirty ~proc ~fs:fs_t monorepo then begin 1687 - Log.err (fun m -> m "Monorepo has uncommitted changes"); 1688 - Error Monorepo_dirty 1689 - end 1690 - else begin 1691 - (* Regenerate opam-repo from monorepo to ensure URLs are up to date *) 1692 - regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config (); 1693 - match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with 1694 - | Error e -> Error e 1695 - | Ok all_pkgs -> 1696 - let pkgs = 1697 - match package with 1698 - | None -> all_pkgs 1699 - | Some name -> 1700 - List.filter (fun p -> Package.name p = name) all_pkgs 1809 + (* Regenerate opam-repo from monorepo to ensure URLs are up to date *) 1810 + (* Skip when syncing a single package for faster operations *) 1811 + (if Option.is_none package then 1812 + time_phase "regenerate-opam-repo" (fun () -> 1813 + regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config ())); 1814 + (match 1815 + time_phase "discover-packages" (fun () -> 1816 + discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config ()) 1817 + with 1818 + | Error e -> Error e 1819 + | Ok all_pkgs -> 1820 + let pkgs = 1821 + match package with 1822 + | None -> all_pkgs 1823 + | Some name -> 1824 + List.filter (fun p -> Package.name p = name) all_pkgs 1825 + in 1826 + if pkgs = [] && package <> None then 1827 + Error (Package_not_found (Option.get package)) 1828 + else begin 1829 + (* Step 1: Validate - check for dirty state in packages being synced *) 1830 + Log.info (fun m -> 1831 + m "Checking status of %d packages" (List.length pkgs)); 1832 + let statuses = 1833 + time_phase "compute-status" (fun () -> 1834 + Status.compute_all ~proc ~fs:fs_t ~config pkgs) 1835 + in 1836 + let dirty = 1837 + List.filter Status.has_local_changes statuses 1838 + |> List.map (fun s -> s.Status.package) 1701 1839 in 1702 - if pkgs = [] && package <> None then 1703 - Error (Package_not_found (Option.get package)) 1840 + if dirty <> [] then Error (Dirty_state dirty) 1704 1841 else begin 1705 - (* Step 1: Validate - check for dirty state *) 1706 - Log.info (fun m -> 1707 - m "Checking status of %d packages" (List.length pkgs)); 1708 - let statuses = 1709 - Status.compute_all ~proc ~fs:fs_t ~config pkgs 1710 - in 1711 - let dirty = 1712 - List.filter Status.has_local_changes statuses 1713 - |> List.map (fun s -> s.Status.package) 1714 - in 1715 - if dirty <> [] then Error (Dirty_state dirty) 1716 - else begin 1717 1842 let repos = unique_repos pkgs in 1718 1843 let total = List.length repos in 1719 1844 Log.app (fun m -> m "Syncing %d repositories..." total); ··· 1818 1943 Log.app (fun m -> 1819 1944 m " Fetching from remotes (parallel)..."); 1820 1945 let fetch_results = 1946 + time_phase "fetch-phase" (fun () -> 1821 1947 Eio.Fiber.List.map ~max_fibers:4 1822 1948 (fun pkg -> 1823 1949 let repo_name = Package.repo_name pkg in 1824 1950 (* First ensure checkout exists *) 1825 1951 match 1826 - ensure_checkout_safe ~proc ~fs:fs_t ~config pkg 1952 + time_phase (Printf.sprintf "ensure-checkout:%s" repo_name) (fun () -> 1953 + ensure_checkout_safe ~proc ~fs:fs_t ~config pkg) 1827 1954 with 1828 1955 | Error e -> 1829 1956 Error { repo_name; phase = `Fetch; error = e } ··· 1831 1958 if was_cloned then Ok (repo_name, true, 0) 1832 1959 else 1833 1960 match 1834 - fetch_checkout_safe ~proc ~fs:fs_t ~config 1835 - pkg 1961 + time_phase (Printf.sprintf "fetch:%s" repo_name) (fun () -> 1962 + fetch_checkout_safe ~sw ~env ~proc ~fs:fs_t 1963 + ~config ~cache ~get_session pkg) 1836 1964 with 1837 1965 | Error e -> 1838 1966 Error ··· 1843 1971 } 1844 1972 | Ok commits -> 1845 1973 Ok (repo_name, false, commits))) 1846 - repos 1974 + repos) 1847 1975 in 1848 1976 let fetch_errs, fetch_successes = 1849 1977 List.partition_map ··· 1886 2014 (* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *) 1887 2015 Log.app (fun m -> m " Merging checkouts..."); 1888 2016 let merge_errs = ref [] in 2017 + time_phase "merge-phase" (fun () -> 1889 2018 List.iter 1890 2019 (fun pkg -> 1891 2020 match 1892 - merge_checkout_safe ~proc ~fs:fs_t ~config pkg 2021 + time_phase (Printf.sprintf "merge:%s" (Package.repo_name pkg)) (fun () -> 2022 + merge_checkout_safe ~proc ~fs:fs_t ~config pkg) 1893 2023 with 1894 2024 | Ok () -> () 1895 2025 | Error e -> ··· 1900 2030 error = e; 1901 2031 } 1902 2032 :: !merge_errs) 1903 - successfully_fetched; 2033 + successfully_fetched); 1904 2034 1905 2035 (* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *) 1906 2036 (* Check if monorepo has local modifications first *) ··· 1972 2102 in 1973 2103 1974 2104 (* Step 5.5: Verse remotes - update and fetch from verse members *) 2105 + (* Skip when syncing a single package for faster operations *) 1975 2106 (* Only operate on successfully fetched repos to avoid missing directory errors *) 1976 - (match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with 2107 + (if Option.is_some package then 2108 + Log.debug (fun m -> m "Skipping verse remotes (single package sync)") 2109 + else 2110 + match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with 1977 2111 | Error _ -> () (* No verse config, skip verse remotes *) 1978 2112 | Ok verse_config -> 2113 + time_phase "sync-verse-remotes" (fun () -> 1979 2114 sync_verse_remotes ~proc ~fs:fs_t ~config ~verse_config 1980 - successfully_fetched_repos; 2115 + successfully_fetched_repos); 1981 2116 (* Fetch from verse remotes in parallel *) 1982 2117 Log.app (fun m -> m " Fetching from verse remotes..."); 2118 + time_phase "fetch-verse-remotes" (fun () -> 1983 2119 Eio.Fiber.List.iter ~max_fibers:4 1984 2120 (fun pkg -> 1985 2121 fetch_verse_remotes ~proc ~fs:fs_t ~config pkg) 1986 - successfully_fetched_repos); 2122 + successfully_fetched_repos)); 1987 2123 1988 2124 (* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *) 2125 + (* Skip when syncing a single package for faster operations *) 2126 + (if Option.is_some package then 2127 + Log.debug (fun m -> m "Skipping finalize (single package sync)") 2128 + else begin 1989 2129 Log.app (fun m -> 1990 2130 m " Writing README.md, CLAUDE.md, and dune-project..."); 1991 - write_readme ~proc ~fs:fs_t ~config all_pkgs; 1992 - write_claude_md ~proc ~fs:fs_t ~config; 1993 - write_dune_project ~proc ~fs:fs_t ~config all_pkgs; 2131 + time_phase "write-readme" (fun () -> 2132 + write_readme ~proc ~fs:fs_t ~config all_pkgs); 2133 + time_phase "write-claude-md" (fun () -> 2134 + write_claude_md ~proc ~fs:fs_t ~config); 2135 + time_phase "write-dune-project" (fun () -> 2136 + write_dune_project ~proc ~fs:fs_t ~config all_pkgs) 2137 + end); 1994 2138 1995 2139 (* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *) 1996 2140 (* Only push repos that were successfully fetched *) ··· 2059 2203 2060 2204 Ok summary 2061 2205 end 2062 - end 2063 - end) 2206 + end)) 2064 2207 2065 2208 (* Opam metadata sync: copy .opam files from monorepo subtrees to opam-repo *) 2066 2209

+8 -1

lib/monopam.mli

··· 166 166 (** [pp_sync_summary] formats a sync summary. *) 167 167 168 168 val sync : 169 + sw:Eio.Switch.t -> 170 + env:< clock : _ Eio.Time.clock 171 + ; net : _ Eio.Net.t 172 + ; fs : Eio.Fs.dir_ty Eio.Path.t 173 + ; .. > -> 169 174 proc:_ Eio.Process.mgr -> 170 175 fs:Eio.Fs.dir_ty Eio.Path.t -> 171 176 config:Config.t -> 177 + xdg:Xdge.t -> 172 178 ?package:string -> 173 179 ?remote:bool -> 174 180 ?skip_push:bool -> 175 181 ?skip_pull:bool -> 182 + ?skip_verse:bool -> 176 183 unit -> 177 184 (sync_summary, error) result 178 - (** [sync ~proc ~fs ~config ?package ?remote ?skip_push ?skip_pull ()] 185 + (** [sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?remote ?skip_push ?skip_pull ?skip_verse ()] 179 186 synchronizes the monorepo with upstream repositories. 180 187 181 188 This is the primary command for all sync operations. It performs both push

+1 -1

lib/status.ml

··· 50 50 | _ -> Missing 51 51 in 52 52 let subtree = 53 - if Git_cli.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present 53 + if Git_cli.subtree_prefix_exists ~fs:fs_t ~repo:monorepo ~prefix then Present 54 54 else Not_added 55 55 in 56 56 (* Compute subtree sync state: compare tree content between monorepo subtree and checkout.

Configure Feed

Configure Feed