forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
WIP: all current changes
+1237
-783
+2
-1
bin/dune
+2
-1
bin/dune
+64
-53
bin/main.ml
+64
-53
bin/main.ml
···
87
87
let doc = "Show all repos including those not in your workspace." in
88
88
Arg.(value & flag & info [ "all"; "a" ] ~doc)
89
89
in
90
-
let run show_all () =
90
+
let forks_arg =
91
+
let doc = "Include fork analysis from verse members (slower)." in
92
+
Arg.(value & flag & info [ "forks"; "f" ] ~doc)
93
+
in
94
+
(* Helper: abbreviate handle to first part before dot, max 4 chars *)
95
+
let abbrev_handle h =
96
+
match String.split_on_char '.' h with
97
+
| first :: _ ->
98
+
if String.length first <= 4 then first else String.sub first 0 3
99
+
| [] -> h
100
+
in
101
+
(* Helper: load sources.toml *)
102
+
let load_sources ~fs ~config =
103
+
let sources_path =
104
+
Fpath.(Monopam.Config.Paths.monorepo config / "sources.toml")
105
+
in
106
+
match
107
+
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
108
+
with
109
+
| Ok s -> Some s
110
+
| Error _ -> None
111
+
in
112
+
(* Helper: print unregistered opam files if any *)
113
+
let print_unregistered ~fs ~config pkgs =
114
+
let unregistered = Monopam.find_unregistered_opam_files ~fs ~config pkgs in
115
+
if unregistered <> [] then begin
116
+
let handle_abbrev =
117
+
match Monopam.Verse_config.load ~fs () with
118
+
| Ok vc -> abbrev_handle (Monopam.Verse_config.handle vc)
119
+
| Error _ -> "local"
120
+
in
121
+
Fmt.pr "%a %a\n"
122
+
Fmt.(styled `Bold string)
123
+
"Unregistered:"
124
+
Fmt.(styled `Faint int)
125
+
(List.length unregistered);
126
+
List.iter
127
+
(fun (_r, p) ->
128
+
Fmt.pr " %-22s %a\n" p
129
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
130
+
handle_abbrev)
131
+
unregistered
132
+
end
133
+
in
134
+
(* Helper: run fork analysis if requested *)
135
+
let print_forks ~proc ~fs ~config ~show_all =
136
+
match Monopam.Verse_config.load ~fs () with
137
+
| Error _ -> ()
138
+
| Ok verse_config ->
139
+
let forks =
140
+
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config
141
+
()
142
+
in
143
+
if forks.repos <> [] then
144
+
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks
145
+
in
146
+
let run show_all show_forks () =
91
147
Eio_main.run @@ fun env ->
92
148
with_config env @@ fun config ->
93
149
let fs = Eio.Stdenv.fs env in
94
150
let proc = Eio.Stdenv.process_mgr env in
95
151
match Monopam.status ~proc ~fs ~config () with
96
152
| Ok statuses ->
97
-
(* Load sources.toml for origin indicators *)
98
-
let sources =
99
-
let mono_path = Monopam.Config.Paths.monorepo config in
100
-
let sources_path = Fpath.(mono_path / "sources.toml") in
101
-
match
102
-
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
103
-
with
104
-
| Ok s -> Some s
105
-
| Error _ -> None
106
-
in
153
+
let sources = load_sources ~fs ~config in
107
154
Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses;
108
-
(* Check for unregistered opam files *)
109
155
(match Monopam.discover_packages ~fs ~config () with
110
-
| Ok pkgs ->
111
-
let unregistered =
112
-
Monopam.find_unregistered_opam_files ~fs ~config pkgs
113
-
in
114
-
if unregistered <> [] then begin
115
-
(* Get local handle abbreviation *)
116
-
let handle_abbrev =
117
-
match Monopam.Verse_config.load ~fs () with
118
-
| Ok vc -> (
119
-
let h = Monopam.Verse_config.handle vc in
120
-
match String.split_on_char '.' h with
121
-
| first :: _ ->
122
-
if String.length first <= 4 then first
123
-
else String.sub first 0 3
124
-
| [] -> h)
125
-
| Error _ -> "local"
126
-
in
127
-
Fmt.pr "%a %a\n"
128
-
Fmt.(styled `Bold string)
129
-
"Unregistered:"
130
-
Fmt.(styled `Faint int)
131
-
(List.length unregistered);
132
-
List.iter
133
-
(fun (_r, p) ->
134
-
Fmt.pr " %-22s %a\n" p
135
-
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
136
-
handle_abbrev)
137
-
unregistered
138
-
end
156
+
| Ok pkgs -> print_unregistered ~fs ~config pkgs
139
157
| Error _ -> ());
140
-
(* Fork analysis *)
141
-
(match Monopam.Verse_config.load ~fs () with
142
-
| Error _ -> ()
143
-
| Ok verse_config ->
144
-
let forks =
145
-
Monopam.Forks.compute ~proc ~fs ~verse_config
146
-
~monopam_config:config ()
147
-
in
148
-
if forks.repos <> [] then
149
-
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks);
158
+
if show_forks then print_forks ~proc ~fs ~config ~show_all;
150
159
`Ok ()
151
160
| Error e ->
152
161
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
153
162
`Error (false, "status failed")
154
163
in
155
-
Cmd.v info Term.(ret (const run $ all_arg $ logging_term))
164
+
Cmd.v info Term.(ret (const run $ all_arg $ forks_arg $ logging_term))
156
165
157
166
(* Sync command *)
158
167
···
2122
2131
site_cmd;
2123
2132
]
2124
2133
2125
-
let () = exit (Cmd.eval main_cmd)
2134
+
let () =
2135
+
Memtrace.trace_if_requested ~context:"monopam" ();
2136
+
exit (Cmd.eval main_cmd)
+1
-1
lib/doctor.ml
+1
-1
lib/doctor.ml
+157
-147
lib/fork_join.ml
+157
-147
lib/fork_join.ml
···
612
612
let src_path = Fpath.(checkouts / name) in
613
613
614
614
(* Gather discovery information *)
615
-
let subtree_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in
615
+
let subtree_exists =
616
+
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
617
+
in
616
618
let src_exists = is_directory ~fs src_path in
617
619
let local_is_repo =
618
620
if is_local then begin
···
754
756
let src_path = Fpath.(checkouts / name) in
755
757
756
758
(* Gather discovery information *)
757
-
let subtree_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in
759
+
let subtree_exists =
760
+
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
761
+
in
758
762
let src_exists = is_directory ~fs src_path in
759
763
let src_is_repo =
760
764
if src_exists then Git_cli.is_repo ~proc ~fs src_path else false
···
827
831
| Git_clone { url; dest; branch } ->
828
832
Git_cli.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
829
833
|> Result.map_error (fun e -> Git_error e)
830
-
| Git_subtree_split { repo; prefix } ->
834
+
| Git_subtree_split { repo; prefix } -> (
831
835
let repo_path = Fpath.to_string repo in
832
836
let git_repo = Git.Repository.open_repo ~fs repo_path in
833
-
(match Git.Repository.read_ref git_repo "HEAD" with
837
+
match Git.Repository.read_ref git_repo "HEAD" with
834
838
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
835
839
| Some head -> (
836
840
match Git.Subtree.split git_repo ~prefix ~head () with
837
-
| Ok None ->
838
-
Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
841
+
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
839
842
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
840
843
| Ok (Some split_hash) ->
841
844
state.split_commit <- Some (Git.Hash.to_hex split_hash);
842
845
Ok ()))
843
-
| Git_subtree_add { repo; prefix; url; branch } ->
846
+
| Git_subtree_add { repo; prefix; url; branch } -> (
844
847
(* Fetch the branch first to get the commit *)
845
-
(match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
848
+
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
846
849
| Error e -> Error (Git_error e)
847
-
| Ok hash_hex ->
850
+
| Ok hash_hex -> (
848
851
let repo_path = Fpath.to_string repo in
849
852
let git_repo = Git.Repository.open_repo ~fs repo_path in
850
853
let commit = Git.Hash.of_hex hash_hex in
851
854
let user =
852
855
Git.User.make ~name:"monopam" ~email:"monopam@localhost"
853
-
~date:(Int64.of_float (Unix.time ())) ()
856
+
~date:(Int64.of_float (Unix.time ()))
857
+
()
854
858
in
855
859
let message =
856
860
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix
857
861
(Uri.to_string url) prefix
858
862
in
859
-
(match
860
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
861
-
~committer:user ~message ()
862
-
with
863
+
match
864
+
Git.Subtree.add git_repo ~prefix ~commit ~author:user
865
+
~committer:user ~message ()
866
+
with
863
867
| Ok _ -> Ok ()
864
868
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))))
865
869
| Git_add_remote { repo; name; url } ->
···
997
1001
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
998
1002
| Some head -> (
999
1003
match Git.Subtree.split git_repo ~prefix ~head () with
1000
-
| Ok None ->
1001
-
Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
1004
+
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
1002
1005
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1003
-
| Ok (Some split_hash) ->
1006
+
| Ok (Some split_hash) -> (
1004
1007
let split_commit = Git.Hash.to_hex split_hash in
1005
-
(
1006
-
(* Ensure src/ exists *)
1007
-
ensure_dir ~fs checkouts;
1008
-
(* Initialize new git repo at src/<name>/ *)
1009
-
match Git_cli.init ~proc ~fs src_path with
1010
-
| Error e -> Error (Git_error e)
1011
-
| Ok () -> (
1012
-
(* Add 'origin' remote pointing to monorepo path temporarily *)
1013
-
let mono_str = Fpath.to_string monorepo in
1014
-
match
1015
-
Git_cli.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path
1016
-
with
1008
+
(* Ensure src/ exists *)
1009
+
ensure_dir ~fs checkouts;
1010
+
(* Initialize new git repo at src/<name>/ *)
1011
+
match Git_cli.init ~proc ~fs src_path with
1017
1012
| Error e -> Error (Git_error e)
1018
1013
| Ok () -> (
1019
-
(* Push split commit to local repo *)
1020
-
let ref_spec = split_commit ^ ":refs/heads/main" in
1014
+
(* Add 'origin' remote pointing to monorepo path temporarily *)
1015
+
let mono_str = Fpath.to_string monorepo in
1021
1016
match
1022
-
Git_cli.push_ref ~proc ~fs ~repo:monorepo
1023
-
~target:(Fpath.to_string src_path) ~ref_spec ()
1017
+
Git_cli.add_remote ~proc ~fs ~name:"mono" ~url:mono_str
1018
+
src_path
1024
1019
with
1025
1020
| Error e -> Error (Git_error e)
1026
1021
| Ok () -> (
1027
-
(* Checkout main branch *)
1022
+
(* Push split commit to local repo *)
1023
+
let ref_spec = split_commit ^ ":refs/heads/main" in
1028
1024
match
1029
-
Git_cli.checkout ~proc ~fs ~branch:"main" src_path
1025
+
Git_cli.push_ref ~proc ~fs ~repo:monorepo
1026
+
~target:(Fpath.to_string src_path) ~ref_spec ()
1030
1027
with
1031
1028
| Error e -> Error (Git_error e)
1032
1029
| Ok () -> (
1033
-
(* Set push URL if provided *)
1034
-
let push_result =
1035
-
match push_url with
1036
-
| Some url -> (
1037
-
match
1038
-
Git_cli.add_remote ~proc ~fs ~name:"origin"
1039
-
~url src_path
1040
-
with
1041
-
| Error e -> Error (Git_error e)
1042
-
| Ok () -> Ok ())
1043
-
| None -> Ok ()
1044
-
in
1045
-
match push_result with
1046
-
| Error _ as e -> e
1047
-
| Ok () ->
1048
-
(* Only update sources.toml if there's a push URL *)
1049
-
(match push_url with
1050
-
| Some url -> (
1051
-
let sources_path =
1052
-
Fpath.(monorepo / "sources.toml")
1053
-
in
1054
-
let sources =
1030
+
(* Checkout main branch *)
1031
+
match
1032
+
Git_cli.checkout ~proc ~fs ~branch:"main" src_path
1033
+
with
1034
+
| Error e -> Error (Git_error e)
1035
+
| Ok () -> (
1036
+
(* Set push URL if provided *)
1037
+
let push_result =
1038
+
match push_url with
1039
+
| Some url -> (
1055
1040
match
1056
-
Sources_registry.load
1057
-
~fs:(fs :> _ Eio.Path.t)
1058
-
sources_path
1041
+
Git_cli.add_remote ~proc ~fs
1042
+
~name:"origin" ~url src_path
1059
1043
with
1060
-
| Ok s -> s
1061
-
| Error _ -> Sources_registry.empty
1062
-
in
1063
-
let entry =
1064
-
Sources_registry.
1065
-
{
1066
-
url = normalize_git_url url;
1067
-
upstream = None;
1068
-
branch = Some "main";
1069
-
reason = None;
1070
-
origin = Some Fork;
1071
-
}
1072
-
in
1073
-
let sources =
1074
-
Sources_registry.add sources ~subtree:name
1075
-
entry
1076
-
in
1077
-
match
1078
-
Sources_registry.save
1079
-
~fs:(fs :> _ Eio.Path.t)
1080
-
sources_path sources
1081
-
with
1082
-
| Ok () -> ()
1083
-
| Error msg ->
1084
-
Logs.warn (fun m ->
1085
-
m "Failed to update sources.toml: %s"
1086
-
msg))
1087
-
| None -> ());
1088
-
Ok
1089
-
{
1090
-
name;
1091
-
split_commit;
1092
-
src_path;
1093
-
push_url;
1094
-
packages_created = packages;
1095
-
}))))))
1044
+
| Error e -> Error (Git_error e)
1045
+
| Ok () -> Ok ())
1046
+
| None -> Ok ()
1047
+
in
1048
+
match push_result with
1049
+
| Error _ as e -> e
1050
+
| Ok () ->
1051
+
(* Only update sources.toml if there's a push URL *)
1052
+
(match push_url with
1053
+
| Some url -> (
1054
+
let sources_path =
1055
+
Fpath.(monorepo / "sources.toml")
1056
+
in
1057
+
let sources =
1058
+
match
1059
+
Sources_registry.load
1060
+
~fs:(fs :> _ Eio.Path.t)
1061
+
sources_path
1062
+
with
1063
+
| Ok s -> s
1064
+
| Error _ -> Sources_registry.empty
1065
+
in
1066
+
let entry =
1067
+
Sources_registry.
1068
+
{
1069
+
url = normalize_git_url url;
1070
+
upstream = None;
1071
+
branch = Some "main";
1072
+
reason = None;
1073
+
origin = Some Fork;
1074
+
}
1075
+
in
1076
+
let sources =
1077
+
Sources_registry.add sources
1078
+
~subtree:name entry
1079
+
in
1080
+
match
1081
+
Sources_registry.save
1082
+
~fs:(fs :> _ Eio.Path.t)
1083
+
sources_path sources
1084
+
with
1085
+
| Ok () -> ()
1086
+
| Error msg ->
1087
+
Logs.warn (fun m ->
1088
+
m
1089
+
"Failed to update \
1090
+
sources.toml: %s"
1091
+
msg))
1092
+
| None -> ());
1093
+
Ok
1094
+
{
1095
+
name;
1096
+
split_commit;
1097
+
src_path;
1098
+
push_url;
1099
+
packages_created = packages;
1100
+
}))))))
1096
1101
end
1097
1102
end
1098
1103
···
1125
1130
| Error e -> Error (Git_error e)
1126
1131
| Ok () -> (
1127
1132
(* Add subtree to monorepo - first fetch to get the commit *)
1128
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch () with
1133
+
match
1134
+
Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch ()
1135
+
with
1129
1136
| Error e -> Error (Git_error e)
1130
-
| Ok hash_hex ->
1137
+
| Ok hash_hex -> (
1131
1138
let repo_path = Fpath.to_string monorepo in
1132
1139
let git_repo = Git.Repository.open_repo ~fs repo_path in
1133
1140
let commit = Git.Hash.of_hex hash_hex in
1134
1141
let user =
1135
1142
Git.User.make ~name:"monopam" ~email:"monopam@localhost"
1136
-
~date:(Int64.of_float (Unix.time ())) ()
1143
+
~date:(Int64.of_float (Unix.time ()))
1144
+
()
1137
1145
in
1138
1146
let message =
1139
1147
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix url
1140
1148
prefix
1141
1149
in
1142
-
(match
1143
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
1144
-
~committer:user ~message ()
1145
-
with
1150
+
match
1151
+
Git.Subtree.add git_repo ~prefix ~commit ~author:user
1152
+
~committer:user ~message ()
1153
+
with
1146
1154
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1147
1155
| Ok _ ->
1148
-
(* Find .opam files in the new subtree *)
1149
-
let packages = find_opam_files ~fs subtree_path in
1150
-
(* Only update sources.toml if there's an upstream to track *)
1151
-
(match upstream with
1152
-
| Some _ -> (
1153
-
let sources_path = Fpath.(monorepo / "sources.toml") in
1154
-
let sources =
1155
-
match
1156
-
Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
1157
-
with
1158
-
| Ok s -> s
1159
-
| Error _ -> Sources_registry.empty
1160
-
in
1161
-
let entry =
1162
-
Sources_registry.
1163
-
{
1164
-
url = normalize_git_url url;
1165
-
upstream = Option.map normalize_git_url upstream;
1166
-
branch = Some branch;
1167
-
reason = None;
1168
-
origin = Some Join;
1169
-
}
1170
-
in
1171
-
let sources =
1172
-
Sources_registry.add sources ~subtree:name entry
1173
-
in
1174
-
match
1175
-
Sources_registry.save
1176
-
~fs:(fs :> _ Eio.Path.t)
1177
-
sources_path sources
1178
-
with
1179
-
| Ok () -> ()
1180
-
| Error msg ->
1181
-
Logs.warn (fun m ->
1182
-
m "Failed to update sources.toml: %s" msg))
1183
-
| None -> ());
1184
-
Ok
1185
-
{
1186
-
name;
1187
-
source_url = url;
1188
-
upstream_url = upstream;
1189
-
packages_added = packages;
1190
-
from_handle = None;
1191
-
}))
1156
+
(* Find .opam files in the new subtree *)
1157
+
let packages = find_opam_files ~fs subtree_path in
1158
+
(* Only update sources.toml if there's an upstream to track *)
1159
+
(match upstream with
1160
+
| Some _ -> (
1161
+
let sources_path = Fpath.(monorepo / "sources.toml") in
1162
+
let sources =
1163
+
match
1164
+
Sources_registry.load
1165
+
~fs:(fs :> _ Eio.Path.t)
1166
+
sources_path
1167
+
with
1168
+
| Ok s -> s
1169
+
| Error _ -> Sources_registry.empty
1170
+
in
1171
+
let entry =
1172
+
Sources_registry.
1173
+
{
1174
+
url = normalize_git_url url;
1175
+
upstream = Option.map normalize_git_url upstream;
1176
+
branch = Some branch;
1177
+
reason = None;
1178
+
origin = Some Join;
1179
+
}
1180
+
in
1181
+
let sources =
1182
+
Sources_registry.add sources ~subtree:name entry
1183
+
in
1184
+
match
1185
+
Sources_registry.save
1186
+
~fs:(fs :> _ Eio.Path.t)
1187
+
sources_path sources
1188
+
with
1189
+
| Ok () -> ()
1190
+
| Error msg ->
1191
+
Logs.warn (fun m ->
1192
+
m "Failed to update sources.toml: %s" msg))
1193
+
| None -> ());
1194
+
Ok
1195
+
{
1196
+
name;
1197
+
source_url = url;
1198
+
upstream_url = upstream;
1199
+
packages_added = packages;
1200
+
from_handle = None;
1201
+
}))
1192
1202
end
1193
1203
1194
1204
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
+99
-11
lib/forks.ml
+99
-11
lib/forks.ml
···
92
92
Hashtbl.replace fetch_cache key now;
93
93
save_cache ()
94
94
95
+
(* ==================== Scan Cache ==================== *)
96
+
97
+
(** In-memory cache of scanned opam repo results: opam_path -> (pkg_name, url)
98
+
list *)
99
+
let scan_cache : (string, (string * Uri.t) list) Hashtbl.t = Hashtbl.create 64
100
+
101
+
(** Scan cache file path *)
102
+
let scan_cache_file_path () =
103
+
Fpath.(to_string (Verse_config.cache_dir () / "scan-cache.json"))
104
+
105
+
(** Load scan cache from disk. Uses simple line-based format:
106
+
path<TAB>pkg1<TAB>url1<TAB>pkg2<TAB>url2... *)
107
+
let load_scan_cache () =
108
+
let path = scan_cache_file_path () in
109
+
if Sys.file_exists path then begin
110
+
try
111
+
let lines =
112
+
In_channel.with_open_text path (fun ic ->
113
+
let rec read acc =
114
+
match In_channel.input_line ic with
115
+
| Some line -> read (line :: acc)
116
+
| None -> List.rev acc
117
+
in
118
+
read [])
119
+
in
120
+
List.iter
121
+
(fun line ->
122
+
match String.split_on_char '\t' line with
123
+
| key :: rest when List.length rest >= 2 ->
124
+
(* rest is alternating pkg, url, pkg, url, ... *)
125
+
let rec parse_pairs acc = function
126
+
| pkg :: url :: tail ->
127
+
parse_pairs ((pkg, Uri.of_string url) :: acc) tail
128
+
| _ -> List.rev acc
129
+
in
130
+
let pairs = parse_pairs [] rest in
131
+
if pairs <> [] then Hashtbl.replace scan_cache key pairs
132
+
| _ -> ())
133
+
lines;
134
+
Log.debug (fun m ->
135
+
m "Loaded scan cache with %d entries" (Hashtbl.length scan_cache))
136
+
with _ -> ()
137
+
end
138
+
139
+
(** Save scan cache to disk. Uses simple line-based format. *)
140
+
let save_scan_cache () =
141
+
let path = scan_cache_file_path () in
142
+
try
143
+
let dir = Filename.dirname path in
144
+
if not (Sys.file_exists dir) then
145
+
ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir)));
146
+
Out_channel.with_open_text path (fun oc ->
147
+
Hashtbl.iter
148
+
(fun key pairs ->
149
+
output_string oc key;
150
+
List.iter
151
+
(fun (pkg, url) ->
152
+
output_char oc '\t';
153
+
output_string oc pkg;
154
+
output_char oc '\t';
155
+
output_string oc (Uri.to_string url))
156
+
pairs;
157
+
output_char oc '\n')
158
+
scan_cache)
159
+
with _ -> ()
160
+
161
+
(** Get cached scan results for a path, or None if not cached *)
162
+
let get_cached_scan path =
163
+
if Hashtbl.length scan_cache = 0 then load_scan_cache ();
164
+
Hashtbl.find_opt scan_cache (Fpath.to_string path)
165
+
166
+
(** Store scan results in cache *)
167
+
let cache_scan path results =
168
+
Hashtbl.replace scan_cache (Fpath.to_string path) results;
169
+
save_scan_cache ()
170
+
95
171
type repo_source = {
96
172
handle : string; (** Member handle or "me" *)
97
173
url : Uri.t; (** Normalized git URL *)
···
397
473
package_names
398
474
with _ -> []
399
475
400
-
(** Fetch a verse opam repo (with caching) *)
476
+
(** Fetch a verse opam repo (with caching). Returns true if actually fetched. *)
401
477
let fetch_verse_opam_repo ~proc ~fs ~refresh path =
402
478
let cache_key = "verse-opam/" ^ Fpath.to_string path in
403
479
if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin
404
480
Log.debug (fun m -> m "Skipping fetch for %a (cached)" Fpath.pp path);
405
-
()
481
+
false (* Did not fetch *)
406
482
end
407
483
else begin
408
484
let cwd = Eio.Path.(fs / Fpath.to_string path) in
···
417
493
cmd
418
494
in
419
495
match Eio.Process.await child with
420
-
| `Exited 0 -> record_fetch cache_key
421
-
| _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path)
496
+
| `Exited 0 ->
497
+
record_fetch cache_key;
498
+
true (* Actually fetched *)
499
+
| _ ->
500
+
Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path);
501
+
false
422
502
end
423
503
424
504
(** Scan all verse opam repos and build a map: repo_basename ->
···
430
510
let opam_dirs =
431
511
List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries
432
512
in
433
-
(* Fetch each opam repo first (respecting cache unless refresh) *)
434
513
Log.info (fun m -> m "Checking %d verse opam repos" (List.length opam_dirs));
435
-
List.iter
436
-
(fun opam_dir ->
437
-
let opam_path = Fpath.(verse_path / opam_dir) in
438
-
fetch_verse_opam_repo ~proc ~fs ~refresh opam_path)
439
-
opam_dirs;
440
514
(* Build map: repo_basename -> [(handle, url, [packages])] *)
441
515
let repo_map = Hashtbl.create 64 in
442
516
List.iter
···
444
518
let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in
445
519
(* strip -opam *)
446
520
let opam_path = Fpath.(verse_path / opam_dir) in
447
-
let pkg_urls = scan_verse_opam_repo ~fs opam_path in
521
+
(* Fetch and decide whether to rescan *)
522
+
let did_fetch = fetch_verse_opam_repo ~proc ~fs ~refresh opam_path in
523
+
(* Use cached scan results unless we fetched or have no cache *)
524
+
let pkg_urls =
525
+
match (did_fetch, get_cached_scan opam_path) with
526
+
| false, Some cached ->
527
+
Log.debug (fun m -> m "Using cached scan for %a" Fpath.pp opam_path);
528
+
cached
529
+
| _ ->
530
+
(* Need to scan: either we fetched or no cache exists *)
531
+
Log.debug (fun m -> m "Scanning %a" Fpath.pp opam_path);
532
+
let results = scan_verse_opam_repo ~fs opam_path in
533
+
cache_scan opam_path results;
534
+
results
535
+
in
448
536
(* Group by repo basename *)
449
537
let by_repo = Hashtbl.create 16 in
450
538
List.iter
+2
-2
lib/git_cli.ml
+2
-2
lib/git_cli.ml
···
675
675
[ "ls-remote"; "--heads"; remote; Printf.sprintf "refs/heads/%s" branch ]
676
676
with
677
677
| Error _ -> None
678
-
| Ok output ->
678
+
| Ok output -> (
679
679
if String.trim output = "" then None
680
680
else
681
681
(* Output format: "hash\trefs/heads/branch" *)
682
682
match String.split_on_char '\t' (String.trim output) with
683
683
| hash :: _ -> Some hash
684
-
| [] -> None
684
+
| [] -> None)
+4
-4
lib/git_cli.mli
+4
-4
lib/git_cli.mli
···
177
177
branch:string ->
178
178
unit ->
179
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.
180
+
(** [fetch_url ~proc ~fs ~repo ~url ~branch ()] fetches a branch from a URL and
181
+
returns the commit hash of FETCH_HEAD.
182
182
183
183
@param repo Path to the local repository
184
184
@param url Git remote URL to fetch from
···
200
200
201
201
val subtree_prefix_exists :
202
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. *)
203
+
(** [subtree_prefix_exists ~fs ~repo ~prefix] returns true if the subtree prefix
204
+
directory exists in the repository. *)
205
205
206
206
(** {1 Initialization} *)
207
207
+420
-455
lib/monopam.ml
+420
-455
lib/monopam.ml
···
16
16
module Sources_registry = Sources_registry
17
17
module Fork_join = Fork_join
18
18
module Site = Site
19
+
module Remote_cache = Remote_cache
19
20
20
21
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
21
22
···
145
146
let fs = fs_typed fs in
146
147
ensure_checkouts_dir ~fs ~config;
147
148
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
148
-
|> Result.map (Status.compute_all ~proc ~fs ~config)
149
+
|> Result.map (Status.compute_all ~fs ~config)
149
150
150
151
(** Find opam files in monorepo subtrees that aren't registered in the overlay.
151
152
Returns a list of (subtree_name, unregistered_package_name) pairs. *)
···
1047
1048
else begin
1048
1049
Log.info (fun m ->
1049
1050
m "Checking status of %d packages" (List.length pkgs));
1050
-
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1051
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
1051
1052
let dirty =
1052
1053
List.filter Status.has_local_changes statuses
1053
1054
|> List.map (fun s -> s.Status.package)
···
1238
1239
else begin
1239
1240
Log.info (fun m ->
1240
1241
m "Checking status of %d packages" (List.length pkgs));
1241
-
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1242
+
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
1242
1243
let dirty =
1243
1244
List.filter Status.has_local_changes statuses
1244
1245
|> List.map (fun s -> s.Status.package)
···
1392
1393
end
1393
1394
1394
1395
(* Fetch a single checkout - safe for parallel execution *)
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
1396
+
1397
+
(** Wrapper around Remote_cache that adds disk persistence via XDG cache *)
1398
+
module Cached_remote_heads : sig
1398
1399
type t
1399
1400
1400
1401
val create : xdg:Xdge.t -> now:(unit -> float) -> t
1401
1402
val get : t -> url:Uri.t -> branch:string -> string option
1402
1403
val set : t -> url:Uri.t -> branch:string -> hash:string -> unit
1403
1404
end = struct
1404
-
type entry = { hash : string; expires : float }
1405
-
type t = { tbl : (string, entry) Hashtbl.t; xdg : Xdge.t; now : unit -> float }
1405
+
type t = { cache : Remote_cache.t; cache_file : Eio.Fs.dir_ty Eio.Path.t }
1406
1406
1407
-
let ttl = 300.0 (* 5 minutes *)
1408
1407
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
1408
1445
1409
let create ~xdg ~now =
1446
-
let tbl = load_from_disk xdg in
1447
-
{ tbl; xdg; now }
1410
+
let cache_file = Eio.Path.(Xdge.cache_dir xdg / filename) in
1411
+
let content = try Eio.Path.load cache_file with _ -> "" in
1412
+
let cache = Remote_cache.create_from_string ~now content in
1413
+
{ cache; cache_file }
1448
1414
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
1415
+
let get t = Remote_cache.get t.cache
1462
1416
1463
1417
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
1418
+
Remote_cache.set t.cache ~url ~branch ~hash;
1419
+
let content = Remote_cache.to_string t.cache in
1420
+
try Eio.Path.save ~create:(`Or_truncate 0o644) t.cache_file content
1421
+
with _ -> ()
1468
1422
end
1469
1423
1470
1424
let fetch_checkout_safe ~sw ~env ~proc ~fs ~config ~cache ~get_session pkg =
···
1482
1436
match local_head with Some h -> hash = h | None -> false
1483
1437
in
1484
1438
(* Step 1: Try cached remote HEAD - O(1) hashtbl lookup *)
1485
-
match Remote_cache.get cache ~url:remote_url ~branch with
1439
+
match Cached_remote_heads.get cache ~url:remote_url ~branch with
1486
1440
| Some cached when remote_matches_local cached ->
1487
1441
Log.debug (fun m -> m "Skipping fetch for %s (cached)" repo);
1488
1442
Ok 0
···
1490
1444
(* Step 2: Query remote HEAD via HTTP (lazily creates session) *)
1491
1445
let remote =
1492
1446
time_phase (Fmt.str "ls-remote:%s" repo) (fun () ->
1493
-
Git.Remote.get_remote_head ~session:(get_session ()) ~sw ~env remote_url ~branch)
1447
+
Git.Remote.get_remote_head ~session:(get_session ()) ~sw ~env
1448
+
remote_url ~branch)
1494
1449
in
1495
1450
Option.iter
1496
1451
(fun h ->
1497
-
Remote_cache.set cache ~url:remote_url ~branch ~hash:(Git.Hash.to_hex h))
1452
+
Cached_remote_heads.set cache ~url:remote_url ~branch
1453
+
~hash:(Git.Hash.to_hex h))
1498
1454
remote;
1499
1455
match remote with
1500
1456
| Some h when remote_matches_local (Git.Hash.to_hex h) ->
···
1539
1495
(* Replace @ and . with - for valid git remote names *)
1540
1496
String.map (function '@' | '.' -> '-' | c -> c) handle
1541
1497
1542
-
(* Ensure verse remotes for a single repo *)
1543
-
let ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg =
1498
+
(* Ensure verse remotes for a single repo - fully native git *)
1499
+
let ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg =
1544
1500
let checkouts_root = Config.Paths.checkouts config in
1545
1501
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1502
+
let checkout_path = Fpath.to_string checkout_dir in
1546
1503
let repo_name = Package.repo_name pkg in
1547
1504
1548
-
(* Only process if checkout exists *)
1549
-
if not (Git_cli.is_repo ~proc ~fs checkout_dir) then ()
1505
+
(* Only process if checkout exists - use native git *)
1506
+
if not (Git.Repository.is_repo ~fs checkout_path) then ()
1550
1507
else begin
1551
1508
(* Get all verse members who have this repo *)
1552
1509
let members_with_repo =
1553
1510
Hashtbl.find_opt verse_subtrees repo_name |> Option.value ~default:[]
1554
1511
in
1555
1512
1556
-
(* Get current remotes *)
1557
-
let current_remotes = Git_cli.list_remotes ~proc ~fs checkout_dir in
1513
+
(* Get current remotes - use native git *)
1514
+
let repo = Git.Repository.open_repo ~fs checkout_path in
1515
+
let current_remotes = Git.Repository.list_remotes repo in
1558
1516
let verse_remotes =
1559
1517
List.filter
1560
1518
(fun r -> String.starts_with ~prefix:"verse-" r)
1561
1519
current_remotes
1562
1520
in
1563
1521
1564
-
(* Build set of expected verse remotes *)
1522
+
(* Build set of expected verse remotes with their URLs *)
1565
1523
let expected_remotes =
1566
-
List.map
1567
-
(fun (handle, _) -> "verse-" ^ sanitize_remote_name handle)
1524
+
List.filter_map
1525
+
(fun (handle, verse_mono_path) ->
1526
+
let remote_name = "verse-" ^ sanitize_remote_name handle in
1527
+
let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in
1528
+
if Sys.file_exists (Fpath.to_string verse_src) then
1529
+
Some (remote_name, Fpath.to_string verse_src)
1530
+
else None)
1568
1531
members_with_repo
1569
1532
in
1533
+
let expected_names = List.map fst expected_remotes in
1570
1534
1571
-
(* Add/update remotes for verse members *)
1535
+
(* Add/update remotes for verse members - native git *)
1572
1536
List.iter
1573
-
(fun (handle, verse_mono_path) ->
1574
-
let remote_name = "verse-" ^ sanitize_remote_name handle in
1575
-
(* Point to their src/ checkout for this repo *)
1576
-
let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in
1577
-
if Sys.file_exists (Fpath.to_string verse_src) then begin
1578
-
let url = Fpath.to_string verse_src in
1579
-
match
1580
-
Git_cli.ensure_remote ~proc ~fs ~name:remote_name ~url checkout_dir
1581
-
with
1582
-
| Ok () ->
1583
-
Log.debug (fun m ->
1584
-
m "Ensured verse remote %s -> %s" remote_name url)
1585
-
| Error e ->
1586
-
Log.warn (fun m ->
1587
-
m "Failed to add verse remote %s: %a" remote_name
1588
-
Git_cli.pp_error e)
1589
-
end)
1590
-
members_with_repo;
1537
+
(fun (remote_name, url) ->
1538
+
match Git.Repository.ensure_remote repo ~name:remote_name ~url with
1539
+
| Ok () ->
1540
+
Log.debug (fun m ->
1541
+
m "Ensured verse remote %s -> %s" remote_name url)
1542
+
| Error (`Msg msg) ->
1543
+
Log.warn (fun m ->
1544
+
m "Failed to add verse remote %s: %s" remote_name msg))
1545
+
expected_remotes;
1591
1546
1592
-
(* Remove outdated verse remotes *)
1547
+
(* Remove outdated verse remotes - native git *)
1593
1548
List.iter
1594
1549
(fun remote_name ->
1595
-
if not (List.mem remote_name expected_remotes) then begin
1550
+
if not (List.mem remote_name expected_names) then begin
1596
1551
Log.debug (fun m -> m "Removing outdated verse remote %s" remote_name);
1597
-
match
1598
-
Git_cli.remove_remote ~proc ~fs ~name:remote_name checkout_dir
1599
-
with
1552
+
match Git.Repository.remove_remote repo remote_name with
1600
1553
| Ok () -> ()
1601
-
| Error e ->
1554
+
| Error (`Msg msg) ->
1602
1555
Log.warn (fun m ->
1603
-
m "Failed to remove verse remote %s: %a" remote_name
1604
-
Git_cli.pp_error e)
1556
+
m "Failed to remove verse remote %s: %s" remote_name msg)
1605
1557
end)
1606
1558
verse_remotes
1607
1559
end
···
1613
1565
Verse.get_verse_subtrees ~proc ~fs ~config:verse_config ()
1614
1566
in
1615
1567
List.iter
1616
-
(fun pkg ->
1617
-
ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg)
1568
+
(fun pkg -> ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg)
1618
1569
repos
1619
1570
1620
-
(* Fetch from verse remotes for a repo *)
1571
+
(* Fetch from verse remotes for a repo - uses native git for list_remotes *)
1621
1572
let fetch_verse_remotes ~proc ~fs ~config pkg =
1622
1573
let checkouts_root = Config.Paths.checkouts config in
1623
1574
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1624
-
let remotes = Git_cli.list_remotes ~proc ~fs checkout_dir in
1575
+
let checkout_path = Fpath.to_string checkout_dir in
1576
+
let remotes =
1577
+
if Git.Repository.is_repo ~fs checkout_path then
1578
+
let repo = Git.Repository.open_repo ~fs checkout_path in
1579
+
Git.Repository.list_remotes repo
1580
+
else []
1581
+
in
1625
1582
let verse_remotes =
1626
1583
List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes
1627
1584
in
···
1753
1710
?(skip_push = false) ?(skip_pull = false) ?(skip_verse = false) () =
1754
1711
let fs_t = fs_typed fs in
1755
1712
(* 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
1713
+
let cache =
1714
+
Cached_remote_heads.create ~xdg ~now:(fun () -> Eio.Time.now env#clock)
1715
+
in
1716
+
(* Domain-safe lazy HTTP session to avoid TLS cert loading if cache hits *)
1717
+
let session_atom : Requests.t option Atomic.t = Atomic.make None in
1759
1718
let get_session () =
1760
-
match !session_ref with
1719
+
match Atomic.get session_atom with
1761
1720
| Some s -> s
1762
1721
| None ->
1763
1722
let s = Requests.create ~sw env in
1764
-
session_ref := Some s;
1765
-
s
1723
+
(* CAS to avoid races - if another domain created one, use theirs *)
1724
+
if Atomic.compare_and_set session_atom None (Some s) then s
1725
+
else Option.get (Atomic.get session_atom)
1766
1726
in
1767
1727
1768
1728
(* Step 0: Sync verse members if verse config exists and not skipping
···
1771
1731
(if not should_skip_verse then
1772
1732
match Verse_config.load ~fs:fs_t () with
1773
1733
| Error _ -> () (* No verse config = skip *)
1774
-
| Ok verse_config -> (
1734
+
| Ok verse_config ->
1775
1735
Log.app (fun m -> m "Syncing verse members...");
1776
1736
time_phase "verse-sync" (fun () ->
1777
1737
match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with
1778
1738
| Ok () -> ()
1779
1739
| Error e ->
1780
-
Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e))));
1740
+
Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e)));
1781
1741
1782
1742
(* Clone from verse registry if repos don't exist *)
1783
1743
match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with
···
1787
1747
Skip when syncing a single package for faster operations *)
1788
1748
let opam_repo = Config.Paths.opam_repo config in
1789
1749
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
1750
+
if
1751
+
(not skip_pull) && (not skip_opam_repo)
1752
+
&& Git_cli.is_repo ~proc ~fs:fs_t opam_repo
1753
+
then begin
1791
1754
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
1792
1755
time_phase "opam-repo-fetch" (fun () ->
1793
1756
let result =
···
1805
1768
ensure_checkouts_dir ~fs:fs_t ~config;
1806
1769
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
1807
1770
| Error e -> Error e
1808
-
| Ok () ->
1771
+
| Ok () -> (
1809
1772
(* Regenerate opam-repo from monorepo to ensure URLs are up to date *)
1810
1773
(* Skip when syncing a single package for faster operations *)
1811
-
(if Option.is_none package then
1774
+
if Option.is_none package then
1812
1775
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
1776
+
regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config ());
1777
+
match
1778
+
time_phase "discover-packages" (fun () ->
1779
+
discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config ())
1780
+
with
1818
1781
| Error e -> Error e
1819
1782
| Ok all_pkgs ->
1820
1783
let pkgs =
···
1831
1794
m "Checking status of %d packages" (List.length pkgs));
1832
1795
let statuses =
1833
1796
time_phase "compute-status" (fun () ->
1834
-
Status.compute_all ~proc ~fs:fs_t ~config pkgs)
1797
+
Status.compute_all ~fs:fs_t ~config pkgs)
1835
1798
in
1836
1799
let dirty =
1837
1800
List.filter Status.has_local_changes statuses
···
1839
1802
in
1840
1803
if dirty <> [] then Error (Dirty_state dirty)
1841
1804
else begin
1842
-
let repos = unique_repos pkgs in
1843
-
let total = List.length repos in
1844
-
Log.app (fun m -> m "Syncing %d repositories..." total);
1805
+
let repos = unique_repos pkgs in
1806
+
let total = List.length repos in
1807
+
Log.app (fun m -> m "Syncing %d repositories..." total);
1845
1808
1846
-
(* Build status lookup for optimization *)
1847
-
let status_by_name =
1848
-
List.map
1849
-
(fun s -> (Package.name s.Status.package, s))
1850
-
statuses
1851
-
in
1852
-
let sync_needs_push = function
1853
-
| Status.Subtree_ahead _ | Status.Trees_differ -> true
1854
-
| Status.In_sync | Status.Subtree_behind _
1855
-
| Status.Unknown ->
1856
-
false
1857
-
in
1858
-
let needs_push pkg =
1859
-
List.assoc_opt (Package.name pkg) status_by_name
1860
-
|> Option.fold ~none:true ~some:(fun s ->
1861
-
sync_needs_push s.Status.subtree_sync)
1862
-
in
1863
-
let sync_needs_pull = function
1864
-
| Status.Subtree_behind _ | Status.Trees_differ -> true
1865
-
| Status.In_sync | Status.Subtree_ahead _ | Status.Unknown
1866
-
->
1867
-
false
1868
-
in
1869
-
let needs_pull pkg =
1870
-
List.assoc_opt (Package.name pkg) status_by_name
1871
-
|> Option.fold ~none:true ~some:(fun s ->
1872
-
sync_needs_pull s.Status.subtree_sync)
1873
-
in
1809
+
(* Build status lookup for optimization *)
1810
+
let status_by_name =
1811
+
List.map
1812
+
(fun s -> (Package.name s.Status.package, s))
1813
+
statuses
1814
+
in
1815
+
let sync_needs_push = function
1816
+
| Status.Subtree_ahead _ | Status.Trees_differ -> true
1817
+
| Status.In_sync | Status.Subtree_behind _ | Status.Unknown
1818
+
->
1819
+
false
1820
+
in
1821
+
let needs_push pkg =
1822
+
List.assoc_opt (Package.name pkg) status_by_name
1823
+
|> Option.fold ~none:true ~some:(fun s ->
1824
+
sync_needs_push s.Status.subtree_sync)
1825
+
in
1826
+
let sync_needs_pull = function
1827
+
| Status.Subtree_behind _ | Status.Trees_differ -> true
1828
+
| Status.In_sync | Status.Subtree_ahead _ | Status.Unknown
1829
+
->
1830
+
false
1831
+
in
1832
+
let needs_pull pkg =
1833
+
List.assoc_opt (Package.name pkg) status_by_name
1834
+
|> Option.fold ~none:true ~some:(fun s ->
1835
+
sync_needs_pull s.Status.subtree_sync)
1836
+
in
1874
1837
1875
-
(* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *)
1876
-
(* git subtree push is read-only on the monorepo, so safe to parallelize *)
1877
-
(* OPTIMIZATION: skip packages already in sync *)
1878
-
let push_results =
1879
-
if skip_push then begin
1838
+
(* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *)
1839
+
(* git subtree push is read-only on the monorepo, so safe to parallelize *)
1840
+
(* OPTIMIZATION: skip packages already in sync *)
1841
+
let push_results =
1842
+
if skip_push then begin
1843
+
Log.app (fun m ->
1844
+
m " Skipping push to checkouts (--skip-push)");
1845
+
List.map (fun pkg -> Ok (Package.repo_name pkg)) repos
1846
+
end
1847
+
else begin
1848
+
let to_push, to_skip = List.partition needs_push repos in
1849
+
Log.app (fun m ->
1850
+
m
1851
+
" Pushing monorepo changes to checkouts \
1852
+
(parallel)...");
1853
+
if to_skip <> [] then
1880
1854
Log.app (fun m ->
1881
-
m " Skipping push to checkouts (--skip-push)");
1882
-
List.map (fun pkg -> Ok (Package.repo_name pkg)) repos
1883
-
end
1884
-
else begin
1885
-
let to_push, to_skip =
1886
-
List.partition needs_push repos
1887
-
in
1888
-
Log.app (fun m ->
1889
-
m
1890
-
" Pushing monorepo changes to checkouts \
1891
-
(parallel)...");
1892
-
if to_skip <> [] then
1893
-
Log.app (fun m ->
1894
-
m " Skipping %d already-synced packages"
1895
-
(List.length to_skip));
1896
-
(* Local git subtree push - no parallelism limit needed *)
1897
-
let pushed =
1898
-
Eio.Fiber.List.map
1855
+
m " Skipping %d already-synced packages"
1856
+
(List.length to_skip));
1857
+
(* Local git subtree push - no parallelism limit needed *)
1858
+
let pushed =
1859
+
Eio.Fiber.List.map
1860
+
(fun pkg ->
1861
+
let repo_name = Package.repo_name pkg in
1862
+
Log.info (fun m ->
1863
+
m "Push to checkout: %s" repo_name);
1864
+
match push_one ~proc ~fs ~config pkg with
1865
+
| Ok () -> Ok repo_name
1866
+
| Error (Git_error e) ->
1867
+
Error
1868
+
{
1869
+
repo_name;
1870
+
phase = `Push_checkout;
1871
+
error = e;
1872
+
}
1873
+
| Error _ -> Ok repo_name)
1874
+
to_push
1875
+
in
1876
+
let skipped_ok =
1877
+
List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip
1878
+
in
1879
+
pushed @ skipped_ok
1880
+
end
1881
+
in
1882
+
let push_errors =
1883
+
List.filter_map
1884
+
(function Error e -> Some e | Ok _ -> None)
1885
+
push_results
1886
+
in
1887
+
1888
+
(* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *)
1889
+
let ( fetch_errors,
1890
+
unchanged_count,
1891
+
total_commits_pulled,
1892
+
merge_errors,
1893
+
subtree_errors,
1894
+
successfully_fetched_repos ) =
1895
+
if skip_pull then begin
1896
+
Log.app (fun m ->
1897
+
m " Skipping pull from remotes (--skip-pull)");
1898
+
([], List.length repos, 0, ref [], ref [], repos)
1899
+
end
1900
+
else begin
1901
+
(* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *)
1902
+
Log.app (fun m ->
1903
+
m " Fetching from remotes (parallel)...");
1904
+
let fetch_results =
1905
+
time_phase "fetch-phase" (fun () ->
1906
+
Eio.Fiber.List.map ~max_fibers:8
1907
+
(fun pkg ->
1908
+
let repo_name = Package.repo_name pkg in
1909
+
(* First ensure checkout exists *)
1910
+
match
1911
+
time_phase
1912
+
(Printf.sprintf "ensure-checkout:%s"
1913
+
repo_name) (fun () ->
1914
+
ensure_checkout_safe ~proc ~fs:fs_t
1915
+
~config pkg)
1916
+
with
1917
+
| Error e ->
1918
+
Error
1919
+
{ repo_name; phase = `Fetch; error = e }
1920
+
| Ok (was_cloned, _) -> (
1921
+
if was_cloned then Ok (repo_name, true, 0)
1922
+
else
1923
+
match
1924
+
time_phase
1925
+
(Printf.sprintf "fetch:%s" repo_name)
1926
+
(fun () ->
1927
+
fetch_checkout_safe ~sw ~env ~proc
1928
+
~fs:fs_t ~config ~cache
1929
+
~get_session pkg)
1930
+
with
1931
+
| Error e ->
1932
+
Error
1933
+
{
1934
+
repo_name;
1935
+
phase = `Fetch;
1936
+
error = e;
1937
+
}
1938
+
| Ok commits ->
1939
+
Ok (repo_name, false, commits)))
1940
+
repos)
1941
+
in
1942
+
let fetch_errs, fetch_successes =
1943
+
List.partition_map
1944
+
(function Error e -> Left e | Ok r -> Right r)
1945
+
fetch_results
1946
+
in
1947
+
let cloned =
1948
+
List.filter (fun (_, c, _) -> c) fetch_successes
1949
+
in
1950
+
let updated =
1951
+
List.filter
1952
+
(fun (_, c, commits) -> (not c) && commits > 0)
1953
+
fetch_successes
1954
+
in
1955
+
let unchanged =
1956
+
List.length fetch_successes
1957
+
- List.length cloned - List.length updated
1958
+
in
1959
+
let commits_pulled =
1960
+
List.fold_left
1961
+
(fun acc (_, _, c) -> acc + c)
1962
+
0 fetch_successes
1963
+
in
1964
+
Log.app (fun m ->
1965
+
m " Pulled: %d cloned, %d updated, %d unchanged"
1966
+
(List.length cloned) (List.length updated) unchanged);
1967
+
1968
+
(* Filter repos to only those that were successfully fetched *)
1969
+
let success_names =
1970
+
List.map (fun (name, _, _) -> name) fetch_successes
1971
+
in
1972
+
let successfully_fetched =
1973
+
List.filter
1974
+
(fun pkg ->
1975
+
List.mem (Package.repo_name pkg) success_names)
1976
+
repos
1977
+
in
1978
+
1979
+
(* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *)
1980
+
Log.app (fun m -> m " Merging checkouts...");
1981
+
let merge_errs = ref [] in
1982
+
time_phase "merge-phase" (fun () ->
1983
+
List.iter
1899
1984
(fun pkg ->
1900
-
let repo_name = Package.repo_name pkg in
1901
-
Log.info (fun m ->
1902
-
m "Push to checkout: %s" repo_name);
1903
-
match push_one ~proc ~fs ~config pkg with
1904
-
| Ok () -> Ok repo_name
1905
-
| Error (Git_error e) ->
1906
-
Error
1985
+
match
1986
+
time_phase
1987
+
(Printf.sprintf "merge:%s"
1988
+
(Package.repo_name pkg))
1989
+
(fun () ->
1990
+
merge_checkout_safe ~proc ~fs:fs_t ~config
1991
+
pkg)
1992
+
with
1993
+
| Ok () -> ()
1994
+
| Error e ->
1995
+
merge_errs :=
1907
1996
{
1908
-
repo_name;
1909
-
phase = `Push_checkout;
1997
+
repo_name = Package.repo_name pkg;
1998
+
phase = `Merge;
1910
1999
error = e;
1911
2000
}
1912
-
| Error _ -> Ok repo_name)
1913
-
to_push
1914
-
in
1915
-
let skipped_ok =
1916
-
List.map
1917
-
(fun pkg -> Ok (Package.repo_name pkg))
1918
-
to_skip
1919
-
in
1920
-
pushed @ skipped_ok
1921
-
end
1922
-
in
1923
-
let push_errors =
1924
-
List.filter_map
1925
-
(function Error e -> Some e | Ok _ -> None)
1926
-
push_results
1927
-
in
2001
+
:: !merge_errs)
2002
+
successfully_fetched);
1928
2003
1929
-
(* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *)
1930
-
let ( fetch_errors,
1931
-
unchanged_count,
1932
-
total_commits_pulled,
1933
-
merge_errors,
1934
-
subtree_errors,
1935
-
successfully_fetched_repos ) =
1936
-
if skip_pull then begin
2004
+
(* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *)
2005
+
(* Check if monorepo has local modifications first *)
2006
+
let monorepo = Config.Paths.monorepo config in
2007
+
let monorepo_dirty =
2008
+
Git_cli.is_dirty ~proc ~fs:fs_t monorepo
2009
+
in
2010
+
let subtree_errs = ref [] in
2011
+
if monorepo_dirty then begin
2012
+
Log.warn (fun m ->
2013
+
m
2014
+
"Monorepo has uncommitted changes, skipping \
2015
+
subtree pulls");
1937
2016
Log.app (fun m ->
1938
-
m " Skipping pull from remotes (--skip-pull)");
1939
-
([], List.length repos, 0, ref [], ref [], repos)
2017
+
m
2018
+
" Skipping subtree updates (local \
2019
+
modifications)...")
1940
2020
end
1941
2021
else begin
1942
-
(* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *)
1943
-
Log.app (fun m ->
1944
-
m " Fetching from remotes (parallel)...");
1945
-
let fetch_results =
1946
-
time_phase "fetch-phase" (fun () ->
1947
-
Eio.Fiber.List.map ~max_fibers:4
1948
-
(fun pkg ->
1949
-
let repo_name = Package.repo_name pkg in
1950
-
(* First ensure checkout exists *)
1951
-
match
1952
-
time_phase (Printf.sprintf "ensure-checkout:%s" repo_name) (fun () ->
1953
-
ensure_checkout_safe ~proc ~fs:fs_t ~config pkg)
1954
-
with
1955
-
| Error e ->
1956
-
Error { repo_name; phase = `Fetch; error = e }
1957
-
| Ok (was_cloned, _) -> (
1958
-
if was_cloned then Ok (repo_name, true, 0)
1959
-
else
1960
-
match
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)
1964
-
with
1965
-
| Error e ->
1966
-
Error
1967
-
{
1968
-
repo_name;
1969
-
phase = `Fetch;
1970
-
error = e;
1971
-
}
1972
-
| Ok commits ->
1973
-
Ok (repo_name, false, commits)))
1974
-
repos)
1975
-
in
1976
-
let fetch_errs, fetch_successes =
1977
-
List.partition_map
1978
-
(function Error e -> Left e | Ok r -> Right r)
1979
-
fetch_results
1980
-
in
1981
-
let cloned =
1982
-
List.filter (fun (_, c, _) -> c) fetch_successes
1983
-
in
1984
-
let updated =
1985
-
List.filter
1986
-
(fun (_, c, commits) -> (not c) && commits > 0)
2022
+
(* OPTIMIZATION: skip packages already in sync *)
2023
+
(* But always pull repos that received commits from fetch *)
2024
+
let repos_updated_by_fetch =
2025
+
List.filter_map
2026
+
(fun (name, was_cloned, commits) ->
2027
+
if was_cloned || commits > 0 then Some name
2028
+
else None)
1987
2029
fetch_successes
1988
2030
in
1989
-
let unchanged =
1990
-
List.length fetch_successes
1991
-
- List.length cloned - List.length updated
2031
+
let needs_pull_after_fetch pkg =
2032
+
needs_pull pkg
2033
+
|| List.mem (Package.repo_name pkg)
2034
+
repos_updated_by_fetch
1992
2035
in
1993
-
let commits_pulled =
1994
-
List.fold_left
1995
-
(fun acc (_, _, c) -> acc + c)
1996
-
0 fetch_successes
2036
+
let to_pull, to_skip =
2037
+
List.partition needs_pull_after_fetch
2038
+
successfully_fetched
1997
2039
in
1998
-
Log.app (fun m ->
1999
-
m " Pulled: %d cloned, %d updated, %d unchanged"
2000
-
(List.length cloned) (List.length updated)
2001
-
unchanged);
2002
-
2003
-
(* Filter repos to only those that were successfully fetched *)
2004
-
let success_names =
2005
-
List.map (fun (name, _, _) -> name) fetch_successes
2006
-
in
2007
-
let successfully_fetched =
2008
-
List.filter
2009
-
(fun pkg ->
2010
-
List.mem (Package.repo_name pkg) success_names)
2011
-
repos
2012
-
in
2013
-
2014
-
(* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *)
2015
-
Log.app (fun m -> m " Merging checkouts...");
2016
-
let merge_errs = ref [] in
2017
-
time_phase "merge-phase" (fun () ->
2018
-
List.iter
2019
-
(fun pkg ->
2020
-
match
2021
-
time_phase (Printf.sprintf "merge:%s" (Package.repo_name pkg)) (fun () ->
2022
-
merge_checkout_safe ~proc ~fs:fs_t ~config pkg)
2023
-
with
2024
-
| Ok () -> ()
2025
-
| Error e ->
2026
-
merge_errs :=
2040
+
Log.app (fun m -> m " Updating subtrees...");
2041
+
if to_skip <> [] then
2042
+
Log.app (fun m ->
2043
+
m " Skipping %d already-synced subtrees"
2044
+
(List.length to_skip));
2045
+
let pull_count = List.length to_pull in
2046
+
List.iteri
2047
+
(fun i pkg ->
2048
+
Log.info (fun m ->
2049
+
m "[%d/%d] Subtree %s" (i + 1) pull_count
2050
+
(Package.subtree_prefix pkg));
2051
+
match pull_subtree ~proc ~fs ~config pkg with
2052
+
| Ok _ -> ()
2053
+
| Error (Git_error e) ->
2054
+
subtree_errs :=
2027
2055
{
2028
2056
repo_name = Package.repo_name pkg;
2029
-
phase = `Merge;
2057
+
phase = `Subtree;
2030
2058
error = e;
2031
2059
}
2032
-
:: !merge_errs)
2033
-
successfully_fetched);
2060
+
:: !subtree_errs
2061
+
| Error _ -> ())
2062
+
to_pull
2063
+
end;
2064
+
( fetch_errs,
2065
+
unchanged,
2066
+
commits_pulled,
2067
+
merge_errs,
2068
+
subtree_errs,
2069
+
successfully_fetched )
2070
+
end
2071
+
in
2034
2072
2035
-
(* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *)
2036
-
(* Check if monorepo has local modifications first *)
2037
-
let monorepo = Config.Paths.monorepo config in
2038
-
let monorepo_dirty =
2039
-
Git_cli.is_dirty ~proc ~fs:fs_t monorepo
2040
-
in
2041
-
let subtree_errs = ref [] in
2042
-
if monorepo_dirty then begin
2043
-
Log.warn (fun m ->
2044
-
m
2045
-
"Monorepo has uncommitted changes, skipping \
2046
-
subtree pulls");
2047
-
Log.app (fun m ->
2048
-
m
2049
-
" Skipping subtree updates (local \
2050
-
modifications)...")
2051
-
end
2052
-
else begin
2053
-
(* OPTIMIZATION: skip packages already in sync *)
2054
-
(* But always pull repos that received commits from fetch *)
2055
-
let repos_updated_by_fetch =
2056
-
List.filter_map
2057
-
(fun (name, was_cloned, commits) ->
2058
-
if was_cloned || commits > 0 then Some name
2059
-
else None)
2060
-
fetch_successes
2061
-
in
2062
-
let needs_pull_after_fetch pkg =
2063
-
needs_pull pkg
2064
-
|| List.mem (Package.repo_name pkg)
2065
-
repos_updated_by_fetch
2066
-
in
2067
-
let to_pull, to_skip =
2068
-
List.partition needs_pull_after_fetch
2069
-
successfully_fetched
2070
-
in
2071
-
Log.app (fun m -> m " Updating subtrees...");
2072
-
if to_skip <> [] then
2073
-
Log.app (fun m ->
2074
-
m " Skipping %d already-synced subtrees"
2075
-
(List.length to_skip));
2076
-
let pull_count = List.length to_pull in
2077
-
List.iteri
2078
-
(fun i pkg ->
2079
-
Log.info (fun m ->
2080
-
m "[%d/%d] Subtree %s" (i + 1) pull_count
2081
-
(Package.subtree_prefix pkg));
2082
-
match pull_subtree ~proc ~fs ~config pkg with
2083
-
| Ok _ -> ()
2084
-
| Error (Git_error e) ->
2085
-
subtree_errs :=
2086
-
{
2087
-
repo_name = Package.repo_name pkg;
2088
-
phase = `Subtree;
2089
-
error = e;
2090
-
}
2091
-
:: !subtree_errs
2092
-
| Error _ -> ())
2093
-
to_pull
2094
-
end;
2095
-
( fetch_errs,
2096
-
unchanged,
2097
-
commits_pulled,
2098
-
merge_errs,
2099
-
subtree_errs,
2100
-
successfully_fetched )
2101
-
end
2102
-
in
2073
+
(* Step 5.5: Verse remotes - update and fetch from verse members *)
2074
+
(* Skip when syncing a single package for faster operations *)
2075
+
(* Only operate on successfully fetched repos to avoid missing directory errors *)
2076
+
(if Option.is_some package then
2077
+
Log.debug (fun m ->
2078
+
m "Skipping verse remotes (single package sync)")
2079
+
else
2080
+
match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with
2081
+
| Error _ -> () (* No verse config, skip verse remotes *)
2082
+
| Ok verse_config ->
2083
+
time_phase "sync-verse-remotes" (fun () ->
2084
+
sync_verse_remotes ~proc ~fs:fs_t ~config
2085
+
~verse_config successfully_fetched_repos);
2086
+
(* Fetch from verse remotes in parallel *)
2087
+
Log.app (fun m -> m " Fetching from verse remotes...");
2088
+
time_phase "fetch-verse-remotes" (fun () ->
2089
+
Eio.Fiber.List.iter ~max_fibers:8
2090
+
(fun pkg ->
2091
+
fetch_verse_remotes ~proc ~fs:fs_t ~config pkg)
2092
+
successfully_fetched_repos));
2103
2093
2104
-
(* Step 5.5: Verse remotes - update and fetch from verse members *)
2105
-
(* Skip when syncing a single package for faster operations *)
2106
-
(* Only operate on successfully fetched repos to avoid missing directory errors *)
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
2111
-
| Error _ -> () (* No verse config, skip verse remotes *)
2112
-
| Ok verse_config ->
2113
-
time_phase "sync-verse-remotes" (fun () ->
2114
-
sync_verse_remotes ~proc ~fs:fs_t ~config ~verse_config
2115
-
successfully_fetched_repos);
2116
-
(* Fetch from verse remotes in parallel *)
2117
-
Log.app (fun m -> m " Fetching from verse remotes...");
2118
-
time_phase "fetch-verse-remotes" (fun () ->
2119
-
Eio.Fiber.List.iter ~max_fibers:4
2120
-
(fun pkg ->
2121
-
fetch_verse_remotes ~proc ~fs:fs_t ~config pkg)
2122
-
successfully_fetched_repos));
2123
-
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
2094
+
(* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *)
2095
+
(* Skip when syncing a single package for faster operations *)
2096
+
if Option.is_some package then
2097
+
Log.debug (fun m ->
2098
+
m "Skipping finalize (single package sync)")
2099
+
else begin
2129
2100
Log.app (fun m ->
2130
2101
m " Writing README.md, CLAUDE.md, and dune-project...");
2131
2102
time_phase "write-readme" (fun () ->
···
2134
2105
write_claude_md ~proc ~fs:fs_t ~config);
2135
2106
time_phase "write-dune-project" (fun () ->
2136
2107
write_dune_project ~proc ~fs:fs_t ~config all_pkgs)
2137
-
end);
2108
+
end;
2138
2109
2139
-
(* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *)
2140
-
(* Only push repos that were successfully fetched *)
2141
-
let remote_errors =
2142
-
if remote then begin
2143
-
Log.app (fun m -> m " Pushing to upstream remotes...");
2144
-
(* Limit to 2 concurrent pushes to avoid overwhelming remotes *)
2145
-
let push_results =
2146
-
Eio.Fiber.List.map ~max_fibers:2
2147
-
(fun pkg ->
2148
-
let repo_name = Package.repo_name pkg in
2149
-
match
2150
-
push_remote_safe ~proc ~fs:fs_t ~config pkg
2151
-
with
2152
-
| Error e ->
2153
-
Error
2154
-
{
2155
-
repo_name;
2156
-
phase = `Push_remote;
2157
-
error = e;
2158
-
}
2159
-
| Ok () ->
2160
-
Log.app (fun m -> m " Pushed %s" repo_name);
2161
-
Ok repo_name)
2162
-
successfully_fetched_repos
2163
-
in
2164
-
let errors, successes =
2165
-
List.partition_map
2166
-
(function Error e -> Left e | Ok r -> Right r)
2167
-
push_results
2168
-
in
2169
-
Log.app (fun m ->
2170
-
m " Pushed: %d repos to upstream"
2171
-
(List.length successes));
2172
-
errors
2173
-
end
2174
-
else []
2175
-
in
2110
+
(* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *)
2111
+
(* Only push repos that were successfully fetched *)
2112
+
let remote_errors =
2113
+
if remote then begin
2114
+
Log.app (fun m -> m " Pushing to upstream remotes...");
2115
+
(* Limit to 2 concurrent pushes to avoid overwhelming remotes *)
2116
+
let push_results =
2117
+
Eio.Fiber.List.map ~max_fibers:2
2118
+
(fun pkg ->
2119
+
let repo_name = Package.repo_name pkg in
2120
+
match
2121
+
push_remote_safe ~proc ~fs:fs_t ~config pkg
2122
+
with
2123
+
| Error e ->
2124
+
Error
2125
+
{ repo_name; phase = `Push_remote; error = e }
2126
+
| Ok () ->
2127
+
Log.app (fun m -> m " Pushed %s" repo_name);
2128
+
Ok repo_name)
2129
+
successfully_fetched_repos
2130
+
in
2131
+
let errors, successes =
2132
+
List.partition_map
2133
+
(function Error e -> Left e | Ok r -> Right r)
2134
+
push_results
2135
+
in
2136
+
Log.app (fun m ->
2137
+
m " Pushed: %d repos to upstream"
2138
+
(List.length successes));
2139
+
errors
2140
+
end
2141
+
else []
2142
+
in
2176
2143
2177
-
(* Collect all errors *)
2178
-
let all_errors =
2179
-
push_errors @ fetch_errors @ !merge_errors
2180
-
@ !subtree_errors @ remote_errors
2181
-
in
2182
-
let summary =
2183
-
{
2184
-
repos_synced =
2185
-
List.length repos - List.length all_errors;
2186
-
repos_unchanged = unchanged_count;
2187
-
commits_pulled = total_commits_pulled;
2188
-
commits_pushed = 0;
2189
-
(* TODO: track this *)
2190
-
errors = all_errors;
2191
-
}
2192
-
in
2144
+
(* Collect all errors *)
2145
+
let all_errors =
2146
+
push_errors @ fetch_errors @ !merge_errors @ !subtree_errors
2147
+
@ remote_errors
2148
+
in
2149
+
let summary =
2150
+
{
2151
+
repos_synced = List.length repos - List.length all_errors;
2152
+
repos_unchanged = unchanged_count;
2153
+
commits_pulled = total_commits_pulled;
2154
+
commits_pushed = 0;
2155
+
(* TODO: track this *)
2156
+
errors = all_errors;
2157
+
}
2158
+
in
2193
2159
2194
-
(* Print summary *)
2195
-
Log.app (fun m ->
2196
-
m "@.Summary: %d synced, %d errors" summary.repos_synced
2197
-
(List.length summary.errors));
2198
-
if summary.errors <> [] then
2199
-
List.iter
2200
-
(fun e ->
2201
-
Log.warn (fun m -> m " %a" pp_sync_failure e))
2202
-
summary.errors;
2160
+
(* Print summary *)
2161
+
Log.app (fun m ->
2162
+
m "@.Summary: %d synced, %d errors" summary.repos_synced
2163
+
(List.length summary.errors));
2164
+
if summary.errors <> [] then
2165
+
List.iter
2166
+
(fun e -> Log.warn (fun m -> m " %a" pp_sync_failure e))
2167
+
summary.errors;
2203
2168
2204
-
Ok summary
2205
-
end
2206
-
end))
2169
+
Ok summary
2170
+
end
2171
+
end))
2207
2172
2208
2173
(* Opam metadata sync: copy .opam files from monorepo subtrees to opam-repo *)
2209
2174
+8
-6
lib/monopam.mli
+8
-6
lib/monopam.mli
···
40
40
module Sources_registry = Sources_registry
41
41
module Fork_join = Fork_join
42
42
module Site = Site
43
+
module Remote_cache = Remote_cache
43
44
44
45
(** {1 High-Level Operations} *)
45
46
···
167
168
168
169
val sync :
169
170
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
-
; .. > ->
171
+
env:
172
+
< clock : _ Eio.Time.clock
173
+
; net : _ Eio.Net.t
174
+
; fs : Eio.Fs.dir_ty Eio.Path.t
175
+
; .. > ->
174
176
proc:_ Eio.Process.mgr ->
175
177
fs:Eio.Fs.dir_ty Eio.Path.t ->
176
178
config:Config.t ->
···
182
184
?skip_verse:bool ->
183
185
unit ->
184
186
(sync_summary, error) result
185
-
(** [sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?remote ?skip_push ?skip_pull ?skip_verse ()]
186
-
synchronizes the monorepo with upstream repositories.
187
+
(** [sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?remote ?skip_push ?skip_pull
188
+
?skip_verse ()] synchronizes the monorepo with upstream repositories.
187
189
188
190
This is the primary command for all sync operations. It performs both push
189
191
and pull operations in the correct order: 1. Validate: check for dirty state
+91
lib/remote_cache.ml
+91
lib/remote_cache.ml
···
1
+
(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
2
+
3
+
Permission to use, copy, modify, and distribute this software for any
4
+
purpose with or without fee is hereby granted, provided that the above
5
+
copyright notice and this permission notice appear in all copies.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
14
+
15
+
(** Remote HEAD cache with O(1) in-memory lookup and optional disk persistence.
16
+
17
+
Uses a Hashtbl for O(1) amortized lookup by key (url:branch). Entries expire
18
+
after a configurable TTL (default 5 minutes).
19
+
20
+
File format: one entry per line "url:branch hash timestamp" *)
21
+
22
+
let src = Logs.Src.create "monopam.remote_cache" ~doc:"Remote HEAD cache"
23
+
24
+
module Log = (val Logs.src_log src : Logs.LOG)
25
+
26
+
type entry = { hash : string; expires : float }
27
+
type t = { tbl : (string, entry) Hashtbl.t; ttl : float; now : unit -> float }
28
+
29
+
let default_ttl = 300.0 (* 5 minutes *)
30
+
let make_key url branch = Fmt.str "%s:%s" (Uri.to_string url) branch
31
+
32
+
let parse_line ~ttl line =
33
+
match String.split_on_char ' ' line with
34
+
| [ key; hash; ts ] ->
35
+
let ts = float_of_string ts in
36
+
Some (key, { hash; expires = ts +. ttl })
37
+
| _ -> None
38
+
39
+
let load_from_string ~ttl content =
40
+
let tbl = Hashtbl.create 32 in
41
+
String.split_on_char '\n' content
42
+
|> List.iter (fun line ->
43
+
match parse_line ~ttl line with
44
+
| Some (key, entry) -> Hashtbl.replace tbl key entry
45
+
| None -> ());
46
+
tbl
47
+
48
+
let to_string t =
49
+
let now = t.now () in
50
+
let lines =
51
+
Hashtbl.fold
52
+
(fun key entry acc ->
53
+
if entry.expires > now then
54
+
let ts = entry.expires -. t.ttl in
55
+
Fmt.str "%s %s %.0f" key entry.hash ts :: acc
56
+
else acc)
57
+
t.tbl []
58
+
in
59
+
String.concat "\n" lines ^ "\n"
60
+
61
+
let create ?(ttl = default_ttl) ~now () =
62
+
let tbl = Hashtbl.create 32 in
63
+
{ tbl; ttl; now }
64
+
65
+
let create_from_string ?(ttl = default_ttl) ~now content =
66
+
let tbl = load_from_string ~ttl content in
67
+
{ tbl; ttl; now }
68
+
69
+
let get t ~url ~branch =
70
+
let key = make_key url branch in
71
+
let now = t.now () in
72
+
match Hashtbl.find_opt t.tbl key with
73
+
| Some entry when entry.expires > now ->
74
+
Log.debug (fun m ->
75
+
m "Cache hit for %s (expires in %.0fs)" key (entry.expires -. now));
76
+
Some entry.hash
77
+
| Some entry ->
78
+
Log.debug (fun m ->
79
+
m "Cache expired for %s (%.0fs ago)" key (now -. entry.expires));
80
+
None
81
+
| None ->
82
+
Log.debug (fun m -> m "Cache miss for %s (not found)" key);
83
+
None
84
+
85
+
let set t ~url ~branch ~hash =
86
+
let key = make_key url branch in
87
+
let expires = t.now () +. t.ttl in
88
+
Hashtbl.replace t.tbl key { hash; expires }
89
+
90
+
let size t = Hashtbl.length t.tbl
91
+
let clear t = Hashtbl.clear t.tbl
+76
lib/remote_cache.mli
+76
lib/remote_cache.mli
···
1
+
(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
2
+
3
+
Permission to use, copy, modify, and distribute this software for any
4
+
purpose with or without fee is hereby granted, provided that the above
5
+
copyright notice and this permission notice appear in all copies.
6
+
7
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
14
+
15
+
(** Remote HEAD cache with O(1) in-memory lookup.
16
+
17
+
This module provides an in-memory cache for remote git HEAD refs with
18
+
time-based expiration. Uses a Hashtbl for O(1) amortized lookup.
19
+
20
+
{2 Example with mock time}
21
+
22
+
{[
23
+
let time = ref 0.0 in
24
+
let now () = !time in
25
+
let cache = Remote_cache.create ~ttl:60.0 ~now () in
26
+
27
+
(* Set a value *)
28
+
let url = Uri.of_string "https://github.com/ocaml/ocaml.git" in
29
+
Remote_cache.set cache ~url ~branch:"trunk" ~hash:"abc123";
30
+
31
+
(* Get it back immediately *)
32
+
assert (Remote_cache.get cache ~url ~branch:"trunk" = Some "abc123");
33
+
34
+
(* Advance time past TTL *)
35
+
time := 61.0;
36
+
assert (Remote_cache.get cache ~url ~branch:"trunk" = None)
37
+
]} *)
38
+
39
+
type t
40
+
(** The cache type. *)
41
+
42
+
val default_ttl : float
43
+
(** Default TTL in seconds (300.0 = 5 minutes). *)
44
+
45
+
val create : ?ttl:float -> now:(unit -> float) -> unit -> t
46
+
(** [create ~ttl ~now ()] creates a new empty cache.
47
+
48
+
@param ttl Time-to-live in seconds (default {!default_ttl})
49
+
@param now Function to get current time in seconds *)
50
+
51
+
val create_from_string : ?ttl:float -> now:(unit -> float) -> string -> t
52
+
(** [create_from_string ~ttl ~now content] creates a cache populated from
53
+
serialized content.
54
+
55
+
@param ttl Time-to-live in seconds (default {!default_ttl})
56
+
@param now Function to get current time in seconds
57
+
@param content Serialized cache content from {!to_string} *)
58
+
59
+
val get : t -> url:Uri.t -> branch:string -> string option
60
+
(** [get t ~url ~branch] returns the cached hash if present and not expired.
61
+
O(1) amortized time complexity. *)
62
+
63
+
val set : t -> url:Uri.t -> branch:string -> hash:string -> unit
64
+
(** [set t ~url ~branch ~hash] adds or updates a cache entry. O(1) amortized
65
+
time complexity. *)
66
+
67
+
val to_string : t -> string
68
+
(** [to_string t] serializes the cache to a string for disk persistence. Format:
69
+
one entry per line "url:branch hash timestamp". Expired entries are not
70
+
included. *)
71
+
72
+
val size : t -> int
73
+
(** [size t] returns the number of entries in the cache. *)
74
+
75
+
val clear : t -> unit
76
+
(** [clear t] removes all entries from the cache. *)
+77
-76
lib/status.ml
+77
-76
lib/status.ml
···
1
-
type checkout_status =
2
-
| Missing
3
-
| Not_a_repo
4
-
| Dirty
5
-
| Clean of Git_cli.ahead_behind
6
-
1
+
type ahead_behind = { ahead : int; behind : int }
2
+
type checkout_status = Missing | Not_a_repo | Dirty | Clean of ahead_behind
7
3
type subtree_status = Not_added | Present
8
4
9
5
(** Sync state between monorepo subtree and local checkout *)
···
27
23
let dir, _ = fs in
28
24
(dir, "")
29
25
30
-
let compute ~proc ~fs ~config pkg =
31
-
let checkouts_root = Config.Paths.checkouts config in
26
+
(** Check if a directory exists *)
27
+
let dir_exists fs path =
28
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
29
+
match Eio.Path.kind ~follow:true eio_path with
30
+
| `Directory -> true
31
+
| _ -> false
32
+
| exception Eio.Io _ -> false
33
+
34
+
let to_ahead_behind (ab : Git.Repository.ahead_behind) =
35
+
{ ahead = ab.ahead; behind = ab.behind }
36
+
37
+
(** Pre-compute all subtree hashes from mono repo's HEAD *)
38
+
let get_subtree_hashes ~fs ~monorepo =
39
+
let mono_repo = Git.Repository.open_repo ~fs (Fpath.to_string monorepo) in
40
+
match Git.Repository.read_ref mono_repo "HEAD" with
41
+
| None -> Hashtbl.create 0
42
+
| Some commit_hash -> (
43
+
match Git.Repository.read mono_repo commit_hash with
44
+
| Error _ -> Hashtbl.create 0
45
+
| Ok (Git.Value.Commit c) ->
46
+
let root_tree_hash = Git.Commit.tree c in
47
+
let tbl = Hashtbl.create 128 in
48
+
(* Read root tree and cache all subtree hashes *)
49
+
(match Git.Repository.read mono_repo root_tree_hash with
50
+
| Ok (Git.Value.Tree tree) ->
51
+
List.iter
52
+
(fun (e : Git.Tree.entry) ->
53
+
if e.perm = `Dir then Hashtbl.add tbl e.name e.hash)
54
+
(Git.Tree.to_list tree)
55
+
| _ -> ());
56
+
tbl
57
+
| Ok _ -> Hashtbl.create 0)
58
+
59
+
(** Internal: compute status for a single package with pre-computed subtree
60
+
hashes *)
61
+
let compute_one ~fs ~checkouts_root ~monorepo ~subtree_hashes pkg =
32
62
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
33
-
let monorepo = Config.Paths.monorepo config in
34
63
let prefix = Package.subtree_prefix pkg in
35
-
let fs_t = fs_typed fs in
36
-
let fs_dir =
37
-
let dir, _ = fs in
38
-
(dir, Fpath.to_string checkout_dir)
39
-
in
64
+
let checkout_path = Fpath.to_string checkout_dir in
40
65
let checkout =
41
-
match Eio.Path.kind ~follow:true fs_dir with
42
-
| exception Eio.Io _ -> Missing
43
-
| `Directory -> (
44
-
if not (Git_cli.is_repo ~proc ~fs:fs_t checkout_dir) then Not_a_repo
45
-
else if Git_cli.is_dirty ~proc ~fs:fs_t checkout_dir then Dirty
46
-
else
47
-
match Git_cli.ahead_behind ~proc ~fs:fs_t checkout_dir with
48
-
| Ok ab -> Clean ab
49
-
| Error _ -> Clean { ahead = 0; behind = 0 })
50
-
| _ -> Missing
66
+
if not (dir_exists fs checkout_dir) then Missing
67
+
else if not (Git.Repository.is_repo ~fs checkout_path) then Not_a_repo
68
+
else
69
+
let repo = Git.Repository.open_repo ~fs checkout_path in
70
+
if Git.Repository.is_dirty repo then Dirty
71
+
else
72
+
let branch =
73
+
match Git.Repository.current_branch repo with
74
+
| Some b -> b
75
+
| None -> "main"
76
+
in
77
+
match Git.Repository.ahead_behind repo ~branch () with
78
+
| Some ab -> Clean (to_ahead_behind ab)
79
+
| None -> Clean { ahead = 0; behind = 0 }
51
80
in
52
-
let subtree =
53
-
if Git_cli.subtree_prefix_exists ~fs:fs_t ~repo:monorepo ~prefix then Present
54
-
else Not_added
55
-
in
56
-
(* Compute subtree sync state: compare tree content between monorepo subtree and checkout.
57
-
This is more accurate than commit ancestry because it handles both push and pull directions.
58
-
If the trees match, the content is in sync regardless of how it got there. *)
81
+
let subtree_dir = Fpath.(monorepo / prefix) in
82
+
let subtree = if dir_exists fs subtree_dir then Present else Not_added in
59
83
let subtree_sync =
60
84
match (checkout, subtree) with
61
85
| (Missing | Not_a_repo | Dirty), _ -> Unknown
62
86
| _, Not_added -> Unknown
63
87
| Clean _, Present -> (
64
-
(* Get tree hash of subtree directory in monorepo *)
65
-
let subtree_tree =
66
-
Git_cli.rev_parse ~proc ~fs:fs_t ~rev:("HEAD:" ^ prefix) monorepo
67
-
in
68
-
(* Get tree hash of checkout root *)
88
+
let checkout_repo = Git.Repository.open_repo ~fs checkout_path in
89
+
let subtree_tree = Hashtbl.find_opt subtree_hashes prefix in
69
90
let checkout_tree =
70
-
Git_cli.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir
91
+
Git.Repository.tree_hash_at_path checkout_repo ~rev:"HEAD" ~path:""
71
92
in
72
93
match (subtree_tree, checkout_tree) with
73
-
| Ok st, Ok ct when st = ct -> In_sync
74
-
| Ok _, Ok _ -> (
75
-
(* Trees differ - check commit ancestry to determine direction *)
76
-
let subtree_commit =
77
-
Git_cli.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo
78
-
~prefix ()
79
-
in
80
-
let checkout_head =
81
-
Git_cli.head_commit ~proc ~fs:fs_t checkout_dir
82
-
in
83
-
match (subtree_commit, checkout_head) with
84
-
| Some subtree_sha, Ok checkout_sha ->
85
-
if
86
-
Git_cli.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
87
-
~commit1:subtree_sha ~commit2:checkout_sha ()
88
-
then
89
-
(* Checkout has commits not in subtree - need subtree pull *)
90
-
let count =
91
-
Git_cli.count_commits_between ~proc ~fs:fs_t
92
-
~repo:checkout_dir ~base:subtree_sha ~head:checkout_sha ()
93
-
in
94
-
if count > 0 then Subtree_behind count else Trees_differ
95
-
(* Same commit but trees differ - monorepo has changes *)
96
-
else if
97
-
Git_cli.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
98
-
~commit1:checkout_sha ~commit2:subtree_sha ()
99
-
then
100
-
(* Subtree has content not in checkout - need push *)
101
-
let count =
102
-
Git_cli.count_commits_between ~proc ~fs:fs_t
103
-
~repo:checkout_dir ~base:checkout_sha ~head:subtree_sha ()
104
-
in
105
-
if count > 0 then Subtree_ahead count else Trees_differ
106
-
else Trees_differ (* Diverged *)
107
-
| _ -> Trees_differ
108
-
(* Trees differ but can't determine ancestry *))
94
+
| Some st, Some ct when Git.Hash.equal st ct -> In_sync
95
+
| Some _, Some _ -> Trees_differ
109
96
| _ -> Unknown)
110
97
in
111
98
{ package = pkg; checkout; subtree; subtree_sync }
112
99
113
-
let compute_all ~proc ~fs ~config packages =
114
-
List.map (compute ~proc ~fs ~config) packages
100
+
let compute ~fs ~config pkg =
101
+
let fs_t = fs_typed fs in
102
+
let checkouts_root = Config.Paths.checkouts config in
103
+
let monorepo = Config.Paths.monorepo config in
104
+
let subtree_hashes = get_subtree_hashes ~fs:fs_t ~monorepo in
105
+
compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes pkg
106
+
107
+
let compute_all ~fs ~config packages =
108
+
let fs_t = fs_typed fs in
109
+
let checkouts_root = Config.Paths.checkouts config in
110
+
let monorepo = Config.Paths.monorepo config in
111
+
(* Pre-compute all subtree hashes once *)
112
+
let subtree_hashes = get_subtree_hashes ~fs:fs_t ~monorepo in
113
+
Eio.Fiber.List.map ~max_fibers:8
114
+
(compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes)
115
+
packages
115
116
116
117
let is_checkout_clean t = match t.checkout with Clean _ -> true | _ -> false
117
118
let has_local_changes t = match t.checkout with Dirty -> true | _ -> false
···
220
221
let entry = Option.bind sources (fun s -> Sources_registry.find s ~subtree) in
221
222
(* Helper to print remote sync info *)
222
223
let pp_remote ab =
223
-
if ab.Git_cli.ahead > 0 && ab.behind > 0 then
224
+
if ab.ahead > 0 && ab.behind > 0 then
224
225
Fmt.pf ppf " %a"
225
226
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
226
227
(ab.ahead, ab.behind)
+10
-26
lib/status.mli
+10
-26
lib/status.mli
···
1
1
(** Status computation and display.
2
2
3
3
This module computes the synchronization status of packages across the three
4
-
locations: git remote, individual checkout, and monorepo subtree. *)
4
+
locations: git remote, individual checkout, and monorepo subtree. Uses
5
+
native OCaml git library for fast in-process operations. *)
5
6
6
7
(** {1 Types} *)
7
8
9
+
type ahead_behind = { ahead : int; behind : int }
10
+
(** Commits ahead/behind relative to upstream. *)
11
+
8
12
(** Status of an individual checkout relative to its remote. *)
9
13
type checkout_status =
10
14
| Missing (** Checkout directory does not exist *)
11
15
| Not_a_repo (** Directory exists but is not a git repository *)
12
16
| Dirty (** Has uncommitted changes *)
13
-
| Clean of Git_cli.ahead_behind
17
+
| Clean of ahead_behind
14
18
(** Clean with ahead/behind info relative to remote *)
15
19
16
20
(** Status of a subtree in the monorepo. *)
···
40
44
41
45
(** {1 Status Computation} *)
42
46
43
-
val compute :
44
-
proc:_ Eio.Process.mgr ->
45
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
46
-
config:Config.t ->
47
-
Package.t ->
48
-
t
49
-
(** [compute ~proc ~fs ~config pkg] computes the status of a single package.
50
-
51
-
@param proc Eio process manager
52
-
@param fs Eio filesystem
53
-
@param config Monopam configuration
54
-
@param pkg Package to check *)
47
+
val compute : fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t -> t
48
+
(** [compute ~fs ~config pkg] computes the status of a single package. *)
55
49
56
50
val compute_all :
57
-
proc:_ Eio.Process.mgr ->
58
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
59
-
config:Config.t ->
60
-
Package.t list ->
61
-
t list
62
-
(** [compute_all ~proc ~fs ~config packages] computes status for all packages in
63
-
parallel.
64
-
65
-
@param proc Eio process manager
66
-
@param fs Eio filesystem
67
-
@param config Monopam configuration
68
-
@param packages List of packages to check *)
51
+
fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t list -> t list
52
+
(** [compute_all ~fs ~config packages] computes status for all packages. *)
69
53
70
54
(** {1 Predicates} *)
71
55
+2
-1
lib/verse.ml
+2
-1
lib/verse.ml
···
322
322
let verse_dir = Verse_config.verse_path config in
323
323
ensure_dir ~fs verse_dir;
324
324
Logs.info (fun m -> m "Syncing %d members" (List.length members));
325
+
(* Sync all members in parallel *)
325
326
let errors =
326
-
List.filter_map
327
+
Eio.Fiber.List.filter_map ~max_fibers:4
327
328
(fun (member : Verse_registry.member) ->
328
329
let h = member.handle in
329
330
let mono_path = Fpath.(verse_dir / h) in
+221
test/test_remote_cache.ml
+221
test/test_remote_cache.ml
···
1
+
(* Tests for Remote_cache module *)
2
+
3
+
module Remote_cache = Monopam.Remote_cache
4
+
5
+
let test_url = Uri.of_string "https://github.com/ocaml/ocaml.git"
6
+
let test_url2 = Uri.of_string "https://github.com/mirage/mirage.git"
7
+
8
+
(* Mock clock for deterministic testing *)
9
+
let make_mock_clock () =
10
+
let time = ref 0.0 in
11
+
let now () = !time in
12
+
let advance dt = time := !time +. dt in
13
+
let set t = time := t in
14
+
(now, advance, set)
15
+
16
+
let test_empty_cache () =
17
+
let now, _, _ = make_mock_clock () in
18
+
let cache = Remote_cache.create ~now () in
19
+
Alcotest.(check int) "empty cache" 0 (Remote_cache.size cache);
20
+
Alcotest.(check (option string))
21
+
"get from empty" None
22
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
23
+
24
+
let test_set_get () =
25
+
let now, _, _ = make_mock_clock () in
26
+
let cache = Remote_cache.create ~now () in
27
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
28
+
Alcotest.(check int) "size after set" 1 (Remote_cache.size cache);
29
+
Alcotest.(check (option string))
30
+
"get after set" (Some "abc123")
31
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
32
+
33
+
let test_different_branches () =
34
+
let now, _, _ = make_mock_clock () in
35
+
let cache = Remote_cache.create ~now () in
36
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"main123";
37
+
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"dev456";
38
+
Alcotest.(check int) "size with two branches" 2 (Remote_cache.size cache);
39
+
Alcotest.(check (option string))
40
+
"get main" (Some "main123")
41
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
42
+
Alcotest.(check (option string))
43
+
"get develop" (Some "dev456")
44
+
(Remote_cache.get cache ~url:test_url ~branch:"develop")
45
+
46
+
let test_different_urls () =
47
+
let now, _, _ = make_mock_clock () in
48
+
let cache = Remote_cache.create ~now () in
49
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"ocaml123";
50
+
Remote_cache.set cache ~url:test_url2 ~branch:"main" ~hash:"mirage456";
51
+
Alcotest.(check int) "size with two urls" 2 (Remote_cache.size cache);
52
+
Alcotest.(check (option string))
53
+
"get ocaml" (Some "ocaml123")
54
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
55
+
Alcotest.(check (option string))
56
+
"get mirage" (Some "mirage456")
57
+
(Remote_cache.get cache ~url:test_url2 ~branch:"main")
58
+
59
+
let test_update_existing () =
60
+
let now, _, _ = make_mock_clock () in
61
+
let cache = Remote_cache.create ~now () in
62
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"old123";
63
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"new456";
64
+
Alcotest.(check int) "size after update" 1 (Remote_cache.size cache);
65
+
Alcotest.(check (option string))
66
+
"get updated value" (Some "new456")
67
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
68
+
69
+
let test_expiration () =
70
+
let now, advance, _ = make_mock_clock () in
71
+
let ttl = 60.0 in
72
+
let cache = Remote_cache.create ~ttl ~now () in
73
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
74
+
(* Still valid *)
75
+
Alcotest.(check (option string))
76
+
"before expiry" (Some "abc123")
77
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
78
+
(* Advance time but still within TTL *)
79
+
advance 30.0;
80
+
Alcotest.(check (option string))
81
+
"half way" (Some "abc123")
82
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
83
+
(* Advance past TTL *)
84
+
advance 31.0;
85
+
Alcotest.(check (option string))
86
+
"after expiry" None
87
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
88
+
89
+
let test_expiration_boundary () =
90
+
let now, advance, _ = make_mock_clock () in
91
+
let ttl = 60.0 in
92
+
let cache = Remote_cache.create ~ttl ~now () in
93
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
94
+
(* Just before TTL - still valid *)
95
+
advance 59.999;
96
+
Alcotest.(check (option string))
97
+
"just before expiry" (Some "abc123")
98
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
99
+
(* Exactly at TTL boundary - expired (uses strict > comparison) *)
100
+
advance 0.001;
101
+
Alcotest.(check (option string))
102
+
"at boundary" None
103
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
104
+
105
+
let test_refresh_extends_ttl () =
106
+
let now, advance, _ = make_mock_clock () in
107
+
let ttl = 60.0 in
108
+
let cache = Remote_cache.create ~ttl ~now () in
109
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
110
+
(* Advance 50 seconds *)
111
+
advance 50.0;
112
+
Alcotest.(check (option string))
113
+
"still valid" (Some "abc123")
114
+
(Remote_cache.get cache ~url:test_url ~branch:"main");
115
+
(* Refresh the entry *)
116
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
117
+
(* Advance another 50 seconds (would be expired without refresh) *)
118
+
advance 50.0;
119
+
Alcotest.(check (option string))
120
+
"valid after refresh" (Some "abc123")
121
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
122
+
123
+
let test_clear () =
124
+
let now, _, _ = make_mock_clock () in
125
+
let cache = Remote_cache.create ~now () in
126
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
127
+
Remote_cache.set cache ~url:test_url2 ~branch:"main" ~hash:"def456";
128
+
Alcotest.(check int) "before clear" 2 (Remote_cache.size cache);
129
+
Remote_cache.clear cache;
130
+
Alcotest.(check int) "after clear" 0 (Remote_cache.size cache);
131
+
Alcotest.(check (option string))
132
+
"get after clear" None
133
+
(Remote_cache.get cache ~url:test_url ~branch:"main")
134
+
135
+
let test_serialization () =
136
+
let now, _, _ = make_mock_clock () in
137
+
let cache = Remote_cache.create ~now () in
138
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
139
+
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"def456";
140
+
let serialized = Remote_cache.to_string cache in
141
+
(* Reload from serialized *)
142
+
let cache2 = Remote_cache.create_from_string ~now serialized in
143
+
Alcotest.(check int) "size after reload" 2 (Remote_cache.size cache2);
144
+
Alcotest.(check (option string))
145
+
"main after reload" (Some "abc123")
146
+
(Remote_cache.get cache2 ~url:test_url ~branch:"main");
147
+
Alcotest.(check (option string))
148
+
"develop after reload" (Some "def456")
149
+
(Remote_cache.get cache2 ~url:test_url ~branch:"develop")
150
+
151
+
let test_serialization_excludes_expired () =
152
+
let now, advance, set = make_mock_clock () in
153
+
let ttl = 60.0 in
154
+
let cache = Remote_cache.create ~ttl ~now () in
155
+
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"fresh";
156
+
advance 30.0;
157
+
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"newer";
158
+
(* Advance so first entry is expired *)
159
+
advance 40.0;
160
+
let serialized = Remote_cache.to_string cache in
161
+
(* Reset time and reload *)
162
+
set 70.0;
163
+
let cache2 = Remote_cache.create_from_string ~ttl ~now serialized in
164
+
(* Only the newer entry should survive *)
165
+
Alcotest.(check int) "only fresh entry" 1 (Remote_cache.size cache2);
166
+
Alcotest.(check (option string))
167
+
"expired not saved" None
168
+
(Remote_cache.get cache2 ~url:test_url ~branch:"main");
169
+
Alcotest.(check (option string))
170
+
"fresh saved" (Some "newer")
171
+
(Remote_cache.get cache2 ~url:test_url ~branch:"develop")
172
+
173
+
let test_many_entries () =
174
+
let now, _, _ = make_mock_clock () in
175
+
let cache = Remote_cache.create ~now () in
176
+
for i = 0 to 999 do
177
+
let url =
178
+
Uri.of_string (Printf.sprintf "https://example.com/repo%d.git" i)
179
+
in
180
+
Remote_cache.set cache ~url ~branch:"main" ~hash:(Printf.sprintf "hash%d" i)
181
+
done;
182
+
Alcotest.(check int) "1000 entries" 1000 (Remote_cache.size cache);
183
+
(* Verify random access is O(1) - just check some entries *)
184
+
let url = Uri.of_string "https://example.com/repo500.git" in
185
+
Alcotest.(check (option string))
186
+
"get entry 500" (Some "hash500")
187
+
(Remote_cache.get cache ~url ~branch:"main")
188
+
189
+
let test_default_ttl () =
190
+
Alcotest.(check (float 0.1))
191
+
"default ttl is 5 minutes" 300.0 Remote_cache.default_ttl
192
+
193
+
let () =
194
+
Alcotest.run "Remote_cache"
195
+
[
196
+
( "basic",
197
+
[
198
+
Alcotest.test_case "empty cache" `Quick test_empty_cache;
199
+
Alcotest.test_case "set and get" `Quick test_set_get;
200
+
Alcotest.test_case "different branches" `Quick test_different_branches;
201
+
Alcotest.test_case "different urls" `Quick test_different_urls;
202
+
Alcotest.test_case "update existing" `Quick test_update_existing;
203
+
Alcotest.test_case "clear" `Quick test_clear;
204
+
] );
205
+
( "expiration",
206
+
[
207
+
Alcotest.test_case "basic expiration" `Quick test_expiration;
208
+
Alcotest.test_case "boundary" `Quick test_expiration_boundary;
209
+
Alcotest.test_case "refresh extends ttl" `Quick
210
+
test_refresh_extends_ttl;
211
+
Alcotest.test_case "default ttl" `Quick test_default_ttl;
212
+
] );
213
+
( "serialization",
214
+
[
215
+
Alcotest.test_case "roundtrip" `Quick test_serialization;
216
+
Alcotest.test_case "excludes expired" `Quick
217
+
test_serialization_excludes_expired;
218
+
] );
219
+
( "performance",
220
+
[ Alcotest.test_case "1000 entries" `Quick test_many_entries ] );
221
+
]