forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
Add base image hash invalidation, cascade --fork, local opam-build support, and perf fixes
- Include base image hash in build layer hash so changes to opam-build
or OS config correctly invalidate all cached layers
- Add base_hash to all Container backends (linux, freebsd, windows, dummy)
- Cache base_hash result to avoid repeated git subprocess calls per layer_hash
- Add --fork N to cascade command for parallel reruns
- Support --local-repo for opam-build: copies into Docker build context
- Fix cascade to scan current state for dependency_failure targets
- Fix blessed status propagation through cascade via --was_blessed
- Optimize batch summary: lazy layer lookups, in-memory dedup, hash memoization
- Record rerun/cascade results in history and regenerate status.json
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+1080
-228
+18
-3
day10/bin/docker.ml
+18
-3
day10/bin/docker.ml
···
23
23
@@ run "apt update && apt install -y curl"
24
24
@@ run "curl -fsSL https://github.com/ocaml/opam/releases/download/2.4.1/opam-2.4.1-%s-linux -o /usr/local/bin/opam && chmod +x /usr/local/bin/opam" opam_arch
25
25
26
-
let opam_build ~(config : Config.t) base_image =
26
+
let opam_build_packages = [ "opam-build" ]
27
+
28
+
let opam_build ~(config : Config.t) ~local_opam_build base_image =
29
+
let clone_or_copy = match local_opam_build with
30
+
| Some _ ->
31
+
copy ~src:[ "opam-build" ] ~dst:"/tmp/opam-build" ()
32
+
| None ->
33
+
run "git clone --depth 1 --branch master https://github.com/mtelvers/opam-build.git /tmp/opam-build"
34
+
in
27
35
from ~platform:(platform config.arch) ~alias:"opam-build-builder" base_image
28
36
@@ run "apt update && apt install -y build-essential git curl unzip bubblewrap"
29
37
@@ copy ~from:"opam-builder" ~src:[ "/usr/local/bin/opam" ] ~dst:"/usr/local/bin/opam" ()
30
38
@@ run "opam init --disable-sandboxing -a --bare -y"
31
-
@@ run "git clone --depth 1 --branch master https://github.com/mtelvers/opam-build.git /tmp/opam-build"
39
+
@@ clone_or_copy
32
40
@@ workdir "/tmp/opam-build"
33
41
@@ run "opam switch create . 5.3.0 --deps-only -y"
34
42
@@ run "opam exec -- dune build --release"
···
36
44
37
45
let debian ~(config : Config.t) ~temp_dir _opam_repository build_log uid gid =
38
46
let base_image = Printf.sprintf "%s:%s" config.os_distribution config.os_version in
47
+
let local_opam_build = Local_repo.find_for_packages ~local_repos:config.local_repos opam_build_packages in
48
+
(* If using local opam-build, copy the repo into the Docker build context *)
49
+
(match local_opam_build with
50
+
| Some (path, _) ->
51
+
let dest = Path.(temp_dir / "opam-build") in
52
+
ignore (Os.exec [ "cp"; "-a"; path; dest ])
53
+
| None -> ());
39
54
let dockerfile =
40
-
(opam ~config base_image) @@ (opam_build ~config base_image)
55
+
(opam ~config base_image) @@ (opam_build ~config ~local_opam_build base_image)
41
56
@@ from ~platform:(platform config.arch) base_image
42
57
@@ run "apt update && apt upgrade -y"
43
58
@@ run "apt install build-essential unzip bubblewrap git sudo curl rsync -y"
+4
day10/bin/dummy.ml
+4
day10/bin/dummy.ml
+4
day10/bin/freebsd.ml
+4
day10/bin/freebsd.ml
···
116
116
let deinit ~t:_ = ()
117
117
let config ~t = t.config
118
118
119
+
let base_hash ~(config : Config.t) =
120
+
String.concat "|" [ config.os_distribution; config.os_version; config.arch ]
121
+
|> Digest.string |> Digest.to_hex
122
+
119
123
let layer_hash ~t deps =
120
124
let hashes =
121
125
List.map
+19
-1
day10/bin/linux.ml
+19
-1
day10/bin/linux.ml
···
151
151
let deinit ~t:_ = ()
152
152
let config ~t = t.config
153
153
154
+
let base_hash_cache : (string, string) Hashtbl.t = Hashtbl.create 1
155
+
156
+
let base_hash ~(config : Config.t) =
157
+
let key = Config.os_key ~config in
158
+
match Hashtbl.find_opt base_hash_cache key with
159
+
| Some h -> h
160
+
| None ->
161
+
let opam_build_component =
162
+
match Local_repo.find_for_packages ~local_repos:config.local_repos Docker.opam_build_packages with
163
+
| Some (path, _) -> Local_repo.repo_hash path
164
+
| None -> "upstream"
165
+
in
166
+
let h = String.concat "|" [ config.os_distribution; config.os_version; config.arch; opam_build_component ]
167
+
|> Digest.string |> Digest.to_hex in
168
+
Hashtbl.replace base_hash_cache key h;
169
+
h
170
+
154
171
let layer_hash ~t deps =
155
172
let hashes =
156
173
List.map
···
159
176
|> OpamHash.compute_from_string |> OpamHash.to_string)
160
177
deps
161
178
in
162
-
String.concat " " hashes |> Digest.string |> Digest.to_hex
179
+
let base = base_hash ~config:t.config in
180
+
String.concat " " (base :: hashes) |> Digest.string |> Digest.to_hex
163
181
164
182
let doc_layer_hash ~t ~build_hash ~dep_doc_hashes ~ocaml_version ~blessed ~compiler_layers =
165
183
let config = t.config in
+1016
-213
day10/bin/main.ml
+1016
-213
day10/bin/main.ml
···
18
18
let os_dir = Path.(config.dir / Config.os_key ~config) in
19
19
let () = Os.mkdir ~parents:true os_dir in
20
20
let root = Path.(os_dir / "base") in
21
-
if not (Sys.file_exists root) then
21
+
let hash_file = Path.(root / "base.hash") in
22
+
let current_hash = Container.base_hash ~config in
23
+
let needs_rebuild =
24
+
if not (Sys.file_exists root) then true
25
+
else if not (Sys.file_exists hash_file) then false (* legacy base without hash — keep it *)
26
+
else try Os.read_from_file hash_file |> String.trim <> current_hash with _ -> true
27
+
in
28
+
if needs_rebuild then begin
29
+
(* Remove stale base if it exists with wrong hash *)
30
+
if Sys.file_exists root then begin
31
+
Printf.printf "Base image hash changed, rebuilding...\n%!";
32
+
ignore (Os.sudo ["rm"; "-rf"; root])
33
+
end;
22
34
Os.create_directory_exclusively root @@ fun ~set_temp_log_path:_ target_dir ->
23
35
let temp_dir = Os.temp_dir ~perms:0o755 ~parent_dir:config.dir "temp-" "" in
24
36
let opam_repository = Util.create_opam_repository temp_dir in
25
37
let build_log = Path.(temp_dir / "build.log") in
26
38
let _ = Container.run ~t ~temp_dir opam_repository build_log in
39
+
Os.write_to_file Path.(temp_dir / "base.hash") current_hash;
27
40
Unix.rename temp_dir target_dir
41
+
end
28
42
29
43
let () = OpamFormatConfig.init ()
30
44
···
265
279
| Failure _ -> "failure"
266
280
| Success _ -> "success"
267
281
282
+
(** In-memory set of (run_id, pkg_str, build_hash) tuples already recorded this process.
283
+
Avoids reading history.jsonl for every package on every call. *)
284
+
let recorded_this_run : (string, bool) Hashtbl.t = Hashtbl.create 4096
285
+
268
286
let record_build_result ~packages_dir ~run_id ~pkg_str ~build_hash
269
287
~compiler ~blessed ~status ~category ?error ?failed_dep ?failed_dep_hash () =
270
-
(* Skip if already recorded for this run and build_hash *)
271
-
let existing = Day10_lib.History.read ~packages_dir ~pkg_str in
272
-
let already_recorded = List.exists (fun (e : Day10_lib.History.entry) ->
273
-
e.run = run_id && e.build_hash = build_hash
274
-
) existing in
275
-
if already_recorded then ()
288
+
let key = Printf.sprintf "%s:%s:%s" run_id pkg_str build_hash in
289
+
if Hashtbl.mem recorded_this_run key then ()
276
290
else begin
291
+
Hashtbl.replace recorded_this_run key true;
277
292
let entry : Day10_lib.History.entry = {
278
293
ts = Day10_lib.Run_log.format_time (Unix.gettimeofday ());
279
294
run = run_id;
···
422
437
let () = Unix.utimes layer_json 0.0 0.0 in
423
438
(* Ensure symlink exists even if layer was pre-existing from previous run *)
424
439
Util.ensure_package_layer_symlink ~cache_dir:config.dir ~os_key:(Config.os_key ~config) ~pkg_str ~layer_name:build_layer_name;
440
+
(* Create blessed-build symlink if this package is blessed *)
441
+
let blessed = match config.blessed_map with
442
+
| Some map -> Blessing.is_blessed map pkg
443
+
| None -> false
444
+
in
445
+
if blessed then
446
+
Util.ensure_package_blessed_symlink ~cache_dir:config.dir ~os_key:(Config.os_key ~config) ~pkg_str ~kind:`Build ~layer_name:build_layer_name;
425
447
let exit_status = Util.load_layer_info_exit_status layer_json in
426
448
match exit_status with
427
449
| 0 -> Success build_layer_name
···
1168
1190
Day10_lib.Run_log.set_log_base_dir log_dir;
1169
1191
let run_info = Day10_lib.Run_log.start_run () in
1170
1192
1193
+
(* Save batch config so rerun --cascade can replay with same settings *)
1194
+
let os_key = Config.os_key ~config in
1195
+
let build_config_path = Path.(config.dir / os_key / "build-config.json") in
1196
+
let build_config_json = `Assoc [
1197
+
("opam_repositories", `List (List.map (fun s -> `String s) config.opam_repositories));
1198
+
("doc_tools_repo", `String config.doc_tools_repo);
1199
+
("doc_tools_branch", `String config.doc_tools_branch);
1200
+
("jtw_tools_repo", `String config.jtw_tools_repo);
1201
+
("jtw_tools_branch", `String config.jtw_tools_branch);
1202
+
("with_doc", `Bool config.with_doc);
1203
+
("with_jtw", `Bool config.with_jtw);
1204
+
("html_output", match config.html_output with Some s -> `String s | None -> `Null);
1205
+
("jtw_output", match config.jtw_output with Some s -> `String s | None -> `Null);
1206
+
("local_repos", `List (List.map (fun s -> `String s) config.local_repos));
1207
+
] in
1208
+
(let tmp = build_config_path ^ ".tmp" in
1209
+
let oc = open_out tmp in
1210
+
Fun.protect ~finally:(fun () -> close_out oc) (fun () ->
1211
+
output_string oc (Yojson.Safe.pretty_to_string build_config_json);
1212
+
output_char oc '\n');
1213
+
Sys.rename tmp build_config_path);
1214
+
1171
1215
(* Clean up stale .new/.old directories from interrupted swaps *)
1172
1216
(match config.html_output with
1173
1217
| Some html_dir -> Os.Atomic_swap.cleanup_stale_dirs ~html_dir
···
1333
1377
List.find_opt (fun (t, _) -> OpamPackage.equal t target) blessing_maps
1334
1378
) solutions in
1335
1379
let print_batch_summary () =
1336
-
(* Count actual results by scanning the filesystem *)
1337
1380
let os_key = Config.os_key ~config in
1338
1381
let layer_dir = Path.(config.dir / os_key) in
1339
1382
let packages_dir = Path.(config.dir / os_key / "packages") in
···
1343
1386
let doc_success = ref 0 in
1344
1387
let doc_fail = ref 0 in
1345
1388
let failures = ref [] in
1389
+
(* Lazy layer index: only reads layer.json when needed for a specific hash *)
1390
+
let layer_cache : (string, (string * int * string * Yojson.Safe.t) option) Hashtbl.t = Hashtbl.create 256 in
1391
+
let lookup_build_layer name =
1392
+
match Hashtbl.find_opt layer_cache name with
1393
+
| Some cached -> cached
1394
+
| None ->
1395
+
let result =
1396
+
let layer_json_path = Path.(layer_dir / name / "layer.json") in
1397
+
if Sys.file_exists layer_json_path then
1398
+
try
1399
+
let json = Yojson.Safe.from_file layer_json_path in
1400
+
let open Yojson.Safe.Util in
1401
+
let pkg_name = json |> member "package" |> to_string in
1402
+
let exit_status = json |> member "exit_status" |> to_int_option |> Option.value ~default:(-1) in
1403
+
let compiler = extract_compiler_from_deps json in
1404
+
Some (pkg_name, exit_status, compiler, json)
1405
+
with _ -> None
1406
+
else None
1407
+
in
1408
+
Hashtbl.replace layer_cache name result;
1409
+
result
1410
+
in
1411
+
let doc_cache : (string, (string * Yojson.Safe.t) option) Hashtbl.t = Hashtbl.create 256 in
1412
+
let lookup_doc_layer name =
1413
+
match Hashtbl.find_opt doc_cache name with
1414
+
| Some cached -> cached
1415
+
| None ->
1416
+
let result =
1417
+
let layer_json_path = Path.(layer_dir / name / "layer.json") in
1418
+
if Sys.file_exists layer_json_path then
1419
+
try
1420
+
let json = Yojson.Safe.from_file layer_json_path in
1421
+
let open Yojson.Safe.Util in
1422
+
let pkg_name = json |> member "package" |> to_string in
1423
+
Some (pkg_name, json)
1424
+
with _ -> None
1425
+
else None
1426
+
in
1427
+
Hashtbl.replace doc_cache name result;
1428
+
result
1429
+
in
1346
1430
(* Track which packages have build layers, for detecting dependency failures *)
1347
1431
let built_packages = Hashtbl.create 64 in
1348
1432
(* Track per-package build layer exit status and compiler, for dep failure reporting *)
1349
1433
let build_layer_info = Hashtbl.create 64 in
1350
-
let () =
1351
-
try
1352
-
Sys.readdir layer_dir |> Array.iter (fun name ->
1353
-
let layer_json = Path.(layer_dir / name / "layer.json") in
1354
-
if Sys.file_exists layer_json then
1355
-
try
1356
-
let json = Yojson.Safe.from_file layer_json in
1434
+
(* Track which (pkg, build_hash) pairs we've already processed *)
1435
+
let processed = Hashtbl.create 4096 in
1436
+
(* Cache for Container.layer_hash results — avoids re-reading opam files *)
1437
+
let hash_cache : (string, string) Hashtbl.t = Hashtbl.create 4096 in
1438
+
let cached_layer_hash ~t pkgs =
1439
+
(* Key: sorted package names *)
1440
+
let key = String.concat "," (List.map OpamPackage.to_string pkgs) in
1441
+
match Hashtbl.find_opt hash_cache key with
1442
+
| Some h -> h
1443
+
| None ->
1444
+
let h = Container.layer_hash ~t pkgs in
1445
+
Hashtbl.replace hash_cache key h;
1446
+
h
1447
+
in
1448
+
(* Iterate over solutions: for each target, compute build hashes and look up results.
1449
+
Use blessing maps to correctly assign blessed status. *)
1450
+
let t_for_hash = Container.init ~config in
1451
+
List.iter (fun (target, solution) ->
1452
+
let bless_map = List.find_opt (fun (t, _) ->
1453
+
OpamPackage.equal t target
1454
+
) blessing_maps in
1455
+
let ordered = topological_sort solution in
1456
+
let dependencies = pkg_deps solution ordered in
1457
+
let rec process_pkgs built_so_far = function
1458
+
| [] -> ()
1459
+
| pkg :: rest ->
1460
+
let pkg_str = OpamPackage.to_string pkg in
1461
+
let ordered_deps = extract_dag dependencies pkg |> topological_sort |> List.rev |> List.tl in
1462
+
let hash = cached_layer_hash ~t:t_for_hash (pkg :: ordered_deps) in
1463
+
let build_layer_name = "build-" ^ hash in
1464
+
let is_blessed = match bless_map with
1465
+
| Some (_, map) -> Blessing.is_blessed map pkg
1466
+
| None -> false
1467
+
in
1468
+
let key = (pkg_str, build_layer_name) in
1469
+
(* Look up this layer on demand *)
1470
+
match lookup_build_layer build_layer_name with
1471
+
| Some (_, exit_status, compiler, _json) ->
1472
+
Hashtbl.replace built_so_far pkg_str build_layer_name;
1473
+
Hashtbl.replace built_packages pkg_str true;
1474
+
Hashtbl.replace build_layer_info pkg_str (build_layer_name, exit_status, compiler);
1475
+
if not (Hashtbl.mem processed key) then begin
1476
+
Hashtbl.replace processed key true;
1477
+
if exit_status = 0 then begin
1478
+
incr build_success;
1479
+
let build_log = Path.(layer_dir / build_layer_name / "build.log") in
1480
+
Day10_lib.Run_log.add_build_log run_info ~package:pkg_str ~source_log:build_log;
1481
+
record_build_result ~packages_dir ~run_id ~pkg_str
1482
+
~build_hash:build_layer_name ~compiler ~blessed:is_blessed
1483
+
~status:"success" ~category:"success" ()
1484
+
end else begin
1485
+
incr build_fail;
1486
+
failures := (pkg_str, Printf.sprintf "build exit code %d" exit_status) :: !failures;
1487
+
let build_log = Path.(layer_dir / build_layer_name / "build.log") in
1488
+
Day10_lib.Run_log.add_build_log run_info ~package:pkg_str ~source_log:build_log;
1489
+
let (status, category, error) = classify_build_failure build_log in
1490
+
record_build_result ~packages_dir ~run_id ~pkg_str
1491
+
~build_hash:build_layer_name ~compiler ~blessed:is_blessed
1492
+
~status ~category ?error ()
1493
+
end
1494
+
end;
1495
+
(* Continue building if this dep succeeded *)
1496
+
if exit_status = 0 then
1497
+
process_pkgs built_so_far rest
1498
+
(* else: remaining deps are dependency failures, handled below *)
1499
+
| None ->
1500
+
(* Layer doesn't exist — this package was never built (dep failure upstream) *)
1501
+
()
1502
+
in
1503
+
process_pkgs (Hashtbl.create 64) ordered;
1504
+
) solutions;
1505
+
(* Process doc layers — only scan doc-* directories modified during this run *)
1506
+
let run_start_time = Day10_lib.Run_log.get_start_time run_info in
1507
+
(try
1508
+
Sys.readdir layer_dir |> Array.iter (fun name ->
1509
+
if String.length name > 4 && String.sub name 0 4 = "doc-" then begin
1510
+
let layer_json_path = Path.(layer_dir / name / "layer.json") in
1511
+
(* Only process layers created/modified during this run *)
1512
+
let dominated = try
1513
+
let stat = Unix.stat layer_json_path in
1514
+
stat.Unix.st_mtime >= run_start_time
1515
+
with _ -> false in
1516
+
if dominated then
1517
+
match lookup_doc_layer name with
1518
+
| Some (pkg_name, json) ->
1357
1519
let open Yojson.Safe.Util in
1358
-
if String.length name > 6 && String.sub name 0 6 = "build-" then begin
1359
-
(* Build layer *)
1360
-
let pkg_name = json |> member "package" |> to_string in
1361
-
let exit_status = json |> member "exit_status" |> to_int_option |> Option.value ~default:(-1) in
1362
-
let compiler = extract_compiler_from_deps json in
1363
-
(* Check if this build is blessed *)
1364
-
let blessed_build_link = Path.(packages_dir / pkg_name / "blessed-build") in
1365
-
let is_blessed = try
1366
-
let target = Unix.readlink blessed_build_link in
1367
-
Filename.basename target = name
1368
-
with _ -> false in
1369
-
Hashtbl.replace built_packages pkg_name true;
1370
-
Hashtbl.replace build_layer_info pkg_name (name, exit_status, compiler);
1371
-
if exit_status = 0 then begin
1372
-
incr build_success;
1373
-
(* Add build log to run *)
1374
-
let build_log = Path.(layer_dir / name / "build.log") in
1375
-
Day10_lib.Run_log.add_build_log run_info ~package:pkg_name ~source_log:build_log;
1376
-
(* Record success in history *)
1377
-
record_build_result ~packages_dir ~run_id ~pkg_str:pkg_name
1378
-
~build_hash:name ~compiler ~blessed:is_blessed
1379
-
~status:"success" ~category:"success" ()
1380
-
end else begin
1381
-
incr build_fail;
1382
-
failures := (pkg_name, Printf.sprintf "build exit code %d" exit_status) :: !failures;
1383
-
let build_log = Path.(layer_dir / name / "build.log") in
1384
-
Day10_lib.Run_log.add_build_log run_info ~package:pkg_name ~source_log:build_log;
1385
-
(* Classify and record build failure in history *)
1386
-
let (status, category, error) = classify_build_failure build_log in
1387
-
record_build_result ~packages_dir ~run_id ~pkg_str:pkg_name
1388
-
~build_hash:name ~compiler ~blessed:is_blessed
1389
-
~status ~category ?error ()
1390
-
end
1391
-
end else if String.length name > 4 && String.sub name 0 4 = "doc-" then begin
1392
-
(* Doc layer - count blessed ones, but log all *)
1393
-
let pkg_name = json |> member "package" |> to_string in
1394
-
let doc = json |> member "doc" in
1520
+
let doc = json |> member "doc" in
1521
+
if doc <> `Null then begin
1395
1522
let blessed = doc |> member "blessed" |> to_bool_option |> Option.value ~default:false in
1396
1523
let status = doc |> member "status" |> to_string_option |> Option.value ~default:"" in
1397
-
(* Extract hash from doc layer name (doc-{hash}) for unique log filenames *)
1398
1524
let layer_hash = String.sub name 4 (String.length name - 4) in
1399
-
(* Add doc log for all doc layers (use hash suffix for uniqueness) *)
1400
1525
let doc_log = Path.(layer_dir / name / "odoc-voodoo-all.log") in
1401
1526
Day10_lib.Run_log.add_doc_log run_info ~package:pkg_name ~source_log:doc_log ~layer_hash ();
1402
-
(* Only count blessed docs in summary stats *)
1403
1527
if blessed then begin
1404
1528
if status = "success" then begin
1405
1529
incr doc_success;
1406
-
(* Record doc success for blessed packages *)
1407
1530
record_build_result ~packages_dir ~run_id ~pkg_str:pkg_name
1408
1531
~build_hash:name ~compiler:"" ~blessed:true
1409
1532
~status:"success" ~category:"success" ()
···
1411
1534
incr doc_fail;
1412
1535
let error_msg = doc |> member "error" |> to_string_option |> Option.value ~default:"unknown error" in
1413
1536
failures := (pkg_name, Printf.sprintf "doc: %s" error_msg) :: !failures;
1414
-
(* Record blessed doc failure in history *)
1415
1537
let doc_category =
1416
1538
if matches_any ["link"] (String.lowercase_ascii error_msg) then
1417
1539
"doc_link_failure"
···
1425
1547
end
1426
1548
end
1427
1549
end
1428
-
with _ -> ()
1429
-
)
1430
-
with _ -> ()
1431
-
in
1432
-
(* Record dependency failures: packages in solutions that have no build layer *)
1433
-
List.iter (fun (_target, solution) ->
1434
-
OpamPackage.Map.iter (fun pkg deps ->
1550
+
| None -> ()
1551
+
end
1552
+
)
1553
+
with _ -> ());
1554
+
(* Record dependency failures: packages in solutions that have no build layer.
1555
+
Walk the dependency graph to find the root cause — the first dep that
1556
+
actually failed to build (has a build layer with non-zero exit). *)
1557
+
List.iter (fun (target, solution) ->
1558
+
let bless_map = List.find_opt (fun (t, _) ->
1559
+
OpamPackage.equal t target
1560
+
) blessing_maps in
1561
+
let ordered = topological_sort solution in
1562
+
let dependencies = pkg_deps solution ordered in
1563
+
(* Find the root failing dependency by walking transitive deps *)
1564
+
let rec find_root_failure pkg visited =
1565
+
let pkg_str = OpamPackage.to_string pkg in
1566
+
if OpamPackage.Set.mem pkg visited then None
1567
+
else
1568
+
let visited = OpamPackage.Set.add pkg visited in
1569
+
(* Check if this package itself failed to build *)
1570
+
match Hashtbl.find_opt build_layer_info pkg_str with
1571
+
| Some (hash, exit_status, _) when exit_status <> 0 ->
1572
+
Some (pkg_str, hash)
1573
+
| _ ->
1574
+
(* Walk its deps to find the root cause *)
1575
+
let dep_pkgs = try OpamPackage.Set.elements (OpamPackage.Map.find pkg solution) with Not_found -> [] in
1576
+
List.find_map (fun dep -> find_root_failure dep visited) dep_pkgs
1577
+
in
1578
+
(* Compute universe hash for this target's solution *)
1579
+
let target_universe_hash =
1580
+
let build_hashes = List.filter_map (fun pkg ->
1581
+
let ordered_deps = extract_dag dependencies pkg |> topological_sort |> List.rev |> List.tl in
1582
+
let hash = cached_layer_hash ~t:t_for_hash (pkg :: ordered_deps) in
1583
+
Some ("build-" ^ hash)
1584
+
) ordered in
1585
+
Odoc_gen.compute_universe_hash build_hashes
1586
+
in
1587
+
OpamPackage.Map.iter (fun pkg _deps ->
1435
1588
let pkg_str = OpamPackage.to_string pkg in
1436
1589
if not (Hashtbl.mem built_packages pkg_str) then begin
1437
-
(* Find which dep failed by checking build_layer_info *)
1438
-
let dep_pkgs = OpamPackage.Set.elements deps in
1439
-
let failed_dep_info = List.find_map (fun dep ->
1440
-
let dep_str = OpamPackage.to_string dep in
1441
-
match Hashtbl.find_opt build_layer_info dep_str with
1442
-
| Some (hash, exit_status, _) when exit_status <> 0 ->
1443
-
Some (dep_str, hash)
1444
-
| _ -> None
1445
-
) dep_pkgs in
1590
+
let failed_dep_info = find_root_failure pkg OpamPackage.Set.empty in
1446
1591
let failed_dep, failed_dep_hash = match failed_dep_info with
1447
1592
| Some (dep, hash) -> (Some dep, Some hash)
1448
1593
| None -> (None, None)
1449
1594
in
1595
+
let is_blessed = match bless_map with
1596
+
| Some (_, map) -> Blessing.is_blessed map pkg
1597
+
| None -> false
1598
+
in
1450
1599
record_build_result ~packages_dir ~run_id ~pkg_str
1451
-
~build_hash:"none" ~compiler:"" ~blessed:false
1600
+
~build_hash:("universe-" ^ target_universe_hash) ~compiler:"" ~blessed:is_blessed
1452
1601
~status:"failure" ~category:"dependency_failure"
1453
1602
?failed_dep ?failed_dep_hash ()
1454
1603
end
1455
1604
) solution
1456
1605
) solutions;
1606
+
(* Write universe JSON files: for each target/solution, compute universe hash
1607
+
and write a file listing the packages in that universe *)
1608
+
let universes_dir = Path.(layer_dir / "universes") in
1609
+
(try Unix.mkdir universes_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
1610
+
let universe_hashes_written = Hashtbl.create 64 in
1611
+
List.iter (fun (_target, solution) ->
1612
+
let ordered = topological_sort solution in
1613
+
let dependencies = pkg_deps solution ordered in
1614
+
(* Compute build hashes for all packages in this solution *)
1615
+
let build_hashes = List.filter_map (fun pkg ->
1616
+
let ordered_deps = extract_dag dependencies pkg |> topological_sort |> List.rev |> List.tl in
1617
+
let hash = cached_layer_hash ~t:t_for_hash (pkg :: ordered_deps) in
1618
+
Some ("build-" ^ hash)
1619
+
) ordered in
1620
+
let universe_hash = Odoc_gen.compute_universe_hash build_hashes in
1621
+
if not (Hashtbl.mem universe_hashes_written universe_hash) then begin
1622
+
Hashtbl.replace universe_hashes_written universe_hash true;
1623
+
let universe_file = Path.(universes_dir / universe_hash ^ ".json") in
1624
+
let pkg_list = List.map (fun pkg ->
1625
+
`String (OpamPackage.to_string pkg)
1626
+
) ordered in
1627
+
let json = `Assoc [
1628
+
("universe_hash", `String universe_hash);
1629
+
("packages", `List pkg_list);
1630
+
("package_count", `Int (List.length ordered));
1631
+
] in
1632
+
let tmp = universe_file ^ ".tmp" in
1633
+
let oc = open_out tmp in
1634
+
Fun.protect ~finally:(fun () -> close_out oc) (fun () ->
1635
+
output_string oc (Yojson.Safe.pretty_to_string json);
1636
+
output_char oc '\n');
1637
+
Sys.rename tmp universe_file
1638
+
end
1639
+
) solutions;
1640
+
Printf.printf " Universes written: %d\n%!" (Hashtbl.length universe_hashes_written);
1457
1641
let html_versions = match config.html_output with
1458
1642
| None -> 0
1459
1643
| Some html_dir ->
···
1945
2129
let batch_info = Cmd.info "batch" ~doc:"Solve all targets, compute blessings, then build with pre-computed blessing maps" in
1946
2130
Cmd.v batch_info batch_term
1947
2131
1948
-
let run_status ~cache_dir ~format ~arch ~os_distribution ~os_version =
2132
+
(** Compute universe hash from a build layer's layer.json hashes field *)
2133
+
let universe_hash_of_layer ~os_dir layer_name =
2134
+
(* For dependency failures, the build_hash is "universe-{hash}" directly *)
2135
+
if String.length layer_name > 9 && String.sub layer_name 0 9 = "universe-" then
2136
+
Some (String.sub layer_name 9 (String.length layer_name - 9))
2137
+
else
2138
+
let layer_json = Path.(os_dir / layer_name / "layer.json") in
2139
+
if Sys.file_exists layer_json then
2140
+
try
2141
+
let json = Yojson.Safe.from_file layer_json in
2142
+
let open Yojson.Safe.Util in
2143
+
let hashes = json |> member "hashes" |> to_list |> List.map to_string in
2144
+
(* Universe hash includes this layer's own hash too *)
2145
+
Some (Odoc_gen.compute_universe_hash (hashes @ [layer_name]))
2146
+
with _ -> None
2147
+
else None
2148
+
2149
+
(** Get the log file path for a layer *)
2150
+
let log_path_of_layer ~os_dir layer_name =
2151
+
if String.length layer_name > 6 && String.sub layer_name 0 6 = "build-" then
2152
+
let p = Path.(os_dir / layer_name / "build.log") in
2153
+
if Sys.file_exists p then Some p else None
2154
+
else if String.length layer_name > 4 && String.sub layer_name 0 4 = "doc-" then
2155
+
let p = Path.(os_dir / layer_name / "odoc-voodoo-all.log") in
2156
+
if Sys.file_exists p then Some p else None
2157
+
else None
2158
+
2159
+
(** Enrich a history entry JSON with universe hash and log path *)
2160
+
let enrich_entry_json ~os_dir (e : Day10_lib.History.entry) =
2161
+
let base = Day10_lib.History.entry_to_json e in
2162
+
let extra = ref [] in
2163
+
(match universe_hash_of_layer ~os_dir e.build_hash with
2164
+
| Some h -> extra := ("universe_hash", `String h) :: !extra
2165
+
| None -> ());
2166
+
(match log_path_of_layer ~os_dir e.build_hash with
2167
+
| Some p -> extra := ("log_path", `String p) :: !extra
2168
+
| None -> ());
2169
+
match base with
2170
+
| `Assoc fields -> `Assoc (fields @ !extra)
2171
+
| _ -> base
2172
+
2173
+
let print_entry_detail ~os_dir (e : Day10_lib.History.entry) ~prefix =
2174
+
let indent = String.make (String.length prefix) ' ' in
2175
+
let universe_str = match universe_hash_of_layer ~os_dir e.build_hash with
2176
+
| Some h -> Printf.sprintf " [universe %s]" h
2177
+
| None -> ""
2178
+
in
2179
+
Printf.printf "%s%s (%s) — %s%s\n" prefix e.build_hash e.compiler e.category universe_str;
2180
+
(match e.category with
2181
+
| "dependency_failure" ->
2182
+
(match e.failed_dep with
2183
+
| Some dep ->
2184
+
Printf.printf "%s root cause: %s%s\n" indent dep
2185
+
(match e.failed_dep_hash with Some h -> Printf.sprintf " (%s)" h | None -> "");
2186
+
Printf.printf "%s → day10 log %s\n" indent
2187
+
(match e.failed_dep_hash with Some h -> h | None -> "<hash>")
2188
+
| None ->
2189
+
Printf.printf "%s (root cause unknown — re-run batch to populate)\n" indent)
2190
+
| _ ->
2191
+
(match e.error with Some err -> Printf.printf "%s error: %s\n" indent err | None -> ()))
2192
+
2193
+
let run_status ~cache_dir ~format ~arch ~os_distribution ~os_version ~details =
1949
2194
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
1950
2195
let os_dir = Path.(cache_dir / os_key) in
2196
+
let packages_dir = Path.(os_dir / "packages") in
1951
2197
match Day10_lib.Status_index.read ~dir:os_dir with
1952
2198
| None ->
1953
2199
Printf.eprintf "No status index found. Run a batch build first.\n%!";
1954
2200
1
1955
2201
| Some status ->
2202
+
let blessed_total = List.fold_left (fun acc (_, v) -> acc + v) 0 status.blessed_totals in
2203
+
let non_blessed_total = List.fold_left (fun acc (_, v) -> acc + v) 0 status.non_blessed_totals in
1956
2204
if format = "json" then begin
1957
-
print_string (Yojson.Safe.pretty_to_string (Day10_lib.Status_index.to_json status));
2205
+
let json = Day10_lib.Status_index.to_json status in
2206
+
let extra_fields = [
2207
+
("blessed_total", `Int blessed_total);
2208
+
("non_blessed_total", `Int non_blessed_total);
2209
+
] in
2210
+
let extra_fields =
2211
+
if details then begin
2212
+
(* Collect failure details *)
2213
+
let failure_details =
2214
+
if Sys.file_exists packages_dir then begin
2215
+
let pkg_dirs = try Sys.readdir packages_dir |> Array.to_list with _ -> [] in
2216
+
List.fold_left (fun acc pkg_str ->
2217
+
let entries = Day10_lib.History.read_latest ~packages_dir ~pkg_str in
2218
+
let failing = List.filter (fun (e : Day10_lib.History.entry) ->
2219
+
e.status = "failure"
2220
+
) entries in
2221
+
List.map (fun (e : Day10_lib.History.entry) ->
2222
+
`Assoc [
2223
+
("package", `String pkg_str);
2224
+
("build_hash", `String e.build_hash);
2225
+
("category", `String e.category);
2226
+
("compiler", `String e.compiler);
2227
+
("blessed", `Bool e.blessed);
2228
+
("error", match e.error with Some s -> `String s | None -> `Null);
2229
+
("failed_dep", match e.failed_dep with Some s -> `String s | None -> `Null);
2230
+
]
2231
+
) failing @ acc
2232
+
) [] pkg_dirs
2233
+
end else []
2234
+
in
2235
+
extra_fields @ [
2236
+
("failure_details", `List failure_details);
2237
+
]
2238
+
end else extra_fields
2239
+
in
2240
+
let merged = match json with
2241
+
| `Assoc fields -> `Assoc (fields @ extra_fields)
2242
+
| _ -> json
2243
+
in
2244
+
print_string (Yojson.Safe.pretty_to_string merged);
1958
2245
print_newline ();
1959
2246
0
1960
2247
end else begin
1961
2248
Printf.printf "Run: %s (generated %s)\n" status.run_id status.generated;
1962
-
Printf.printf "Blessed: %s\n"
1963
-
(String.concat ", " (List.map (fun (k, v) -> Printf.sprintf "%d %s" v k) status.blessed_totals));
1964
-
Printf.printf "Non-blessed: %s\n"
1965
-
(String.concat ", " (List.map (fun (k, v) -> Printf.sprintf "%d %s" v k) status.non_blessed_totals));
2249
+
Printf.printf "Blessed: %d total — %s\n" blessed_total
2250
+
(String.concat " / " (List.map (fun (k, v) -> Printf.sprintf "%d %s" v k) status.blessed_totals));
2251
+
Printf.printf "Non-blessed: %d total — %s\n" non_blessed_total
2252
+
(String.concat " / " (List.map (fun (k, v) -> Printf.sprintf "%d %s" v k) status.non_blessed_totals));
1966
2253
if status.changes <> [] then begin
1967
2254
Printf.printf "Changes (blessed):\n";
1968
2255
List.iter (fun (c : Day10_lib.Status_index.change) ->
···
1972
2259
c.package c.from_status c.to_status
1973
2260
) status.changes
1974
2261
end;
1975
-
if status.new_packages <> [] then
2262
+
if status.new_packages <> [] then begin
1976
2263
Printf.printf "New packages: %d\n" (List.length status.new_packages);
2264
+
if details then
2265
+
List.iter (fun pkg -> Printf.printf " %s\n" pkg) status.new_packages
2266
+
end;
2267
+
if details then begin
2268
+
(* Collect one failure entry per package (best entry: prefer one with
2269
+
failed_dep set, then universe- over none, then blessed over not).
2270
+
Group by category. *)
2271
+
let failure_by_cat : (string, (string * Day10_lib.History.entry) list) Hashtbl.t = Hashtbl.create 16 in
2272
+
if Sys.file_exists packages_dir then begin
2273
+
let pkg_dirs = try Sys.readdir packages_dir |> Array.to_list with _ -> [] in
2274
+
List.iter (fun pkg_str ->
2275
+
let entries = Day10_lib.History.read_latest ~packages_dir ~pkg_str in
2276
+
let failing = List.filter (fun (e : Day10_lib.History.entry) -> e.status = "failure") entries in
2277
+
(* Deduplicate: group by category, pick the best entry per category *)
2278
+
let by_cat : (string, Day10_lib.History.entry list) Hashtbl.t = Hashtbl.create 4 in
2279
+
List.iter (fun (e : Day10_lib.History.entry) ->
2280
+
let existing = try Hashtbl.find by_cat e.category with Not_found -> [] in
2281
+
Hashtbl.replace by_cat e.category (e :: existing)
2282
+
) failing;
2283
+
Hashtbl.iter (fun cat entries_for_cat ->
2284
+
(* Pick best: prefer entry with failed_dep, then blessed, then universe- over none *)
2285
+
let best = List.fold_left (fun best (e : Day10_lib.History.entry) ->
2286
+
let score e =
2287
+
(if e.Day10_lib.History.failed_dep <> None then 4 else 0)
2288
+
+ (if e.blessed then 2 else 0)
2289
+
+ (if e.build_hash <> "none" then 1 else 0)
2290
+
in
2291
+
if score e > score best then e else best
2292
+
) (List.hd entries_for_cat) (List.tl entries_for_cat) in
2293
+
let existing = try Hashtbl.find failure_by_cat cat with Not_found -> [] in
2294
+
Hashtbl.replace failure_by_cat cat ((pkg_str, best) :: existing)
2295
+
) by_cat
2296
+
) pkg_dirs
2297
+
end;
2298
+
let cats = Hashtbl.fold (fun k v acc -> (k, v) :: acc) failure_by_cat [] in
2299
+
let cats = List.sort (fun (a, _) (b, _) -> String.compare a b) cats in
2300
+
let print_failure ~blessed_marker (pkg, (e : Day10_lib.History.entry)) =
2301
+
let universe_str = match universe_hash_of_layer ~os_dir e.build_hash with
2302
+
| Some h -> Printf.sprintf " [universe %s]" (String.sub h 0 (min 12 (String.length h)))
2303
+
| None -> ""
2304
+
in
2305
+
match e.category with
2306
+
| "dependency_failure" ->
2307
+
(match e.failed_dep with
2308
+
| Some dep ->
2309
+
Printf.printf " %s%-40s dep: %-30s%s\n" blessed_marker pkg dep universe_str
2310
+
| None ->
2311
+
Printf.printf " %s%-40s (root cause unknown)%s\n" blessed_marker pkg universe_str)
2312
+
| _ ->
2313
+
let detail = match e.error with
2314
+
| Some err -> err
2315
+
| None -> e.build_hash
2316
+
in
2317
+
Printf.printf " %s%-40s %s%s\n" blessed_marker pkg detail universe_str
2318
+
in
2319
+
List.iter (fun (cat, failures) ->
2320
+
let blessed_failures = List.filter (fun (_, (e : Day10_lib.History.entry)) -> e.blessed) failures in
2321
+
let non_blessed_failures = List.filter (fun (_, (e : Day10_lib.History.entry)) -> not e.blessed) failures in
2322
+
Printf.printf "\n%s: %d total (%d blessed, %d non-blessed)\n" cat
2323
+
(List.length failures) (List.length blessed_failures) (List.length non_blessed_failures);
2324
+
List.iter (fun f -> print_failure ~blessed_marker:"[blessed] " f) blessed_failures;
2325
+
let shown = ref 0 in
2326
+
List.iter (fun f ->
2327
+
if !shown < 10 then begin
2328
+
print_failure ~blessed_marker:" " f;
2329
+
incr shown
2330
+
end
2331
+
) non_blessed_failures;
2332
+
if List.length non_blessed_failures > 10 then
2333
+
Printf.printf " ... and %d more\n" (List.length non_blessed_failures - 10)
2334
+
) cats
2335
+
end;
1977
2336
0
1978
2337
end
1979
2338
1980
2339
let status_cmd =
2340
+
let details_term =
2341
+
let doc = "Show detailed failure and new package listings" in
2342
+
Arg.(value & flag & info [ "details" ] ~doc)
2343
+
in
1981
2344
let status_term =
1982
-
Term.(const (fun cache_dir format arch _os os_distribution os_version ->
1983
-
let code = run_status ~cache_dir ~format ~arch ~os_distribution ~os_version in
2345
+
Term.(const (fun cache_dir format arch _os os_distribution os_version details ->
2346
+
let code = run_status ~cache_dir ~format ~arch ~os_distribution ~os_version ~details in
1984
2347
if code <> 0 then Stdlib.exit code)
1985
-
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term)
2348
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ details_term)
1986
2349
in
1987
2350
let status_info = Cmd.info "status" ~doc:"Show current build status overview" in
1988
2351
Cmd.v status_info status_term
1989
2352
1990
-
let run_query ~cache_dir ~format ~arch ~os_distribution ~os_version ~history ~package =
2353
+
let run_query ~cache_dir ~format ~arch ~os_distribution ~os_version ~history ~show_log ~package =
1991
2354
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
1992
-
let packages_dir = Path.(cache_dir / os_key / "packages") in
2355
+
let os_dir = Path.(cache_dir / os_key) in
2356
+
let packages_dir = Path.(os_dir / "packages") in
1993
2357
let pkg_dir = Path.(packages_dir / package) in
1994
2358
if not (Sys.file_exists pkg_dir) then begin
1995
2359
Printf.eprintf "Package %s not found\n%!" package;
···
2000
2364
let blessed = Day10_lib.History.read_blessed ~packages_dir ~pkg_str:package in
2001
2365
let json = `Assoc [
2002
2366
("package", `String package);
2003
-
("blessed", match blessed with Some e -> Day10_lib.History.entry_to_json e | None -> `Null);
2004
-
("builds", `List (List.map Day10_lib.History.entry_to_json entries));
2367
+
("blessed", match blessed with Some e -> enrich_entry_json ~os_dir e | None -> `Null);
2368
+
("builds", `List (List.map (enrich_entry_json ~os_dir) entries));
2005
2369
] in
2006
2370
print_string (Yojson.Safe.pretty_to_string json);
2007
2371
print_newline ()
···
2010
2374
(* Show blessed build *)
2011
2375
(match Day10_lib.History.read_blessed ~packages_dir ~pkg_str:package with
2012
2376
| Some e ->
2013
-
Printf.printf " Blessed: %s (%s) — %s\n" e.build_hash e.compiler e.category
2377
+
print_entry_detail ~os_dir e ~prefix:" Blessed: ";
2378
+
if show_log then begin
2379
+
match log_path_of_layer ~os_dir e.build_hash with
2380
+
| Some p ->
2381
+
Printf.printf " --- log: %s ---\n" p;
2382
+
(try
2383
+
let ic = open_in p in
2384
+
Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
2385
+
try while true do print_endline (input_line ic) done with End_of_file -> ())
2386
+
with _ -> Printf.printf " (could not read log)\n")
2387
+
| None -> Printf.printf " (no log available)\n"
2388
+
end
2014
2389
| None ->
2015
2390
Printf.printf " Blessed: none\n");
2016
2391
(* Show other builds *)
···
2019
2394
if non_blessed <> [] then begin
2020
2395
Printf.printf " Other builds:\n";
2021
2396
List.iter (fun (e : Day10_lib.History.entry) ->
2022
-
Printf.printf " %s (%s) — %s%s\n" e.build_hash e.compiler e.category
2023
-
(match e.error with Some err -> Printf.sprintf " (%s)" err | None -> "")
2397
+
print_entry_detail ~os_dir e ~prefix:" "
2024
2398
) non_blessed
2025
2399
end;
2026
2400
if history then begin
···
2043
2417
let doc = "Show full build history" in
2044
2418
Arg.(value & flag & info [ "history" ] ~doc)
2045
2419
in
2420
+
let log_term =
2421
+
let doc = "Print the build log for the blessed build" in
2422
+
Arg.(value & flag & info [ "log" ] ~doc)
2423
+
in
2046
2424
let query_term =
2047
-
Term.(const (fun cache_dir format arch _os os_distribution os_version history package ->
2048
-
run_query ~cache_dir ~format ~arch ~os_distribution ~os_version ~history ~package)
2049
-
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ history_term $ package_arg)
2425
+
Term.(const (fun cache_dir format arch _os os_distribution os_version history show_log package ->
2426
+
run_query ~cache_dir ~format ~arch ~os_distribution ~os_version ~history ~show_log ~package)
2427
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ history_term $ log_term $ package_arg)
2050
2428
in
2051
2429
let query_info = Cmd.info "query" ~doc:"Show package build details" in
2052
2430
Cmd.v query_info query_term
···
2212
2590
let disk_info = Cmd.info "disk" ~doc:"Show disk usage breakdown" in
2213
2591
Cmd.v disk_info disk_term
2214
2592
2215
-
let run_rerun ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~force ~target =
2593
+
(** Find all packages in dependency_failure whose root cause is one of the given build hashes.
2594
+
Returns one entry per package (the first matching, preferring blessed). *)
2595
+
let find_cascade_targets ~packages_dir ~build_hashes =
2596
+
let hash_set = Hashtbl.create 16 in
2597
+
List.iter (fun h -> Hashtbl.replace hash_set h true) build_hashes;
2598
+
let pkg_dirs = try Sys.readdir packages_dir |> Array.to_list with _ -> [] in
2599
+
let seen = Hashtbl.create 64 in
2600
+
List.fold_left (fun acc pkg_str ->
2601
+
if Hashtbl.mem seen pkg_str then acc
2602
+
else begin
2603
+
let entries = Day10_lib.History.read_latest ~packages_dir ~pkg_str in
2604
+
let dep_failures = List.filter (fun (e : Day10_lib.History.entry) ->
2605
+
e.category = "dependency_failure" &&
2606
+
(match e.failed_dep_hash with
2607
+
| Some h -> Hashtbl.mem hash_set h
2608
+
| None -> false)
2609
+
) entries in
2610
+
match dep_failures with
2611
+
| [] -> acc
2612
+
| _ ->
2613
+
Hashtbl.replace seen pkg_str true;
2614
+
(* Prefer the blessed entry if there is one *)
2615
+
let best = match List.find_opt (fun (e : Day10_lib.History.entry) -> e.blessed) dep_failures with
2616
+
| Some e -> e
2617
+
| None -> List.hd dep_failures
2618
+
in
2619
+
(pkg_str, best) :: acc
2620
+
end
2621
+
) [] pkg_dirs
2622
+
2623
+
(** Rerun a single build layer: read its layer.json for the original deps/hashes,
2624
+
delete the layer, and rebuild using exactly the same inputs. No re-solving.
2625
+
Records the result in history. *)
2626
+
let rerun_build_layer ~cache_dir ~os_key ~opam_repositories ~arch ~os ~os_distribution ~os_family ~os_version ~packages_dir ~run_id ~build_hash =
2627
+
let layer_dir = Path.(cache_dir / os_key / build_hash) in
2628
+
let layer_json = Path.(layer_dir / "layer.json") in
2629
+
if not (Sys.file_exists layer_json) then begin
2630
+
Printf.eprintf "Build layer %s not found (no layer.json)\n%!" build_hash;
2631
+
false
2632
+
end else begin
2633
+
let json = Yojson.Safe.from_file layer_json in
2634
+
let open Yojson.Safe.Util in
2635
+
let pkg_str = json |> member "package" |> to_string in
2636
+
let compiler = extract_compiler_from_deps json in
2637
+
(* Look up blessed status from existing history *)
2638
+
let blessed = match Day10_lib.History.read_blessed ~packages_dir ~pkg_str with
2639
+
| Some e -> e.build_hash = build_hash
2640
+
| None -> false
2641
+
in
2642
+
let pkg = match OpamPackage.of_string_opt pkg_str with
2643
+
| Some p -> p
2644
+
| None -> Printf.eprintf "Invalid package name in layer.json: %s\n%!" pkg_str; Stdlib.exit 1
2645
+
in
2646
+
let ordered_deps = json |> member "deps" |> to_list |> List.filter_map (fun j ->
2647
+
OpamPackage.of_string_opt (to_string j)
2648
+
) in
2649
+
let ordered_build_hashes = json |> member "hashes" |> to_list |> List.map to_string in
2650
+
Printf.printf "Rerunning %s (%s)\n%!" pkg_str build_hash;
2651
+
Printf.printf " Removing cached layer...\n%!";
2652
+
let _ = Os.sudo ["rm"; "-rf"; layer_dir] in
2653
+
(* Build a minimal config — only what build_layer needs *)
2654
+
let config : Config.t = {
2655
+
dir = cache_dir; ocaml_version = None; opam_repositories;
2656
+
package = pkg_str; arch; os; os_distribution; os_family; os_version;
2657
+
directory = None; md = None; json = None; dot = None;
2658
+
with_test = false; with_doc = false; with_jtw = false;
2659
+
doc_tools_repo = ""; doc_tools_branch = "";
2660
+
jtw_tools_repo = ""; jtw_tools_branch = "";
2661
+
local_repos = []; html_output = None; jtw_output = None; tag = None;
2662
+
log = false; dry_run = false; fork = None; prune_layers = false; blessed_map = None;
2663
+
} in
2664
+
let t = Container.init ~config in
2665
+
let result = build_layer t pkg build_hash ordered_deps ordered_build_hashes in
2666
+
let (success, status, category, error) = match result with
2667
+
| Success _ -> (true, "success", "success", None)
2668
+
| Failure _msg ->
2669
+
let (_s, cat, err) = classify_build_failure Path.(layer_dir / "build.log") in
2670
+
(false, "failure", cat, err)
2671
+
| _ -> (false, "failure", "build_failure", Some "unexpected result")
2672
+
in
2673
+
Printf.printf " Result: %s\n%!" category;
2674
+
record_build_result ~packages_dir ~run_id ~pkg_str ~build_hash
2675
+
~compiler ~blessed ~status ~category ?error ();
2676
+
success
2677
+
end
2678
+
2679
+
(** After a cascade rebuild via run_health_check, scan the package's build layers
2680
+
and record history entries for any new/changed layers.
2681
+
[was_blessed] indicates whether the original dependency_failure entry was blessed —
2682
+
if so, any new build layer for this package inherits blessed status. *)
2683
+
let record_cascade_results ~cache_dir ~os_key ~packages_dir ~run_id ~pkg_str ~was_blessed =
2684
+
let os_dir = Path.(cache_dir / os_key) in
2685
+
let pkg_dir = Path.(packages_dir / pkg_str) in
2686
+
if Sys.file_exists pkg_dir then begin
2687
+
(* Find build-* and doc-* symlinks in the package directory *)
2688
+
try
2689
+
Sys.readdir pkg_dir |> Array.iter (fun name ->
2690
+
if String.length name > 6 && String.sub name 0 6 = "build-" then begin
2691
+
let layer_json = Path.(os_dir / name / "layer.json") in
2692
+
if Sys.file_exists layer_json then begin
2693
+
try
2694
+
let json = Yojson.Safe.from_file layer_json in
2695
+
let open Yojson.Safe.Util in
2696
+
let exit_status = try json |> member "exit_status" |> to_int with _ -> -1 in
2697
+
let compiler = extract_compiler_from_deps json in
2698
+
let (status, category, error) =
2699
+
if exit_status = 0 then ("success", "success", None)
2700
+
else
2701
+
let (_s, cat, err) = classify_build_failure Path.(os_dir / name / "build.log") in
2702
+
("failure", cat, match err with Some _ -> err | None -> Some (Printf.sprintf "exit code %d" exit_status))
2703
+
in
2704
+
record_build_result ~packages_dir ~run_id ~pkg_str ~build_hash:name
2705
+
~compiler ~blessed:was_blessed ~status ~category ?error ()
2706
+
with _ -> ()
2707
+
end
2708
+
end;
2709
+
if String.length name > 4 && String.sub name 0 4 = "doc-" then begin
2710
+
let layer_json = Path.(os_dir / name / "layer.json") in
2711
+
if Sys.file_exists layer_json then begin
2712
+
try
2713
+
let json = Yojson.Safe.from_file layer_json in
2714
+
let open Yojson.Safe.Util in
2715
+
let exit_status = try json |> member "exit_status" |> to_int with _ -> -1 in
2716
+
if exit_status <> 0 then begin
2717
+
let compiler = extract_compiler_from_deps json in
2718
+
let (_s, category, err) = classify_build_failure Path.(os_dir / name / "odoc-voodoo-all.log") in
2719
+
let error = match err with Some _ -> err | None -> Some (Printf.sprintf "doc exit code %d" exit_status) in
2720
+
record_build_result ~packages_dir ~run_id ~pkg_str ~build_hash:name
2721
+
~compiler ~blessed:was_blessed ~status:"failure" ~category ?error ()
2722
+
end
2723
+
with _ -> ()
2724
+
end
2725
+
end
2726
+
)
2727
+
with _ -> ()
2728
+
end
2729
+
2730
+
let run_rerun ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~cascade ~target =
2216
2731
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
2217
2732
let packages_dir = Path.(cache_dir / os_key / "packages") in
2733
+
let run_id = Printf.sprintf "rerun-%s" (Day10_lib.Run_log.format_time (Unix.gettimeofday ())) in
2218
2734
(* Determine if target is a build hash or package name *)
2219
-
let is_hash = String.length target > 6 && String.sub target 0 6 = "build-" in
2735
+
let is_build_hash = String.length target > 6 && String.sub target 0 6 = "build-" in
2220
2736
let builds_to_rerun =
2221
-
if is_hash then begin
2737
+
if is_build_hash then begin
2222
2738
(* Read layer.json to get package name *)
2223
2739
let layer_json = Path.(cache_dir / os_key / target / "layer.json") in
2224
2740
if not (Sys.file_exists layer_json) then begin
···
2229
2745
let pkg_name = Yojson.Safe.Util.(json |> member "package" |> to_string) in
2230
2746
[(pkg_name, target)]
2231
2747
end else begin
2232
-
(* Package name: find all failing builds *)
2748
+
(* Package name: find all failing builds that have real build hashes *)
2233
2749
let entries = Day10_lib.History.read_latest ~packages_dir ~pkg_str:target in
2234
-
let failing = List.filter (fun (e : Day10_lib.History.entry) -> e.status = "failure") entries in
2750
+
let failing = List.filter (fun (e : Day10_lib.History.entry) ->
2751
+
e.status = "failure" &&
2752
+
String.length e.build_hash > 6 && String.sub e.build_hash 0 6 = "build-"
2753
+
) entries in
2235
2754
if failing = [] then begin
2236
-
Printf.eprintf "No failing builds for %s\n%!" target;
2755
+
Printf.eprintf "No failing builds with rerunnable layers for %s\n%!" target;
2237
2756
Stdlib.exit 1
2238
2757
end;
2239
2758
List.map (fun (e : Day10_lib.History.entry) -> (target, e.build_hash)) failing
···
2243
2762
let results = List.map (fun (pkg_name, build_hash) ->
2244
2763
`Assoc [("package", `String pkg_name); ("build_hash", `String build_hash); ("action", `String "rerun")]
2245
2764
) builds_to_rerun in
2246
-
print_string (Yojson.Safe.pretty_to_string (`List results));
2765
+
let cascade_targets =
2766
+
if cascade then
2767
+
let hashes = List.map snd builds_to_rerun in
2768
+
find_cascade_targets ~packages_dir ~build_hashes:hashes
2769
+
else []
2770
+
in
2771
+
let cascade_json = List.map (fun (pkg, (e : Day10_lib.History.entry)) ->
2772
+
`Assoc [("package", `String pkg); ("build_hash", `String e.build_hash);
2773
+
("failed_dep_hash", match e.failed_dep_hash with Some h -> `String h | None -> `Null);
2774
+
("action", `String "cascade")]
2775
+
) cascade_targets in
2776
+
print_string (Yojson.Safe.pretty_to_string (`List (results @ cascade_json)));
2247
2777
print_newline ()
2248
2778
end else begin
2249
-
List.iter (fun (pkg_name, build_hash) ->
2250
-
Printf.printf "Rerunning %s (build %s)%s\n%!" pkg_name build_hash
2251
-
(if force then " [force]" else "");
2252
-
if force then begin
2253
-
let layer_dir = Path.(cache_dir / os_key / build_hash) in
2254
-
if Sys.file_exists layer_dir then begin
2255
-
Printf.printf " Removing cached layer %s\n%!" build_hash;
2256
-
let _ = Os.sudo ["rm"; "-rf"; layer_dir] in ()
2257
-
end
2258
-
end;
2259
-
(* Re-invoke build via run_health_check *)
2260
-
let ocaml_version = None in
2261
-
run_health_check { dir = cache_dir; ocaml_version; opam_repositories; package = pkg_name;
2262
-
arch; os; os_distribution; os_family; os_version;
2263
-
directory = None; md = None; json = None; dot = None;
2264
-
with_test = false; with_doc = true; with_jtw = false;
2265
-
doc_tools_repo = "https://github.com/ocaml/odoc.git"; doc_tools_branch = "master";
2266
-
jtw_tools_repo = ""; jtw_tools_branch = "";
2267
-
local_repos = []; html_output = None; jtw_output = None; tag = None;
2268
-
log = false; dry_run = false; fork = None; prune_layers = false; blessed_map = None }
2269
-
) builds_to_rerun
2779
+
let rerun_hashes = List.map snd builds_to_rerun in
2780
+
(* Rerun: delete layer, rebuild with same deps/hashes *)
2781
+
let succeeded = List.filter_map (fun (_pkg_name, build_hash) ->
2782
+
if rerun_build_layer ~cache_dir ~os_key ~opam_repositories ~arch ~os ~os_distribution ~os_family ~os_version ~packages_dir ~run_id ~build_hash then
2783
+
Some build_hash
2784
+
else
2785
+
None
2786
+
) builds_to_rerun in
2787
+
(* Cascade: for builds that succeeded, find and rerun their dep-failure dependants *)
2788
+
if cascade && succeeded <> [] then begin
2789
+
let cascade_targets = find_cascade_targets ~packages_dir ~build_hashes:rerun_hashes in
2790
+
if cascade_targets <> [] then begin
2791
+
(* Read build-config.json from last batch run for doc tools etc *)
2792
+
let build_config_path = Path.(cache_dir / os_key / "build-config.json") in
2793
+
let (with_doc, doc_tools_repo, doc_tools_branch, jtw_tools_repo, jtw_tools_branch,
2794
+
html_output, jtw_output, local_repos) =
2795
+
if Sys.file_exists build_config_path then begin
2796
+
try
2797
+
let json = Yojson.Safe.from_file build_config_path in
2798
+
let open Yojson.Safe.Util in
2799
+
let s key default = json |> member key |> to_string_option |> Option.value ~default in
2800
+
let b key default = json |> member key |> to_bool_option |> Option.value ~default in
2801
+
let so key = json |> member key |> to_string_option in
2802
+
let sl key = try json |> member key |> to_list |> List.map to_string with _ -> [] in
2803
+
Printf.printf "Using batch config from %s\n%!" build_config_path;
2804
+
(b "with_doc" false,
2805
+
s "doc_tools_repo" "", s "doc_tools_branch" "",
2806
+
s "jtw_tools_repo" "", s "jtw_tools_branch" "",
2807
+
so "html_output", so "jtw_output", sl "local_repos")
2808
+
with _ ->
2809
+
Printf.printf "Warning: could not read %s, cascading without docs\n%!" build_config_path;
2810
+
(false, "", "", "", "", None, None, [])
2811
+
end else begin
2812
+
Printf.printf "Warning: no build-config.json found, cascading without docs\n%!";
2813
+
(false, "", "", "", "", None, None, [])
2814
+
end
2815
+
in
2816
+
Printf.printf "Cascading to %d packages with dependency_failure on rerun targets%s:\n%!"
2817
+
(List.length cascade_targets) (if with_doc then " (with docs)" else "");
2818
+
List.iter (fun (pkg, (e : Day10_lib.History.entry)) ->
2819
+
Printf.printf " %s (was blocked on %s)\n%!" pkg
2820
+
(match e.failed_dep with Some d -> d | None -> "unknown");
2821
+
run_health_check { dir = cache_dir; ocaml_version = None; opam_repositories;
2822
+
package = pkg; arch; os; os_distribution; os_family; os_version;
2823
+
directory = None; md = None; json = None; dot = None;
2824
+
with_test = false; with_doc; with_jtw = false;
2825
+
doc_tools_repo; doc_tools_branch;
2826
+
jtw_tools_repo; jtw_tools_branch;
2827
+
local_repos; html_output; jtw_output; tag = None;
2828
+
log = false; dry_run = false; fork = None; prune_layers = false; blessed_map = None };
2829
+
record_cascade_results ~cache_dir ~os_key ~packages_dir ~run_id ~pkg_str:pkg ~was_blessed:e.blessed
2830
+
) cascade_targets
2831
+
end else
2832
+
Printf.printf "\nNo cascade targets found.\n%!"
2833
+
end;
2834
+
(* Regenerate status.json to reflect rerun/cascade results *)
2835
+
let os_dir = Path.(cache_dir / os_key) in
2836
+
let previous = Day10_lib.Status_index.read ~dir:os_dir in
2837
+
let status = Day10_lib.Status_index.generate ~packages_dir ~run_id ~previous in
2838
+
Day10_lib.Status_index.write ~dir:os_dir status;
2839
+
Printf.printf "\nRegenerated status.json (run: %s)\n%!" run_id
2270
2840
end
2271
2841
2272
2842
let rerun_cmd =
···
2274
2844
let doc = "Build hash or package name to rerun" in
2275
2845
Arg.(required & pos 0 (some string) None & info [] ~docv:"TARGET" ~doc)
2276
2846
in
2277
-
let force_term =
2278
-
let doc = "Force rerun by removing cached layers first" in
2279
-
Arg.(value & flag & info [ "force" ] ~doc)
2847
+
let cascade_term =
2848
+
let doc = "After rerunning, also rebuild packages whose dependency_failure was caused by this build" in
2849
+
Arg.(value & flag & info [ "cascade" ] ~doc)
2280
2850
in
2281
2851
let rerun_term =
2282
-
Term.(const (fun cache_dir format arch os os_distribution os_family os_version opam_repositories force target ->
2283
-
run_rerun ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~force ~target)
2284
-
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_family_term $ os_version_term $ opam_repository_term $ force_term $ target_arg)
2852
+
Term.(const (fun cache_dir format arch os os_distribution os_family os_version opam_repositories cascade target ->
2853
+
run_rerun ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~cascade ~target)
2854
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_family_term $ os_version_term $ opam_repository_term $ cascade_term $ target_arg)
2285
2855
in
2286
2856
let rerun_info = Cmd.info "rerun" ~doc:"Retry a failed build" in
2287
2857
Cmd.v rerun_info rerun_term
···
2386
2956
let notify_info = Cmd.info "notify" ~doc:"Send a notification via configured channel" in
2387
2957
Cmd.v notify_info notify_term
2388
2958
2389
-
let run_cascade ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~blessed_first ~dry_run =
2959
+
let run_cascade ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~blessed_first ~dry_run ~fork =
2390
2960
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
2391
2961
let os_dir = Path.(cache_dir / os_key) in
2392
2962
let packages_dir = Path.(os_dir / "packages") in
2393
-
(* Find packages that recently transitioned to success *)
2394
-
let recently_fixed = match Day10_lib.Status_index.read ~dir:os_dir with
2395
-
| None -> []
2396
-
| Some status ->
2397
-
List.filter_map (fun (c : Day10_lib.Status_index.change) ->
2398
-
if c.to_status = "success" then Some c.package else None
2399
-
) status.changes
2400
-
in
2401
-
if recently_fixed = [] then begin
2402
-
if format = "json" then
2403
-
print_endline "[]"
2404
-
else
2405
-
Printf.printf "No recently fixed packages found\n%!";
2406
-
Stdlib.exit 0
2407
-
end;
2408
-
(* For each fixed package, find rdeps in dependency_failure *)
2409
-
let solutions_dir = Path.(cache_dir / "solutions") in
2410
-
let find_rdeps_in_dep_failure pkg =
2411
-
let rdeps = Hashtbl.create 64 in
2412
-
(try
2413
-
Sys.readdir solutions_dir |> Array.iter (fun sha_dir ->
2414
-
let sha_path = Path.(solutions_dir / sha_dir) in
2415
-
if try Sys.is_directory sha_path with _ -> false then
2416
-
try
2417
-
Sys.readdir sha_path |> Array.iter (fun sol_file ->
2418
-
if Filename.check_suffix sol_file ".json" then
2419
-
try
2420
-
let json = Yojson.Safe.from_file Path.(sha_path / sol_file) in
2421
-
let open Yojson.Safe.Util in
2422
-
let failed_check = json |> member "failed" |> to_bool_option in
2423
-
if failed_check <> Some true then begin
2424
-
let pkg_str = json |> member "package" |> to_string in
2425
-
let solution = json |> member "solution" in
2426
-
let deps = solution |> keys in
2427
-
if List.exists (fun dep ->
2428
-
(* dep is "name.version", pkg might be just "name.version" too *)
2429
-
dep = pkg || String.length dep > String.length pkg &&
2430
-
String.sub dep 0 (String.length pkg) = pkg
2431
-
) deps then begin
2432
-
if not (Hashtbl.mem rdeps pkg_str) then
2433
-
Hashtbl.add rdeps pkg_str true
2434
-
end
2435
-
end
2436
-
with _ -> ()
2437
-
)
2438
-
with _ -> ()
2439
-
)
2440
-
with _ -> ());
2441
-
(* Filter to only rdeps currently in dependency_failure *)
2442
-
Hashtbl.fold (fun k _ acc ->
2443
-
let entries = Day10_lib.History.read_latest ~packages_dir ~pkg_str:k in
2444
-
let in_dep_failure = List.exists (fun (e : Day10_lib.History.entry) ->
2445
-
e.category = "dependency_failure"
2446
-
) entries in
2447
-
if in_dep_failure then k :: acc else acc
2448
-
) rdeps []
2449
-
in
2450
-
let all_cascades = List.fold_left (fun acc pkg ->
2451
-
let rdeps = find_rdeps_in_dep_failure pkg in
2452
-
List.map (fun rdep -> (rdep, pkg)) rdeps @ acc
2453
-
) [] recently_fixed in
2963
+
(* Find all packages currently in dependency_failure whose failed dep now passes.
2964
+
Scan all package history to find dep_failure entries with a failed_dep_hash,
2965
+
then check if that dep's build layer now succeeds. *)
2966
+
let cascade_targets = ref [] in
2967
+
let pkg_dirs = try Sys.readdir packages_dir |> Array.to_list with _ -> [] in
2968
+
List.iter (fun pkg_str ->
2969
+
let latest = Day10_lib.History.read_latest ~packages_dir ~pkg_str in
2970
+
List.iter (fun (e : Day10_lib.History.entry) ->
2971
+
if e.category = "dependency_failure" then begin
2972
+
match e.failed_dep_hash with
2973
+
| Some dep_hash when String.length dep_hash > 6 && String.sub dep_hash 0 6 = "build-" ->
2974
+
(* Check if the failed dep's build layer now succeeds *)
2975
+
let dep_layer_json = Path.(os_dir / dep_hash / "layer.json") in
2976
+
let dep_now_passes =
2977
+
if Sys.file_exists dep_layer_json then
2978
+
try
2979
+
let json = Yojson.Safe.from_file dep_layer_json in
2980
+
let exit_status = Yojson.Safe.Util.(json |> member "exit_status" |> to_int) in
2981
+
exit_status = 0
2982
+
with _ -> false
2983
+
else false
2984
+
in
2985
+
if dep_now_passes then
2986
+
cascade_targets := (pkg_str, e) :: !cascade_targets
2987
+
| _ -> ()
2988
+
end
2989
+
) latest
2990
+
) pkg_dirs;
2991
+
let all_cascades = !cascade_targets in
2454
2992
(* Sort: blessed first if requested *)
2455
2993
let all_cascades =
2456
2994
if blessed_first then
2457
-
let is_blessed pkg =
2458
-
match Day10_lib.History.read_blessed ~packages_dir ~pkg_str:pkg with
2459
-
| Some _ -> true | None -> false
2460
-
in
2461
-
List.sort (fun (a, _) (b, _) ->
2462
-
compare (not (is_blessed a)) (not (is_blessed b))
2995
+
List.sort (fun (_, (a : Day10_lib.History.entry)) (_, (b : Day10_lib.History.entry)) ->
2996
+
compare (not a.blessed) (not b.blessed)
2463
2997
) all_cascades
2464
2998
else all_cascades
2465
2999
in
2466
-
(* Deduplicate *)
3000
+
(* Deduplicate by package name, keeping the blessed entry if there is one *)
2467
3001
let seen = Hashtbl.create 64 in
2468
3002
let all_cascades = List.filter (fun (pkg, _) ->
2469
3003
if Hashtbl.mem seen pkg then false
2470
3004
else begin Hashtbl.add seen pkg true; true end
2471
3005
) all_cascades in
3006
+
if all_cascades = [] then begin
3007
+
if format = "json" then
3008
+
print_endline "[]"
3009
+
else
3010
+
Printf.printf "No cascade targets found (no dependency_failure packages with now-passing deps)\n%!";
3011
+
Stdlib.exit 0
3012
+
end;
2472
3013
if format = "json" then begin
2473
-
let json = `List (List.map (fun (pkg, fixed_dep) ->
2474
-
`Assoc [("package", `String pkg); ("fixed_dep", `String fixed_dep);
3014
+
let json = `List (List.map (fun (pkg, (e : Day10_lib.History.entry)) ->
3015
+
`Assoc [("package", `String pkg);
3016
+
("failed_dep", match e.failed_dep with Some d -> `String d | None -> `Null);
3017
+
("failed_dep_hash", match e.failed_dep_hash with Some h -> `String h | None -> `Null);
3018
+
("blessed", `Bool e.blessed);
2475
3019
("action", `String (if dry_run then "would_rerun" else "rerun"))]
2476
3020
) all_cascades) in
2477
3021
print_string (Yojson.Safe.pretty_to_string json);
···
2481
3025
Printf.printf "Would cascade rerun %d packages:\n%!" (List.length all_cascades)
2482
3026
else
2483
3027
Printf.printf "Cascading rerun for %d packages:\n%!" (List.length all_cascades);
2484
-
List.iter (fun (pkg, fixed_dep) ->
2485
-
Printf.printf " %-40s (dep %s fixed)\n%!" pkg fixed_dep
3028
+
List.iter (fun (pkg, (e : Day10_lib.History.entry)) ->
3029
+
let dep_info = match e.failed_dep with Some d -> d | None -> "unknown" in
3030
+
let blessed_marker = if e.blessed then " [blessed]" else "" in
3031
+
Printf.printf " %-40s (dep %s now passes)%s\n%!" pkg dep_info blessed_marker
2486
3032
) all_cascades;
2487
3033
if not dry_run then begin
2488
-
List.iter (fun (pkg, _) ->
3034
+
(* Read build-config.json from last batch run *)
3035
+
let build_config_path = Path.(cache_dir / os_key / "build-config.json") in
3036
+
let (with_doc, doc_tools_repo, doc_tools_branch, jtw_tools_repo, jtw_tools_branch,
3037
+
html_output, jtw_output, local_repos) =
3038
+
if Sys.file_exists build_config_path then begin
3039
+
try
3040
+
let json = Yojson.Safe.from_file build_config_path in
3041
+
let open Yojson.Safe.Util in
3042
+
let s key default = json |> member key |> to_string_option |> Option.value ~default in
3043
+
let b key default = json |> member key |> to_bool_option |> Option.value ~default in
3044
+
let so key = json |> member key |> to_string_option in
3045
+
let sl key = try json |> member key |> to_list |> List.map to_string with _ -> [] in
3046
+
Printf.printf "Using batch config from %s\n%!" build_config_path;
3047
+
(b "with_doc" false,
3048
+
s "doc_tools_repo" "", s "doc_tools_branch" "",
3049
+
s "jtw_tools_repo" "", s "jtw_tools_branch" "",
3050
+
so "html_output", so "jtw_output", sl "local_repos")
3051
+
with _ ->
3052
+
Printf.printf "Warning: could not read %s, cascading without docs\n%!" build_config_path;
3053
+
(false, "", "", "", "", None, None, [])
3054
+
end else begin
3055
+
Printf.printf "Warning: no build-config.json found, cascading without docs\n%!";
3056
+
(false, "", "", "", "", None, None, [])
3057
+
end
3058
+
in
3059
+
if with_doc then Printf.printf "Building with docs enabled\n%!";
3060
+
let run_id = Printf.sprintf "cascade-%s" (Day10_lib.Run_log.format_time (Unix.gettimeofday ())) in
3061
+
let run_one (pkg, (e : Day10_lib.History.entry)) =
2489
3062
Printf.printf "Rerunning %s...\n%!" pkg;
2490
3063
run_health_check { dir = cache_dir; ocaml_version = None; opam_repositories;
2491
3064
package = pkg; arch; os; os_distribution; os_family; os_version;
2492
3065
directory = None; md = None; json = None; dot = None;
2493
-
with_test = false; with_doc = true; with_jtw = false;
2494
-
doc_tools_repo = "https://github.com/ocaml/odoc.git"; doc_tools_branch = "master";
2495
-
jtw_tools_repo = ""; jtw_tools_branch = "";
2496
-
local_repos = []; html_output = None; jtw_output = None; tag = None;
2497
-
log = false; dry_run = false; fork = None; prune_layers = false; blessed_map = None }
2498
-
) all_cascades
3066
+
with_test = false; with_doc; with_jtw = false;
3067
+
doc_tools_repo; doc_tools_branch;
3068
+
jtw_tools_repo; jtw_tools_branch;
3069
+
local_repos; html_output; jtw_output; tag = None;
3070
+
log = false; dry_run = false; fork = None; prune_layers = false; blessed_map = None };
3071
+
record_cascade_results ~cache_dir ~os_key ~packages_dir ~run_id ~pkg_str:pkg ~was_blessed:e.blessed
3072
+
in
3073
+
(match fork with
3074
+
| Some n when n > 1 ->
3075
+
let completed = ref 0 in
3076
+
let failed = ref 0 in
3077
+
let total = List.length all_cascades in
3078
+
let on_complete exit_code =
3079
+
incr completed;
3080
+
if exit_code <> 0 then incr failed;
3081
+
if !completed mod 25 = 0 || !completed = total then
3082
+
Printf.printf "\r%-60s\r[Cascade] %d/%d completed%s%!"
3083
+
"" !completed total
3084
+
(if !failed > 0 then Printf.sprintf " (%d failed)" !failed else "")
3085
+
in
3086
+
Os.fork_with_progress ~np:n ~on_complete run_one all_cascades;
3087
+
Printf.printf "\n%!"
3088
+
| _ ->
3089
+
List.iter run_one all_cascades);
3090
+
(* Regenerate status.json *)
3091
+
let previous = Day10_lib.Status_index.read ~dir:os_dir in
3092
+
let status = Day10_lib.Status_index.generate ~packages_dir ~run_id ~previous in
3093
+
Day10_lib.Status_index.write ~dir:os_dir status;
3094
+
Printf.printf "\nRegenerated status.json (run: %s)\n%!" run_id
2499
3095
end
2500
3096
end
2501
3097
···
2505
3101
Arg.(value & flag & info [ "blessed-first" ] ~doc)
2506
3102
in
2507
3103
let cascade_term =
2508
-
Term.(const (fun cache_dir format arch os os_distribution os_family os_version opam_repositories blessed_first dry_run ->
2509
-
run_cascade ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~blessed_first ~dry_run)
2510
-
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_family_term $ os_version_term $ opam_repository_term $ blessed_first_term $ dry_run_term)
3104
+
Term.(const (fun cache_dir format arch os os_distribution os_family os_version opam_repositories blessed_first dry_run fork ->
3105
+
run_cascade ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~blessed_first ~dry_run ~fork)
3106
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_family_term $ os_version_term $ opam_repository_term $ blessed_first_term $ dry_run_term $ fork_term)
2511
3107
in
2512
3108
let cascade_info = Cmd.info "cascade" ~doc:"Cascade reruns to reverse dependencies of recently fixed packages" in
2513
3109
Cmd.v cascade_info cascade_term
···
2562
3158
let gc_cli_info = Cmd.info "gc" ~doc:"Garbage collect logs, runs, and compact histories" in
2563
3159
Cmd.v gc_cli_info gc_cli_term
2564
3160
3161
+
let run_universe ~cache_dir ~format ~arch ~os_distribution ~os_version ~hash =
3162
+
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
3163
+
let universes_dir = Path.(cache_dir / os_key / "universes") in
3164
+
if hash = "" then begin
3165
+
(* List all universes *)
3166
+
if not (Sys.file_exists universes_dir) then begin
3167
+
Printf.eprintf "No universes directory found. Run a batch build first.\n%!";
3168
+
Stdlib.exit 1
3169
+
end;
3170
+
let files = try Sys.readdir universes_dir |> Array.to_list with _ -> [] in
3171
+
let universe_hashes = List.filter_map (fun f ->
3172
+
if Filename.check_suffix f ".json" then
3173
+
Some (Filename.chop_suffix f ".json")
3174
+
else None
3175
+
) files in
3176
+
let universe_hashes = List.sort String.compare universe_hashes in
3177
+
if format = "json" then begin
3178
+
let json = `List (List.map (fun h ->
3179
+
let file = Path.(universes_dir / h ^ ".json") in
3180
+
try
3181
+
let j = Yojson.Safe.from_file file in
3182
+
let open Yojson.Safe.Util in
3183
+
let count = j |> member "package_count" |> to_int_option |> Option.value ~default:0 in
3184
+
`Assoc [("hash", `String h); ("package_count", `Int count)]
3185
+
with _ -> `Assoc [("hash", `String h)]
3186
+
) universe_hashes) in
3187
+
print_string (Yojson.Safe.pretty_to_string json);
3188
+
print_newline ()
3189
+
end else begin
3190
+
Printf.printf "Universes: %d\n" (List.length universe_hashes);
3191
+
List.iter (fun h ->
3192
+
let file = Path.(universes_dir / h ^ ".json") in
3193
+
let count = try
3194
+
let j = Yojson.Safe.from_file file in
3195
+
let open Yojson.Safe.Util in
3196
+
j |> member "package_count" |> to_int_option |> Option.value ~default:0
3197
+
with _ -> 0 in
3198
+
Printf.printf " %s (%d packages)\n" h count
3199
+
) universe_hashes
3200
+
end
3201
+
end else begin
3202
+
(* Look up specific universe *)
3203
+
let file = Path.(universes_dir / hash ^ ".json") in
3204
+
if not (Sys.file_exists file) then begin
3205
+
(* Try prefix match *)
3206
+
let files = try Sys.readdir universes_dir |> Array.to_list with _ -> [] in
3207
+
let matches = List.filter (fun f ->
3208
+
String.length f > String.length hash &&
3209
+
String.sub f 0 (String.length hash) = hash &&
3210
+
Filename.check_suffix f ".json"
3211
+
) files in
3212
+
match matches with
3213
+
| [single] ->
3214
+
let json = Yojson.Safe.from_file Path.(universes_dir / single) in
3215
+
if format = "json" then begin
3216
+
print_string (Yojson.Safe.pretty_to_string json);
3217
+
print_newline ()
3218
+
end else begin
3219
+
let open Yojson.Safe.Util in
3220
+
let full_hash = json |> member "universe_hash" |> to_string in
3221
+
let pkgs = json |> member "packages" |> to_list |> List.map to_string in
3222
+
Printf.printf "Universe: %s (%d packages)\n" full_hash (List.length pkgs);
3223
+
List.iter (fun p -> Printf.printf " %s\n" p) pkgs
3224
+
end
3225
+
| [] ->
3226
+
Printf.eprintf "Universe %s not found\n%!" hash;
3227
+
Stdlib.exit 1
3228
+
| _ ->
3229
+
Printf.eprintf "Ambiguous prefix %s, matches: %s\n%!" hash
3230
+
(String.concat ", " (List.map (fun f -> Filename.chop_suffix f ".json") matches));
3231
+
Stdlib.exit 1
3232
+
end else begin
3233
+
let json = Yojson.Safe.from_file file in
3234
+
if format = "json" then begin
3235
+
print_string (Yojson.Safe.pretty_to_string json);
3236
+
print_newline ()
3237
+
end else begin
3238
+
let open Yojson.Safe.Util in
3239
+
let pkgs = json |> member "packages" |> to_list |> List.map to_string in
3240
+
Printf.printf "Universe: %s (%d packages)\n" hash (List.length pkgs);
3241
+
List.iter (fun p -> Printf.printf " %s\n" p) pkgs
3242
+
end
3243
+
end
3244
+
end
3245
+
3246
+
let universe_cmd =
3247
+
let hash_arg =
3248
+
let doc = "Universe hash (or prefix) to look up. Omit to list all universes." in
3249
+
Arg.(value & pos 0 string "" & info [] ~docv:"HASH" ~doc)
3250
+
in
3251
+
let universe_term =
3252
+
Term.(const (fun cache_dir format arch _os os_distribution os_version hash ->
3253
+
run_universe ~cache_dir ~format ~arch ~os_distribution ~os_version ~hash)
3254
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ hash_arg)
3255
+
in
3256
+
let universe_info = Cmd.info "universe" ~doc:"Look up packages in a universe by hash" in
3257
+
Cmd.v universe_info universe_term
3258
+
3259
+
let run_log ~cache_dir ~format ~arch ~os_distribution ~os_version ~layer_hash =
3260
+
let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in
3261
+
let os_dir = Path.(cache_dir / os_key) in
3262
+
(* Determine if this is a build or doc layer *)
3263
+
let is_build = String.length layer_hash > 6 && String.sub layer_hash 0 6 = "build-" in
3264
+
let is_doc = String.length layer_hash > 4 && String.sub layer_hash 0 4 = "doc-" in
3265
+
if not (is_build || is_doc) then begin
3266
+
Printf.eprintf "Layer hash must start with 'build-' or 'doc-'\n%!";
3267
+
Stdlib.exit 1
3268
+
end;
3269
+
let layer_dir = Path.(os_dir / layer_hash) in
3270
+
if not (Sys.file_exists layer_dir) then begin
3271
+
Printf.eprintf "Layer %s not found\n%!" layer_hash;
3272
+
Stdlib.exit 1
3273
+
end;
3274
+
let log_file = if is_build then
3275
+
Path.(layer_dir / "build.log")
3276
+
else
3277
+
Path.(layer_dir / "odoc-voodoo-all.log")
3278
+
in
3279
+
let layer_json = Path.(layer_dir / "layer.json") in
3280
+
if format = "json" then begin
3281
+
let log_content =
3282
+
if Sys.file_exists log_file then
3283
+
try
3284
+
let ic = open_in log_file in
3285
+
let content = Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
3286
+
really_input_string ic (in_channel_length ic)) in
3287
+
`String content
3288
+
with _ -> `Null
3289
+
else `Null
3290
+
in
3291
+
let layer_info =
3292
+
if Sys.file_exists layer_json then
3293
+
try Yojson.Safe.from_file layer_json with _ -> `Null
3294
+
else `Null
3295
+
in
3296
+
let universe = universe_hash_of_layer ~os_dir layer_hash in
3297
+
let json = `Assoc [
3298
+
("layer", `String layer_hash);
3299
+
("log_path", if Sys.file_exists log_file then `String log_file else `Null);
3300
+
("universe_hash", (match universe with Some h -> `String h | None -> `Null));
3301
+
("layer_info", layer_info);
3302
+
("log", log_content);
3303
+
] in
3304
+
print_string (Yojson.Safe.pretty_to_string json);
3305
+
print_newline ()
3306
+
end else begin
3307
+
(* Print layer metadata *)
3308
+
let universe = universe_hash_of_layer ~os_dir layer_hash in
3309
+
if Sys.file_exists layer_json then begin
3310
+
try
3311
+
let json = Yojson.Safe.from_file layer_json in
3312
+
let open Yojson.Safe.Util in
3313
+
let pkg = json |> member "package" |> to_string in
3314
+
Printf.printf "Layer: %s\n" layer_hash;
3315
+
Printf.printf "Package: %s\n" pkg;
3316
+
(match universe with
3317
+
| Some h -> Printf.printf "Universe: %s\n" h
3318
+
| None -> ());
3319
+
if is_build then begin
3320
+
let exit_status = json |> member "exit_status" |> to_int in
3321
+
Printf.printf "Status: %s (exit %d)\n" (if exit_status = 0 then "success" else "failure") exit_status
3322
+
end else begin
3323
+
let doc = json |> member "doc" in
3324
+
if doc <> `Null then begin
3325
+
let status = doc |> member "status" |> to_string_option |> Option.value ~default:"unknown" in
3326
+
Printf.printf "Status: %s\n" status;
3327
+
(match doc |> member "error" |> to_string_option with
3328
+
| Some err -> Printf.printf "Error: %s\n" err
3329
+
| None -> ())
3330
+
end;
3331
+
let build_hash = json |> member "build_hash" |> to_string_option in
3332
+
(match build_hash with
3333
+
| Some h -> Printf.printf "Build: %s\n" h
3334
+
| None -> ())
3335
+
end
3336
+
with _ -> Printf.printf "Layer: %s\n" layer_hash
3337
+
end else
3338
+
Printf.printf "Layer: %s\n" layer_hash;
3339
+
(* Print the log *)
3340
+
if Sys.file_exists log_file then begin
3341
+
Printf.printf "\n--- %s ---\n" (Filename.basename log_file);
3342
+
(try
3343
+
let ic = open_in log_file in
3344
+
Fun.protect ~finally:(fun () -> close_in ic) (fun () ->
3345
+
try while true do print_endline (input_line ic) done with End_of_file -> ())
3346
+
with _ -> Printf.printf "(could not read log)\n")
3347
+
end else
3348
+
Printf.printf "\n(no log file found at %s)\n" log_file
3349
+
end
3350
+
3351
+
let log_cmd =
3352
+
let layer_arg =
3353
+
let doc = "Layer hash (build-xxx or doc-xxx) to show log for" in
3354
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"LAYER" ~doc)
3355
+
in
3356
+
let log_term =
3357
+
Term.(const (fun cache_dir format arch _os os_distribution os_version layer_hash ->
3358
+
run_log ~cache_dir ~format ~arch ~os_distribution ~os_version ~layer_hash)
3359
+
$ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ layer_arg)
3360
+
in
3361
+
let log_info = Cmd.info "log" ~doc:"Show build or doc log for a layer" in
3362
+
Cmd.v log_info log_term
3363
+
2565
3364
let main_info =
2566
3365
let doc = "A tool for running CI and health checks" in
2567
3366
let man =
···
2575
3374
`P "Use '$(mname) list' list packages in opam repository.";
2576
3375
`P "Use '$(mname) sync-docs DESTINATION' to sync documentation to a destination.";
2577
3376
`P "Use '$(mname) combine-docs MOUNT_POINT' to combine all doc layers into an overlay mount.";
2578
-
`P "Use '$(mname) status' to show current build status overview.";
3377
+
`P "Use '$(mname) status [--details]' to show current build status overview.";
2579
3378
`P "Use '$(mname) query PACKAGE' to show package build details.";
2580
3379
`P "Use '$(mname) failures' to list failing packages.";
2581
3380
`P "Use '$(mname) changes' to show status transitions since last run.";
···
2585
3384
`P "Use '$(mname) cascade' to rerun reverse dependencies of recently fixed packages.";
2586
3385
`P "Use '$(mname) gc' to garbage collect logs, runs, and compact histories.";
2587
3386
`P "Use '$(mname) notify --channel CHANNEL --message TEXT' to send a notification.";
3387
+
`P "Use '$(mname) universe [HASH]' to look up packages in a universe.";
3388
+
`P "Use '$(mname) log LAYER' to show build or doc log for a layer.";
2588
3389
`P "Add --md flag to output results in markdown format.";
2589
3390
`S Manpage.s_examples;
2590
3391
`P "$(mname) ci --cache-dir /tmp/cache --opam-repository /tmp/opam-repository /path/to/project";
···
2599
3400
`P "$(mname) cascade --cache-dir /tmp/cache --opam-repository /tmp/opam-repository --dry-run";
2600
3401
`P "$(mname) gc --cache-dir /tmp/cache --keep-runs 20 --dry-run";
2601
3402
`P "$(mname) notify --channel stdout --message 'Build complete'";
3403
+
`P "$(mname) universe abc123 --cache-dir /tmp/cache";
3404
+
`P "$(mname) log --cache-dir /tmp/cache build-abc123";
2602
3405
]
2603
3406
in
2604
3407
Cmd.info "day10" ~version:"0.0.1" ~doc ~man
2605
3408
2606
3409
let () =
2607
3410
let default_term = Term.(ret (const (`Help (`Pager, None)))) in
2608
-
let cmd = Cmd.group ~default:default_term main_info [ ci_cmd; health_check_cmd; batch_cmd; list_cmd; sync_docs_cmd; combine_docs_cmd; status_cmd; query_cmd; failures_cmd; changes_cmd; disk_cmd; rerun_cmd; rdeps_cmd; cascade_cmd; gc_cli_cmd; notify_cmd ] in
3411
+
let cmd = Cmd.group ~default:default_term main_info [ ci_cmd; health_check_cmd; batch_cmd; list_cmd; sync_docs_cmd; combine_docs_cmd; status_cmd; query_cmd; failures_cmd; changes_cmd; disk_cmd; rerun_cmd; rdeps_cmd; cascade_cmd; gc_cli_cmd; notify_cmd; universe_cmd; log_cmd ] in
2609
3412
exit (Cmd.eval cmd)
+1
day10/bin/s.ml
+1
day10/bin/s.ml
···
10
10
val init : config:Config.t -> t
11
11
val deinit : t:t -> unit
12
12
val config : t:t -> Config.t
13
+
val base_hash : config:Config.t -> string
13
14
val run : t:t -> temp_dir:string -> string -> string -> int
14
15
val build : t:t -> temp_dir:string -> string -> OpamPackage.t -> string list -> int
15
16
val layer_hash : t:t -> OpamPackage.t list -> string
+4
day10/bin/windows.ml
+4
day10/bin/windows.ml
···
38
38
let deinit ~t = ignore (Os.exec [ "hcn-namespace"; "delete"; t.network ])
39
39
let config ~t = t.config
40
40
41
+
let base_hash ~(config : Config.t) =
42
+
String.concat "|" [ config.os_distribution; config.os_version; config.arch ]
43
+
|> Digest.string |> Digest.to_hex
44
+
41
45
let layer_hash ~t deps =
42
46
let hashes =
43
47
List.map
+3
day10/lib/gc.ml
+3
day10/lib/gc.ml
···
53
53
let is_special_layer name =
54
54
name = "base" ||
55
55
name = "solutions" ||
56
+
name = "packages" ||
57
+
name = "logs" ||
58
+
name = "universes" ||
56
59
(String.length name > 11 && String.sub name 0 11 = "doc-driver-") ||
57
60
(String.length name > 9 && String.sub name 0 9 = "doc-odoc-") ||
58
61
(String.length name > 10 && String.sub name 0 10 = "jtw-tools-")
+11
-11
day10/lib/status_index.ml
+11
-11
day10/lib/status_index.ml
···
135
135
let new_packages = ref [] in
136
136
List.iter (fun pkg_str ->
137
137
let latest_entries = History.read_latest ~packages_dir ~pkg_str in
138
-
(* Tally blessed and non-blessed totals *)
138
+
(* Tally blessed totals: count each package ONCE using its blessed entry.
139
+
Tally non-blessed totals: count each non-blessed build separately. *)
140
+
let blessed_entry = List.find_opt (fun (e : History.entry) -> e.blessed) latest_entries in
141
+
(match blessed_entry with
142
+
| Some e -> blessed_totals := incr_totals !blessed_totals e.category
143
+
| None -> ());
139
144
List.iter (fun (e : History.entry) ->
140
-
if e.blessed then
141
-
blessed_totals := incr_totals !blessed_totals e.category
142
-
else
145
+
if not e.blessed then
143
146
non_blessed_totals := incr_totals !non_blessed_totals e.category
144
147
) latest_entries;
145
148
(* Detect changes: read full history for this package *)
···
149
152
List.iter (fun (e : History.entry) ->
150
153
if not (Hashtbl.mem seen_hashes e.build_hash) then begin
151
154
Hashtbl.add seen_hashes e.build_hash true;
152
-
(* This is the latest entry for this build_hash (since read returns
153
-
most recent first). Find the previous entry for same build_hash. *)
154
155
if e.run = run_id then begin
155
-
(* Look for the next entry with the same build_hash *)
156
156
let prev = List.find_opt (fun (e2 : History.entry) ->
157
157
e2.build_hash = e.build_hash && e2.run <> run_id
158
158
) all_entries in
···
169
169
end
170
170
end
171
171
) all_entries;
172
-
(* New packages: all entries have run_id matching current run *)
173
-
let is_new = List.for_all (fun (e : History.entry) ->
174
-
e.run = run_id
172
+
(* New packages: package has no entries from previous runs *)
173
+
let has_old_entries = List.exists (fun (e : History.entry) ->
174
+
e.run <> run_id
175
175
) all_entries in
176
-
if is_new && all_entries <> [] then
176
+
if (not has_old_entries) && all_entries <> [] then
177
177
new_packages := pkg_str :: !new_packages
178
178
) pkg_dirs;
179
179
{