Add cascade and gc CLI commands to day10 · jon.recoil.org/day10@ef5611c

+181 -1

bin/main.ml

··· 2386 2386 let notify_info = Cmd.info "notify" ~doc:"Send a notification via configured channel" in 2387 2387 Cmd.v notify_info notify_term 2388 2388 2389 + let run_cascade ~cache_dir ~format ~arch ~os ~os_distribution ~os_family ~os_version ~opam_repositories ~blessed_first ~dry_run = 2390 + let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in 2391 + let os_dir = Path.(cache_dir / os_key) in 2392 + 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 2454 + (* Sort: blessed first if requested *) 2455 + let all_cascades = 2456 + 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)) 2463 + ) all_cascades 2464 + else all_cascades 2465 + in 2466 + (* Deduplicate *) 2467 + let seen = Hashtbl.create 64 in 2468 + let all_cascades = List.filter (fun (pkg, _) -> 2469 + if Hashtbl.mem seen pkg then false 2470 + else begin Hashtbl.add seen pkg true; true end 2471 + ) all_cascades in 2472 + 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); 2475 + ("action", `String (if dry_run then "would_rerun" else "rerun"))] 2476 + ) all_cascades) in 2477 + print_string (Yojson.Safe.pretty_to_string json); 2478 + print_newline () 2479 + end else begin 2480 + if dry_run then 2481 + Printf.printf "Would cascade rerun %d packages:\n%!" (List.length all_cascades) 2482 + else 2483 + 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 2486 + ) all_cascades; 2487 + if not dry_run then begin 2488 + List.iter (fun (pkg, _) -> 2489 + Printf.printf "Rerunning %s...\n%!" pkg; 2490 + run_health_check { dir = cache_dir; ocaml_version = None; opam_repositories; 2491 + package = pkg; arch; os; os_distribution; os_family; os_version; 2492 + 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 2499 + end 2500 + end 2501 + 2502 + let cascade_cmd = 2503 + let blessed_first_term = 2504 + let doc = "Process blessed packages first" in 2505 + Arg.(value & flag & info [ "blessed-first" ] ~doc) 2506 + in 2507 + 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) 2511 + in 2512 + let cascade_info = Cmd.info "cascade" ~doc:"Cascade reruns to reverse dependencies of recently fixed packages" in 2513 + Cmd.v cascade_info cascade_term 2514 + 2515 + let run_gc_cli ~cache_dir ~format ~arch ~os_distribution ~os_version ~archive ~keep_runs ~stable_threshold ~dry_run = 2516 + let os_key = Printf.sprintf "%s-%s-%s" os_distribution os_version arch in 2517 + let config : Day10_lib.Gc.log_gc_config = { 2518 + archive_dir = archive; 2519 + keep_runs; 2520 + stable_threshold; 2521 + compact_max_age_days = 90; 2522 + } in 2523 + let result = Day10_lib.Gc.gc_logs ~cache_dir ~os_key ~config ~dry_run in 2524 + if format = "json" then begin 2525 + let json = `Assoc [ 2526 + ("dry_run", `Bool dry_run); 2527 + ("histories_compacted", `Int result.histories_compacted); 2528 + ("runs_archived", `Int result.runs_archived); 2529 + ("runs_deleted", `Int result.runs_deleted); 2530 + ("logs_archived", `Int result.logs_archived); 2531 + ("logs_deleted", `Int result.logs_deleted); 2532 + ] in 2533 + print_string (Yojson.Safe.pretty_to_string json); 2534 + print_newline () 2535 + end else begin 2536 + if dry_run then Printf.printf "GC dry run:\n%!" else Printf.printf "GC results:\n%!"; 2537 + Printf.printf " Histories compacted: %d\n%!" result.histories_compacted; 2538 + Printf.printf " Runs archived: %d\n%!" result.runs_archived; 2539 + Printf.printf " Runs deleted: %d\n%!" result.runs_deleted; 2540 + Printf.printf " Logs archived: %d\n%!" result.logs_archived; 2541 + Printf.printf " Logs deleted: %d\n%!" result.logs_deleted 2542 + end 2543 + 2544 + let gc_cli_cmd = 2545 + let archive_term = 2546 + let doc = "Path to archive directory for old logs/runs" in 2547 + Arg.(value & opt (some string) None & info [ "archive" ] ~docv:"DIR" ~doc) 2548 + in 2549 + let keep_runs_term = 2550 + let doc = "Number of recent runs to keep (default: 30)" in 2551 + Arg.(value & opt int 30 & info [ "keep-runs" ] ~docv:"N" ~doc) 2552 + in 2553 + let stable_threshold_term = 2554 + let doc = "Compact history for packages with more than N entries (default: 5)" in 2555 + Arg.(value & opt int 5 & info [ "stable-threshold" ] ~docv:"N" ~doc) 2556 + in 2557 + let gc_cli_term = 2558 + Term.(const (fun cache_dir format arch _os os_distribution os_version archive keep_runs stable_threshold dry_run -> 2559 + run_gc_cli ~cache_dir ~format ~arch ~os_distribution ~os_version ~archive ~keep_runs ~stable_threshold ~dry_run) 2560 + $ cache_dir_term $ format_term $ arch_term $ os_term $ os_distribution_term $ os_version_term $ archive_term $ keep_runs_term $ stable_threshold_term $ dry_run_term) 2561 + in 2562 + let gc_cli_info = Cmd.info "gc" ~doc:"Garbage collect logs, runs, and compact histories" in 2563 + Cmd.v gc_cli_info gc_cli_term 2564 + 2389 2565 let main_info = 2390 2566 let doc = "A tool for running CI and health checks" in 2391 2567 let man = ··· 2406 2582 `P "Use '$(mname) disk' to show disk usage breakdown."; 2407 2583 `P "Use '$(mname) rerun TARGET' to retry a failed build (by hash or package name)."; 2408 2584 `P "Use '$(mname) rdeps PACKAGE' to find reverse dependencies from cached solutions."; 2585 + `P "Use '$(mname) cascade' to rerun reverse dependencies of recently fixed packages."; 2586 + `P "Use '$(mname) gc' to garbage collect logs, runs, and compact histories."; 2409 2587 `P "Use '$(mname) notify --channel CHANNEL --message TEXT' to send a notification."; 2410 2588 `P "Add --md flag to output results in markdown format."; 2411 2589 `S Manpage.s_examples; ··· 2418 2596 `P "$(mname) sync-docs --cache-dir /tmp/cache user@host:/var/www/docs"; 2419 2597 `P "$(mname) rerun --cache-dir /tmp/cache --opam-repository /tmp/opam-repository my-package"; 2420 2598 `P "$(mname) rdeps --cache-dir /tmp/cache my-package"; 2599 + `P "$(mname) cascade --cache-dir /tmp/cache --opam-repository /tmp/opam-repository --dry-run"; 2600 + `P "$(mname) gc --cache-dir /tmp/cache --keep-runs 20 --dry-run"; 2421 2601 `P "$(mname) notify --channel stdout --message 'Build complete'"; 2422 2602 ] 2423 2603 in ··· 2425 2605 2426 2606 let () = 2427 2607 let default_term = Term.(ret (const (`Help (`Pager, None)))) in 2428 - 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; notify_cmd ] 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 2429 2609 exit (Cmd.eval cmd)

+69

lib/gc.ml

··· 207 207 universe_result.referenced universe_result.deleted; 208 208 209 209 (layer_result, universe_result) 210 + 211 + type log_gc_config = { 212 + archive_dir : string option; 213 + keep_runs : int; 214 + stable_threshold : int; 215 + compact_max_age_days : int; 216 + } 217 + 218 + type log_gc_result = { 219 + logs_archived : int; 220 + logs_deleted : int; 221 + runs_archived : int; 222 + runs_deleted : int; 223 + histories_compacted : int; 224 + bytes_reclaimed : int64; 225 + } 226 + 227 + let gc_logs ~cache_dir ~os_key ~config ~dry_run = 228 + let packages_dir = Filename.concat (Filename.concat cache_dir os_key) "packages" in 229 + let logs_archived = ref 0 in 230 + let logs_deleted = ref 0 in 231 + let runs_archived = ref 0 in 232 + let runs_deleted = ref 0 in 233 + let histories_compacted = ref 0 in 234 + let bytes_reclaimed = ref 0L in 235 + (* Compact history files *) 236 + let pkg_dirs = try Sys.readdir packages_dir |> Array.to_list with _ -> [] in 237 + List.iter (fun pkg_str -> 238 + let entries = History.read ~packages_dir ~pkg_str in 239 + if List.length entries > config.stable_threshold then begin 240 + if not dry_run then 241 + History.compact ~packages_dir ~pkg_str ~max_age_days:config.compact_max_age_days; 242 + incr histories_compacted 243 + end 244 + ) pkg_dirs; 245 + (* Archive/delete old run directories *) 246 + let logs_dir = Filename.concat cache_dir "logs" in 247 + let runs_dir = Filename.concat logs_dir "runs" in 248 + if Sys.file_exists runs_dir then begin 249 + let run_dirs = try Sys.readdir runs_dir |> Array.to_list |> List.sort (fun a b -> compare b a) with _ -> [] in 250 + (* Keep the most recent keep_runs *) 251 + let to_remove = if List.length run_dirs > config.keep_runs then 252 + let rec drop n = function [] -> [] | _ :: rest when n > 0 -> drop (n-1) rest | l -> l in 253 + drop config.keep_runs run_dirs 254 + else [] in 255 + List.iter (fun dir_name -> 256 + let run_path = Filename.concat runs_dir dir_name in 257 + match config.archive_dir with 258 + | Some archive -> 259 + if not dry_run then begin 260 + let dest = Filename.concat (Filename.concat archive "runs") dir_name in 261 + (try Unix.mkdir (Filename.concat archive "runs") 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()); 262 + Unix.rename run_path dest 263 + end; 264 + incr runs_archived 265 + | None -> 266 + if not dry_run then begin 267 + let _ = Sys.command (Printf.sprintf "rm -rf %s" (Filename.quote run_path)) in () 268 + end; 269 + incr runs_deleted 270 + ) to_remove 271 + end; 272 + ignore bytes_reclaimed; 273 + { logs_archived = !logs_archived; 274 + logs_deleted = !logs_deleted; 275 + runs_archived = !runs_archived; 276 + runs_deleted = !runs_deleted; 277 + histories_compacted = !histories_compacted; 278 + bytes_reclaimed = !bytes_reclaimed }

+26

lib/gc.mli

··· 29 29 30 30 (** Perform full GC (layers + universes). *) 31 31 val gc_all : cache_dir:string -> os_key:string -> html_dir:string -> referenced_layer_hashes:string list -> layer_gc_result * universe_gc_result 32 + 33 + (** Log GC configuration. *) 34 + type log_gc_config = { 35 + archive_dir : string option; 36 + keep_runs : int; 37 + stable_threshold : int; 38 + compact_max_age_days : int; 39 + } 40 + 41 + (** Log GC results. *) 42 + type log_gc_result = { 43 + logs_archived : int; 44 + logs_deleted : int; 45 + runs_archived : int; 46 + runs_deleted : int; 47 + histories_compacted : int; 48 + bytes_reclaimed : int64; 49 + } 50 + 51 + (** Perform log GC: compact histories, archive/delete old run directories. *) 52 + val gc_logs : 53 + cache_dir:string -> 54 + os_key:string -> 55 + config:log_gc_config -> 56 + dry_run:bool -> 57 + log_gc_result