forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam/status: --remote probes each source URL for reachability
Adds a new --remote flag that, after the usual local-state output,
runs 'git ls-remote --exit-code --heads' against every known package's
source URL and lists the ones that do not resolve. Flags missing
tangled repos, typos (like tangled.sh instead of tangled.org), and
stale source entries pointing at deleted forks.
Sequential today: one HTTP roundtrip per package, on the order of a
minute for the full repo. Not enabled by default.
Adds Git_cli.ls_remote_exists as a thin wrapper over the git CLI.
+73
-5
+55
-5
bin/cmd_status.ml
+55
-5
bin/cmd_status.ml
···
148
148
in
149
149
Fmt.pr "%a" (pp ?sources) statuses
150
150
151
-
let run_status ~sw ~proc ~fs ~config ~show_all ~show_forks =
151
+
let print_remote_block ~proc ~fs ~config =
152
+
let sources = load_sources ~fs ~config in
153
+
match Monopam.discover_packages ~fs ~config () with
154
+
| Error _ -> ()
155
+
| Ok pkgs ->
156
+
let subtrees =
157
+
List.map Monopam.Package.subtree_prefix pkgs
158
+
|> List.sort_uniq String.compare
159
+
in
160
+
let missing = ref [] in
161
+
List.iter
162
+
(fun subtree ->
163
+
match
164
+
Option.bind sources (fun s ->
165
+
Monopam.Sources_registry.derive_source s ~subtree)
166
+
with
167
+
| None -> ()
168
+
| Some url ->
169
+
let clean =
170
+
if String.starts_with ~prefix:"git+" url then
171
+
String.sub url 4 (String.length url - 4)
172
+
else url
173
+
in
174
+
if not (Monopam.Git_cli.ls_remote_exists ~proc ~fs ~url:clean)
175
+
then missing := (subtree, clean) :: !missing)
176
+
subtrees;
177
+
let missing = List.rev !missing in
178
+
if missing <> [] then begin
179
+
Fmt.pr "%a %a\n"
180
+
Fmt.(styled `Bold string)
181
+
"Remote missing:"
182
+
Fmt.(styled `Red int)
183
+
(List.length missing);
184
+
List.iter
185
+
(fun (name, url) ->
186
+
Fmt.pr " %-22s %a\n" name
187
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s" s))
188
+
url)
189
+
missing
190
+
end
191
+
192
+
let run_status ~sw ~proc ~fs ~config ~show_all ~show_forks ~show_remote =
152
193
match Monopam.status ~sw ~fs ~config () with
153
194
| Error e -> Common.fail_ctx e
154
195
| Ok statuses ->
···
157
198
print_untracked_block ~fs ~config;
158
199
print_unpublished_block ~fs ~config;
159
200
if show_forks then print_forks ~sw ~proc ~fs ~config ~show_all;
201
+
if show_remote then print_remote_block ~proc ~fs ~config;
160
202
`Ok ()
161
203
162
-
let run ~show_all ~show_forks () =
204
+
let run ~show_all ~show_forks ~show_remote () =
163
205
Eio_main.run @@ fun env ->
164
206
Common.with_config env @@ fun config ->
165
207
let fs = Eio.Stdenv.fs env in
166
208
let proc = Eio.Stdenv.process_mgr env in
167
209
Eio.Switch.run @@ fun sw ->
168
-
run_status ~sw ~proc ~fs ~config ~show_all ~show_forks
210
+
run_status ~sw ~proc ~fs ~config ~show_all ~show_forks ~show_remote
169
211
170
212
let cmd =
171
213
let doc = "Show synchronization status of all packages" in
···
178
220
let doc = "Include fork analysis from verse members (slower)." in
179
221
Arg.(value & flag & info [ "forks"; "f" ] ~doc)
180
222
in
223
+
let remote_arg =
224
+
let doc =
225
+
"Probe each source URL with $(b,git ls-remote) and report the ones that \
226
+
do not resolve. Slow (one HTTP roundtrip per package)."
227
+
in
228
+
Arg.(value & flag & info [ "remote" ] ~doc)
229
+
in
181
230
Cmd.v info
182
231
Term.(
183
232
ret
184
-
(const (fun show_all show_forks () -> run ~show_all ~show_forks ())
185
-
$ all_arg $ forks_arg $ Common.logging_term))
233
+
(const (fun show_all show_forks show_remote () ->
234
+
run ~show_all ~show_forks ~show_remote ())
235
+
$ all_arg $ forks_arg $ remote_arg $ Common.logging_term))
+7
lib/git_cli.ml
+7
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 =
54
+
let cwd = Eio.Path.(fs / "/") in
55
+
let result =
56
+
run_git ~proc ~cwd [ "ls-remote"; "--exit-code"; "--heads"; url ]
57
+
in
58
+
result.exit_code = 0
59
+
53
60
let run_git_ok ~proc ~cwd args =
54
61
let result = run_git ~proc ~cwd args in
55
62
if result.exit_code = 0 then Ok result.stdout
+11
lib/git_cli.mli
+11
lib/git_cli.mli
···
126
126
@param remote Remote name (default: ["origin"]).
127
127
@param branch Branch to reset to. *)
128
128
129
+
(** {1 Remote Reachability} *)
130
+
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
134
+
[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
+
129
140
(** {1 Subtree Helper Operations} *)
130
141
131
142
val fetch_url :