forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: fix catch-all exception handlers and remove silenced warning
Replace generic catch-all handlers (with _ ->) with specific exception
types to avoid hiding unexpected errors. Also removes unused ahead field
from remote_status type instead of silencing warning 69.
+134
-134
+19
-22
lib/doctor.ml
+19
-22
lib/doctor.ml
···
184
184
185
185
let local_sync_to_string = function
186
186
| `In_sync -> "in_sync"
187
-
| `Ahead n -> Printf.sprintf "ahead:%d" n
188
-
| `Behind n -> Printf.sprintf "behind:%d" n
187
+
| `Ahead n -> Fmt.str "ahead:%d" n
188
+
| `Behind n -> Fmt.str "behind:%d" n
189
189
| `Needs_sync -> "needs_sync"
190
190
191
191
let local_sync_of_string s =
···
309
309
let local_str =
310
310
match r.local_sync with
311
311
| `In_sync -> "="
312
-
| `Ahead n -> Printf.sprintf "+%d" n
313
-
| `Behind n -> Printf.sprintf "-%d" n
312
+
| `Ahead n -> Fmt.str "+%d" n
313
+
| `Behind n -> Fmt.str "-%d" n
314
314
| `Needs_sync -> "sync"
315
315
in
316
316
Fmt.pf ppf "@.%a (local:%s, remote:+%d/-%d)@."
···
361
361
type remote_status = {
362
362
remote_name : string;
363
363
url : string;
364
-
ahead : int; [@warning "-69"] (** Commits we have that remote doesn't *)
365
364
behind : int; (** Commits remote has that we don't *)
366
365
incoming_commits : Git.Repository.log_entry list;
367
366
(** Commits from remote we don't have *)
···
376
375
|> Option.value ~default:"(unknown)"
377
376
in
378
377
(* Try to get ahead/behind for this remote *)
379
-
let ahead, behind =
378
+
let behind =
380
379
match Git.Repository.ahead_behind repo ~remote:remote_name () with
381
-
| Some ab -> (ab.ahead, ab.behind)
382
-
| None -> (0, 0)
380
+
| Some ab -> ab.behind
381
+
| None -> 0
383
382
in
384
383
(* Get commits from remote that we don't have *)
385
384
let incoming_commits =
386
385
if behind > 0 then
387
-
let tip = Printf.sprintf "%s/main" remote_name in
386
+
let tip = Fmt.str "%s/main" remote_name in
388
387
match
389
388
Git.Repository.log_range_refs repo ~base:"HEAD" ~tip ~max_count:20 ()
390
389
with
···
393
392
(* Try with master branch *)
394
393
match
395
394
Git.Repository.log_range_refs repo ~base:"HEAD"
396
-
~tip:(Printf.sprintf "%s/master" remote_name)
395
+
~tip:(Fmt.str "%s/master" remote_name)
397
396
~max_count:20 ()
398
397
with
399
398
| Ok commits -> commits
400
399
| Error _ -> [])
401
400
else []
402
401
in
403
-
{ remote_name; url; ahead; behind; incoming_commits }
402
+
{ remote_name; url; behind; incoming_commits }
404
403
405
404
(** Analyze all remotes for a checkout *)
406
405
let analyze_checkout_remotes ~fs ~checkout_dir =
···
445
444
let local_str =
446
445
match status.subtree_sync with
447
446
| Status.In_sync -> "local:="
448
-
| Status.Subtree_behind n -> Printf.sprintf "local:-%d" n
449
-
| Status.Subtree_ahead n -> Printf.sprintf "local:+%d" n
447
+
| Status.Subtree_behind n -> Fmt.str "local:-%d" n
448
+
| Status.Subtree_ahead n -> Fmt.str "local:+%d" n
450
449
| Status.Trees_differ -> "local:sync"
451
450
| Status.Unknown -> "local:?"
452
451
in
···
454
453
match status.checkout with
455
454
| Status.Clean ab ->
456
455
if ab.ahead > 0 && ab.behind > 0 then
457
-
Printf.sprintf "remote:+%d/-%d" ab.ahead ab.behind
458
-
else if ab.ahead > 0 then Printf.sprintf "remote:+%d" ab.ahead
459
-
else if ab.behind > 0 then Printf.sprintf "remote:-%d" ab.behind
456
+
Fmt.str "remote:+%d/-%d" ab.ahead ab.behind
457
+
else if ab.ahead > 0 then Fmt.str "remote:+%d" ab.ahead
458
+
else if ab.behind > 0 then Fmt.str "remote:-%d" ab.behind
460
459
else "remote:="
461
460
| Status.Dirty -> "remote:dirty"
462
461
| Status.Missing -> "remote:missing"
463
462
| Status.Not_a_repo -> "remote:not-repo"
464
463
in
465
-
Buffer.add_string buf
466
-
(Printf.sprintf "- %s: %s %s\n" name local_str remote_str))
464
+
Buffer.add_string buf (Fmt.str "- %s: %s %s\n" name local_str remote_str))
467
465
statuses;
468
466
Buffer.contents buf
469
467
470
468
let format_commit buf (c : Git.Repository.log_entry) =
471
469
let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
472
470
Buffer.add_string buf
473
-
(Printf.sprintf " - %s %s (%s)\n" short_hash c.subject c.author)
471
+
(Fmt.str " - %s %s (%s)\n" short_hash c.subject c.author)
474
472
475
473
let format_remote_commits buf r =
476
474
if r.behind > 0 then begin
477
475
Buffer.add_string buf
478
-
(Printf.sprintf "**%s** (%s) - %d commits behind:\n" r.remote_name r.url
479
-
r.behind);
476
+
(Fmt.str "**%s** (%s) - %d commits behind:\n" r.remote_name r.url r.behind);
480
477
List.iter (format_commit buf) r.incoming_commits;
481
478
Buffer.add_string buf "\n"
482
479
end
···
484
481
let format_repo_incoming buf repo_name remotes =
485
482
let has_incoming = List.exists (fun r -> r.behind > 0) remotes in
486
483
if has_incoming then begin
487
-
Buffer.add_string buf (Printf.sprintf "### %s\n\n" repo_name);
484
+
Buffer.add_string buf (Fmt.str "### %s\n\n" repo_name);
488
485
List.iter (format_remote_commits buf) remotes
489
486
end
490
487
+2
-2
lib/fork_join.ml
+2
-2
lib/fork_join.ml
···
437
437
| `Symbolic_link -> (
438
438
(* Read symlink target and recreate it *)
439
439
let target = Eio.Path.read_link src_path in
440
-
try Unix.symlink target (snd dest_path) with _ -> ())
440
+
try Unix.symlink target (snd dest_path) with Unix.Unix_error _ -> ())
441
441
| _ -> () (* Skip other file types *)
442
-
| exception _ -> ()
442
+
| exception Eio.Io _ -> ()
443
443
in
444
444
copy_rec src_eio dest_eio
445
445
+111
-108
lib/forks.ml
+111
-108
lib/forks.ml
···
19
19
let cache_file_path () =
20
20
Fpath.(to_string (Verse_config.cache_dir () / "fetch-cache.json"))
21
21
22
+
let parse_cache_pair pair =
23
+
let pair = String.trim pair in
24
+
match String.split_on_char ':' pair with
25
+
| [ key; value ] ->
26
+
let key = String.trim key in
27
+
let value = String.trim value in
28
+
let key =
29
+
if String.length key > 2 && key.[0] = '"' then
30
+
String.sub key 1 (String.length key - 2)
31
+
else key
32
+
in
33
+
Option.iter
34
+
(fun ts -> Hashtbl.replace fetch_cache key ts)
35
+
(float_of_string_opt value)
36
+
| _ -> ()
37
+
38
+
let parse_cache_content content =
39
+
let content = String.trim content in
40
+
if String.length content > 2 then begin
41
+
let inner = String.sub content 1 (String.length content - 2) in
42
+
List.iter parse_cache_pair (String.split_on_char ',' inner)
43
+
end
44
+
22
45
(** Load cache from disk *)
23
46
let load_cache () =
24
47
let path = cache_file_path () in
25
-
if Sys.file_exists path then begin
48
+
if not (Sys.file_exists path) then ()
49
+
else
26
50
try
27
51
let content = In_channel.with_open_text path In_channel.input_all in
28
-
(* Simple JSON parsing for {"key": timestamp, ...} *)
29
-
let content = String.trim content in
30
-
if String.length content > 2 then begin
31
-
let inner = String.sub content 1 (String.length content - 2) in
32
-
let pairs = String.split_on_char ',' inner in
33
-
List.iter
34
-
(fun pair ->
35
-
let pair = String.trim pair in
36
-
match String.split_on_char ':' pair with
37
-
| [ key; value ] -> (
38
-
let key = String.trim key in
39
-
let value = String.trim value in
40
-
(* Strip quotes from key *)
41
-
let key =
42
-
if String.length key > 2 && key.[0] = '"' then
43
-
String.sub key 1 (String.length key - 2)
44
-
else key
45
-
in
46
-
match float_of_string_opt value with
47
-
| Some ts -> Hashtbl.replace fetch_cache key ts
48
-
| None -> ())
49
-
| _ -> ())
50
-
pairs
51
-
end
52
-
with _ -> ()
53
-
end
52
+
parse_cache_content content
53
+
with Sys_error msg ->
54
+
Log.debug (fun m -> m "Failed to load fetch cache: %s" msg)
54
55
55
56
(** Save cache to disk *)
56
57
let save_cache () =
···
71
72
Printf.fprintf oc " \"%s\": %.0f" key ts)
72
73
fetch_cache;
73
74
output_string oc "\n}\n")
74
-
with _ -> ()
75
+
with Sys_error msg ->
76
+
Log.debug (fun m -> m "Failed to save fetch cache: %s" msg)
75
77
76
78
(** Check if a fetch is needed for a cache key *)
77
79
let needs_fetch ~refresh ~timeout key =
···
102
104
let scan_cache_file_path () =
103
105
Fpath.(to_string (Verse_config.cache_dir () / "scan-cache.json"))
104
106
107
+
let rec parse_scan_pairs acc = function
108
+
| pkg :: url :: tail ->
109
+
parse_scan_pairs ((pkg, Uri.of_string url) :: acc) tail
110
+
| _ -> List.rev acc
111
+
112
+
let parse_scan_line line =
113
+
match String.split_on_char '\t' line with
114
+
| key :: rest when List.length rest >= 2 ->
115
+
let pairs = parse_scan_pairs [] rest in
116
+
if pairs <> [] then Hashtbl.replace scan_cache key pairs
117
+
| _ -> ()
118
+
119
+
let read_all_lines ic =
120
+
let rec read acc =
121
+
match In_channel.input_line ic with
122
+
| Some line -> read (line :: acc)
123
+
| None -> List.rev acc
124
+
in
125
+
read []
126
+
105
127
(** Load scan cache from disk. Uses simple line-based format:
106
128
path<TAB>pkg1<TAB>url1<TAB>pkg2<TAB>url2... *)
107
129
let load_scan_cache () =
108
130
let path = scan_cache_file_path () in
109
-
if Sys.file_exists path then begin
131
+
if not (Sys.file_exists path) then ()
132
+
else
110
133
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
+
let lines = In_channel.with_open_text path read_all_lines in
135
+
List.iter parse_scan_line lines;
134
136
Log.debug (fun m ->
135
137
m "Loaded scan cache with %d entries" (Hashtbl.length scan_cache))
136
-
with _ -> ()
137
-
end
138
+
with Sys_error msg ->
139
+
Log.debug (fun m -> m "Failed to load scan cache: %s" msg)
138
140
139
141
(** Save scan cache to disk. Uses simple line-based format. *)
140
142
let save_scan_cache () =
···
156
158
pairs;
157
159
output_char oc '\n')
158
160
scan_cache)
159
-
with _ -> ()
161
+
with Sys_error msg ->
162
+
Log.debug (fun m -> m "Failed to save scan cache: %s" msg)
160
163
161
164
(** Get cached scan results for a path, or None if not cached *)
162
165
let cached_scan path =
···
281
284
Fmt.pf ppf "%s%a" (abbrev_handle h) pp_rel_short rel)
282
285
actionable
283
286
287
+
let pp_not_mine_repo ppf r =
288
+
let handles =
289
+
List.map (fun (h, _, _) -> abbrev_handle h) r.verse_sources
290
+
|> List.sort_uniq String.compare
291
+
in
292
+
Fmt.pf ppf " %-22s %a\n" r.repo_name
293
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
294
+
(String.concat "," handles)
295
+
296
+
let pp_not_mine_compact ppf not_mine =
297
+
let grouped = Hashtbl.create 16 in
298
+
List.iter
299
+
(fun r ->
300
+
List.iter
301
+
(fun (h, _, _) ->
302
+
let existing = try Hashtbl.find grouped h with Not_found -> [] in
303
+
Hashtbl.replace grouped h (r.repo_name :: existing))
304
+
r.verse_sources)
305
+
not_mine;
306
+
Fmt.pf ppf " %a " Fmt.(styled `Bold string) "Others:";
307
+
let first = ref true in
308
+
Hashtbl.iter
309
+
(fun h repos ->
310
+
if not !first then Fmt.pf ppf ", ";
311
+
first := false;
312
+
Fmt.(styled `Faint (fun ppf (h, n) -> pf ppf "%s(%d)" h n))
313
+
ppf
314
+
(abbrev_handle h, List.length repos))
315
+
grouped;
316
+
Fmt.pf ppf "\n"
317
+
318
+
let pp_not_mine ~show_all ppf not_mine =
319
+
if not_mine = [] then ()
320
+
else if show_all then begin
321
+
let sorted =
322
+
List.sort (fun a b -> String.compare a.repo_name b.repo_name) not_mine
323
+
in
324
+
List.iter (pp_not_mine_repo ppf) sorted
325
+
end
326
+
else pp_not_mine_compact ppf not_mine
327
+
284
328
(** Succinct summary: dense one-line-per-repo format *)
285
329
let pp_summary' ~show_all ppf t =
286
330
if t.repos = [] then ()
···
298
342
| Some _ when actionable <> [] ->
299
343
with_actions := (r, actionable) :: !with_actions
300
344
| Some _ when is_in_sync -> in_sync := r :: !in_sync
301
-
| Some _ ->
302
-
(* Has verse sources but all same URL - treat as in sync *)
303
-
in_sync := r :: !in_sync)
345
+
| Some _ -> in_sync := r :: !in_sync)
304
346
t.repos;
305
347
306
348
(* Print header with counts *)
···
335
377
in_sync_sorted
336
378
end;
337
379
338
-
(* Print others *)
339
-
if !not_mine <> [] then begin
340
-
if show_all then begin
341
-
(* List each repo with ~ *)
342
-
let not_mine_sorted =
343
-
List.sort
344
-
(fun a b -> String.compare a.repo_name b.repo_name)
345
-
!not_mine
346
-
in
347
-
List.iter
348
-
(fun r ->
349
-
let handles =
350
-
List.map (fun (h, _, _) -> abbrev_handle h) r.verse_sources
351
-
|> List.sort_uniq String.compare
352
-
in
353
-
Fmt.pf ppf " %-22s %a\n" r.repo_name
354
-
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
355
-
(String.concat "," handles))
356
-
not_mine_sorted
357
-
end
358
-
else begin
359
-
(* Compact summary *)
360
-
let grouped = Hashtbl.create 16 in
361
-
List.iter
362
-
(fun r ->
363
-
List.iter
364
-
(fun (h, _, _) ->
365
-
let existing =
366
-
try Hashtbl.find grouped h with Not_found -> []
367
-
in
368
-
Hashtbl.replace grouped h (r.repo_name :: existing))
369
-
r.verse_sources)
370
-
!not_mine;
371
-
Fmt.pf ppf " %a " Fmt.(styled `Bold string) "Others:";
372
-
let first = ref true in
373
-
Hashtbl.iter
374
-
(fun h repos ->
375
-
if not !first then Fmt.pf ppf ", ";
376
-
first := false;
377
-
Fmt.(styled `Faint (fun ppf (h, n) -> pf ppf "%s(%d)" h n))
378
-
ppf
379
-
(abbrev_handle h, List.length repos))
380
-
grouped;
381
-
Fmt.pf ppf "\n"
382
-
end
383
-
end
380
+
pp_not_mine ~show_all ppf !not_mine
384
381
end
385
382
386
383
let pp_summary ppf t = pp_summary' ~show_all:false ppf t
···
468
465
if Opam_repo.is_git_url url_str then
469
466
Some (pkg_name, Opam_repo.normalize_git_url url_str)
470
467
else None
471
-
with _ -> None)
472
-
with _ -> None)
468
+
with
469
+
| Eio.Io _ -> None
470
+
| exn ->
471
+
Log.debug (fun m ->
472
+
m "Failed to parse opam file %a: %s" Fpath.pp opam_path
473
+
(Printexc.to_string exn));
474
+
None)
475
+
with Eio.Io _ -> None)
473
476
package_names
474
-
with _ -> []
477
+
with Eio.Io _ -> []
475
478
476
479
(** Fetch a verse opam repo (with caching). Returns true if actually fetched. *)
477
480
let fetch_verse_opam_repo ~proc ~fs ~refresh path =
···
505
508
[(handle, url, [packages])] *)
506
509
let scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () =
507
510
let eio_verse = Eio.Path.(fs / Fpath.to_string verse_path) in
508
-
let entries = try Eio.Path.read_dir eio_verse with _ -> [] in
511
+
let entries = try Eio.Path.read_dir eio_verse with Eio.Io _ -> [] in
509
512
(* Find opam repo directories (ending in -opam) *)
510
513
let opam_dirs =
511
514
List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries
+1
-1
lib/opam_repo.ml
+1
-1
lib/opam_repo.ml
+1
-1
lib/verse_registry.ml
+1
-1
lib/verse_registry.ml