forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam/status: use ocaml-retry in ls_remote_exists
Replace the hand-rolled retry-once-on-miss with Retry.with_retry_result
(max_retries=2, exponential backoff to 4s cap). Thread the Eio clock
through run_status -> print_remote_block -> run_probes so Retry can
sleep between attempts. Absorbs transient ls-remote failures under
parallel contention that would otherwise produce false negatives.
+37
-26
+8
-16
bin/cmd_status.ml
+8
-16
bin/cmd_status.ml
···
204
204
(** Probe every URL in parallel (bounded to 8 concurrent git ls-remote calls,
205
205
which tangled tolerates without rate-limiting). Shows a [Tty.Progress] bar
206
206
while running. Returns a [url -> bool] lookup. *)
207
-
let run_probes ~proc ~fs urls =
207
+
let run_probes ~clock ~proc ~fs urls =
208
208
let n = List.length urls in
209
209
Log.info (fun m -> m "probing %d unique URLs (up to 8 in parallel)" n);
210
210
let t0 = Unix.gettimeofday () in
···
212
212
let mutex = Eio.Mutex.create () in
213
213
let probe_one url =
214
214
let t = Unix.gettimeofday () in
215
-
let r = Monopam.Git_cli.ls_remote_exists ~proc ~fs ~url in
216
-
(* Parallel ls-remote occasionally returns a false MISS under contention.
217
-
Re-probe once before concluding the URL is unreachable. *)
218
-
let r =
219
-
if r then r
220
-
else begin
221
-
Log.debug (fun m -> m "retrying after miss: %s" url);
222
-
Monopam.Git_cli.ls_remote_exists ~proc ~fs ~url
223
-
end
224
-
in
215
+
let r = Monopam.Git_cli.ls_remote_exists ~clock ~proc ~fs ~url in
225
216
let dt = Unix.gettimeofday () -. t in
226
217
Log.debug (fun m -> m "%s %s (%.2fs)" (if r then "OK" else "MISS") url dt);
227
218
Eio.Mutex.use_rw ~protect:true mutex (fun () ->
···
273
264
Fmt.pr " %-22s %a\n" name Fmt.(styled `Faint string) url)
274
265
rows)
275
266
276
-
let print_remote_block ~proc ~fs ~config =
267
+
let print_remote_block ~clock ~proc ~fs ~config =
277
268
let sources = load_sources ~fs ~config in
278
269
match Monopam.discover_packages ~fs ~config () with
279
270
| Error _ -> ()
···
288
279
Log.debug (fun m ->
289
280
m "origin base: %s" (Option.value ~default:"(none)" origin_base));
290
281
let urls = probe_set ~sources ~origin_base subtrees in
291
-
let probe = run_probes ~proc ~fs urls in
282
+
let probe = run_probes ~clock ~proc ~fs urls in
292
283
let classified =
293
284
List.map (classify_subtree ~probe ~sources ~origin_base) subtrees
294
285
in
···
307
298
~label:"Old fork still at origin (upstream-named), consider deleting:"
308
299
old_forks
309
300
310
-
let run_status ~sw ~proc ~fs ~config ~show_all ~show_forks ~show_remote =
301
+
let run_status ~sw ~clock ~proc ~fs ~config ~show_all ~show_forks ~show_remote =
311
302
match Monopam.status ~sw ~fs ~config () with
312
303
| Error e -> Common.fail_ctx e
313
304
| Ok statuses ->
···
316
307
print_untracked_block ~fs ~config;
317
308
print_unpublished_block ~fs ~config;
318
309
if show_forks then print_forks ~sw ~proc ~fs ~config ~show_all;
319
-
if show_remote then print_remote_block ~proc ~fs ~config;
310
+
if show_remote then print_remote_block ~clock ~proc ~fs ~config;
320
311
`Ok ()
321
312
322
313
let run ~show_all ~show_forks ~show_remote () =
···
324
315
Common.with_config env @@ fun config ->
325
316
let fs = Eio.Stdenv.fs env in
326
317
let proc = Eio.Stdenv.process_mgr env in
318
+
let clock = Eio.Stdenv.clock env in
327
319
Eio.Switch.run @@ fun sw ->
328
-
run_status ~sw ~proc ~fs ~config ~show_all ~show_forks ~show_remote
320
+
run_status ~sw ~clock ~proc ~fs ~config ~show_all ~show_forks ~show_remote
329
321
330
322
let cmd =
331
323
let doc = "Show synchronization status of all packages" in
+1
lib/dune
+1
lib/dune
+19
-4
lib/git_cli.ml
+19
-4
lib/git_cli.ml
···
50
50
stderr = Buffer.contents buf_stderr |> String.trim;
51
51
}
52
52
53
-
let ls_remote_exists ~proc ~fs ~url =
53
+
(* Retry configuration shared by all [ls_remote_exists] calls. *)
54
+
let ls_remote_retry_config =
55
+
Retry.config ~max_retries:2 ~backoff_factor:0.3 ~backoff_max:4.0 ()
56
+
57
+
let ls_remote_exists ~clock ~proc ~fs ~url =
54
58
let cwd = Eio.Path.(fs / "/") in
55
-
let result =
56
-
run_git ~proc ~cwd [ "ls-remote"; "--exit-code"; "--heads"; url ]
59
+
let result_ref = ref None in
60
+
(* Under parallel contention against the git host, a request occasionally
61
+
fails with a transient non-zero exit and succeeds on retry. Retry on
62
+
any non-zero outcome; [Retry] applies exponential backoff. *)
63
+
let should_retry (r : cmd_result) = r.exit_code <> 0 in
64
+
let attempt () =
65
+
let r = run_git ~proc ~cwd [ "ls-remote"; "--exit-code"; "--heads"; url ] in
66
+
result_ref := Some r;
67
+
if r.exit_code = 0 then Ok () else Error r
68
+
in
69
+
let _ =
70
+
Retry.with_retry_result ~clock ~config:ls_remote_retry_config ~should_retry
71
+
attempt
57
72
in
58
-
result.exit_code = 0
73
+
match !result_ref with Some r -> r.exit_code = 0 | None -> false
59
74
60
75
let run_git_ok ~proc ~cwd args =
61
76
let result = run_git ~proc ~cwd args in
+9
-6
lib/git_cli.mli
+9
-6
lib/git_cli.mli
···
129
129
(** {1 Remote Reachability} *)
130
130
131
131
val ls_remote_exists :
132
-
proc:_ Eio.Process.mgr -> fs:Eio.Fs.dir_ty Eio.Path.t -> url:string -> bool
133
-
(** [ls_remote_exists ~proc ~fs ~url] shells out to
132
+
clock:_ Eio.Time.clock ->
133
+
proc:_ Eio.Process.mgr ->
134
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
135
+
url:string ->
136
+
bool
137
+
(** [ls_remote_exists ~clock ~proc ~fs ~url] shells out to
134
138
[git ls-remote --exit-code --heads URL] and returns [true] if the remote
135
-
responded with at least one head, [false] if the URL is unreachable or the
136
-
repository is missing. Does not distinguish between causes (network failure,
137
-
auth failure, no such repo); callers that need that detail should invoke
138
-
[git ls-remote] directly. *)
139
+
responded with at least one head, [false] otherwise. Wrapped in {!Retry}
140
+
with exponential backoff so a transient network blip under parallel
141
+
contention does not produce a false negative. *)
139
142
140
143
(** {1 Subtree Helper Operations} *)
141
144