monopam: remove deprecated sync function and types · gazagnaire.org/monopam@f320893

+27 -1128

1 changed file

expand all

lib

monopam.ml

+27 -1128

lib/monopam.ml

··· 1068 1068 | Error e -> Error (Git_error e))) 1069 1069 end 1070 1070 1071 - let push ~proc ~fs ~config ?package ?(upstream = false) ?(clean = false) 1071 + let rec push ~proc ~fs ~config ?package ?(upstream = false) ?(clean = false) 1072 1072 ?(force = false) () = 1073 1073 let fs_t = fs_typed fs in 1074 1074 (* Ensure checkouts directory exists before computing status *) ··· 1184 1184 (* Return first error if any *) 1185 1185 match List.find_opt Result.is_error push_results with 1186 1186 | Some (Error (_, e)) -> Error e 1187 - | _ -> Ok () 1187 + | _ -> 1188 + (* Also push mono and opam-repo if they have remotes *) 1189 + push_workspace_repos ~proc ~fs:fs_t ~config ~force; 1190 + Ok () 1188 1191 end 1189 1192 else Ok () 1190 1193 end 1191 1194 end 1192 1195 1193 - (* Sync types for tracking sync operation results *) 1194 - type sync_phase = [ `Push_checkout | `Fetch | `Merge | `Subtree | `Push_remote ] 1195 - 1196 - type sync_failure = { 1197 - repo_name : string; 1198 - phase : sync_phase; 1199 - error : Git_cli.error; 1200 - } 1201 - 1202 - type sync_summary = { 1203 - repos_synced : int; 1204 - repos_unchanged : int; 1205 - commits_pulled : int; 1206 - commits_pushed : int; 1207 - errors : sync_failure list; 1208 - } 1209 - 1210 - let pp_sync_phase ppf = function 1211 - | `Push_checkout -> Fmt.string ppf "push-checkout" 1212 - | `Fetch -> Fmt.string ppf "fetch" 1213 - | `Merge -> Fmt.string ppf "merge" 1214 - | `Subtree -> Fmt.string ppf "subtree" 1215 - | `Push_remote -> Fmt.string ppf "push-remote" 1216 - 1217 - let pp_sync_failure ppf f = 1218 - Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git_cli.pp_error 1219 - f.error 1220 - 1221 - let pp_sync_summary ppf s = 1222 - Fmt.pf ppf "Synced: %d, Unchanged: %d, Pulled: %d commits, Pushed: %d commits" 1223 - s.repos_synced s.repos_unchanged s.commits_pulled s.commits_pushed; 1224 - if s.errors <> [] then 1225 - Fmt.pf ppf "@.Errors (%d):@. @[<v>%a@]" (List.length s.errors) 1226 - Fmt.(list ~sep:cut pp_sync_failure) 1227 - s.errors 1228 - 1229 - (** Error categories for succinct error reporting *) 1230 - type error_category = 1231 - | Checkout_ahead (** Local checkout has commits ahead of monorepo *) 1232 - | Remote_ahead (** Remote/checkout has commits we don't have *) 1233 - | Dirty_workdir (** Working directory has unstaged changes *) 1234 - | Other of string (** Other errors *) 1235 - 1236 - (** Check if [sub] appears anywhere in [s] *) 1237 - let contains ~sub s = 1238 - let sub_len = String.length sub in 1239 - let s_len = String.length s in 1240 - if sub_len > s_len then false 1241 - else 1242 - let rec check i = 1243 - if i + sub_len > s_len then false 1244 - else if String.sub s i sub_len = sub then true 1245 - else check (i + 1) 1246 - in 1247 - check 0 1248 - 1249 - let categorize_error (f : sync_failure) : error_category = 1250 - match f.error with 1251 - | Git_cli.Command_failed (_, result) -> 1252 - let stderr = result.Git_cli.stderr in 1253 - if 1254 - contains ~sub:"non-fast-forward" stderr 1255 - || contains ~sub:"tip of your current branch is behind" stderr 1256 - then Checkout_ahead 1257 - else if 1258 - contains ~sub:"remote contains work" stderr 1259 - || contains ~sub:"fetch first" stderr 1260 - then Remote_ahead 1261 - else if contains ~sub:"unstaged changes" stderr then Dirty_workdir 1262 - else Other (Fmt.str "%a" Git_cli.pp_error f.error) 1263 - | _ -> Other (Fmt.str "%a" Git_cli.pp_error f.error) 1264 - 1265 - let group_errors_by_category (errors : sync_failure list) = 1266 - let checkout_ahead = ref [] in 1267 - let remote_ahead = ref [] in 1268 - let dirty = ref [] in 1269 - let other = ref [] in 1270 - List.iter 1271 - (fun e -> 1272 - match categorize_error e with 1273 - | Checkout_ahead -> checkout_ahead := e.repo_name :: !checkout_ahead 1274 - | Remote_ahead -> remote_ahead := e.repo_name :: !remote_ahead 1275 - | Dirty_workdir -> dirty := e.repo_name :: !dirty 1276 - | Other _ -> other := e :: !other) 1277 - errors; 1278 - ( List.rev !checkout_ahead, 1279 - List.rev !remote_ahead, 1280 - List.rev !dirty, 1281 - List.rev !other ) 1282 - 1283 - let pp_error_summary ppf (errors : sync_failure list) = 1284 - let checkout_ahead, remote_ahead, dirty, other = 1285 - group_errors_by_category errors 1286 - in 1287 - let pp_repo_list ppf repos = Fmt.(list ~sep:comma string) ppf repos in 1288 - if checkout_ahead <> [] then 1289 - Fmt.pf ppf "@. Checkout ahead (%d): %a@. Fix: run 'monopam pull' first" 1290 - (List.length checkout_ahead) 1291 - pp_repo_list checkout_ahead; 1292 - if remote_ahead <> [] then 1293 - Fmt.pf ppf "@. Remote ahead (%d): %a@. Fix: run 'monopam pull' first" 1294 - (List.length remote_ahead) pp_repo_list remote_ahead; 1295 - if dirty <> [] then 1296 - Fmt.pf ppf 1297 - "@. Dirty workdir (%d): %a@. Fix: commit or stash changes in checkout" 1298 - (List.length dirty) pp_repo_list dirty; 1299 - if other <> [] then begin 1300 - let other_repos = List.map (fun e -> e.repo_name) other in 1301 - Fmt.pf ppf "@. Other errors (%d): %a@. Run with -v for details" 1302 - (List.length other) pp_repo_list other_repos 1303 - end 1304 - 1305 - (* Sync helper functions to reduce repetitive patterns *) 1306 - 1307 - (** Partition a result list into errors and successes *) 1308 - let partition_results results = 1309 - List.partition_map (function Error e -> Left e | Ok r -> Right r) results 1310 - 1311 - (** Styled icons for sync status output *) 1312 - module Icon = struct 1313 - let success = Tty.Span.styled Tty.Style.(fg Tty.Color.green) "✓" 1314 - let failure = Tty.Span.styled Tty.Style.(fg Tty.Color.red) "✗" 1315 - let arrow = Tty.Span.styled Tty.Style.(fg Tty.Color.cyan) "→" 1316 - 1317 - let styled_count color n = 1318 - Tty.Span.styled Tty.Style.(fg color) (string_of_int n) 1319 - 1320 - let green_count n = styled_count Tty.Color.green n 1321 - let red_count n = styled_count Tty.Color.red n 1322 - let cyan_count n = styled_count Tty.Color.cyan n 1323 - end 1324 - 1325 - (** Check if a repo needs to be pushed to remote (has local commits ahead) *) 1326 - let repo_needs_remote_push ~fs ~config pkg = 1327 - let checkouts_root = Config.Paths.checkouts config in 1328 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1329 - if not (Git.Repository.is_repo ~fs checkout_dir) then false 1330 - else 1331 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1332 - let branch = 1333 - match Git.Repository.current_branch repo with 1334 - | Some b -> b 1335 - | None -> "main" 1336 - in 1337 - match Git.Repository.ahead_behind repo ~branch () with 1338 - | Some ab -> ab.ahead > 0 1339 - | None -> true (* Push if we can't determine *) 1340 - 1341 - (* Helper to ensure checkout exists, returning whether it was cloned *) 1342 - let ensure_checkout_safe ~proc ~fs ~config pkg = 1343 - let checkouts_root = Config.Paths.checkouts config in 1344 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1345 - let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in 1346 - let branch = branch ~config pkg in 1347 - let is_directory = 1348 - match Eio.Path.kind ~follow:true checkout_eio with 1349 - | `Directory -> true 1350 - | _ -> false 1351 - | exception Eio.Io _ -> false 1352 - in 1353 - let was_cloned = 1354 - not (is_directory && Git.Repository.is_repo ~fs checkout_dir) 1355 - in 1356 - (* Configure checkout to accept pushes to current branch *) 1357 - let configure_for_push path = 1358 - let repo = Git.Repository.open_repo ~fs path in 1359 - let config = 1360 - match Git.Repository.read_config repo with 1361 - | Some c -> c 1362 - | None -> Git.Config.empty 1363 - in 1364 - let section = Git.Config.section "receive" in 1365 - let config = 1366 - Git.Config.set config ~section ~key:"denycurrentbranch" 1367 - ~value:"updateInstead" 1368 - in 1369 - Git.Repository.write_config repo config 1370 - in 1371 - if was_cloned then begin 1372 - Log.info (fun m -> 1373 - m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp 1374 - (Package.dev_repo pkg) branch); 1375 - match 1376 - Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir 1377 - with 1378 - | Ok () -> 1379 - configure_for_push checkout_dir; 1380 - Ok (true, 0) 1381 - | Error e -> Error e 1382 - end 1383 - else begin 1384 - configure_for_push checkout_dir; 1385 - Ok (false, 0) 1386 - end 1387 - 1388 - (* Fetch a single checkout - safe for parallel execution *) 1389 - 1390 - (** Wrapper around Remote_cache that adds disk persistence via XDG cache *) 1391 - module Cached_remote_heads : sig 1392 - type t 1393 - 1394 - val create : xdg:Xdge.t -> now:(unit -> float) -> t 1395 - val get : t -> url:Uri.t -> branch:string -> string option 1396 - val set : t -> url:Uri.t -> branch:string -> hash:string -> unit 1397 - end = struct 1398 - type t = { cache : Remote_cache.t; cache_file : Eio.Fs.dir_ty Eio.Path.t } 1399 - 1400 - let filename = "remote-heads" 1401 - 1402 - let create ~xdg ~now = 1403 - let cache_file = Eio.Path.(Xdge.cache_dir xdg / filename) in 1404 - let content = try Eio.Path.load cache_file with Eio.Io _ -> "" in 1405 - let cache = Remote_cache.create_from_string ~now content in 1406 - { cache; cache_file } 1407 - 1408 - let get t = Remote_cache.get t.cache 1409 - 1410 - let set t ~url ~branch ~hash = 1411 - Remote_cache.set t.cache ~url ~branch ~hash; 1412 - let content = Remote_cache.to_string t.cache in 1413 - try Eio.Path.save ~create:(`Or_truncate 0o644) t.cache_file content 1414 - with Eio.Io _ -> () 1415 - end 1416 - 1417 - let fetch_checkout_safe ~sw ~env ~proc ~fs ~config ~cache ~get_session pkg = 1418 - let repo = Package.repo_name pkg in 1419 - let checkouts_root = Config.Paths.checkouts config in 1420 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1421 - let branch = branch ~config pkg in 1422 - let remote_url = Package.dev_repo pkg in 1423 - let local_head = 1424 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1425 - Git.Repository.read_ref repo (Fmt.str "refs/remotes/origin/%s" branch) 1426 - |> Option.map Git.Hash.to_hex 1427 - in 1428 - (* Check if we can skip fetch entirely *) 1429 - let remote_matches_local hash = 1430 - match local_head with Some h -> hash = h | None -> false 1431 - in 1432 - (* Step 1: Try cached remote HEAD - O(1) hashtbl lookup *) 1433 - match Cached_remote_heads.get cache ~url:remote_url ~branch with 1434 - | Some cached when remote_matches_local cached -> 1435 - Log.debug (fun m -> m "Skipping fetch for %s (cached)" repo); 1436 - Ok 0 1437 - | _ -> ( 1438 - (* Step 2: Query remote HEAD via HTTP (lazily creates session) *) 1439 - let remote = 1440 - time_phase (Fmt.str "ls-remote:%s" repo) (fun () -> 1441 - Git.Remote.get_remote_head ~session:(get_session ()) ~sw ~env 1442 - remote_url ~branch) 1443 - in 1444 - Option.iter 1445 - (fun h -> 1446 - Cached_remote_heads.set cache ~url:remote_url ~branch 1447 - ~hash:(Git.Hash.to_hex h)) 1448 - remote; 1449 - match remote with 1450 - | Some h when remote_matches_local (Git.Hash.to_hex h) -> 1451 - Log.debug (fun m -> m "Skipping fetch for %s (remote unchanged)" repo); 1452 - Ok 0 1453 - | _ -> 1454 - (* Step 3: Do full git fetch *) 1455 - let get_behind () = 1456 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1457 - match Git.Repository.ahead_behind repo ~branch () with 1458 - | Some ab -> ab.behind 1459 - | None -> 0 1460 - in 1461 - let behind_before = get_behind () in 1462 - Log.info (fun m -> m "Fetching %s (all remotes)" repo); 1463 - Git_cli.fetch_all ~proc ~fs checkout_dir 1464 - |> Result.map (fun () -> get_behind () - behind_before)) 1465 - 1466 - (* Merge checkout to latest - must be sequential *) 1467 - let merge_checkout_safe ~proc ~fs ~config pkg = 1468 - let checkouts_root = Config.Paths.checkouts config in 1469 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1470 - let branch = branch ~config pkg in 1471 - Log.info (fun m -> m "Merging %s to %s" (Package.repo_name pkg) branch); 1472 - Git_cli.merge_ff ~proc ~fs ~branch checkout_dir 1473 - 1474 - (* Push checkout to remote - safe for parallel execution *) 1475 - let push_remote_safe ~proc ~fs ~config pkg = 1476 - let checkouts_root = Config.Paths.checkouts config in 1477 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1478 - let branch = branch ~config pkg in 1479 - let push_url = url_to_push_url (Package.dev_repo pkg) in 1480 - Log.info (fun m -> m "Pushing %s to %s" (Package.repo_name pkg) push_url); 1481 - (* Set the push URL for origin *) 1482 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1483 - (match Git.Repository.set_push_url repo ~name:"origin" ~url:push_url with 1484 - | Ok () -> () 1485 - | Error (`Msg msg) -> Log.warn (fun m -> m "Failed to set push URL: %s" msg)); 1486 - Git_cli.push_remote ~proc ~fs ~branch checkout_dir 1487 - 1488 - (* Sanitize handle for use as git remote name *) 1489 - let sanitize_remote_name handle = 1490 - (* Replace @ and . with - for valid git remote names *) 1491 - String.map (function '@' | '.' -> '-' | c -> c) handle 1492 - 1493 - (* Ensure verse remotes for a single repo - fully native git *) 1494 - let ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg = 1495 - let checkouts_root = Config.Paths.checkouts config in 1496 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1497 - let repo_name = Package.repo_name pkg in 1498 - 1499 - (* Only process if checkout exists - use native git *) 1500 - if not (Git.Repository.is_repo ~fs checkout_dir) then () 1501 - else begin 1502 - (* Get all verse members who have this repo *) 1503 - let members_with_repo = 1504 - Hashtbl.find_opt verse_subtrees repo_name |> Option.value ~default:[] 1505 - in 1506 - 1507 - (* Get current remotes - use native git *) 1508 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1509 - let current_remotes = Git.Repository.list_remotes repo in 1510 - let verse_remotes = 1511 - List.filter 1512 - (fun r -> String.starts_with ~prefix:"verse-" r) 1513 - current_remotes 1514 - in 1515 - 1516 - (* Build set of expected verse remotes with their URLs *) 1517 - let expected_remotes = 1518 - List.filter_map 1519 - (fun (handle, verse_mono_path) -> 1520 - let remote_name = "verse-" ^ sanitize_remote_name handle in 1521 - let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in 1522 - if Sys.file_exists (Fpath.to_string verse_src) then 1523 - Some (remote_name, Fpath.to_string verse_src) 1524 - else None) 1525 - members_with_repo 1526 - in 1527 - let expected_names = List.map fst expected_remotes in 1528 - 1529 - (* Add/update remotes for verse members - native git *) 1530 - List.iter 1531 - (fun (remote_name, url) -> 1532 - match Git.Repository.ensure_remote repo ~name:remote_name ~url with 1533 - | Ok () -> 1534 - Log.debug (fun m -> 1535 - m "Ensured verse remote %s -> %s" remote_name url) 1536 - | Error (`Msg msg) -> 1537 - Log.warn (fun m -> 1538 - m "Failed to add verse remote %s: %s" remote_name msg)) 1539 - expected_remotes; 1540 - 1541 - (* Remove outdated verse remotes - native git *) 1542 - List.iter 1543 - (fun remote_name -> 1544 - if not (List.mem remote_name expected_names) then begin 1545 - Log.debug (fun m -> m "Removing outdated verse remote %s" remote_name); 1546 - match Git.Repository.remove_remote repo remote_name with 1547 - | Ok () -> () 1548 - | Error (`Msg msg) -> 1549 - Log.warn (fun m -> 1550 - m "Failed to remove verse remote %s: %s" remote_name msg) 1551 - end) 1552 - verse_remotes 1553 - end 1554 - 1555 - (* Sync verse remotes for all repos *) 1556 - let sync_verse_remotes ~fs ~config ~verse_config repos = 1557 - Log.app (fun m -> m " Updating verse remotes..."); 1558 - let verse_subtrees = Verse.verse_subtrees ~fs ~config:verse_config () in 1559 - List.iter 1560 - (fun pkg -> ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg) 1561 - repos 1562 - 1563 - (* Fetch from verse remotes for a repo - uses native git for list_remotes *) 1564 - let fetch_verse_remotes ~proc ~fs ~config pkg = 1565 - let checkouts_root = Config.Paths.checkouts config in 1566 - let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1567 - let remotes = 1568 - if Git.Repository.is_repo ~fs checkout_dir then 1569 - let repo = Git.Repository.open_repo ~fs checkout_dir in 1570 - Git.Repository.list_remotes repo 1571 - else [] 1196 + (* Push mono and opam-repo to their remotes if configured *) 1197 + and push_workspace_repos ~proc ~fs ~config ~force = 1198 + let push_repo name path = 1199 + if Git.Repository.is_repo ~fs path then begin 1200 + let repo = Git.Repository.open_repo ~fs path in 1201 + match Git.Repository.get_remote_url repo "origin" with 1202 + | None -> Log.debug (fun m -> m "%s has no origin remote, skipping" name) 1203 + | Some _ -> ( 1204 + match 1205 + Git_cli.push_remote ~proc ~fs:(fs :> _ Eio.Path.t) ~force path 1206 + with 1207 + | Ok () -> Log.app (fun m -> m " ✓ %s" name) 1208 + | Error (Git_cli.Command_failed (_, result)) 1209 + when String.starts_with ~prefix:"Everything up-to-date" 1210 + result.Git_cli.stderr -> 1211 + Log.app (fun m -> m " ✓ %s (already synced)" name) 1212 + | Error e -> Log.app (fun m -> m " ✗ %s: %a" name Git_cli.pp_error e) 1213 + ) 1214 + end 1572 1215 in 1573 - let verse_remotes = 1574 - List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes 1575 - in 1576 - List.iter 1577 - (fun remote -> 1578 - Log.debug (fun m -> m "Fetching from verse remote %s" remote); 1579 - match Git_cli.fetch ~proc ~fs ~remote checkout_dir with 1580 - | Ok () -> () 1581 - | Error e -> 1582 - Log.debug (fun m -> 1583 - m "Failed to fetch from %s: %a" remote Git_cli.pp_error e)) 1584 - verse_remotes 1585 - 1586 - (* Helper to read file contents, returning None if file doesn't exist *) 1587 - let read_file_opt path = try Some (Eio.Path.load path) with Eio.Io _ -> None 1588 - 1589 - (* Regenerate opam-repo entries from monorepo dune-project files. 1590 - This ensures URLs in opam-repo match the monorepo before sync. *) 1591 - let regenerate_opam_repo ~proc ~fs ~config ~commit () = 1592 - let monorepo = Config.Paths.monorepo config in 1593 - let sources_path = Fpath.(monorepo / "sources.toml") in 1594 - let sources = 1595 - match Sources_registry.load ~fs sources_path with 1596 - | Ok s -> s 1597 - | Error _ -> Sources_registry.empty 1598 - in 1599 - match Monorepo_pkg.discover ~fs ~config ~sources () with 1600 - | Error _ -> () (* Skip on error *) 1601 - | Ok pkgs -> 1602 - let opam_repo = Config.Paths.opam_repo config in 1603 - let updated = ref 0 in 1604 - List.iter 1605 - (fun pkg -> 1606 - let pkg_name = Monorepo_pkg.name pkg in 1607 - let pkg_dir = 1608 - Fpath.(opam_repo / "packages" / pkg_name / (pkg_name ^ ".dev")) 1609 - in 1610 - let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in 1611 - let dst_content = read_file_opt dst_path in 1612 - let opam_content = Monorepo_pkg.opam_content pkg in 1613 - if Some opam_content <> dst_content then begin 1614 - let pkg_dir_eio = Eio.Path.(fs / Fpath.to_string pkg_dir) in 1615 - (try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ()); 1616 - Eio.Path.save ~create:(`Or_truncate 0o644) dst_path opam_content; 1617 - incr updated 1618 - end) 1619 - pkgs; 1620 - if !updated > 0 then begin 1621 - Log.info (fun m -> 1622 - m "Regenerated %d opam-repo entries from monorepo" !updated); 1623 - if commit && Git.Repository.is_repo ~fs opam_repo then 1624 - let repo = Git.Repository.open_repo ~fs opam_repo in 1625 - match Git.Repository.add_all repo with 1626 - | Error (`Msg e) -> 1627 - Log.warn (fun m -> m "Failed to stage opam-repo: %s" e) 1628 - | Ok () -> ( 1629 - match 1630 - Git.Repository.commit repo 1631 - ~message:"Update opam files from monorepo" 1632 - with 1633 - | Error (`Msg msg) 1634 - when String.starts_with ~prefix:"nothing to commit" msg -> 1635 - () 1636 - | Error (`Msg e) -> 1637 - Log.warn (fun m -> m "Failed to commit opam-repo: %s" e) 1638 - | Ok _ -> Log.info (fun m -> m "Committed opam-repo changes")) 1639 - end 1640 - 1641 - (** Clone monorepo and opam-repo from verse registry if they don't exist 1642 - locally. This enables `monopam sync` to work in a fresh devcontainer. *) 1643 - let clone_from_verse_if_needed ~proc ~fs ~config () = 1644 - let monorepo = Config.Paths.monorepo config in 1216 + let mono = Config.Paths.monorepo config in 1645 1217 let opam_repo = Config.Paths.opam_repo config in 1646 - let monorepo_exists = Git.Repository.is_repo ~fs monorepo in 1647 - let opam_repo_exists = Git.Repository.is_repo ~fs opam_repo in 1648 - 1649 - (* If both exist, nothing to do *) 1650 - if monorepo_exists && opam_repo_exists then Ok () 1651 - else 1652 - (* Try to load verse config to get handle *) 1653 - match Verse_config.load ~fs () with 1654 - | Error _ -> 1655 - (* No verse config - can't clone from registry *) 1656 - Log.debug (fun m -> 1657 - m "No verse config found, will initialize fresh repos"); 1658 - Ok () 1659 - | Ok verse_config -> ( 1660 - let handle = Verse_config.handle verse_config in 1661 - Log.info (fun m -> m "Found verse config for handle: %s" handle); 1662 - (* Load registry to look up URLs *) 1663 - match 1664 - Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config () 1665 - with 1666 - | Error msg -> 1667 - Log.warn (fun m -> m "Could not load verse registry: %s" msg); 1668 - Ok () (* Continue without cloning - will init fresh *) 1669 - | Ok registry -> ( 1670 - match Verse_registry.member registry ~handle with 1671 - | None -> 1672 - Log.warn (fun m -> m "Handle %s not found in registry" handle); 1673 - Ok () 1674 - | Some member -> ( 1675 - (* Clone monorepo if needed *) 1676 - let result = 1677 - if monorepo_exists then Ok () 1678 - else begin 1679 - Log.app (fun m -> 1680 - m "Cloning monorepo from %s..." member.monorepo); 1681 - let url = Uri.of_string member.monorepo in 1682 - let branch = 1683 - Option.value ~default:"main" member.monorepo_branch 1684 - in 1685 - match Git_cli.clone ~proc ~fs ~url ~branch monorepo with 1686 - | Ok () -> 1687 - Log.app (fun m -> m "Monorepo cloned successfully"); 1688 - Ok () 1689 - | Error e -> 1690 - Log.err (fun m -> 1691 - m "Failed to clone monorepo: %a" Git_cli.pp_error e); 1692 - Error (Git_error e) 1693 - end 1694 - in 1695 - match result with 1696 - | Error e -> Error e 1697 - | Ok () -> 1698 - (* Clone opam-repo if needed *) 1699 - if opam_repo_exists then Ok () 1700 - else begin 1701 - Log.app (fun m -> 1702 - m "Cloning opam-repo from %s..." member.opamrepo); 1703 - let url = Uri.of_string member.opamrepo in 1704 - let branch = 1705 - Option.value ~default:"main" member.opamrepo_branch 1706 - in 1707 - match Git_cli.clone ~proc ~fs ~url ~branch opam_repo with 1708 - | Ok () -> 1709 - Log.app (fun m -> m "Opam-repo cloned successfully"); 1710 - Ok () 1711 - | Error e -> 1712 - Log.err (fun m -> 1713 - m "Failed to clone opam-repo: %a" Git_cli.pp_error 1714 - e); 1715 - Error (Git_error e) 1716 - end))) 1717 - 1718 - let sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?(remote = false) 1719 - ?(skip_push = false) ?(skip_pull = false) ?(skip_verse = false) 1720 - ?(show_progress = false) () = 1721 - (* Select progress module based on show_progress flag *) 1722 - let module P = 1723 - (val if show_progress then (module Sync_progress.Active : Sync_progress.S) 1724 - else (module Sync_progress.Disabled : Sync_progress.S)) 1725 - in 1726 - let _ = (module P : Sync_progress.S) in 1727 - let fs_t = fs_typed fs in 1728 - (* Create remote HEAD cache with O(1) lookup - loaded once, persisted on updates *) 1729 - let cache = 1730 - Cached_remote_heads.create ~xdg ~now:(fun () -> Eio.Time.now env#clock) 1731 - in 1732 - (* Domain-safe lazy HTTP session to avoid TLS cert loading if cache hits *) 1733 - let session_atom : Requests.t option Atomic.t = Atomic.make None in 1734 - let get_session () = 1735 - match Atomic.get session_atom with 1736 - | Some s -> s 1737 - | None -> 1738 - let s = Requests.create ~sw env in 1739 - (* CAS to avoid races - if another domain created one, use theirs *) 1740 - if Atomic.compare_and_set session_atom None (Some s) then s 1741 - else Option.get (Atomic.get session_atom) 1742 - in 1743 - 1744 - (* Step 0: Sync verse members if verse config exists and not skipping 1745 - Skip verse sync when syncing a specific package for faster operations *) 1746 - let should_skip_verse = skip_pull || skip_verse || Option.is_some package in 1747 - (if not should_skip_verse then 1748 - match Verse_config.load ~fs:fs_t () with 1749 - | Error _ -> () (* No verse config = skip *) 1750 - | Ok verse_config -> 1751 - Log.app (fun m -> m "Syncing verse members..."); 1752 - time_phase "verse-sync" (fun () -> 1753 - match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with 1754 - | Ok () -> () 1755 - | Error e -> 1756 - Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e))); 1757 - 1758 - (* Clone from verse registry if repos don't exist *) 1759 - match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with 1760 - | Error e -> Error e 1761 - | Ok () -> ( 1762 - (* Update the opam repo first - clone if needed 1763 - Skip when syncing a single package for faster operations *) 1764 - let opam_repo = Config.Paths.opam_repo config in 1765 - let skip_opam_repo = Option.is_some package in 1766 - if 1767 - (not skip_pull) && (not skip_opam_repo) 1768 - && Git.Repository.is_repo ~fs:fs_t opam_repo 1769 - then begin 1770 - Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo); 1771 - time_phase "opam-repo-fetch" (fun () -> 1772 - let result = 1773 - let ( let* ) = Result.bind in 1774 - let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in 1775 - Git_cli.merge_ff ~proc ~fs:fs_t opam_repo 1776 - in 1777 - match result with 1778 - | Ok () -> () 1779 - | Error e -> 1780 - Log.warn (fun m -> 1781 - m "Failed to update opam repo: %a" Git_cli.pp_error e)) 1782 - end; 1783 - (* Ensure directories exist *) 1784 - ensure_checkouts_dir ~fs:fs_t ~config; 1785 - match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with 1786 - | Error e -> Error e 1787 - | Ok () -> ( 1788 - (* Regenerate opam-repo from monorepo to ensure URLs are up to date *) 1789 - (* Skip when syncing a single package for faster operations *) 1790 - if Option.is_none package then 1791 - time_phase "regenerate-opam-repo" (fun () -> 1792 - regenerate_opam_repo ~proc 1793 - ~fs:(fs_t :> _ Eio.Path.t) 1794 - ~config ~commit:true ()); 1795 - match 1796 - time_phase "discover-packages" (fun () -> 1797 - discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config ()) 1798 - with 1799 - | Error e -> Error e 1800 - | Ok all_pkgs -> 1801 - let pkgs = 1802 - match package with 1803 - | None -> all_pkgs 1804 - | Some name -> 1805 - List.filter (fun p -> Package.name p = name) all_pkgs 1806 - in 1807 - if pkgs = [] && package <> None then 1808 - Error (Package_not_found (Option.get package)) 1809 - else begin 1810 - (* Step 1: Validate - check for dirty state in packages being synced *) 1811 - Log.info (fun m -> 1812 - m "Checking status of %d packages" (List.length pkgs)); 1813 - let statuses = 1814 - time_phase "compute-status" (fun () -> 1815 - Status.compute_all ~fs:fs_t ~config pkgs) 1816 - in 1817 - let dirty = 1818 - List.filter Status.has_local_changes statuses 1819 - |> List.map (fun s -> s.Status.package) 1820 - in 1821 - if dirty <> [] then Error (Dirty_state dirty) 1822 - else begin 1823 - let repos = unique_repos pkgs in 1824 - let total = List.length repos in 1825 - Log.app (fun m -> m "Syncing %d repositories..." total); 1826 - 1827 - (* Build status lookup for optimization *) 1828 - let status_by_name = 1829 - List.map 1830 - (fun s -> (Package.name s.Status.package, s)) 1831 - statuses 1832 - in 1833 - let sync_needs_push = function 1834 - | Status.Subtree_ahead _ | Status.Trees_differ -> true 1835 - | Status.In_sync | Status.Subtree_behind _ | Status.Unknown 1836 - -> 1837 - false 1838 - in 1839 - let needs_push pkg = 1840 - List.assoc_opt (Package.name pkg) status_by_name 1841 - |> Option.fold ~none:true ~some:(fun s -> 1842 - sync_needs_push s.Status.subtree_sync) 1843 - in 1844 - let sync_needs_pull = function 1845 - | Status.Subtree_behind _ | Status.Trees_differ -> true 1846 - | Status.In_sync | Status.Subtree_ahead _ | Status.Unknown 1847 - -> 1848 - false 1849 - in 1850 - let needs_pull pkg = 1851 - List.assoc_opt (Package.name pkg) status_by_name 1852 - |> Option.fold ~none:true ~some:(fun s -> 1853 - sync_needs_pull s.Status.subtree_sync) 1854 - in 1855 - 1856 - (* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *) 1857 - (* git subtree push is read-only on the monorepo, so safe to parallelize *) 1858 - (* OPTIMIZATION: skip packages already in sync *) 1859 - let push_results = 1860 - if skip_push then 1861 - List.map (fun pkg -> Ok (Package.repo_name pkg)) repos 1862 - else begin 1863 - let to_push, to_skip = List.partition needs_push repos in 1864 - if to_push = [] then begin 1865 - Log.app (fun m -> 1866 - m " %a All packages in sync with checkouts" 1867 - Tty.Span.pp Icon.success); 1868 - List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip 1869 - end 1870 - else begin 1871 - Log.app (fun m -> 1872 - m " %a Pushing %d packages to checkouts..." 1873 - Tty.Span.pp Icon.arrow (List.length to_push)); 1874 - if to_skip <> [] then 1875 - Log.app (fun m -> 1876 - m " Skipping %d already-synced packages" 1877 - (List.length to_skip)); 1878 - (* Local git subtree push - no parallelism limit needed *) 1879 - let push_progress = 1880 - P.create ~total:(List.length to_push) "Push" 1881 - in 1882 - let pushed = 1883 - Eio.Fiber.List.map 1884 - (fun pkg -> 1885 - let repo_name = Package.repo_name pkg in 1886 - Log.info (fun m -> 1887 - m "Push to checkout: %s" repo_name); 1888 - let result = 1889 - match 1890 - push_one ~proc ~fs ~config ~clean:false pkg 1891 - with 1892 - | Ok () -> Ok repo_name 1893 - | Error (Git_error e) -> 1894 - Error 1895 - { 1896 - repo_name; 1897 - phase = `Push_checkout; 1898 - error = e; 1899 - } 1900 - | Error _ -> Ok repo_name 1901 - in 1902 - P.tick push_progress repo_name; 1903 - result) 1904 - to_push 1905 - in 1906 - P.clear push_progress; 1907 - let skipped_ok = 1908 - List.map 1909 - (fun pkg -> Ok (Package.repo_name pkg)) 1910 - to_skip 1911 - in 1912 - pushed @ skipped_ok 1913 - end 1914 - end 1915 - in 1916 - let push_errors = 1917 - List.filter_map 1918 - (function Error e -> Some e | Ok _ -> None) 1919 - push_results 1920 - in 1921 - 1922 - (* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *) 1923 - let ( fetch_errors, 1924 - unchanged_count, 1925 - total_commits_pulled, 1926 - merge_errors, 1927 - subtree_errors, 1928 - successfully_fetched_repos ) = 1929 - if skip_pull then 1930 - ([], List.length repos, 0, ref [], ref [], repos) 1931 - else begin 1932 - (* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *) 1933 - Log.app (fun m -> 1934 - m " Fetching from remotes (parallel)..."); 1935 - let fetch_progress = 1936 - P.create ~total:(List.length repos) "Fetch" 1937 - in 1938 - let fetch_results = 1939 - time_phase "fetch-phase" (fun () -> 1940 - Eio.Fiber.List.map ~max_fibers:8 1941 - (fun pkg -> 1942 - let repo_name = Package.repo_name pkg in 1943 - (* First ensure checkout exists *) 1944 - let result = 1945 - match 1946 - time_phase 1947 - (Printf.sprintf "ensure-checkout:%s" 1948 - repo_name) (fun () -> 1949 - ensure_checkout_safe ~proc ~fs:fs_t 1950 - ~config pkg) 1951 - with 1952 - | Error e -> 1953 - Error 1954 - { repo_name; phase = `Fetch; error = e } 1955 - | Ok (was_cloned, _) -> ( 1956 - if was_cloned then Ok (repo_name, true, 0) 1957 - else 1958 - match 1959 - time_phase 1960 - (Printf.sprintf "fetch:%s" repo_name) 1961 - (fun () -> 1962 - fetch_checkout_safe ~sw ~env ~proc 1963 - ~fs:fs_t ~config ~cache 1964 - ~get_session pkg) 1965 - with 1966 - | Error e -> 1967 - Error 1968 - { 1969 - repo_name; 1970 - phase = `Fetch; 1971 - error = e; 1972 - } 1973 - | Ok commits -> 1974 - Ok (repo_name, false, commits)) 1975 - in 1976 - P.tick fetch_progress repo_name; 1977 - result) 1978 - repos) 1979 - in 1980 - P.clear fetch_progress; 1981 - let fetch_errs, fetch_successes = 1982 - partition_results fetch_results 1983 - in 1984 - let cloned = 1985 - List.filter (fun (_, c, _) -> c) fetch_successes 1986 - in 1987 - let updated = 1988 - List.filter 1989 - (fun (_, c, commits) -> (not c) && commits > 0) 1990 - fetch_successes 1991 - in 1992 - let unchanged = 1993 - List.length fetch_successes 1994 - - List.length cloned - List.length updated 1995 - in 1996 - let commits_pulled = 1997 - List.fold_left 1998 - (fun acc (_, _, c) -> acc + c) 1999 - 0 fetch_successes 2000 - in 2001 - Log.app (fun m -> 2002 - m " Pulled: %d cloned, %d updated, %d unchanged" 2003 - (List.length cloned) (List.length updated) unchanged); 2004 - 2005 - (* Filter repos to only those that were successfully fetched *) 2006 - let success_names = 2007 - List.map (fun (name, _, _) -> name) fetch_successes 2008 - in 2009 - let successfully_fetched = 2010 - List.filter 2011 - (fun pkg -> 2012 - List.mem (Package.repo_name pkg) success_names) 2013 - repos 2014 - in 2015 - 2016 - (* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *) 2017 - Log.app (fun m -> m " Merging checkouts..."); 2018 - let merge_errs = ref [] in 2019 - time_phase "merge-phase" (fun () -> 2020 - List.iter 2021 - (fun pkg -> 2022 - match 2023 - time_phase 2024 - (Printf.sprintf "merge:%s" 2025 - (Package.repo_name pkg)) 2026 - (fun () -> 2027 - merge_checkout_safe ~proc ~fs:fs_t ~config 2028 - pkg) 2029 - with 2030 - | Ok () -> () 2031 - | Error e -> 2032 - merge_errs := 2033 - { 2034 - repo_name = Package.repo_name pkg; 2035 - phase = `Merge; 2036 - error = e; 2037 - } 2038 - :: !merge_errs) 2039 - successfully_fetched); 2040 - 2041 - (* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *) 2042 - (* Check if monorepo has local modifications first *) 2043 - let monorepo = Config.Paths.monorepo config in 2044 - let monorepo_dirty = 2045 - let repo = Git.Repository.open_repo ~fs:fs_t monorepo in 2046 - Git.Repository.is_dirty repo 2047 - in 2048 - let subtree_errs = ref [] in 2049 - if monorepo_dirty then begin 2050 - Log.warn (fun m -> 2051 - m 2052 - "Monorepo has uncommitted changes, skipping \ 2053 - subtree pulls"); 2054 - Log.app (fun m -> 2055 - m 2056 - " Skipping subtree updates (local \ 2057 - modifications)...") 2058 - end 2059 - else begin 2060 - (* OPTIMIZATION: skip packages already in sync *) 2061 - (* But always pull repos that received commits from fetch *) 2062 - let repos_updated_by_fetch = 2063 - List.filter_map 2064 - (fun (name, was_cloned, commits) -> 2065 - if was_cloned || commits > 0 then Some name 2066 - else None) 2067 - fetch_successes 2068 - in 2069 - let needs_pull_after_fetch pkg = 2070 - needs_pull pkg 2071 - || List.mem (Package.repo_name pkg) 2072 - repos_updated_by_fetch 2073 - in 2074 - let to_pull, to_skip = 2075 - List.partition needs_pull_after_fetch 2076 - successfully_fetched 2077 - in 2078 - Log.app (fun m -> m " Updating subtrees..."); 2079 - if to_skip <> [] then 2080 - Log.app (fun m -> 2081 - m " Skipping %d already-synced subtrees" 2082 - (List.length to_skip)); 2083 - let pull_count = List.length to_pull in 2084 - let subtree_progress = 2085 - P.create ~total:pull_count "Subtree" 2086 - in 2087 - List.iteri 2088 - (fun i pkg -> 2089 - Log.info (fun m -> 2090 - m "[%d/%d] Subtree %s" (i + 1) pull_count 2091 - (Package.subtree_prefix pkg)); 2092 - (match pull_subtree ~proc ~fs ~config pkg with 2093 - | Ok _ -> () 2094 - | Error (Git_error e) -> 2095 - subtree_errs := 2096 - { 2097 - repo_name = Package.repo_name pkg; 2098 - phase = `Subtree; 2099 - error = e; 2100 - } 2101 - :: !subtree_errs 2102 - | Error _ -> ()); 2103 - P.tick subtree_progress (Package.subtree_prefix pkg)) 2104 - to_pull; 2105 - P.clear subtree_progress 2106 - end; 2107 - ( fetch_errs, 2108 - unchanged, 2109 - commits_pulled, 2110 - merge_errs, 2111 - subtree_errs, 2112 - successfully_fetched ) 2113 - end 2114 - in 2115 - 2116 - (* Step 5.5: Verse remotes - update and fetch from verse members *) 2117 - (* Skip when syncing a single package for faster operations *) 2118 - (* Only operate on successfully fetched repos to avoid missing directory errors *) 2119 - (if Option.is_some package then 2120 - Log.debug (fun m -> 2121 - m "Skipping verse remotes (single package sync)") 2122 - else 2123 - match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with 2124 - | Error _ -> () (* No verse config, skip verse remotes *) 2125 - | Ok verse_config -> 2126 - time_phase "sync-verse-remotes" (fun () -> 2127 - sync_verse_remotes ~fs:fs_t ~config ~verse_config 2128 - successfully_fetched_repos); 2129 - (* Fetch from verse remotes in parallel *) 2130 - Log.app (fun m -> m " Fetching from verse remotes..."); 2131 - time_phase "fetch-verse-remotes" (fun () -> 2132 - Eio.Fiber.List.iter ~max_fibers:8 2133 - (fun pkg -> 2134 - fetch_verse_remotes ~proc ~fs:fs_t ~config pkg) 2135 - successfully_fetched_repos)); 2136 - 2137 - (* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *) 2138 - (* Skip when syncing a single package for faster operations *) 2139 - if Option.is_some package then 2140 - Log.debug (fun m -> 2141 - m "Skipping finalize (single package sync)") 2142 - else begin 2143 - Log.app (fun m -> 2144 - m " Writing README.md, CLAUDE.md, and dune-project..."); 2145 - time_phase "write-readme" (fun () -> 2146 - write_readme ~proc ~fs:fs_t ~config all_pkgs); 2147 - time_phase "write-claude-md" (fun () -> 2148 - write_claude_md ~proc ~fs:fs_t ~config); 2149 - time_phase "write-dune-project" (fun () -> 2150 - write_dune_project ~proc ~fs:fs_t ~config all_pkgs) 2151 - end; 2152 - 2153 - (* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *) 2154 - (* Only push repos that were successfully fetched and need pushing *) 2155 - let remote_errors, remote_pushed, remote_skipped = 2156 - if remote then begin 2157 - (* Show spinner while checking which repos need pushing *) 2158 - let check_progress = 2159 - if show_progress then 2160 - Some 2161 - (Tty.Progress.create 2162 - ~total:(List.length successfully_fetched_repos) 2163 - "Checking upstream status") 2164 - else None 2165 - in 2166 - (* Check which repos actually need pushing (ahead > 0) *) 2167 - let check_needs_push pkg = 2168 - let repo_name = Package.repo_name pkg in 2169 - Option.iter 2170 - (fun p -> Tty.Progress.message p repo_name) 2171 - check_progress; 2172 - let needs_push = 2173 - repo_needs_remote_push ~fs:fs_t ~config pkg 2174 - in 2175 - Option.iter Tty.Progress.tick check_progress; 2176 - (pkg, needs_push) 2177 - in 2178 - let check_results = 2179 - List.map check_needs_push successfully_fetched_repos 2180 - in 2181 - Option.iter Tty.Progress.clear check_progress; 2182 - let to_push, to_skip = 2183 - List.partition_map 2184 - (fun (pkg, needs) -> 2185 - if needs then Left pkg else Right pkg) 2186 - check_results 2187 - in 2188 - (* Show per-repo status *) 2189 - if to_skip <> [] then begin 2190 - Log.app (fun m -> 2191 - m " %a %a repos already in sync with upstream" 2192 - Tty.Span.pp Icon.success Tty.Span.pp 2193 - (Icon.green_count (List.length to_skip))); 2194 - List.iter 2195 - (fun pkg -> 2196 - Log.app (fun m -> 2197 - m " %a %s" Tty.Span.pp Icon.success 2198 - (Package.repo_name pkg))) 2199 - to_skip 2200 - end; 2201 - if to_push = [] then ([], 0, List.length to_skip) 2202 - else begin 2203 - Log.app (fun m -> 2204 - m " %a Pushing %a repos to upstream..." Tty.Span.pp 2205 - Icon.arrow Tty.Span.pp 2206 - (Icon.cyan_count (List.length to_push))); 2207 - let push_progress = 2208 - P.create ~total:(List.length to_push) "Push remote" 2209 - in 2210 - (* Limit to 2 concurrent pushes to avoid overwhelming remotes *) 2211 - let push_results = 2212 - Eio.Fiber.List.map ~max_fibers:2 2213 - (fun pkg -> 2214 - let repo_name = Package.repo_name pkg in 2215 - let result = 2216 - match 2217 - push_remote_safe ~proc ~fs:fs_t ~config pkg 2218 - with 2219 - | Error e -> 2220 - Log.app (fun m -> 2221 - m " %a %s" Tty.Span.pp Icon.failure 2222 - repo_name); 2223 - Error 2224 - { 2225 - repo_name; 2226 - phase = `Push_remote; 2227 - error = e; 2228 - } 2229 - | Ok () -> 2230 - Log.app (fun m -> 2231 - m " %a %s" Tty.Span.pp Icon.success 2232 - repo_name); 2233 - Ok repo_name 2234 - in 2235 - P.tick push_progress repo_name; 2236 - result) 2237 - to_push 2238 - in 2239 - P.clear push_progress; 2240 - let errors, successes = 2241 - partition_results push_results 2242 - in 2243 - (* Also push opam-repo if it has a remote *) 2244 - let opam_repo = Config.Paths.opam_repo config in 2245 - if Git.Repository.is_repo ~fs:fs_t opam_repo then begin 2246 - match 2247 - Git_cli.push_remote ~proc 2248 - ~fs:(fs_t :> _ Eio.Path.t) 2249 - opam_repo 2250 - with 2251 - | Ok () -> 2252 - Log.app (fun m -> 2253 - m " %a opam-repo" Tty.Span.pp Icon.success) 2254 - | Error (Git_cli.Command_failed (_, result)) 2255 - when String.starts_with 2256 - ~prefix:"Everything up-to-date" 2257 - result.Git_cli.stderr -> 2258 - Log.app (fun m -> 2259 - m " %a opam-repo (already synced)" 2260 - Tty.Span.pp Icon.success) 2261 - | Error e -> 2262 - Log.app (fun m -> 2263 - m " %a opam-repo: %a" Tty.Span.pp 2264 - Icon.failure Git_cli.pp_error e) 2265 - end; 2266 - Log.app (fun m -> 2267 - m " %a Pushed %a repos to upstream" Tty.Span.pp 2268 - Icon.success Tty.Span.pp 2269 - (Icon.green_count (List.length successes))); 2270 - (errors, List.length successes, List.length to_skip) 2271 - end 2272 - end 2273 - else ([], 0, 0) 2274 - in 2275 - let _ = (remote_pushed, remote_skipped) in 2276 - 2277 - (* Collect all errors *) 2278 - let all_errors = 2279 - push_errors @ fetch_errors @ !merge_errors @ !subtree_errors 2280 - @ remote_errors 2281 - in 2282 - let summary = 2283 - { 2284 - repos_synced = List.length repos - List.length all_errors; 2285 - repos_unchanged = unchanged_count; 2286 - commits_pulled = total_commits_pulled; 2287 - commits_pushed = 0; 2288 - (* TODO: track this *) 2289 - errors = all_errors; 2290 - } 2291 - in 2292 - 2293 - (* Print summary *) 2294 - let status_icon = 2295 - if summary.errors = [] then Icon.success else Icon.failure 2296 - in 2297 - let error_count = 2298 - if summary.errors = [] then Icon.green_count 0 2299 - else Icon.red_count (List.length summary.errors) 2300 - in 2301 - Log.app (fun m -> 2302 - m "@.%a Summary: %a synced, %a errors" Tty.Span.pp 2303 - status_icon Tty.Span.pp 2304 - (Icon.green_count summary.repos_synced) 2305 - Tty.Span.pp error_count); 2306 - if summary.errors <> [] then begin 2307 - (* Succinct categorized summary (always shown) *) 2308 - Log.app (fun m -> m "%a" pp_error_summary summary.errors); 2309 - (* Detailed errors (only with -v) *) 2310 - List.iter 2311 - (fun e -> 2312 - Log.info (fun m -> 2313 - m " %a %a" Tty.Span.pp Icon.failure pp_sync_failure 2314 - e)) 2315 - summary.errors 2316 - end; 2317 - 2318 - Ok summary 2319 - end 2320 - end)) 1218 + push_repo "mono" mono; 1219 + push_repo "opam-repo" opam_repo 2321 1220 2322 1221 (* Thin wrappers to extracted modules *) 2323 1222 let pp_opam_sync_result = Opam_sync.pp

Configure Feed

Configure Feed