forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam/status: report canonical URL, filter off-origin legacy URLs
Previously [Remote missing] showed whatever URL [sources.toml] declared
as [source], which for a renamed subtree was the legacy name (e.g.
[ocaml-claude] reported as [ocaml-claudeio]). Push now goes to
[origin_base/subtree], so that is what should be flagged when missing.
[Old fork] now considers all URLs declared in [sources.toml] (both
[source] and [upstream]) that differ from the canonical URL, then keeps
only the ones hosted on our own origin. External upstreams like
[anil.recoil.org/...] are not ours to delete and were producing false
positives.
+43
-49
+43
-49
bin/cmd_status.ml
+43
-49
bin/cmd_status.ml
···
157
157
String.sub url 4 (String.length url - 4)
158
158
else url
159
159
160
-
let configured_url sources subtree =
161
-
Option.bind sources (fun s ->
162
-
Monopam.Sources_registry.derive_source s ~subtree)
163
-
|> Option.map strip_git_plus
164
-
165
160
let canonical_url origin_base subtree =
166
161
Option.map (fun b -> strip_git_plus b ^ "/" ^ subtree) origin_base
167
162
168
-
(** Strip the final path segment from a URL. *)
169
-
let url_basename url =
170
-
match String.rindex_opt url '/' with
171
-
| Some i when i + 1 < String.length url ->
172
-
Some (String.sub url (i + 1) (String.length url - i - 1))
173
-
| _ -> None
163
+
(** [true] if [url] is hosted on our own origin (same host + owner as
164
+
[origin_base]). *)
165
+
let on_our_origin origin_base url =
166
+
match origin_base with
167
+
| None -> false
168
+
| Some b -> String.starts_with ~prefix:(strip_git_plus b ^ "/") url
174
169
175
-
(** If [sources.toml] declares an [upstream] URL whose basename differs from the
176
-
subtree name, the legacy fork would live at
177
-
[origin_base]/[upstream basename] on our own origin. Return that URL, or
178
-
[None] if there is no such candidate. *)
179
-
let old_fork_url sources origin_base subtree =
180
-
match
181
-
( Option.bind sources (fun s -> Monopam.Sources_registry.find s ~subtree),
182
-
origin_base )
183
-
with
184
-
| Some { upstream = Some up; _ }, Some base -> (
185
-
match url_basename (strip_git_plus up) with
186
-
| Some name when name <> subtree -> Some (strip_git_plus base ^ "/" ^ name)
187
-
| _ -> None)
188
-
| _ -> None
170
+
(** URLs declared in [sources.toml] ([source] and [upstream]) that differ from
171
+
the canonical URL for this subtree. A legacy fork lives here if the URL
172
+
still resolves. *)
173
+
let legacy_candidates sources origin_base subtree =
174
+
let entry =
175
+
Option.bind sources (fun s -> Monopam.Sources_registry.find s ~subtree)
176
+
in
177
+
let canon = canonical_url origin_base subtree in
178
+
let add_if acc url =
179
+
let url = strip_git_plus url in
180
+
if Some url = canon || List.mem url acc then acc else url :: acc
181
+
in
182
+
match entry with
183
+
| None -> []
184
+
| Some e ->
185
+
let acc = add_if [] e.source in
186
+
let acc = match e.upstream with Some u -> add_if acc u | None -> acc in
187
+
List.rev acc
189
188
190
-
(** Every distinct URL worth probing: the push target for each subtree, plus one
191
-
candidate old-fork URL per subtree that has an [upstream]. *)
189
+
(** Every distinct URL worth probing: the canonical URL for each subtree (what
190
+
monopam will push to) plus legacy candidates from [sources.toml]. *)
192
191
let probe_set ~sources ~origin_base subtrees =
193
192
let set = Hashtbl.create 256 in
194
193
let add u = Hashtbl.replace set u () in
195
194
List.iter
196
195
(fun subtree ->
197
-
(match configured_url sources subtree with
198
-
| Some _ as u -> Option.iter add u
199
-
| None -> Option.iter add (canonical_url origin_base subtree));
200
-
Option.iter add (old_fork_url sources origin_base subtree))
196
+
Option.iter add (canonical_url origin_base subtree);
197
+
List.iter add (legacy_candidates sources origin_base subtree))
201
198
subtrees;
202
199
Hashtbl.to_seq_keys set |> List.of_seq
203
200
···
231
228
fun url -> try Hashtbl.find table url with Not_found -> false
232
229
233
230
(** Two questions per subtree:
234
-
- [mine]: the URL monopam will push to (configured source, or the
235
-
default-origin URL). If it does not resolve, push would fail.
236
-
- [old_fork]: if [sources.toml] declares an [upstream], the URL at our
237
-
origin named after the upstream's basename. If the repo still exists
238
-
there, it is a leftover from before the rename. *)
231
+
- [missing]: the canonical URL for this subtree (origin_base/subtree) that
232
+
monopam should push to. If it does not resolve, it needs provisioning.
233
+
- [old_forks]: legacy URLs from [sources.toml] that still resolve at our
234
+
origin. External upstreams (github.com, anil.recoil.org, ...) are not ours
235
+
to delete and are filtered out. *)
239
236
let classify_subtree ~probe ~sources ~origin_base subtree =
240
-
let mine =
241
-
match configured_url sources subtree with
242
-
| Some _ as u -> u
243
-
| None -> canonical_url origin_base subtree
244
-
in
245
237
let missing =
246
-
match mine with Some u when not (probe u) -> Some u | _ -> None
238
+
match canonical_url origin_base subtree with
239
+
| Some u when not (probe u) -> Some u
240
+
| _ -> None
247
241
in
248
-
let old_fork =
249
-
match old_fork_url sources origin_base subtree with
250
-
| Some u when probe u -> Some u
251
-
| _ -> None
242
+
let old_forks =
243
+
legacy_candidates sources origin_base subtree
244
+
|> List.filter (on_our_origin origin_base)
245
+
|> List.filter probe
252
246
in
253
-
(subtree, missing, old_fork)
247
+
(subtree, missing, old_forks)
254
248
255
249
let print_remote_list ~style ~label rows =
256
250
if rows <> [] then (
···
289
283
classified
290
284
in
291
285
let old_forks =
292
-
List.filter_map
293
-
(fun (s, _, f) -> Option.map (fun u -> (s, u)) f)
286
+
List.concat_map
287
+
(fun (s, _, fs) -> List.map (fun u -> (s, u)) fs)
294
288
classified
295
289
in
296
290
print_remote_list ~style:`Red ~label:"Remote missing:" missing;