Add monopam sync command with parallel operations · anil.recoil.org/monopam@837529e

+59 -1

bin/main.ml

··· 212 212 Term.( 213 213 ret (const run $ package_arg $ upstream_arg $ logging_term)) 214 214 215 + (* Sync command *) 216 + 217 + let sync_cmd = 218 + let doc = "Synchronize monorepo with upstream repositories" in 219 + let man = 220 + [ 221 + `S Manpage.s_description; 222 + `P 223 + "Performs both push and pull operations in the correct order to fully \ 224 + synchronize the monorepo with upstream repositories."; 225 + `P "The sync command executes the following phases:"; 226 + `I ("1. Validate", "Check for dirty state (abort if dirty)"); 227 + `I ("2. Push", "Export monorepo changes to checkouts (sequential)"); 228 + `I ("3. Fetch", "Clone/fetch from remotes (parallel)"); 229 + `I ("4. Merge", "Fast-forward merge checkouts (sequential)"); 230 + `I ("5. Subtree", "Pull subtrees into monorepo (sequential)"); 231 + `I ("6. Finalize", "Write README.md and dune-project (sequential)"); 232 + `I ("7. Remote", "Push to upstream remotes if --remote (parallel)"); 233 + `P 234 + "The fetch and remote push phases run concurrently across repositories \ 235 + for improved performance on network-bound operations."; 236 + `P 237 + "If a specific package is given, only that package's repository is \ 238 + processed."; 239 + `P "The operation will fail if any checkout has uncommitted changes."; 240 + `S "WHY PUSH BEFORE PULL"; 241 + `P 242 + "Local monorepo changes must be exported to checkouts before fetching \ 243 + remote changes, otherwise local work could be lost during merge."; 244 + ] 245 + in 246 + let info = Cmd.info "sync" ~doc ~man in 247 + let remote_arg = 248 + let doc = 249 + "Also push each checkout to its upstream git remote after syncing." 250 + in 251 + Arg.(value & flag & info [ "remote" ] ~doc) 252 + in 253 + let run package remote () = 254 + Eio_main.run @@ fun env -> 255 + with_config env @@ fun config -> 256 + let fs = Eio.Stdenv.fs env in 257 + let proc = Eio.Stdenv.process_mgr env in 258 + match Monopam.sync ~proc ~fs ~config ?package ~remote () with 259 + | Ok summary -> 260 + if summary.errors = [] then 261 + `Ok () 262 + else begin 263 + Fmt.epr "Sync completed with %d errors.@." (List.length summary.errors); 264 + `Ok () 265 + end 266 + | Error e -> 267 + Fmt.epr "Error: %a@." Monopam.pp_error e; 268 + `Error (false, "sync failed") 269 + in 270 + Cmd.v info 271 + Term.(ret (const run $ package_arg $ remote_arg $ logging_term)) 272 + 215 273 (* Add command *) 216 274 217 275 let add_cmd = ··· 828 886 in 829 887 let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in 830 888 Cmd.group info 831 - [ status_cmd; pull_cmd; push_cmd; add_cmd; remove_cmd; changes_cmd; verse_cmd ] 889 + [ status_cmd; pull_cmd; push_cmd; sync_cmd; add_cmd; remove_cmd; changes_cmd; verse_cmd ] 832 890 833 891 let () = exit (Cmd.eval main_cmd)

+313 -11

lib/monopam.ml

··· 227 227 2. Build and test: `opam exec -- dune build` and `opam exec -- dune test` 228 228 3. Commit your changes to this monorepo with git 229 229 230 - ## Exporting Changes to Upstream 230 + ## Synchronizing with Upstream 231 231 232 - After committing changes here, they must be exported to the individual 233 - repositories before they can be pushed upstream: 232 + The recommended way to keep your monorepo in sync is: 233 + 234 + ``` 235 + monopam sync 236 + ``` 237 + 238 + This performs push and pull in the correct order: 239 + 1. Exports your monorepo changes to checkouts 240 + 2. Fetches latest from all remotes (in parallel) 241 + 3. Merges and updates subtrees 242 + 243 + To also push to upstream git remotes: 244 + 245 + ``` 246 + monopam sync --remote 247 + ``` 248 + 249 + ## Manual Push/Pull 250 + 251 + For finer control, you can use the individual commands: 252 + 253 + ### Exporting Changes to Upstream 234 254 235 255 ``` 236 256 monopam push ··· 245 265 git push origin main # push to upstream 246 266 ``` 247 267 248 - ## Pulling Updates from Upstream 249 - 250 - To fetch the latest changes from all upstream repositories: 268 + ### Pulling Updates from Upstream 251 269 252 270 ``` 253 271 monopam pull ··· 257 275 258 276 ## Important Notes 259 277 260 - - **Always commit before push**: `monopam push` only exports committed changes 278 + - **Always commit before sync/push**: These commands only export committed changes 261 279 - **Check status first**: Run `monopam status` to see which repos have changes 262 280 - **One repo per directory**: Each subdirectory maps to exactly one git remote 263 281 - **Shared repos**: Multiple opam packages may live in the same subdirectory ··· 265 283 266 284 ## Troubleshooting 267 285 268 - If `monopam push` fails with "dirty state", you have uncommitted changes. 269 - Commit or stash them first. 286 + If `monopam sync` or `monopam push` fails with "dirty state", you have 287 + uncommitted changes. Commit or stash them first. 270 288 271 - If merge conflicts occur during `monopam pull`, resolve them in this monorepo, 272 - commit, then the next pull will succeed. 289 + If merge conflicts occur during sync/pull, resolve them in this monorepo, 290 + commit, then the next sync will succeed. 273 291 |} 274 292 275 293 let gitignore_content = {|_build ··· 932 950 else Ok () 933 951 end 934 952 end 953 + 954 + (* Sync types for tracking sync operation results *) 955 + type sync_phase = [ `Push_checkout | `Fetch | `Merge | `Subtree | `Push_remote ] 956 + 957 + type sync_failure = { 958 + repo_name : string; 959 + phase : sync_phase; 960 + error : Git.error; 961 + } 962 + 963 + type sync_summary = { 964 + repos_synced : int; 965 + repos_unchanged : int; 966 + commits_pulled : int; 967 + commits_pushed : int; 968 + errors : sync_failure list; 969 + } 970 + 971 + let pp_sync_phase ppf = function 972 + | `Push_checkout -> Fmt.string ppf "push-checkout" 973 + | `Fetch -> Fmt.string ppf "fetch" 974 + | `Merge -> Fmt.string ppf "merge" 975 + | `Subtree -> Fmt.string ppf "subtree" 976 + | `Push_remote -> Fmt.string ppf "push-remote" 977 + 978 + let pp_sync_failure ppf f = 979 + Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git.pp_error f.error 980 + 981 + let pp_sync_summary ppf s = 982 + Fmt.pf ppf "Synced: %d, Unchanged: %d, Pulled: %d commits, Pushed: %d commits" 983 + s.repos_synced s.repos_unchanged s.commits_pulled s.commits_pushed; 984 + if s.errors <> [] then 985 + Fmt.pf ppf "@.Errors (%d):@. @[<v>%a@]" 986 + (List.length s.errors) 987 + Fmt.(list ~sep:cut pp_sync_failure) s.errors 988 + 989 + (* Helper to ensure checkout exists, returning whether it was cloned *) 990 + let ensure_checkout_safe ~proc ~fs ~config pkg = 991 + let checkouts_root = Config.Paths.checkouts config in 992 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 993 + let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in 994 + let branch = get_branch ~config pkg in 995 + let is_directory = 996 + match Eio.Path.kind ~follow:true checkout_eio with 997 + | `Directory -> true 998 + | _ -> false 999 + | exception Eio.Io _ -> false 1000 + in 1001 + let was_cloned = not (is_directory && Git.is_repo ~proc ~fs checkout_dir) in 1002 + if was_cloned then begin 1003 + Log.info (fun m -> 1004 + m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp 1005 + (Package.dev_repo pkg) branch); 1006 + match Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir with 1007 + | Ok () -> Ok (true, 0) 1008 + | Error e -> Error e 1009 + end 1010 + else Ok (false, 0) 1011 + 1012 + (* Fetch a single checkout - safe for parallel execution *) 1013 + let fetch_checkout_safe ~proc ~fs ~config pkg = 1014 + let checkouts_root = Config.Paths.checkouts config in 1015 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1016 + let branch = get_branch ~config pkg in 1017 + (* Get commits behind before fetching *) 1018 + let behind_before = 1019 + match Git.ahead_behind ~proc ~fs ~branch checkout_dir with 1020 + | Ok ab -> ab.behind 1021 + | Error _ -> 0 1022 + in 1023 + Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg)); 1024 + match Git.fetch ~proc ~fs checkout_dir with 1025 + | Error e -> Error e 1026 + | Ok () -> 1027 + (* Get commits behind after fetching *) 1028 + let behind_after = 1029 + match Git.ahead_behind ~proc ~fs ~branch checkout_dir with 1030 + | Ok ab -> ab.behind 1031 + | Error _ -> 0 1032 + in 1033 + Ok (behind_after - behind_before) 1034 + 1035 + (* Merge checkout to latest - must be sequential *) 1036 + let merge_checkout_safe ~proc ~fs ~config pkg = 1037 + let checkouts_root = Config.Paths.checkouts config in 1038 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1039 + let branch = get_branch ~config pkg in 1040 + Log.info (fun m -> m "Merging %s to %s" (Package.repo_name pkg) branch); 1041 + Git.merge_ff ~proc ~fs ~branch checkout_dir 1042 + 1043 + (* Push checkout to remote - safe for parallel execution *) 1044 + let push_remote_safe ~proc ~fs ~config pkg = 1045 + let checkouts_root = Config.Paths.checkouts config in 1046 + let checkout_dir = Package.checkout_dir ~checkouts_root pkg in 1047 + let branch = get_branch ~config pkg in 1048 + let push_url = url_to_push_url (Package.dev_repo pkg) in 1049 + Log.info (fun m -> m "Pushing %s to %s" (Package.repo_name pkg) push_url); 1050 + (* Set the push URL for origin *) 1051 + (match Git.set_push_url ~proc ~fs ~url:push_url checkout_dir with 1052 + | Ok () -> () 1053 + | Error e -> 1054 + Log.warn (fun m -> m "Failed to set push URL: %a" Git.pp_error e)); 1055 + Git.push_remote ~proc ~fs ~branch checkout_dir 1056 + 1057 + let sync ~proc ~fs ~config ?package ?(remote = false) () = 1058 + let fs_t = fs_typed fs in 1059 + (* Update the opam repo first - clone if needed *) 1060 + let opam_repo = Config.Paths.opam_repo config in 1061 + if Git.is_repo ~proc ~fs:fs_t opam_repo then begin 1062 + Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo); 1063 + let result = 1064 + let ( let* ) = Result.bind in 1065 + let* () = Git.fetch ~proc ~fs:fs_t opam_repo in 1066 + Git.merge_ff ~proc ~fs:fs_t opam_repo 1067 + in 1068 + match result with 1069 + | Ok () -> () 1070 + | Error e -> 1071 + Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e) 1072 + end; 1073 + (* Ensure directories exist *) 1074 + ensure_checkouts_dir ~fs:fs_t ~config; 1075 + match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with 1076 + | Error e -> Error e 1077 + | Ok () -> ( 1078 + match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with 1079 + | Error e -> Error e 1080 + | Ok all_pkgs -> 1081 + let pkgs = 1082 + match package with 1083 + | None -> all_pkgs 1084 + | Some name -> List.filter (fun p -> Package.name p = name) all_pkgs 1085 + in 1086 + if pkgs = [] && package <> None then 1087 + Error (Package_not_found (Option.get package)) 1088 + else begin 1089 + (* Step 1: Validate - check for dirty state *) 1090 + Log.info (fun m -> 1091 + m "Checking status of %d packages" (List.length pkgs)); 1092 + let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in 1093 + let dirty = 1094 + List.filter Status.has_local_changes statuses 1095 + |> List.map (fun s -> s.Status.package) 1096 + in 1097 + if dirty <> [] then Error (Dirty_state dirty) 1098 + else begin 1099 + let repos = unique_repos pkgs in 1100 + let total = List.length repos in 1101 + Log.app (fun m -> m "Syncing %d repositories..." total); 1102 + 1103 + (* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *) 1104 + (* git subtree push is read-only on the monorepo, so safe to parallelize *) 1105 + Log.app (fun m -> m " Pushing monorepo changes to checkouts (parallel)..."); 1106 + let push_results = Eio.Fiber.List.map (fun pkg -> 1107 + let repo_name = Package.repo_name pkg in 1108 + Log.info (fun m -> m "Push to checkout: %s" repo_name); 1109 + match push_one ~proc ~fs ~config pkg with 1110 + | Ok () -> Ok repo_name 1111 + | Error (Git_error e) -> 1112 + Error { repo_name; phase = `Push_checkout; error = e } 1113 + | Error _ -> Ok repo_name) 1114 + repos 1115 + in 1116 + let push_errors = 1117 + List.filter_map (function Error e -> Some e | Ok _ -> None) push_results 1118 + in 1119 + 1120 + (* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *) 1121 + Log.app (fun m -> m " Fetching from remotes (parallel)..."); 1122 + let fetch_results = Eio.Fiber.List.map (fun pkg -> 1123 + let repo_name = Package.repo_name pkg in 1124 + (* First ensure checkout exists *) 1125 + match ensure_checkout_safe ~proc ~fs:fs_t ~config pkg with 1126 + | Error e -> Error { repo_name; phase = `Fetch; error = e } 1127 + | Ok (was_cloned, _) -> 1128 + if was_cloned then Ok (repo_name, true, 0) 1129 + else 1130 + match fetch_checkout_safe ~proc ~fs:fs_t ~config pkg with 1131 + | Error e -> Error { repo_name; phase = `Fetch; error = e } 1132 + | Ok commits -> Ok (repo_name, false, commits)) 1133 + repos 1134 + in 1135 + let fetch_errors, fetch_successes = 1136 + List.partition_map (function 1137 + | Error e -> Left e 1138 + | Ok r -> Right r) 1139 + fetch_results 1140 + in 1141 + let cloned = List.filter (fun (_, c, _) -> c) fetch_successes in 1142 + let updated = List.filter (fun (_, c, commits) -> not c && commits > 0) fetch_successes in 1143 + let unchanged_count = List.length fetch_successes - List.length cloned - List.length updated in 1144 + let total_commits_pulled = List.fold_left (fun acc (_, _, c) -> acc + c) 0 fetch_successes in 1145 + Log.app (fun m -> m " Pulled: %d cloned, %d updated, %d unchanged" 1146 + (List.length cloned) (List.length updated) unchanged_count); 1147 + 1148 + (* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *) 1149 + Log.app (fun m -> m " Merging checkouts..."); 1150 + let merge_errors = ref [] in 1151 + List.iter (fun pkg -> 1152 + match merge_checkout_safe ~proc ~fs:fs_t ~config pkg with 1153 + | Ok () -> () 1154 + | Error e -> 1155 + merge_errors := { repo_name = Package.repo_name pkg; 1156 + phase = `Merge; error = e } :: !merge_errors) 1157 + repos; 1158 + 1159 + (* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *) 1160 + (* Check if monorepo has local modifications first *) 1161 + let monorepo = Config.Paths.monorepo config in 1162 + let monorepo_dirty = Git.is_dirty ~proc ~fs:fs_t monorepo in 1163 + let subtree_errors = ref [] in 1164 + if monorepo_dirty then begin 1165 + Log.warn (fun m -> 1166 + m "Monorepo has uncommitted changes, skipping subtree pulls"); 1167 + Log.app (fun m -> m " Skipping subtree updates (local modifications)...") 1168 + end 1169 + else begin 1170 + Log.app (fun m -> m " Updating subtrees..."); 1171 + List.iteri (fun i pkg -> 1172 + Log.info (fun m -> 1173 + m "[%d/%d] Subtree %s" (i + 1) total 1174 + (Package.subtree_prefix pkg)); 1175 + match pull_subtree ~proc ~fs ~config pkg with 1176 + | Ok _ -> () 1177 + | Error (Git_error e) -> 1178 + subtree_errors := { repo_name = Package.repo_name pkg; 1179 + phase = `Subtree; error = e } :: !subtree_errors 1180 + | Error _ -> ()) 1181 + repos 1182 + end; 1183 + 1184 + (* Step 6: Finalize - write README.md and dune-project (SEQUENTIAL) *) 1185 + Log.app (fun m -> m " Writing README.md and dune-project..."); 1186 + write_readme ~proc ~fs:fs_t ~config all_pkgs; 1187 + write_dune_project ~proc ~fs:fs_t ~config all_pkgs; 1188 + 1189 + (* Step 7: Remote phase - push to upstream remotes if --remote (PARALLEL) *) 1190 + let remote_errors = 1191 + if remote then begin 1192 + Log.app (fun m -> m " Pushing to upstream remotes (parallel)..."); 1193 + let push_results = Eio.Fiber.List.map (fun pkg -> 1194 + let repo_name = Package.repo_name pkg in 1195 + match push_remote_safe ~proc ~fs:fs_t ~config pkg with 1196 + | Error e -> Error { repo_name; phase = `Push_remote; error = e } 1197 + | Ok () -> 1198 + Log.app (fun m -> m " Pushed %s" repo_name); 1199 + Ok repo_name) 1200 + repos 1201 + in 1202 + let errors, successes = 1203 + List.partition_map (function 1204 + | Error e -> Left e 1205 + | Ok r -> Right r) 1206 + push_results 1207 + in 1208 + Log.app (fun m -> m " Pushed: %d repos to upstream" (List.length successes)); 1209 + errors 1210 + end 1211 + else [] 1212 + in 1213 + 1214 + (* Collect all errors *) 1215 + let all_errors = 1216 + push_errors @ fetch_errors @ !merge_errors @ !subtree_errors @ remote_errors 1217 + in 1218 + let summary = { 1219 + repos_synced = List.length repos - List.length all_errors; 1220 + repos_unchanged = unchanged_count; 1221 + commits_pulled = total_commits_pulled; 1222 + commits_pushed = 0; (* TODO: track this *) 1223 + errors = all_errors; 1224 + } in 1225 + 1226 + (* Print summary *) 1227 + Log.app (fun m -> m "@.Summary: %d synced, %d errors" 1228 + summary.repos_synced (List.length summary.errors)); 1229 + if summary.errors <> [] then 1230 + List.iter (fun e -> 1231 + Log.warn (fun m -> m " %a" pp_sync_failure e)) 1232 + summary.errors; 1233 + 1234 + Ok summary 1235 + end 1236 + end) 935 1237 936 1238 let add ~proc ~fs ~config ~package () = 937 1239 let fs_t = fs_typed fs in

+58

lib/monopam.mli

··· 118 118 @param package Optional specific package to push 119 119 @param upstream If true, also push checkouts to their git remotes *) 120 120 121 + (** {2 Sync} *) 122 + 123 + (** Phase where a sync failure occurred. *) 124 + type sync_phase = [ `Push_checkout | `Fetch | `Merge | `Subtree | `Push_remote ] 125 + 126 + (** A failure during sync for a specific repository. *) 127 + type sync_failure = { 128 + repo_name : string; 129 + phase : sync_phase; 130 + error : Git.error; 131 + } 132 + 133 + (** Summary of a sync operation. *) 134 + type sync_summary = { 135 + repos_synced : int; 136 + repos_unchanged : int; 137 + commits_pulled : int; 138 + commits_pushed : int; 139 + errors : sync_failure list; 140 + } 141 + 142 + val pp_sync_phase : sync_phase Fmt.t 143 + (** [pp_sync_phase] formats a sync phase. *) 144 + 145 + val pp_sync_failure : sync_failure Fmt.t 146 + (** [pp_sync_failure] formats a sync failure. *) 147 + 148 + val pp_sync_summary : sync_summary Fmt.t 149 + (** [pp_sync_summary] formats a sync summary. *) 150 + 151 + val sync : 152 + proc:_ Eio.Process.mgr -> 153 + fs:Eio.Fs.dir_ty Eio.Path.t -> 154 + config:Config.t -> 155 + ?package:string -> 156 + ?remote:bool -> 157 + unit -> 158 + (sync_summary, error) result 159 + (** [sync ~proc ~fs ~config ?package ?remote ()] synchronizes the monorepo with 160 + upstream repositories. 161 + 162 + This performs both push and pull operations in the correct order: 163 + 1. Validate: check for dirty state (abort if dirty) 164 + 2. Push phase: export monorepo changes to checkouts (sequential) 165 + 3. Fetch phase: clone/fetch from remotes (parallel) 166 + 4. Merge phase: fast-forward merge checkouts (sequential) 167 + 5. Subtree phase: pull subtrees into monorepo (sequential) 168 + 6. Finalize: write README.md and dune-project (sequential) 169 + 7. Remote phase: push to upstream remotes if [~remote:true] (parallel) 170 + 171 + The fetch and remote push phases run concurrently for improved performance. 172 + 173 + @param proc Eio process manager 174 + @param fs Eio filesystem 175 + @param config Monopam configuration 176 + @param package Optional specific package to sync 177 + @param remote If true, also push checkouts to their upstream git remotes *) 178 + 121 179 (** {2 Package Management} *) 122 180 123 181 val add :

Configure Feed

Configure Feed