forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
day11: library reorganization and API cleanup
Several independent cleanups bundled together:
- layer: delete Layer_info (dead parallel serialization path) and
Query (untyped JSON wrapper, redundant with Layer_meta.load_build).
Type Layer_meta.kind as Build | Compile | Link | Doc_all instead of
a raw string. Make Layer_meta.timing an open (string * float) list
so phases can evolve additively. Refactor Stack.plan_lowerdir to
take pre-computed byte costs instead of four path parameters.
Default created_at in save_build so callers don't need now_iso8601.
Add Last_used for LRU bookkeeping (separate sentinel file so touch
doesn't rewrite JSON). Rewrite the library README to reflect the
current modules and document the error-handling convention.
- layer/cli: new day11-layer-cli standalone binary for low-level
inspection of the cache (list, show, tree, stats, package, log).
Depends only on day11_layer and its transitive deps — no solver,
no build, no doc pipeline.
- solver: split opam-specific code out of day11/solver into new
day11/opam library (git_packages, git_utils, opam_env, local_repo,
deps). Extract solver worker-pool orchestration into standalone
day11/solver_pool library.
- exec: delete unused modules (atomic_publish, reporter, retry,
safe_rename, wait, worker_pool). Simplify fork_client to use an
Atomic-based singleton (was a Mutex that deadlocked under Eio).
- build: thread ?kind through Build_layer.build as a typed value.
Hybrid lowerdir plan in run_in_layers: keep as many dep layers as
possible as separate overlayfs lowerdirs, cp-merge only the excess
to stay under the 4K mount-options limit. Touch dep layers via
Last_used before mounting. Tools.ml simplification.
- doc: generate.ml passes typed kind constructors to build_layer.
Doc pipeline cache-hit path touches layers for LRU tracking.
sync.ml and combine.ml migrate off Query.metadata (inlined raw
JSON read — these modules are dead code to be removed separately).
- container/tests: new integration tests for Stack.plan_lowerdir
that actually mount overlayfs with varying layer counts and verify
every dep's file is visible inside a running container. Gated on
DAY11_INTEGRATION=true.
- bin, batch, benchmark, jtw, graph: adapt to the new library layout.
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
+1763
-2369
+6
-6
day11/batch/targets.ml
+6
-6
day11/batch/targets.ml
···
5
5
]
6
6
7
7
let find_latest_versions git_packages =
8
-
let all_names = Day11_solver.Git_packages.all_names git_packages in
8
+
let all_names = Day11_opam.Git_packages.all_names git_packages in
9
9
let compiler_names = Day11_layer.Opamh.compiler_packages in
10
10
let all_names = List.filter (fun name ->
11
11
not (List.mem name compiler_names)
12
12
) all_names in
13
13
List.filter_map (fun name ->
14
-
let versions = Day11_solver.Git_packages.get_versions git_packages name in
14
+
let versions = Day11_opam.Git_packages.get_versions git_packages name in
15
15
let non_avoided =
16
16
OpamPackage.Version.Map.filter (fun _v opam ->
17
17
not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam)
···
25
25
) all_names
26
26
27
27
let find_all_versions git_packages =
28
-
let all_names = Day11_solver.Git_packages.all_names git_packages in
28
+
let all_names = Day11_opam.Git_packages.all_names git_packages in
29
29
let compiler_names = Day11_layer.Opamh.compiler_packages in
30
30
let all_names = List.filter (fun name ->
31
31
not (List.mem name compiler_names)
32
32
) all_names in
33
33
List.concat_map (fun name ->
34
-
let versions = Day11_solver.Git_packages.get_versions git_packages name in
34
+
let versions = Day11_opam.Git_packages.get_versions git_packages name in
35
35
OpamPackage.Version.Map.fold (fun v _opam acc ->
36
36
OpamPackage.create name v :: acc
37
37
) versions []
···
52
52
53
53
let pick_latest_version git_packages name =
54
54
let n = OpamPackage.Name.of_string name in
55
-
let versions = Day11_solver.Git_packages.get_versions git_packages n in
55
+
let versions = Day11_opam.Git_packages.get_versions git_packages n in
56
56
let non_avoided =
57
57
OpamPackage.Version.Map.filter (fun _v opam ->
58
58
not (OpamFile.OPAM.has_flag Pkgflag_AvoidVersion opam)
···
73
73
if List.mem n compiler_names then None else Some n
74
74
) small_universe in
75
75
List.concat_map (fun name ->
76
-
let versions = Day11_solver.Git_packages.get_versions git_packages name in
76
+
let versions = Day11_opam.Git_packages.get_versions git_packages name in
77
77
OpamPackage.Version.Map.fold (fun v _opam acc ->
78
78
OpamPackage.create name v :: acc
79
79
) versions [] |> List.rev
+3
-3
day11/batch/targets.mli
+3
-3
day11/batch/targets.mli
···
10
10
(** Package names for the small universe. *)
11
11
12
12
val pick_latest_version :
13
-
Day11_solver.Git_packages.t -> string -> OpamPackage.t list
13
+
Day11_opam.Git_packages.t -> string -> OpamPackage.t list
14
14
(** [pick_latest_version packages name] returns all non-avoid versions
15
15
of [name] from newest to oldest. Used for retry on solve failure. *)
16
16
17
17
val find_all_versions :
18
-
Day11_solver.Git_packages.t -> OpamPackage.t list
18
+
Day11_opam.Git_packages.t -> OpamPackage.t list
19
19
(** All versions of all non-compiler packages. *)
20
20
21
21
val resolve :
22
22
?small:bool ->
23
23
?all_versions:bool ->
24
-
Day11_solver.Git_packages.t ->
24
+
Day11_opam.Git_packages.t ->
25
25
string option ->
26
26
OpamPackage.t list
27
27
(** [resolve ?small ?all_versions packages target] resolves the target
+1
-1
day11/batch/test/test_batch.ml
+1
-1
day11/batch/test/test_batch.ml
···
307
307
308
308
let test_resolve_single_target () =
309
309
(* resolve with an explicit target returns exactly that *)
310
-
let dummy_packages = Day11_solver.Git_packages.empty in
310
+
let dummy_packages = Day11_opam.Git_packages.empty in
311
311
let result = Targets.resolve dummy_packages (Some "astring.0.8.5") in
312
312
Alcotest.(check int) "one target" 1 (List.length result);
313
313
Alcotest.(check string) "correct" "astring.0.8.5"
+7
-7
day11/batch/test/test_batch_integration.ml
+7
-7
day11/batch/test/test_batch_integration.ml
···
24
24
let setup_solver () =
25
25
let opam_repository = opam_repository () in
26
26
let git_packages, store, commit =
27
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
28
-
let opam_env = Day11_solver.Opam_env.std_env
27
+
Day11_opam.Git_packages.of_opam_repository opam_repository in
28
+
let opam_env = Day11_opam.Opam_env.std_env
29
29
~arch ~os:"linux" ~os_distribution ~os_family:"debian"
30
30
~os_version:"12" () in
31
31
(git_packages, store, commit, opam_env)
···
60
60
Alcotest.(check bool) "some blessed" true
61
61
(OpamPackage.Set.cardinal all_blessed > 0);
62
62
(* Build DAG *)
63
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
63
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
64
64
let cache = Day11_build.Hash_cache.create ~find_opam () in
65
65
let base_hash = Base.hash ~image:"test" in
66
66
let nodes = Dag.build_dag cache ~base_hash solutions in
···
97
97
let sol_astring = solve_package git_packages opam_env "astring.0.8.5" in
98
98
let solutions = [ sol_astring ] in
99
99
let blessing_maps = Blessing.compute_blessings solutions in
100
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
100
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
101
101
let cache = Day11_build.Hash_cache.create ~find_opam () in
102
102
let base_hash = Base.hash ~image:"test" in
103
103
let nodes = Dag.build_dag cache ~base_hash solutions in
···
160
160
(* Solve a small package *)
161
161
let sol_astring = solve_package git_packages opam_env "astring.0.8.5" in
162
162
let solutions = [ sol_astring ] in
163
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
163
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
164
164
let cache = Day11_build.Hash_cache.create ~find_opam () in
165
165
let nodes = Dag.build_dag cache ~base_hash:base.hash
166
166
solutions in
···
276
276
(Printf.sprintf "git -C %s rev-parse HEAD~1" opam_repository)
277
277
|> In_channel.input_all) in
278
278
let parent =
279
-
Day11_solver.Git_utils.resolve_commit_in_store store (Some parent_sha) in
280
-
let changed_real = Day11_solver.Git_packages.diff_packages
279
+
Day11_opam.Git_utils.resolve_commit_in_store store (Some parent_sha) in
280
+
let changed_real = Day11_opam.Git_packages.diff_packages
281
281
~store parent commit in
282
282
Printf.printf " Real changes (HEAD~1..HEAD): %d packages\n%!"
283
283
(List.length changed_real)
+4
-4
day11/batch/test/test_cmdliner_all.ml
+4
-4
day11/batch/test/test_cmdliner_all.ml
···
23
23
Types.ensure_dirs benv;
24
24
Printf.printf "Setting up solver...\n%!";
25
25
let git_packages, _store, _commit =
26
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
27
-
let opam_env = Day11_solver.Opam_env.std_env
26
+
Day11_opam.Git_packages.of_opam_repository opam_repository in
27
+
let opam_env = Day11_opam.Opam_env.std_env
28
28
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
29
29
~os_family:"debian" ~os_version:"12" () in
30
30
(* Find all cmdliner versions *)
31
31
let cmdliner_versions =
32
-
Day11_solver.Git_packages.get_versions git_packages
32
+
Day11_opam.Git_packages.get_versions git_packages
33
33
(OpamPackage.Name.of_string "cmdliner") in
34
34
let targets =
35
35
OpamPackage.Version.Map.fold (fun v _ acc ->
···
70
70
Printf.printf "Blessed: %d/%d package instances across %d universes\n%!"
71
71
blessed_count total_instances (List.length solutions);
72
72
(* Build global DAG *)
73
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
73
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
74
74
let cache = Hash_cache.create ~find_opam () in
75
75
let nodes = Dag.build_dag cache ~base_hash:base.hash solutions in
76
76
Printf.printf "DAG: %d unique build nodes (deduplicated from %d solutions)\n%!"
+2
-2
day11/batch/test/test_examined_diff.ml
+2
-2
day11/batch/test/test_examined_diff.ml
···
17
17
"astring.0.8.5";
18
18
]
19
19
20
-
let opam_env = Day11_solver.Opam_env.std_env
20
+
let opam_env = Day11_opam.Opam_env.std_env
21
21
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
22
22
~os_family:"debian" ~os_version:"12" ()
23
23
···
25
25
if not (is_integration ()) then
26
26
(Printf.printf "Skipping (set DAY11_INTEGRATION=true)\n"; exit 0);
27
27
let git_packages, _, _ =
28
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
28
+
Day11_opam.Git_packages.of_opam_repository opam_repository in
29
29
(* Solve each target and collect examined sets *)
30
30
let examined_sets = List.filter_map (fun target_str ->
31
31
let target = OpamPackage.of_string target_str in
+7
-7
day11/batch/test/test_incremental.ml
+7
-7
day11/batch/test/test_incremental.ml
···
57
57
"astring.0.8.5";
58
58
]
59
59
60
-
let opam_env = Day11_solver.Opam_env.std_env
60
+
let opam_env = Day11_opam.Opam_env.std_env
61
61
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
62
62
~os_family:"debian" ~os_version:"12" ()
63
63
64
64
let load_packages_at_commit store commit_sha =
65
-
let hash = Day11_solver.Git_utils.resolve_commit_in_store
65
+
let hash = Day11_opam.Git_utils.resolve_commit_in_store
66
66
store (Some commit_sha) in
67
-
Day11_solver.Git_packages.of_commit store hash
67
+
Day11_opam.Git_packages.of_commit store hash
68
68
69
69
let solve_and_cache ~git_packages ~cache_dir targets =
70
70
let solved = ref 0 in
···
103
103
let opam_repository = opam_repository () in
104
104
Printf.printf "\n=== %s ===\n%!" name;
105
105
let store, _head =
106
-
Day11_solver.Git_utils.get_git_repo_store_and_hash opam_repository in
106
+
Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository in
107
107
(* Step 1: Solve at "before" commit *)
108
108
let before_dir = Fpath.(dir / "before") in
109
109
mkdir before_dir;
···
115
115
Printf.printf " Before: %d solved, %d failed\n%!" solved failed;
116
116
Alcotest.(check bool) "some solved" true (solved > 0);
117
117
(* Step 2: Compute changed packages *)
118
-
let before_hash = Day11_solver.Git_utils.resolve_commit_in_store
118
+
let before_hash = Day11_opam.Git_utils.resolve_commit_in_store
119
119
store (Some before_sha) in
120
-
let after_hash = Day11_solver.Git_utils.resolve_commit_in_store
120
+
let after_hash = Day11_opam.Git_utils.resolve_commit_in_store
121
121
store (Some after_sha) in
122
-
let changed_names = Day11_solver.Git_packages.diff_packages
122
+
let changed_names = Day11_opam.Git_packages.diff_packages
123
123
~store before_hash after_hash in
124
124
let changed_set = List.fold_left (fun s n ->
125
125
OpamPackage.Name.Set.add n s
+6
-5
day11/benchmark/benchmark.ml
+6
-5
day11/benchmark/benchmark.ml
···
15
15
Printf.printf "=== day11 benchmark ===\n\n";
16
16
17
17
(* 1. Solver setup *)
18
-
let git_packages, _store, _commit =
18
+
let git_packages, repos_with_shas =
19
19
time "Load opam-repository (git)" (fun () ->
20
-
Day11_solver.Git_packages.of_opam_repository opam_repository) in
21
-
let opam_env = Day11_solver.Opam_env.std_env
20
+
Day11_opam.Git_packages.of_repositories
21
+
[ (opam_repository, None) ]) in
22
+
let opam_env = Day11_opam.Opam_env.std_env
22
23
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
23
24
~os_family:"debian" ~os_version:"12" () in
24
25
···
67
68
Printf.printf " → %d/%d solved\n%!" (List.length solutions) (List.length packages_50);
68
69
69
70
(* 4. DAG construction *)
70
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
71
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
71
72
let cache = Day11_build.Hash_cache.create ~find_opam () in
72
73
let nodes =
73
74
time "Build DAG (50 solutions)" (fun () ->
···
104
105
(* Warm cache: build odoc-driver tool *)
105
106
ignore (time "Tools.build_tool odoc-driver (cache hit)" (fun () ->
106
107
Day11_build.Tools.build_tool env benv
107
-
~packages:git_packages ~env:opam_env
108
+
~packages:git_packages ~repos:repos_with_shas
108
109
(OpamPackage.of_string "odoc-driver.3.1.0")));
109
110
);
110
111
Printf.printf "\nDone.\n%!"
+3
-3
day11/benchmark/benchmark_builds.ml
+3
-3
day11/benchmark/benchmark_builds.ml
···
32
32
~uid:1000 ~gid:1000 () in
33
33
Day11_build.Types.ensure_dirs benv;
34
34
let git_packages, _store, _commit =
35
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
36
-
let opam_env = Day11_solver.Opam_env.std_env
35
+
Day11_opam.Git_packages.of_opam_repository opam_repository in
36
+
let opam_env = Day11_opam.Opam_env.std_env
37
37
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
38
38
~os_family:"debian" ~os_version:"12" () in
39
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
39
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
40
40
let cache = Day11_build.Hash_cache.create ~find_opam () in
41
41
(* Build packages that should exist in the compiler layer already.
42
42
These are small packages that build quickly. *)
+2
-2
day11/benchmark/benchmark_day10.ml
+2
-2
day11/benchmark/benchmark_day10.ml
···
20
20
(* Eager load: read all packages upfront (like day10 does with readdir) *)
21
21
let git_packages, _store, _commit =
22
22
time "Load opam-repository (git eager)" (fun () ->
23
-
Day11_solver.Git_packages.of_opam_repository opam_repository) in
23
+
Day11_opam.Git_packages.of_opam_repository opam_repository) in
24
24
25
-
let opam_env = Day11_solver.Opam_env.std_env
25
+
let opam_env = Day11_opam.Opam_env.std_env
26
26
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
27
27
~os_family:"debian" ~os_version:"12" () in
28
28
+6
-5
day11/benchmark/benchmark_docs.ml
+6
-5
day11/benchmark/benchmark_docs.ml
···
29
29
let benv = Day11_build.Types.make_build_env ~base ~os_dir
30
30
~uid:1000 ~gid:1000 () in
31
31
Day11_build.Types.ensure_dirs benv;
32
-
let git_packages, _store, _commit =
33
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
34
-
let opam_env = Day11_solver.Opam_env.std_env
32
+
let git_packages, repos_with_shas =
33
+
Day11_opam.Git_packages.of_repositories
34
+
[ (opam_repository, None) ] in
35
+
let opam_env = Day11_opam.Opam_env.std_env
35
36
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
36
37
~os_family:"debian" ~os_version:"12" () in
37
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
38
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
38
39
let cache = Day11_build.Hash_cache.create ~find_opam () in
39
40
(* Build odoc-driver tools *)
40
41
let odoc_tool = time "Build odoc-driver tools (cache)" (fun () ->
41
42
Day11_build.Tools.build_tool env benv
42
-
~packages:git_packages ~env:opam_env
43
+
~packages:git_packages ~repos:repos_with_shas
43
44
(OpamPackage.of_string "odoc-driver.3.1.0")
44
45
|> Result.get_ok) in
45
46
let tool_mounts, odoc_bin, odoc_md_bin =
+1
-1
day11/benchmark/dune
+1
-1
day11/benchmark/dune
+9
-13
day11/benchmark/trial_run.ml
+9
-13
day11/benchmark/trial_run.ml
···
49
49
"FILE file with one package name per line";
50
50
]
51
51
52
-
let opam_env = Day11_solver.Opam_env.std_env
53
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
54
-
~os_family:"debian" ~os_version:"12" ()
55
-
56
52
let time name f =
57
53
let t0 = Unix.gettimeofday () in
58
54
let result = f () in
···
61
57
result
62
58
63
59
let find_latest_version git_packages name =
64
-
let versions = Day11_solver.Git_packages.get_versions git_packages
60
+
let versions = Day11_opam.Git_packages.get_versions git_packages
65
61
(OpamPackage.Name.of_string name) in
66
62
let non_avoided =
67
63
OpamPackage.Version.Map.filter (fun _v opam ->
···
125
121
Day11_build.Types.ensure_dirs benv;
126
122
(* Get the store for loading packages at different commits *)
127
123
let store, head_commit =
128
-
Day11_solver.Git_utils.get_git_repo_store_and_hash opam_repository in
124
+
Day11_opam.Git_utils.get_git_repo_store_and_hash opam_repository in
129
125
let all_commits =
130
126
let ic = Unix.open_process_in
131
127
(Printf.sprintf "git -C %s log --format=%%H --since='%s' --until='%s'"
···
153
149
if (i + 1) mod 50 = 0 || i = 0 then
154
150
Printf.printf "── Commit %d/%d: %s ──\n%!" (i + 1) (List.length sampled) short;
155
151
let commit_hash =
156
-
Day11_solver.Git_utils.resolve_commit_in_store store (Some commit_sha) in
152
+
Day11_opam.Git_utils.resolve_commit_in_store store (Some commit_sha) in
157
153
(* Load packages lazily *)
158
154
let git_packages =
159
-
Day11_solver.Git_packages.of_commit store commit_hash in
155
+
Day11_opam.Git_packages.of_commit store commit_hash in
160
156
(* Find latest versions *)
161
157
let targets = List.filter_map (fun name ->
162
158
find_latest_version git_packages name
···
173
169
let changed =
174
170
if i > 0 then
175
171
let prev_sha = List.nth sampled (i - 1) in
176
-
let prev_hash = Day11_solver.Git_utils.resolve_commit_in_store
172
+
let prev_hash = Day11_opam.Git_utils.resolve_commit_in_store
177
173
store (Some prev_sha) in
178
-
let changed_names = Day11_solver.Git_packages.diff_packages
174
+
let changed_names = Day11_opam.Git_packages.diff_packages
179
175
~store prev_hash commit_hash in
180
176
List.fold_left (fun s n -> OpamPackage.Name.Set.add n s)
181
177
OpamPackage.Name.Set.empty changed_names
···
200
196
not (Sys.file_exists (Fpath.to_string cache_file))
201
197
) targets in
202
198
let new_solutions = time (Printf.sprintf "solve %d packages" (List.length need_solve)) (fun () ->
203
-
let results = Day11_solver.Solve.solve_many
204
-
~packages:git_packages ~env:opam_env ?ocaml_version ~np
199
+
let results = Day11_solver_pool.Solver_pool.solve_many
200
+
?ocaml_version ~np
205
201
~repos:[(opam_repository, commit_sha)] need_solve in
206
202
List.filter_map (fun (target, result) ->
207
203
match result with
···
230
226
Printf.printf " solutions: %d total (%d new)\n%!"
231
227
(List.length all_solutions) (List.length new_solutions);
232
228
(* Build DAG *)
233
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
229
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
234
230
let cache = Day11_build.Hash_cache.create ~find_opam () in
235
231
let nodes = Day11_build.Dag.build_dag cache ~base_hash:base.hash
236
232
all_solutions in
+20
-13
day11/bin/cmd_batch.ml
+20
-13
day11/bin/cmd_batch.ml
···
66
66
("ocaml_version", match ocaml_version with
67
67
| Some v -> `String (OpamPackage.to_string v)
68
68
| None -> `Null);
69
-
("created", `String (Day11_layer.Layer_meta.now_iso8601 ()));
69
+
("created", `String (
70
+
let tm = Unix.(gmtime (gettimeofday ())) in
71
+
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
72
+
(tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
73
+
tm.tm_hour tm.tm_min tm.tm_sec));
70
74
] in
71
75
ignore (Bos.OS.File.write manifest_file
72
76
(Yojson.Safe.pretty_to_string json))
···
81
85
) targets in
82
86
Printf.printf "Solving: %d cached, %d need solving (%d workers)...\n%!"
83
87
!cached (List.length need_solve) np;
84
-
let results = Day11_solver.Solve.solve_many
85
-
~packages:git_packages ~env:opam_env ?ocaml_version
86
-
~np ~repos:repos_with_shas need_solve in
88
+
let results = Day11_solver_pool.Solver_pool.solve_many
89
+
?ocaml_version ~np ~repos:repos_with_shas need_solve in
87
90
(* Retry failed solves with older versions (useful for overlays that
88
91
pin transitive deps to specific versions) *)
89
92
let results, targets =
···
116
119
new_results := (target, result) :: !new_results
117
120
else begin
118
121
Printf.printf " Retrying %s with older versions...\n%!" name;
119
-
let retries = Day11_solver.Solve.solve_many
120
-
~packages:git_packages ~env:opam_env ?ocaml_version
121
-
~np:1 ~repos:repos_with_shas older in
122
+
let retries = Day11_solver_pool.Solver_pool.solve_many
123
+
?ocaml_version ~np:1 ~repos:repos_with_shas older in
122
124
match List.find_opt (fun (_, r) -> Result.is_ok r) retries with
123
125
| Some hit ->
124
126
Printf.printf " %s -> %s\n%!"
···
169
171
Printf.printf "Solutions cached in %s\n%!" (Fpath.to_string solutions_dir);
170
172
0
171
173
end else
172
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
174
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
173
175
let patches = Option.map (fun dir ->
174
176
Day11_build.Patches.create (Fpath.v dir)) patches_dir in
175
177
(* Delete base image early if --rebuild-base, before loading *)
···
318
320
(* Build + Docs (unified pipeline when --with-doc) *)
319
321
if with_doc then begin
320
322
Day11_doc.Generate.build_tools_and_run env benv ~np ~os_dir
321
-
~packages:git_packages ~opam_env ~mounts:base_mounts
323
+
~packages:git_packages ~repos:repos_with_shas ~opam_env
324
+
~mounts:base_mounts
322
325
~driver_compiler ~odoc_repo ~build_one
323
326
~opam_repositories ~cache ~run_log
324
327
~nodes ~solutions ~blessing_maps
···
326
329
else begin
327
330
(* Build only — no docs *)
328
331
let is_cached node =
329
-
Bos.OS.File.exists
330
-
Fpath.(Day11_layer.Layer_type.build_dir ~os_dir node / "layer.json")
331
-
|> Result.get_ok
332
+
let layer_dir = Day11_layer.Layer_type.build_dir ~os_dir node in
333
+
let cached =
334
+
Bos.OS.File.exists Fpath.(layer_dir / "layer.json")
335
+
|> Result.get_ok
336
+
in
337
+
if cached then Day11_layer.Last_used.touch layer_dir;
338
+
cached
332
339
in
333
340
Day11_build.Dag_executor.execute env ~np ~is_cached
334
341
~on_complete:(fun ~total ~completed ~failed node success ->
···
358
365
| Some dir ->
359
366
let output = Fpath.to_string Fpath.(cache_dir / "jtw-output") in
360
367
Day11_jtw.Build_tools.build_and_run env benv ~np ~os_dir
361
-
~packages:git_packages ~opam_env ~mounts:[repo_mount]
368
+
~packages:git_packages ~repos:repos_with_shas ~mounts:[repo_mount]
362
369
~extra_repo_dirs:extra_pins ~repo_dir:dir ~output
363
370
~nodes ~solutions
364
371
| None -> ());
+8
-4
day11/bin/cmd_rdeps.ml
+8
-4
day11/bin/cmd_rdeps.ml
···
3
3
open Cmdliner
4
4
5
5
let run opam_repository package =
6
-
let git_packages, _repos_with_shas, opam_env =
6
+
let _git_packages, repos_with_shas, _opam_env =
7
7
Common.setup_solver opam_repository in
8
8
let pkg = OpamPackage.of_string package in
9
-
match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env pkg with
10
-
| Error diag ->
9
+
let results = Day11_solver_pool.Solver_pool.solve_many ~np:1
10
+
~repos:repos_with_shas [ pkg ] in
11
+
match List.assoc_opt pkg results with
12
+
| Some (Error (diag, _examined)) ->
11
13
Printf.eprintf "Cannot solve %s: %s\n" package diag; 1
12
-
| Ok solution ->
14
+
| None ->
15
+
Printf.eprintf "No result for %s\n" package; 1
16
+
| Some (Ok (solution, _examined)) ->
13
17
let rdeps = Day11_graph.Rdeps.find [ solution ] pkg in
14
18
if OpamPackage.Set.is_empty rdeps then
15
19
Printf.printf "No reverse dependencies for %s\n" package
+2
-2
day11/bin/common.ml
+2
-2
day11/bin/common.ml
···
58
58
(repo, None)
59
59
) opam_repositories in
60
60
let git_packages, repos_with_shas =
61
-
Day11_solver.Git_packages.of_repositories repos_with_heads in
61
+
Day11_opam.Git_packages.of_repositories repos_with_heads in
62
62
(* ocaml-git corrupts Bos's temp dir setting — reset it *)
63
63
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
64
-
let opam_env = Day11_solver.Opam_env.std_env
64
+
let opam_env = Day11_opam.Opam_env.std_env
65
65
~arch ~os ~os_distribution ~os_family ~os_version () in
66
66
(git_packages, repos_with_shas, opam_env)
67
67
+1
-1
day11/bin/dune
+1
-1
day11/bin/dune
+9
-5
day11/build/build_layer.ml
+9
-5
day11/build/build_layer.ml
···
40
40
| _ -> Types.Failure (build_dir_name node)
41
41
42
42
(** Extract the build result: move upper to layer, scan files, write metadata. *)
43
-
let extract_layer env ~layer_dir ~layer_json ~upper ~pkg_str
43
+
let extract_layer env ~layer_dir ~layer_json ~upper ~pkg_str ~kind
44
44
~(node : build) ~packages_dir ~(benv : Types.build_env)
45
45
?patches ~timing (run : Day11_exec.Run.t) =
46
46
let layer_name = build_dir_name node in
···
72
72
in
73
73
let meta : Day11_layer.Layer_meta.build_meta = {
74
74
package = pkg_str;
75
+
kind;
75
76
exit_status = exit_code;
76
77
deps = List.map (fun (d : build) -> OpamPackage.to_string d.pkg) node.deps;
77
78
hashes = dep_hashes;
···
81
82
patches = patch_names; failed_dep = None;
82
83
disk_usage;
83
84
timing;
84
-
created_at = Day11_layer.Layer_meta.now_iso8601 ();
85
+
created_at = "";
85
86
} in
86
87
let _ = Day11_layer.Layer_meta.save_build layer_json meta in
87
88
let _ = Day11_layer.Package_symlinks.ensure_layer_symlink
···
92
93
let build env (benv : Types.build_env)
93
94
?(opam_repositories = []) ?(mounts = [])
94
95
?patches ?(skip_state_dump = false)
96
+
?(kind = Day11_layer.Layer_meta.Build)
95
97
(node : build)
96
98
?strategy () =
97
99
let base = benv.base in
···
109
111
let layer_json = Fpath.(layer_dir / "layer.json") in
110
112
if Bos.OS.File.exists layer_json |> Result.get_ok then begin
111
113
Log.info (fun m -> m "Cache hit: %s (%s)" pkg_str layer_name);
114
+
Day11_layer.Last_used.touch layer_dir;
112
115
result_of_layer_json layer_json node
113
116
end else begin
114
117
Log.info (fun m -> m "Building %s (%s)" pkg_str layer_name);
···
165
168
| Ok (run, upper, timing) ->
166
169
strategy.cleanup env upper;
167
170
let _exit_code =
168
-
extract_layer env ~layer_dir ~layer_json ~upper
171
+
extract_layer env ~layer_dir ~layer_json ~upper ~kind
169
172
~pkg_str ~node ~packages_dir ~benv ?patches
170
173
~timing run in
171
174
ignore (Day11_exec.Sudo.rm_rf env (Fpath.parent upper));
172
175
Ok ()
173
176
| Error (`Msg e) ->
174
177
Log.err (fun m -> m "Build %s failed: %s" pkg_str e);
178
+
Printf.eprintf "BUILD ERROR %s: %s\n%!" pkg_str e;
175
179
let fail_meta : Day11_layer.Layer_meta.build_meta = {
176
-
package = pkg_str; exit_status = 1;
180
+
package = pkg_str; kind; exit_status = 1;
177
181
deps = []; hashes = [];
178
182
uid = benv.uid; gid = benv.gid;
179
183
base_hash = benv.base.hash;
180
184
installed_libs = []; installed_docs = []; patches = []; failed_dep = None;
181
185
disk_usage = 0;
182
186
timing = Day11_layer.Layer_meta.empty_timing;
183
-
created_at = Day11_layer.Layer_meta.now_iso8601 ();
187
+
created_at = "";
184
188
} in
185
189
let _ = Day11_layer.Layer_meta.save_build layer_json fail_meta in
186
190
Ok ())
+7
-6
day11/build/build_layer.mli
+7
-6
day11/build/build_layer.mli
···
5
5
and repo state cache from an upper dir. Suitable for any layer
6
6
built with opam. *)
7
7
8
-
val opam_build_strategy :
9
-
?patches:Patches.t -> OpamPackage.t -> Types.build_strategy
10
-
(** Default strategy for building an opam package. When [patches]
11
-
has entries for the package, adds [--patch] flags to the command. *)
12
-
13
8
val build :
14
9
Eio_unix.Stdenv.base ->
15
10
Types.build_env ->
···
17
12
?mounts:Day11_container.Mount.t list ->
18
13
?patches:Patches.t ->
19
14
?skip_state_dump:bool ->
15
+
?kind:Day11_layer.Layer_meta.kind ->
20
16
Day11_layer.Layer_type.build ->
21
17
?strategy:Types.build_strategy ->
22
18
unit ->
···
24
20
(** [build env benv ?patches node ()] builds the package described
25
21
by [node] in a container. When [patches] has entries for this
26
22
package, patch files are mounted and applied before building.
27
-
Uses {!opam_build_strategy} by default. *)
23
+
Uses {!opam_build_strategy} by default.
24
+
25
+
[kind] is recorded in the layer metadata. Defaults to
26
+
{!Day11_layer.Layer_meta.Build}. Doc-phase callers should pass
27
+
{!Day11_layer.Layer_meta.Compile}, {!Day11_layer.Layer_meta.Link},
28
+
or {!Day11_layer.Layer_meta.Doc_all}. *)
+1
-1
day11/build/dune
+1
-1
day11/build/dune
-2
day11/build/hash_cache.mli
-2
day11/build/hash_cache.mli
···
14
14
package hashes so patched builds get distinct cache keys. *)
15
15
16
16
val pkg_opam_hash : t -> OpamPackage.t -> string
17
-
(** [pkg_opam_hash t pkg] returns a hash of the package's effective
18
-
opam file content. Memoized per package. *)
19
17
20
18
val layer_hash : t -> base_hash:string -> OpamPackage.t list -> string
21
19
(** [layer_hash t ~base_hash pkgs] returns a hash for a build layer.
+74
-27
day11/build/run_in_layers.ml
+74
-27
day11/build/run_in_layers.ml
···
54
54
let merged = Fpath.(temp_dir / "merged") in
55
55
let lower = Fpath.(temp_dir / "lower") in
56
56
List.iter mkdir [ upper; work; merged ];
57
-
(* Merge all dep layers into a single lower dir using cp --link.
58
-
overlayfs multi-lower does NOT merge directories across layers —
59
-
only the topmost layer's version of a directory is visible. This
60
-
broke packages depending on multiple conf packages that install
61
-
into the same system directories (e.g. /usr/include/GL/). *)
57
+
(* Hybrid lowerdir layout. The classic mount(2) options string is
58
+
capped at PAGE_SIZE (typically 4096 bytes), which limits how many
59
+
dep layers we can pass as separate lowerdirs. The hybrid:
60
+
61
+
1. Try to fit all dep layers as individual lowerdirs in the mount
62
+
options. For typical opam packages (<60 deps with current paths,
63
+
~160 with /c-style short paths) this works directly.
64
+
65
+
2. If the option string would exceed the budget, keep as many
66
+
layers as possible as separate lowerdirs and cp-merge the
67
+
excess into one [lower/] dir, which becomes one extra lowerdir.
68
+
69
+
Multi-lower is correct: per the kernel docs, overlayfs DOES merge
70
+
directories across multiple lowers — see docs.kernel.org/
71
+
filesystems/overlayfs.html: "Where both upper and lower objects
72
+
are directories, a merged directory is formed". The
73
+
trusted.overlay.opaque xattr only takes effect when set on the
74
+
UPPER layer, not on lowers, so layers carrying opaque=y from a
75
+
prior overlay-build don't cause shadowing here. *)
76
+
(* Mark every dep layer as recently used for LRU eviction. *)
77
+
List.iter Day11_layer.Last_used.touch build_dirs;
78
+
(* Compute the byte budget for plan_lowerdir. The overlayfs mount(2)
79
+
options string is capped at PAGE_SIZE; we leave ~96 bytes of
80
+
headroom below 4096. Fixed overhead is the keyword, the base
81
+
entry (plus leading colon), and the upper/work options. *)
82
+
let dep_entry_cost d =
83
+
String.length (Fpath.to_string Fpath.(d / "fs")) + 1 (* colon *)
84
+
in
85
+
let fixed_overhead =
86
+
String.length "lowerdir="
87
+
+ String.length (Fpath.to_string base_fs)
88
+
+ String.length ",upperdir=" + String.length (Fpath.to_string upper)
89
+
+ String.length ",workdir=" + String.length (Fpath.to_string work)
90
+
in
91
+
let merged_overhead =
92
+
String.length (Fpath.to_string lower) + 1 (* colon *)
93
+
in
94
+
let available = 4000 - fixed_overhead in
95
+
let separate_dirs, to_merge_dirs =
96
+
Day11_layer.Stack.plan_lowerdir
97
+
~available ~merged_overhead ~entry_cost:dep_entry_cost
98
+
build_dirs
99
+
in
100
+
let did_merge = to_merge_dirs <> [] in
101
+
if did_merge then begin
102
+
mkdir lower;
103
+
let merge_result =
104
+
timed_to (Printf.sprintf "stack.merge (%d of %d build layers)"
105
+
(List.length to_merge_dirs) (List.length build_dirs)) t_merge
106
+
(fun () ->
107
+
Day11_layer.Stack.merge env ~layer_dirs:to_merge_dirs ~target:lower)
108
+
in
109
+
(match merge_result with
110
+
| Ok () -> ()
111
+
| Error (`Msg e) ->
112
+
Log.err (fun m -> m "stack.merge failed: %s" e))
113
+
end;
114
+
(* layer_fs_dirs is the list of dep lowers in the order used in the
115
+
overlayfs mount (separate first, then merged-lower if any). It's
116
+
reused below by dump_state to walk per-dep packages dirs. *)
62
117
let layer_fs_dirs =
63
-
if build_dirs = [] then []
64
-
else begin
65
-
mkdir lower;
66
-
let merge_result =
67
-
timed_to (Printf.sprintf "stack.merge (%d build layers)"
68
-
(List.length build_dirs)) t_merge (fun () ->
69
-
Day11_layer.Stack.merge env ~layer_dirs:build_dirs ~target:lower)
70
-
in
71
-
(match merge_result with
72
-
| Ok () -> ()
73
-
| Error (`Msg e) ->
74
-
Log.err (fun m -> m "stack.merge failed: %s" e));
75
-
[ lower ]
76
-
end
118
+
List.map (fun d -> Fpath.(d / "fs")) separate_dirs
119
+
@ (if did_merge then [ lower ] else [])
77
120
in
78
121
let cleanup_internals () =
79
-
if build_dirs <> [] then
122
+
if did_merge then
80
123
ignore (Day11_exec.Sudo.rm_rf env lower);
81
124
ignore (Day11_exec.Sudo.rm_rf env work);
82
125
ignore (Day11_exec.Sudo.rm_rf env merged);
···
159
202
in
160
203
(* Always clean up internals — only upper survives *)
161
204
timed_to "cleanup internals" t_cleanup (fun () -> cleanup_internals ());
162
-
let timing : Day11_layer.Layer_meta.timing = {
163
-
merge = !t_merge; dump_state = !t_dump; chown = !t_chown;
164
-
overlay_mount = !t_mount; runc_run = !t_runc;
165
-
overlay_umount = !t_umount; cleanup = !t_cleanup;
166
-
extract = 0.; (* filled in by build_layer *)
167
-
total = Unix.gettimeofday () -. t_total;
168
-
} in
205
+
let timing : Day11_layer.Layer_meta.timing = [
206
+
"merge", !t_merge;
207
+
"dump_state", !t_dump;
208
+
"chown", !t_chown;
209
+
"overlay_mount", !t_mount;
210
+
"runc_run", !t_runc;
211
+
"overlay_umount", !t_umount;
212
+
"cleanup", !t_cleanup;
213
+
(* "extract" is filled in by build_layer *)
214
+
"total", Unix.gettimeofday () -. t_total;
215
+
] in
169
216
match run_result with
170
217
| Ok run -> Ok (run, upper, timing)
171
218
| Error _ as e ->
+7
-7
day11/build/test/test_from_scratch.ml
+7
-7
day11/build/test/test_from_scratch.ml
···
17
17
mkdir os_dir;
18
18
Printf.printf "Solving astring.0.8.5...\n%!";
19
19
let git_packages, _store, _commit =
20
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
21
-
let opam_env = Day11_solver.Opam_env.std_env
20
+
Day11_opam.Git_packages.of_opam_repository opam_repository in
21
+
let opam_env = Day11_opam.Opam_env.std_env
22
22
~arch ~os:"linux" ~os_distribution ~os_family:"debian"
23
23
~os_version:"12" () in
24
24
let solution =
···
27
27
| Ok s -> s
28
28
| Error diag -> Alcotest.fail ("Solve failed: " ^ diag)
29
29
in
30
-
let topo = Day11_graph.Graph.topological_sort solution in
31
-
Printf.printf "Solved: %d packages\n%!" (List.length topo);
30
+
let pkgs = OpamPackage.Map.keys solution in
31
+
Printf.printf "Solved: %d packages\n%!" (List.length pkgs);
32
32
Printf.printf "\nBuilding base image from %s:%s...\n%!"
33
33
os_distribution os_version;
34
34
let base = Base.build env ~cache_dir
···
36
36
~opam_repositories:[Fpath.v opam_repository] ~uid:1000 ~gid:1000 ()
37
37
|> ok_or_fail "base build" in
38
38
Printf.printf "Base: %s\n%!" (Fpath.to_string base.dir);
39
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
39
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
40
40
let cache = Hash_cache.create ~find_opam () in
41
41
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
42
42
let _final =
···
65
65
Alcotest.fail (Printf.sprintf "%s build failed: %s" pkg_str name)
66
66
| _ ->
67
67
Alcotest.fail (Printf.sprintf "%s unexpected" pkg_str)
68
-
) [] topo
68
+
) [] pkgs
69
69
in
70
70
Printf.printf "\n=== All %d packages built successfully ===\n%!"
71
-
(List.length topo)
71
+
(List.length pkgs)
72
72
73
73
let () =
74
74
if not (is_integration ()) then
+19
-29
day11/build/test/test_tools.ml
+19
-29
day11/build/test/test_tools.ml
···
18
18
let test_build_astring () = with_eio @@ fun env ->
19
19
let opam_repository = opam_repository () in
20
20
let benv = make_build_env () in
21
-
let git_packages, _store, _commit =
22
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
23
-
let opam_env = Day11_solver.Opam_env.std_env
24
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
25
-
~os_family:"debian" ~os_version:"12" () in
21
+
let git_packages, repos_with_shas =
22
+
Day11_opam.Git_packages.of_repositories
23
+
[ (opam_repository, None) ] in
26
24
let tool =
27
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
25
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
28
26
(OpamPackage.of_string "astring.0.8.5")
29
27
|> ok_or_fail "build_tool"
30
28
in
···
41
39
let test_build_odoc () = with_eio @@ fun env ->
42
40
let opam_repository = opam_repository () in
43
41
let benv = make_build_env () in
44
-
let git_packages, _store, _commit =
45
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
46
-
let opam_env = Day11_solver.Opam_env.std_env
47
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
48
-
~os_family:"debian" ~os_version:"12" () in
42
+
let git_packages, repos_with_shas =
43
+
Day11_opam.Git_packages.of_repositories
44
+
[ (opam_repository, None) ] in
49
45
let odoc_versions =
50
-
Day11_solver.Git_packages.get_versions git_packages
46
+
Day11_opam.Git_packages.get_versions git_packages
51
47
(OpamPackage.Name.of_string "odoc") in
52
48
let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
53
49
| Some (v, _) ->
···
56
52
in
57
53
Printf.printf "Building %s...\n%!" (OpamPackage.to_string odoc_pkg);
58
54
let tool =
59
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
55
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
60
56
odoc_pkg
61
57
|> ok_or_fail "build_tool"
62
58
in
···
71
67
let test_build_odoc_pinned_compiler () = with_eio @@ fun env ->
72
68
let opam_repository = opam_repository () in
73
69
let benv = make_build_env () in
74
-
let git_packages, _store, _commit =
75
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
76
-
let opam_env = Day11_solver.Opam_env.std_env
77
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
78
-
~os_family:"debian" ~os_version:"12" () in
70
+
let git_packages, repos_with_shas =
71
+
Day11_opam.Git_packages.of_repositories
72
+
[ (opam_repository, None) ] in
79
73
let odoc_versions =
80
-
Day11_solver.Git_packages.get_versions git_packages
74
+
Day11_opam.Git_packages.get_versions git_packages
81
75
(OpamPackage.Name.of_string "odoc") in
82
76
let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
83
77
| Some (v, _) ->
84
78
OpamPackage.create (OpamPackage.Name.of_string "odoc") v
85
79
| None -> Alcotest.skip ()
86
80
in
87
-
let constraints = OpamPackage.Name.Map.singleton
88
-
(OpamPackage.Name.of_string "ocaml-base-compiler")
89
-
(`Eq, OpamPackage.Version.of_string "5.4.1") in
81
+
let constraints = [ OpamPackage.of_string "ocaml-base-compiler.5.4.1" ] in
90
82
Printf.printf "Building %s pinned to ocaml 5.4.1...\n%!"
91
83
(OpamPackage.to_string odoc_pkg);
92
84
let tool =
93
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
85
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
94
86
~constraints odoc_pkg
95
87
|> ok_or_fail "build_tool"
96
88
in
···
113
105
let test_solve_failure () = with_eio @@ fun env ->
114
106
let opam_repository = opam_repository () in
115
107
let benv = make_build_env () in
116
-
let git_packages, _store, _commit =
117
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
118
-
let opam_env = Day11_solver.Opam_env.std_env
119
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
120
-
~os_family:"debian" ~os_version:"12" () in
108
+
let git_packages, repos_with_shas =
109
+
Day11_opam.Git_packages.of_repositories
110
+
[ (opam_repository, None) ] in
121
111
let result =
122
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
112
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
123
113
(OpamPackage.of_string "nonexistent-pkg.1.0")
124
114
in
125
115
Alcotest.(check bool) "returns error" true (Result.is_error result)
+13
-28
day11/build/test/test_tools_pinned.ml
+13
-28
day11/build/test/test_tools_pinned.ml
···
64
64
let opam_repository = opam_repository () in
65
65
let odoc_dir = odoc_repo () in
66
66
let benv = make_build_env () in
67
-
let git_packages, _store, _commit =
68
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
69
-
let opam_env = Day11_solver.Opam_env.std_env
70
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
71
-
~os_family:"debian" ~os_version:"12" () in
67
+
let git_packages, repos_with_shas =
68
+
Day11_opam.Git_packages.of_repositories
69
+
[ (opam_repository, None) ] in
72
70
let pins = read_pins odoc_dir in
73
71
let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
74
72
OpamPackage.Name.Map.add name odoc_dir acc
···
79
77
let target = OpamPackage.of_string "odoc-parser.dev" in
80
78
Printf.printf "Building %s from source...\n%!"
81
79
(OpamPackage.to_string target);
82
-
(* Test solve first *)
83
-
(match Day11_solver.Solve.solve ~packages:git_packages ~env:opam_env
84
-
~pins target with
85
-
| Ok solution ->
86
-
Printf.printf "Solve OK: %d packages\n%!"
87
-
(OpamPackage.Map.cardinal solution)
88
-
| Error msg ->
89
-
Printf.printf "Solve FAILED: %s\n%!" msg);
90
80
Printf.printf "Attempting build...\n%!";
91
-
let result = Tools.build_tool env benv ~packages:git_packages ~env:opam_env
92
-
~pins ~source_dirs target in
81
+
let result = Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
82
+
~pin_dirs:[ odoc_dir ] ~source_dirs target in
93
83
(match result with
94
84
| Error (`Msg e) -> Printf.printf "Build error: %s\n%!" e
95
85
| Ok _ -> Printf.printf "Build succeeded!\n%!");
···
110
100
let opam_repository = opam_repository () in
111
101
let odoc_dir = odoc_repo () in
112
102
let benv = make_build_env () in
113
-
let git_packages, _store, _commit =
114
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
115
-
let opam_env = Day11_solver.Opam_env.std_env
116
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
117
-
~os_family:"debian" ~os_version:"12" () in
103
+
let git_packages, repos_with_shas =
104
+
Day11_opam.Git_packages.of_repositories
105
+
[ (opam_repository, None) ] in
118
106
let pins = read_pins odoc_dir in
119
107
let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
120
108
OpamPackage.Name.Map.add name odoc_dir acc
···
123
111
Printf.printf "Building %s from source...\n%!"
124
112
(OpamPackage.to_string target);
125
113
let tool =
126
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
127
-
~pins ~source_dirs target
114
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
115
+
~pin_dirs:[ odoc_dir ] ~source_dirs target
128
116
|> ok_or_fail "build_tool odoc-driver.dev"
129
117
in
130
118
Printf.printf "odoc-driver.dev built: %d layers\n%!"
···
162
150
let opam_repository = opam_repository () in
163
151
let benv = make_build_env () in
164
152
(* Load from a single repo *)
165
-
let git_packages, _stores =
166
-
Day11_solver.Git_packages.of_repositories
153
+
let git_packages, repos_with_shas =
154
+
Day11_opam.Git_packages.of_repositories
167
155
[ (opam_repository, None) ] in
168
-
let opam_env = Day11_solver.Opam_env.std_env
169
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
170
-
~os_family:"debian" ~os_version:"12" () in
171
156
(* Build astring as a sanity check *)
172
157
let target = OpamPackage.of_string "astring.0.8.5" in
173
158
Printf.printf "Building %s via of_repositories...\n%!"
174
159
(OpamPackage.to_string target);
175
160
let tool =
176
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env target
161
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas target
177
162
|> ok_or_fail "build_tool astring"
178
163
in
179
164
Printf.printf "astring built: %d layers\n%!" (List.length tool.builds);
+34
-38
day11/build/tools.ml
+34
-38
day11/build/tools.ml
···
25
25
pkg_str;
26
26
cleanup = Build_layer.opam_build_cleanup }
27
27
28
-
let plan_tool (benv : Types.build_env) ~packages ~env:opam_env
29
-
?(constraints = OpamPackage.Name.Map.empty)
30
-
?(pins = OpamPackage.Name.Map.empty)
31
-
?(doc = true) ?(extra_targets = [])
28
+
let plan_tool (benv : Types.build_env) ~packages ~repos
29
+
?(constraints = [])
30
+
?(pin_dirs = [])
31
+
?(doc = true)
32
32
?ocaml_version
33
33
?(source_dirs = OpamPackage.Name.Map.empty)
34
34
?cache
35
35
target =
36
36
let pkg_str = OpamPackage.to_string target in
37
37
Log.info (fun m -> m "Planning tool %s" pkg_str);
38
-
match Day11_solver.Solve.solve ~packages ~env:opam_env
39
-
~constraints ~pins ~doc ~extra_targets ?ocaml_version target with
40
-
| Error diag ->
38
+
let results = Day11_solver_pool.Solver_pool.solve_many
39
+
~pin_dirs ~constraints ~doc ?ocaml_version
40
+
~np:1 ~repos [ target ] in
41
+
match List.assoc_opt target results with
42
+
| None ->
43
+
Rresult.R.error_msgf "Cannot solve %s: no result" pkg_str
44
+
| Some (Error (diag, _examined)) ->
41
45
Rresult.R.error_msgf "Cannot solve %s: %s" pkg_str diag
42
-
| Ok solution ->
46
+
| Some (Ok (solution, _examined)) ->
43
47
let cache = match cache with
44
48
| Some c -> c
45
49
| None ->
46
-
let find_opam pkg =
47
-
match OpamPackage.Name.Map.find_opt (OpamPackage.name pkg) pins with
48
-
| Some (_ver, opam) -> Some opam
49
-
| None -> Day11_solver.Git_packages.find_package packages pkg
50
-
in
50
+
let find_opam = Day11_opam.Git_packages.find_package packages in
51
51
Hash_cache.create ~find_opam ()
52
52
in
53
53
let nodes = Dag.build_dag cache ~base_hash:benv.base.hash
54
54
[ (target, solution) ] in
55
-
let topo = Day11_graph.Graph.topological_sort solution in
56
55
let last = List.find (fun (n : build) ->
57
56
OpamPackage.equal n.pkg target) nodes in
58
57
let tool_dir = build_dir ~os_dir:benv.os_dir last in
59
58
Log.info (fun m -> m "Tool %s: %d nodes in DAG"
60
59
pkg_str (List.length nodes));
61
60
Ok ({ hash = last.hash; dir = tool_dir;
62
-
packages = topo; builds = nodes },
61
+
builds = nodes },
63
62
source_dirs)
64
63
65
-
let build_tool env (benv : Types.build_env) ?(np = 4) ~packages ~env:opam_env
66
-
?(constraints = OpamPackage.Name.Map.empty)
67
-
?(pins = OpamPackage.Name.Map.empty)
68
-
?(doc = true) ?(extra_targets = [])
64
+
let build_tool env (benv : Types.build_env) ?(np = 4) ~packages ~repos
65
+
?(constraints = [])
66
+
?(pin_dirs = [])
67
+
?(doc = true)
69
68
?ocaml_version
70
69
?(source_dirs = OpamPackage.Name.Map.empty)
71
70
?(mounts = []) target =
72
71
let pkg_str = OpamPackage.to_string target in
73
72
Log.info (fun m -> m "Building tool %s" pkg_str);
74
-
match plan_tool benv ~packages ~env:opam_env
75
-
~constraints ~pins ~doc ~extra_targets ?ocaml_version
73
+
match plan_tool benv ~packages ~repos
74
+
~constraints ~pin_dirs ~doc ?ocaml_version
76
75
~source_dirs target with
77
76
| Error _ as e -> e
78
77
| Ok (tool, source_dirs) ->
···
119
118
Rresult.R.error_msgf "Build failed for %s" name
120
119
| None -> Ok tool
121
120
122
-
let build_tool_from_repo env benv ?(np = 4) ~packages ~env:opam_env
121
+
let build_tool_from_repo env benv ?(np = 4) ~packages ~repos
123
122
?ocaml_version ?(mounts = []) ?(extra_repo_dirs = [])
124
123
?(extra_target_names = [])
125
124
~repo_dir ~target_name () =
126
-
let add_repo_pins dir (pins, source_dirs) =
127
-
let new_pins = read_pins_from_dir dir in
128
-
let pins = OpamPackage.Name.Map.fold
129
-
OpamPackage.Name.Map.add new_pins pins in
130
-
let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
131
-
OpamPackage.Name.Map.add name dir acc
132
-
) new_pins source_dirs in
133
-
(pins, source_dirs)
134
-
in
135
-
let pins, source_dirs =
136
-
List.fold_right add_repo_pins (repo_dir :: extra_repo_dirs)
137
-
(OpamPackage.Name.Map.empty, OpamPackage.Name.Map.empty)
138
-
in
125
+
let all_dirs = repo_dir :: extra_repo_dirs in
126
+
let source_dirs = List.fold_right (fun dir acc ->
127
+
let opam_files = Sys.readdir dir |> Array.to_list
128
+
|> List.filter (fun f -> Filename.check_suffix f ".opam") in
129
+
List.fold_left (fun acc filename ->
130
+
let name = Filename.chop_suffix filename ".opam" in
131
+
OpamPackage.Name.Map.add
132
+
(OpamPackage.Name.of_string name) dir acc
133
+
) acc opam_files
134
+
) all_dirs OpamPackage.Name.Map.empty in
139
135
let target = OpamPackage.of_string (target_name ^ ".dev") in
140
-
let extra_targets = List.map (fun n ->
136
+
let constraints = List.map (fun n ->
141
137
OpamPackage.of_string (n ^ ".dev")) extra_target_names in
142
-
build_tool env benv ~np ~packages ~env:opam_env ~pins ~source_dirs
143
-
~doc:false ~extra_targets ?ocaml_version ~mounts target
138
+
build_tool env benv ~np ~packages ~repos ~pin_dirs:all_dirs
139
+
~constraints ~source_dirs ~doc:false ?ocaml_version ~mounts target
+21
-21
day11/build/tools.mli
+21
-21
day11/build/tools.mli
···
7
7
8
8
val plan_tool :
9
9
Types.build_env ->
10
-
packages:Day11_solver.Git_packages.t ->
11
-
env:(string -> OpamVariable.variable_contents option) ->
12
-
?constraints:OpamFormula.version_constraint OpamTypes.name_map ->
13
-
?pins:(OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t ->
10
+
packages:Day11_opam.Git_packages.t ->
11
+
repos:(string * string) list ->
12
+
?constraints:OpamPackage.t list ->
13
+
?pin_dirs:string list ->
14
14
?doc:bool ->
15
-
?extra_targets:OpamPackage.t list ->
16
15
?ocaml_version:OpamPackage.t ->
17
16
?source_dirs:string OpamPackage.Name.Map.t ->
18
17
?cache:Hash_cache.t ->
19
18
OpamPackage.t ->
20
19
(Day11_layer.Layer_type.tool * string OpamPackage.Name.Map.t,
21
20
[> Rresult.R.msg ]) result
22
-
(** [plan_tool benv ~packages ~env ?cache target] solves [target] and creates
23
-
DAG nodes without building. When [cache] is provided, shares hash
24
-
computation with the main build DAG to ensure identical layer hashes
25
-
for shared packages. Returns the tool plan and source_dirs for
26
-
pinned packages. *)
21
+
(** [plan_tool benv ~packages ~repos ?cache target] solves [target]
22
+
via solver_worker and creates DAG nodes without building.
23
+
[pin_dirs] are directories of [.opam] files pinned at version [dev].
24
+
[constraints] pins packages at exact versions.
25
+
When [cache] is provided, shares hash computation with the main
26
+
build DAG. Returns the tool plan and source_dirs for pinned packages. *)
27
27
28
28
val build_tool :
29
29
Eio_unix.Stdenv.base ->
30
30
Types.build_env ->
31
31
?np:int ->
32
-
packages:Day11_solver.Git_packages.t ->
33
-
env:(string -> OpamVariable.variable_contents option) ->
34
-
?constraints:OpamFormula.version_constraint OpamTypes.name_map ->
35
-
?pins:(OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t ->
32
+
packages:Day11_opam.Git_packages.t ->
33
+
repos:(string * string) list ->
34
+
?constraints:OpamPackage.t list ->
35
+
?pin_dirs:string list ->
36
36
?doc:bool ->
37
-
?extra_targets:OpamPackage.t list ->
38
37
?ocaml_version:OpamPackage.t ->
39
38
?source_dirs:string OpamPackage.Name.Map.t ->
40
39
?mounts:Day11_container.Mount.t list ->
41
40
OpamPackage.t ->
42
41
(Day11_layer.Layer_type.tool, [> Rresult.R.msg ]) result
43
-
(** [build_tool env benv ?np ~packages ~env ?pins ?ocaml_version
44
-
?source_dirs target] solves and builds [target] and all its
45
-
dependencies. [pins] override packages with local dev versions.
42
+
(** [build_tool env benv ?np ~packages ~repos target] solves and builds
43
+
[target] and all its dependencies via solver_worker subprocesses.
44
+
[pin_dirs] are directories of [.opam] files pinned at version [dev].
45
+
[constraints] pins packages at exact versions.
46
46
[source_dirs] maps pinned package names to local source directories
47
47
that are mounted into the build container. *)
48
48
···
56
56
Eio_unix.Stdenv.base ->
57
57
Types.build_env ->
58
58
?np:int ->
59
-
packages:Day11_solver.Git_packages.t ->
60
-
env:(string -> OpamVariable.variable_contents option) ->
59
+
packages:Day11_opam.Git_packages.t ->
60
+
repos:(string * string) list ->
61
61
?ocaml_version:OpamPackage.t ->
62
62
?mounts:Day11_container.Mount.t list ->
63
63
?extra_repo_dirs:string list ->
···
66
66
target_name:string ->
67
67
unit ->
68
68
(Day11_layer.Layer_type.tool, [> Rresult.R.msg ]) result
69
-
(** [build_tool_from_repo env benv ~packages ~env ~repo_dir
69
+
(** [build_tool_from_repo env benv ~packages ~repos ~repo_dir
70
70
?extra_repo_dirs ~target_name ()] reads [.opam] files from
71
71
[repo_dir] and each [extra_repo_dirs], pins all packages found
72
72
to dev, and builds [target_name.dev] with [~doc:false].
-1
day11/build/types.mli
-1
day11/build/types.mli
+14
-5
day11/container/test/test_build_package.ml
+14
-5
day11/container/test/test_build_package.ml
···
108
108
% Fpath.to_string Fpath.(layer_dir / "fs")) in
109
109
(match r with Ok _ -> () | Error (`Msg e) -> Alcotest.fail e);
110
110
(* Write layer.json *)
111
-
Day11_layer.Layer_info.save
112
-
Fpath.(layer_dir / "layer.json")
113
-
~pkg ~deps:[] ~hashes:[] ~exit_status:exit_code
114
-
~uid:1000 ~gid:1000 ~base_hash:(Day11_layer.Hash.base_hash ~image:base_image)
115
-
|> ok_or_fail "save layer_info";
111
+
let meta : Day11_layer.Layer_meta.build_meta = {
112
+
package = pkg; kind = Day11_layer.Layer_meta.Build;
113
+
exit_status = exit_code;
114
+
deps = []; hashes = [];
115
+
uid = 1000; gid = 1000;
116
+
base_hash = Day11_layer.Hash.base_hash ~image:base_image;
117
+
installed_libs = []; installed_docs = []; patches = [];
118
+
failed_dep = None; disk_usage = 0;
119
+
timing = Day11_layer.Layer_meta.empty_timing;
120
+
created_at = "";
121
+
} in
122
+
Day11_layer.Layer_meta.save_build
123
+
Fpath.(layer_dir / "layer.json") meta
124
+
|> ok_or_fail "save layer meta";
116
125
(* Clean up temp dir *)
117
126
Day11_exec.Sudo.rm_rf env temp_dir |> ignore;
118
127
Printf.printf "Layer for %s at %s\n%!" pkg (Fpath.to_string layer_dir);
+164
day11/container/test/test_integration.ml
+164
day11/container/test/test_integration.ml
···
126
126
true (String.trim run.output = "hello from layer1"
127
127
|| String.trim run.errors = "hello from layer1")
128
128
129
+
(* ── Hybrid lowerdir plan ─────────────────────────────────────────── *)
130
+
131
+
(** Create [n] fake "dep" layer dirs. Each one has [fs/data/<i>.txt]
132
+
with content ["payload-<i>"], so we can verify the merged view
133
+
contains data from every layer. The base layer provides /bin/cat
134
+
and a /data directory we can append into. *)
135
+
let make_dep_layers parent_dir n =
136
+
List.init n (fun i ->
137
+
let layer_dir = Fpath.(parent_dir / Printf.sprintf "dep-%03d" i) in
138
+
let fs = Fpath.(layer_dir / "fs") in
139
+
let data = Fpath.(fs / "data") in
140
+
mkdir data;
141
+
write_file Fpath.(data / Printf.sprintf "%03d.txt" i)
142
+
(Printf.sprintf "payload-%d" i);
143
+
layer_dir)
144
+
145
+
(** End-to-end test for [Stack.plan_lowerdir]: create [n_layers] fake
146
+
dep layers, plan, optionally merge, mount overlay, and verify
147
+
every dep's file is visible inside the container. *)
148
+
let run_hybrid_plan_test ~n_layers ~budget () =
149
+
with_eio @@ fun env ->
150
+
with_tmp_dir @@ fun dir ->
151
+
(* Base rootfs (busybox) *)
152
+
let base_layer = Fpath.(dir / "base") in
153
+
let base_fs = Fpath.(base_layer / "fs") in
154
+
create_rootfs base_fs;
155
+
mkdir Fpath.(base_fs / "data"); (* placeholder so /data exists *)
156
+
(* N dep layers, each adding /data/<i>.txt *)
157
+
let deps_parent = Fpath.(dir / "deps") in
158
+
mkdir deps_parent;
159
+
let dep_layers = make_dep_layers deps_parent n_layers in
160
+
(* Plan the layout *)
161
+
let upper = Fpath.(dir / "upper") in
162
+
let work = Fpath.(dir / "work") in
163
+
let merged = Fpath.(dir / "merged") in
164
+
let merged_lower = Fpath.(dir / "lower") in
165
+
List.iter mkdir [ upper; work; merged ];
166
+
let entry_cost d =
167
+
String.length (Fpath.to_string Fpath.(d / "fs")) + 1
168
+
in
169
+
let fixed_overhead =
170
+
String.length "lowerdir="
171
+
+ String.length (Fpath.to_string base_fs)
172
+
+ String.length ",upperdir=" + String.length (Fpath.to_string upper)
173
+
+ String.length ",workdir=" + String.length (Fpath.to_string work)
174
+
in
175
+
let merged_overhead =
176
+
String.length (Fpath.to_string merged_lower) + 1
177
+
in
178
+
let available = budget - fixed_overhead in
179
+
let separate, to_merge = Day11_layer.Stack.plan_lowerdir
180
+
~available ~merged_overhead ~entry_cost dep_layers
181
+
in
182
+
Alcotest.(check int) "all layers accounted for"
183
+
n_layers (List.length separate + List.length to_merge);
184
+
(* If anything to merge, do the cp-merge *)
185
+
if to_merge <> [] then begin
186
+
mkdir merged_lower;
187
+
Day11_layer.Stack.merge env ~layer_dirs:to_merge ~target:merged_lower
188
+
|> ok_or_fail "stack.merge"
189
+
end;
190
+
(* Build the overlay lower list: separate dep fs/ dirs + (merged
191
+
lower if any) + base. This must be the same construction
192
+
run_in_layers.ml uses. *)
193
+
let lower_dirs =
194
+
List.map (fun d -> Fpath.(d / "fs")) separate
195
+
@ (if to_merge = [] then [] else [ merged_lower ])
196
+
@ [ base_fs ]
197
+
in
198
+
(* Verify the actual mount-options string fits the budget. This is
199
+
the key invariant plan_lowerdir is meant to enforce. *)
200
+
let options =
201
+
Printf.sprintf "lowerdir=%s,upperdir=%s,workdir=%s"
202
+
(String.concat ":" (List.map Fpath.to_string lower_dirs))
203
+
(Fpath.to_string upper)
204
+
(Fpath.to_string work)
205
+
in
206
+
Alcotest.(check bool)
207
+
(Printf.sprintf "options string %d bytes ≤ budget %d"
208
+
(String.length options) budget)
209
+
true (String.length options <= budget);
210
+
(* Mount the overlay *)
211
+
Overlay.mount env ~lower:lower_dirs ~upper ~work ~target:merged
212
+
|> ok_or_fail "overlay mount";
213
+
Fun.protect ~finally:(fun () ->
214
+
ignore (Overlay.umount env merged))
215
+
(fun () ->
216
+
(* Run a container that lists /data and verifies every file is
217
+
present. We use shell to count files and check their content. *)
218
+
let script =
219
+
Printf.sprintf
220
+
"n=$(ls /data | wc -l); echo \"count=$n\"; \
221
+
for i in $(ls /data); do cat /data/$i; echo; done"
222
+
in
223
+
let spec =
224
+
Oci_spec.make
225
+
~terminal:false
226
+
~root:(Fpath.to_string merged)
227
+
~cwd:"/"
228
+
~argv:[ "/bin/sh"; "-c"; script ]
229
+
~hostname:"test"
230
+
~uid:0 ~gid:0
231
+
~env:[ ("PATH", "/bin") ]
232
+
~mounts:[]
233
+
~network:false
234
+
in
235
+
Runc.write_spec dir spec |> ok_or_fail "write_spec";
236
+
let container_id =
237
+
Printf.sprintf "day11-hybrid-%d-%d" n_layers (Unix.getpid ()) in
238
+
ignore (Runc.delete env container_id);
239
+
let run = Runc.run env ~bundle:dir ~container_id
240
+
|> ok_or_fail "runc run" in
241
+
ignore (Runc.delete env container_id);
242
+
Alcotest.(check bool) "container exit 0"
243
+
true (run.Day11_exec.Run.status = `Exited 0);
244
+
let out = run.output ^ run.errors in
245
+
(* Check the file count *)
246
+
let expected_count_line = Printf.sprintf "count=%d" n_layers in
247
+
Alcotest.(check bool)
248
+
(Printf.sprintf "container saw all %d files" n_layers)
249
+
true
250
+
(let lines = String.split_on_char '\n' out in
251
+
List.exists (fun l -> String.trim l = expected_count_line) lines);
252
+
(* Check every payload is present *)
253
+
for i = 0 to n_layers - 1 do
254
+
let expected = Printf.sprintf "payload-%d" i in
255
+
Alcotest.(check bool)
256
+
(Printf.sprintf "payload-%d visible" i)
257
+
true
258
+
(let lines = String.split_on_char '\n' out in
259
+
List.exists (fun l -> String.trim l = expected) lines)
260
+
done)
261
+
262
+
(** Multi-lower path: small layer count, generous budget. Should
263
+
keep every layer separate and never invoke Stack.merge. *)
264
+
let test_hybrid_pure_multi_lower () =
265
+
run_hybrid_plan_test ~n_layers:30 ~budget:4000 ()
266
+
267
+
(** Forced split: many layers, tight budget. Plan must split into
268
+
separate + merged buckets, and the assembled mount must still
269
+
show every dep's content. *)
270
+
let test_hybrid_forced_split () =
271
+
(* 60 layers with realistic-ish (long) path components inside the
272
+
temp dir. With a deliberately small budget, the plan is forced
273
+
to merge most of them. *)
274
+
run_hybrid_plan_test ~n_layers:60 ~budget:1500 ()
275
+
276
+
(** Realistic 4K test: enough layers that pure multi-lower would
277
+
overflow PAGE_SIZE. Without the split, the mount would fail. *)
278
+
let test_hybrid_real_4k_overflow () =
279
+
(* The temp dirs in this test have long paths under /tmp, and
280
+
each "dep-NNN" entry costs around 60 bytes. With ~70+ deps,
281
+
the lowerdir string would exceed 4096. The plan must split. *)
282
+
run_hybrid_plan_test ~n_layers:80 ~budget:4000 ()
283
+
129
284
let () =
130
285
if not (is_integration ()) then
131
286
Printf.printf
···
138
293
Alcotest.test_case "runc echo" `Slow test_runc_echo;
139
294
Alcotest.test_case "overlay + runc" `Slow
140
295
test_overlay_and_runc;
296
+
] );
297
+
( "Hybrid lowerdir plan",
298
+
[
299
+
Alcotest.test_case "pure multi-lower" `Slow
300
+
test_hybrid_pure_multi_lower;
301
+
Alcotest.test_case "forced split (small budget)" `Slow
302
+
test_hybrid_forced_split;
303
+
Alcotest.test_case "4K boundary" `Slow
304
+
test_hybrid_real_4k_overflow;
141
305
] );
142
306
]
+5
-1
day11/doc/combine.ml
+5
-1
day11/doc/combine.ml
···
16
16
List.filter_map (fun (name, layer_path) ->
17
17
if not (is_doc_layer name) then None
18
18
else
19
-
match Day11_layer.Query.metadata layer_path with
19
+
let json_path = Fpath.(layer_path / "layer.json") in
20
+
match
21
+
try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
22
+
with _ -> None
23
+
with
20
24
| None -> None
21
25
| Some json ->
22
26
try
+13
-9
day11/doc/generate.ml
+13
-9
day11/doc/generate.ml
···
117
117
let result =
118
118
match Day11_build.Build_layer.build env benv
119
119
~mounts:(mounts @ store_mounts) ~skip_state_dump:true
120
+
~kind:Day11_layer.Layer_meta.Compile
120
121
compile_node
121
122
~strategy:{ cmd; cleanup = doc_cleanup } () with
122
123
| Day11_build.Types.Success bl ->
···
170
171
let result =
171
172
match Day11_build.Build_layer.build env benv
172
173
~mounts:(mounts @ store_mounts) ~skip_state_dump:true
174
+
~kind:Day11_layer.Layer_meta.Link
173
175
link_node
174
176
~strategy:{ cmd; cleanup = doc_cleanup } () with
175
177
| Day11_build.Types.Success _bl ->
···
221
223
let result =
222
224
match Day11_build.Build_layer.build env benv
223
225
~mounts:(mounts @ store_mounts) ~skip_state_dump:true
226
+
~kind:Day11_layer.Layer_meta.Doc_all
224
227
doc_node
225
228
~strategy:{ cmd; cleanup = doc_cleanup } () with
226
229
| Day11_build.Types.Success bl ->
···
317
320
) nodes;
318
321
(* Compute link deps (with {post}) per solution for split detection *)
319
322
let link_solutions = List.map (fun (target, solution) ->
320
-
let link_deps = Day11_solver.Solve.recompute_with_post
323
+
let link_deps = Day11_opam.Deps.recompute_with_post
321
324
~packages ~env:opam_env solution in
322
325
(target, solution, link_deps)
323
326
) solutions in
···
587
590
Hashtbl.replace dep_locs build_hash loc
588
591
) node_pkg_loc;
589
592
let is_cached node =
593
+
let layer_dir = Day11_layer.Layer_type.build_dir ~os_dir node in
590
594
let layer_cached =
591
-
Bos.OS.File.exists
592
-
Fpath.(Day11_layer.Layer_type.build_dir ~os_dir node / "layer.json")
595
+
Bos.OS.File.exists Fpath.(layer_dir / "layer.json")
593
596
|> Result.get_ok
594
597
in
598
+
if layer_cached then Day11_layer.Last_used.touch layer_dir;
595
599
if not layer_cached then false
596
600
else if Hashtbl.mem doc_all_set node.hash then
597
601
(* Doc-all: check store has both odoc-out and html *)
···
746
750
| _ -> None
747
751
) solutions
748
752
749
-
let build_tools_and_run env benv ~np ~os_dir ~packages ~opam_env
753
+
let build_tools_and_run env benv ~np ~os_dir ~packages ~repos ~opam_env
750
754
~mounts ~driver_compiler ~odoc_repo ~build_one
751
755
~opam_repositories:_
752
756
~cache ~run_log
753
757
~nodes ~solutions ~blessing_maps =
754
758
Printf.printf "\nPlanning doc tools...\n%!";
755
-
let all_pins, all_source_dirs = match odoc_repo with
759
+
let all_pin_dirs, all_source_dirs = match odoc_repo with
756
760
| Some dir ->
757
761
Printf.printf "Using local odoc from %s\n%!" dir;
758
762
let pins = Day11_build.Tools.read_pins_from_dir dir in
759
763
let source_dirs = OpamPackage.Name.Map.fold (fun name _ acc ->
760
764
OpamPackage.Name.Map.add name dir acc
761
765
) pins OpamPackage.Name.Map.empty in
762
-
(pins, source_dirs)
766
+
([ dir ], source_dirs)
763
767
| None ->
764
-
(OpamPackage.Name.Map.empty, OpamPackage.Name.Map.empty)
768
+
([], OpamPackage.Name.Map.empty)
765
769
in
766
770
(* 1. Plan driver with fixed compiler *)
767
771
let driver_pkg = OpamPackage.of_string "odoc-driver.3.1.0" in
768
772
Printf.printf "Planning doc driver (%s)...\n%!"
769
773
(OpamPackage.to_string driver_compiler);
770
774
let driver_result = Day11_build.Tools.plan_tool benv
771
-
~packages ~env:opam_env ~doc:false ~cache
775
+
~packages ~repos ~doc:false ~cache
772
776
~ocaml_version:driver_compiler driver_pkg in
773
777
match driver_result with
774
778
| Error (`Msg e) ->
···
788
792
Printf.printf "Planning odoc for %s...\n%!"
789
793
(OpamPackage.to_string compiler_v);
790
794
match Day11_build.Tools.plan_tool benv
791
-
~packages ~env:opam_env ~pins:all_pins
795
+
~packages ~repos ~pin_dirs:all_pin_dirs
792
796
~source_dirs:all_source_dirs ~doc:false ~cache
793
797
~ocaml_version:compiler_v odoc_pkg with
794
798
| Error (`Msg e) ->
+3
-2
day11/doc/generate.mli
+3
-2
day11/doc/generate.mli
···
39
39
odoc_tools:(OpamPackage.t * Day11_layer.Layer_type.tool) list ->
40
40
tool_source_dirs:string OpamPackage.Name.Map.t ->
41
41
mounts:Day11_container.Mount.t list ->
42
-
packages:Day11_solver.Git_packages.t ->
42
+
packages:Day11_opam.Git_packages.t ->
43
43
opam_env:(string -> OpamVariable.variable_contents option) ->
44
44
run_log:Day11_lib.Run_log.t ->
45
45
build_one:(Day11_layer.Layer_type.build -> bool) ->
···
53
53
Day11_build.Types.build_env ->
54
54
np:int ->
55
55
os_dir:Fpath.t ->
56
-
packages:Day11_solver.Git_packages.t ->
56
+
packages:Day11_opam.Git_packages.t ->
57
+
repos:(string * string) list ->
57
58
opam_env:(string -> OpamVariable.variable_contents option) ->
58
59
mounts:Day11_container.Mount.t list ->
59
60
driver_compiler:OpamPackage.t ->
+5
-1
day11/doc/sync.ml
+5
-1
day11/doc/sync.ml
···
13
13
|| Astring.String.is_prefix ~affix:"doc-odoc-" name then
14
14
None
15
15
else
16
-
match Day11_layer.Query.metadata path with
16
+
let json_path = Fpath.(path / "layer.json") in
17
+
match
18
+
try Some (Yojson.Safe.from_file (Fpath.to_string json_path))
19
+
with _ -> None
20
+
with
17
21
| None -> None
18
22
| Some json ->
19
23
try
+10
-9
day11/doc/test/test_doc_compile_link.ml
+10
-9
day11/doc/test/test_doc_compile_link.ml
···
121
121
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
122
122
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
123
123
Types.ensure_dirs benv;
124
-
let git_packages, _store, _commit =
125
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
126
-
let opam_env = Day11_solver.Opam_env.std_env
124
+
let git_packages, repos_with_shas =
125
+
Day11_opam.Git_packages.of_repositories
126
+
[ (opam_repository, None) ] in
127
+
let opam_env = Day11_opam.Opam_env.std_env
127
128
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
128
129
~os_family:"debian" ~os_version:"12" () in
129
-
(base, os_dir, benv, git_packages, opam_env)
130
+
(base, os_dir, benv, git_packages, repos_with_shas, opam_env)
130
131
131
132
let test_astring_docs () = with_eio @@ fun env ->
132
-
let base, os_dir, benv, git_packages, opam_env = setup () in
133
+
let base, os_dir, benv, git_packages, repos_with_shas, opam_env = setup () in
133
134
Printf.printf "Building odoc-driver tools...\n%!";
134
135
let odoc_tool =
135
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
136
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
136
137
(OpamPackage.of_string "odoc-driver.3.1.0")
137
138
|> ok_or_fail "build odoc-driver"
138
139
in
139
140
Printf.printf " odoc-driver: %d layers\n%!" (List.length odoc_tool.builds);
140
141
Printf.printf "Building astring...\n%!";
141
142
let astring_pkg = OpamPackage.of_string "astring.0.8.5" in
142
-
let find_opam = Day11_solver.Git_packages.find_package git_packages in
143
+
let find_opam = Day11_opam.Git_packages.find_package git_packages in
143
144
let cache = Hash_cache.create ~find_opam () in
144
145
let astring_solution = match Day11_solver.Solve.solve ~packages:git_packages
145
146
~env:opam_env astring_pkg with
···
160
161
Alcotest.(check bool) "astring has HTML" true (html > 0)
161
162
162
163
let test_odoc_docs () = with_eio @@ fun env ->
163
-
let _base, os_dir, benv, git_packages, opam_env = setup () in
164
+
let _base, os_dir, benv, git_packages, repos_with_shas, _opam_env = setup () in
164
165
Printf.printf "Building odoc-driver tools...\n%!";
165
166
let odoc_tool =
166
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
167
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
167
168
(OpamPackage.of_string "odoc-driver.3.1.0")
168
169
|> ok_or_fail "build odoc-driver"
169
170
in
+5
-7
day11/doc/test/test_doc_integration.ml
+5
-7
day11/doc/test/test_doc_integration.ml
···
75
75
Alcotest.skip ();
76
76
let opam_repository = opam_repository () in
77
77
let base = make_base () in
78
-
let git_packages, _store, _commit =
79
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
80
-
let opam_env = Day11_solver.Opam_env.std_env
81
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
82
-
~os_family:"debian" ~os_version:"12" () in
78
+
let git_packages, repos_with_shas =
79
+
Day11_opam.Git_packages.of_repositories
80
+
[ (opam_repository, None) ] in
83
81
let odoc_versions =
84
-
Day11_solver.Git_packages.get_versions git_packages
82
+
Day11_opam.Git_packages.get_versions git_packages
85
83
(OpamPackage.Name.of_string "odoc") in
86
84
let odoc_pkg = match OpamPackage.Version.Map.max_binding_opt odoc_versions with
87
85
| Some (v, _) ->
···
92
90
let benv : Day11_build.Types.build_env =
93
91
{ base; os_dir; uid = 1000; gid = 1000 } in
94
92
let tool =
95
-
Day11_build.Tools.build_tool env benv ~packages:git_packages ~env:opam_env
93
+
Day11_build.Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
96
94
odoc_pkg
97
95
|> ok_or_fail "build_tool"
98
96
in
+4
-6
day11/doc/test/test_doc_pipeline.ml
+4
-6
day11/doc/test/test_doc_pipeline.ml
···
23
23
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
24
24
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
25
25
Types.ensure_dirs benv;
26
-
let git_packages, _store, _commit =
27
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
28
-
let opam_env = Day11_solver.Opam_env.std_env
29
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
30
-
~os_family:"debian" ~os_version:"12" () in
26
+
let git_packages, repos_with_shas =
27
+
Day11_opam.Git_packages.of_repositories
28
+
[ (opam_repository, None) ] in
31
29
let switch = Types.switch in
32
30
let odoc_bin = Printf.sprintf "/home/opam/.opam/%s/bin/odoc" switch in
33
31
let odoc_md_bin = Printf.sprintf "/home/opam/.opam/%s/bin/odoc-md" switch in
···
35
33
Printf.printf "Building odoc-driver and all deps...\n%!";
36
34
let driver_pkg = OpamPackage.of_string "odoc-driver.3.1.0" in
37
35
let odoc_tool =
38
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
36
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
39
37
driver_pkg
40
38
|> ok_or_fail "build odoc-driver"
41
39
in
+5
-7
day11/doc/test/test_generate_docs.ml
+5
-7
day11/doc/test/test_generate_docs.ml
···
21
21
Alcotest.skip ();
22
22
let opam_repository = opam_repository () in
23
23
let base = make_base () in
24
-
let git_packages, _store, _commit =
25
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
26
-
let opam_env = Day11_solver.Opam_env.std_env
27
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
28
-
~os_family:"debian" ~os_version:"12" () in
24
+
let git_packages, repos_with_shas =
25
+
Day11_opam.Git_packages.of_repositories
26
+
[ (opam_repository, None) ] in
29
27
(* Step 1: Build odoc-driver *)
30
28
Printf.printf "Building odoc-driver.3.1.0...\n%!";
31
29
let benv : Day11_build.Types.build_env =
32
30
{ base; os_dir; uid = 1000; gid = 1000 } in
33
31
let driver_tool =
34
-
Day11_build.Tools.build_tool env benv ~packages:git_packages ~env:opam_env
32
+
Day11_build.Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
35
33
(OpamPackage.of_string "odoc-driver.3.1.0")
36
34
|> ok_or_fail "build odoc-driver"
37
35
in
···
40
38
(* Step 2: Build astring on top of driver layers *)
41
39
Printf.printf "Building astring...\n%!";
42
40
let find_opam pkg =
43
-
try Some (Day11_solver.Git_packages.get_package git_packages pkg)
41
+
try Some (Day11_opam.Git_packages.get_package git_packages pkg)
44
42
with Not_found -> None
45
43
in
46
44
let astring_pkg = OpamPackage.of_string "astring.0.8.5" in
-44
day11/exec/atomic_publish.ml
-44
day11/exec/atomic_publish.ml
···
1
-
let suffix_old p = Fpath.(v (to_string p ^ ".old"))
2
-
let suffix_new p = Fpath.(v (to_string p ^ ".new"))
3
-
4
-
let dir_exists p = Bos.OS.Dir.exists p |> Result.get_ok
5
-
6
-
let publish ~src ~dst =
7
-
if not (dir_exists src) then
8
-
Rresult.R.error_msgf "Source %a does not exist" Fpath.pp src
9
-
else begin
10
-
(* Step 1: move existing dst to dst.old *)
11
-
let old = suffix_old dst in
12
-
if dir_exists old then
13
-
Bos.OS.Dir.delete ~recurse:true old |> ignore;
14
-
if dir_exists dst then
15
-
Unix.rename (Fpath.to_string dst) (Fpath.to_string old);
16
-
(* Step 2: move src to dst *)
17
-
(try
18
-
Unix.rename (Fpath.to_string src) (Fpath.to_string dst);
19
-
(* Step 3: remove old *)
20
-
if dir_exists old then
21
-
Bos.OS.Dir.delete ~recurse:true old |> ignore;
22
-
Ok ()
23
-
with Unix.Unix_error (e, _, _) ->
24
-
(* Rollback: restore old if we still have it *)
25
-
if dir_exists old && not (dir_exists dst) then
26
-
Unix.rename (Fpath.to_string old) (Fpath.to_string dst);
27
-
Rresult.R.error_msgf "Publish failed: %s" (Unix.error_message e))
28
-
end
29
-
30
-
let recover path =
31
-
let old = suffix_old path in
32
-
let new_ = suffix_new path in
33
-
(* Clean up .old leftover *)
34
-
if dir_exists old then
35
-
Bos.OS.Dir.delete ~recurse:true old |> ignore;
36
-
(* Handle .new leftover *)
37
-
if dir_exists new_ then begin
38
-
if dir_exists path then
39
-
(* Both exist: .new is stale, remove it *)
40
-
Bos.OS.Dir.delete ~recurse:true new_ |> ignore
41
-
else
42
-
(* .new exists but path doesn't: promote .new *)
43
-
Unix.rename (Fpath.to_string new_) (Fpath.to_string path)
44
-
end
-29
day11/exec/atomic_publish.mli
-29
day11/exec/atomic_publish.mli
···
1
-
(** Atomic directory publishing with graceful failure.
2
-
3
-
Swaps a newly-built directory into place using a three-step
4
-
rename sequence. If the process is interrupted, {!recover}
5
-
cleans up partial state.
6
-
7
-
Used for doc and JTW output where we want to preserve existing
8
-
output on rebuild failure. *)
9
-
10
-
val publish :
11
-
src:Fpath.t -> dst:Fpath.t ->
12
-
(unit, [> Rresult.R.msg ]) result
13
-
(** [publish ~src ~dst] atomically replaces [dst] with [src]:
14
-
1. [mv dst dst.old] (if dst exists)
15
-
2. [mv src dst]
16
-
3. [rm -rf dst.old]
17
-
18
-
If [dst] does not exist, simply renames [src] to [dst].
19
-
Returns [Error] if the rename fails. *)
20
-
21
-
val recover :
22
-
Fpath.t ->
23
-
unit
24
-
(** [recover path] cleans up interrupted publish state at [path]:
25
-
- If [path.new] exists and [path] does not, renames [.new] to [path]
26
-
- If [path.old] exists, removes it
27
-
- If both [path] and [path.new] exist, removes [.new] (stale)
28
-
29
-
Safe to call unconditionally at startup. *)
+16
-12
day11/exec/fork_client.ml
+16
-12
day11/exec/fork_client.ml
···
120
120
in
121
121
(stdout, stderr, status))
122
122
123
-
(* Global instance, started lazily *)
124
-
let instance : t option ref = ref None
125
-
let instance_lock = Mutex.create ()
123
+
(* Global instance, started lazily.
124
+
Uses Atomic to avoid Mutex deadlocks under Eio — multiple fibers
125
+
on the same OS thread would deadlock an OCaml Mutex.t. *)
126
+
let instance : t option Atomic.t = Atomic.make None
126
127
127
128
let get_instance () =
128
-
Mutex.lock instance_lock;
129
-
let t = match !instance with
130
-
| Some t -> t
131
-
| None ->
132
-
let t = start () in
133
-
instance := Some t;
129
+
match Atomic.get instance with
130
+
| Some t -> t
131
+
| None ->
132
+
let t = start () in
133
+
if Atomic.compare_and_set instance None (Some t) then begin
134
134
at_exit (fun () -> stop t);
135
135
t
136
-
in
137
-
Mutex.unlock instance_lock;
138
-
t
136
+
end else begin
137
+
(* Another fiber raced us — discard ours, use theirs *)
138
+
stop t;
139
+
match Atomic.get instance with
140
+
| Some t -> t
141
+
| None -> failwith "fork helper: startup race"
142
+
end
-6
day11/exec/fork_client.mli
-6
day11/exec/fork_client.mli
-49
day11/exec/reporter.ml
-49
day11/exec/reporter.ml
···
1
-
let timestamp () =
2
-
let t = Unix.gettimeofday () in
3
-
let tm = Unix.localtime t in
4
-
let ms = int_of_float (Float.rem (t *. 1000.0) 1000.0) in
5
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d.%03d"
6
-
(tm.Unix.tm_year + 1900)
7
-
(tm.Unix.tm_mon + 1)
8
-
tm.Unix.tm_mday
9
-
tm.Unix.tm_hour
10
-
tm.Unix.tm_min
11
-
tm.Unix.tm_sec
12
-
ms
13
-
14
-
let pid_file_reporter ~dir =
15
-
let () = Bos.OS.Dir.create ~path:true dir |> ignore in
16
-
let pid = Unix.getpid () in
17
-
let log_file = Fpath.(dir / (string_of_int pid ^ ".log")) in
18
-
let report _src level ~over k msgf =
19
-
let k _ = over (); k () in
20
-
msgf @@ fun ?header:_ ?tags:_ fmt ->
21
-
let level_s =
22
-
match level with
23
-
| Logs.App -> "APP"
24
-
| Logs.Error -> "ERR"
25
-
| Logs.Warning -> "WRN"
26
-
| Logs.Info -> "INF"
27
-
| Logs.Debug -> "DBG"
28
-
in
29
-
Format.kasprintf
30
-
(fun msg ->
31
-
let line = Printf.sprintf "%s [%s] %s\n" (timestamp ()) level_s msg in
32
-
let fd =
33
-
Unix.openfile (Fpath.to_string log_file)
34
-
[ Unix.O_WRONLY; Unix.O_APPEND; Unix.O_CREAT ]
35
-
0o644
36
-
in
37
-
Fun.protect ~finally:(fun () -> Unix.close fd) (fun () ->
38
-
let bytes = Bytes.of_string line in
39
-
let len = Bytes.length bytes in
40
-
let written = ref 0 in
41
-
while !written < len do
42
-
written :=
43
-
!written
44
-
+ Unix.write fd bytes !written (len - !written)
45
-
done);
46
-
k ())
47
-
fmt
48
-
in
49
-
{ Logs.report }
-12
day11/exec/reporter.mli
-12
day11/exec/reporter.mli
···
1
-
(** Per-PID file logging reporter.
2
-
3
-
A [Logs.reporter] that writes to per-PID log files with millisecond
4
-
timestamps. Installed by the binary at startup. *)
5
-
6
-
val pid_file_reporter : dir:Fpath.t -> Logs.reporter
7
-
(** [pid_file_reporter ~dir] returns a [Logs.reporter] that appends
8
-
log messages to [{dir}/{pid}.log]. Each line is prefixed with a
9
-
timestamp in [YYYY-MM-DD HH:MM:SS.mmm] format.
10
-
11
-
The log file is created on the first message. If [dir] does not
12
-
exist, it is created. *)
-52
day11/exec/retry.ml
-52
day11/exec/retry.ml
···
1
-
let src = Logs.Src.create "day11.exec.retry" ~doc:"Retried operations"
2
-
module Log = (val Logs.src_log src)
3
-
4
-
let exec ?(tries = 10) env cmd =
5
-
let rec loop n =
6
-
if n > tries then
7
-
Rresult.R.error_msgf "command failed after %d attempts: %s"
8
-
tries (Bos.Cmd.to_string cmd)
9
-
else
10
-
let r = Run.run env cmd None in
11
-
match r.Run.status with
12
-
| `Exited 0 -> Ok ()
13
-
| _ ->
14
-
if n < tries then begin
15
-
let delay = Random.float 2.0 in
16
-
Log.info (fun m ->
17
-
m "Attempt %d/%d failed (exit %a), retrying in %.1fs: %s"
18
-
n tries
19
-
Fmt.(of_to_string (fun s ->
20
-
match s with
21
-
| `Exited c -> string_of_int c
22
-
| `Signaled c -> "signal " ^ string_of_int c))
23
-
r.status
24
-
delay (Bos.Cmd.to_string cmd));
25
-
Unix.sleepf delay
26
-
end;
27
-
loop (n + 1)
28
-
in
29
-
loop 1
30
-
31
-
let rename ?(tries = 10) src dst =
32
-
let rec loop n =
33
-
if n > tries then
34
-
Rresult.R.error_msgf "rename failed after %d attempts: %a -> %a"
35
-
tries Fpath.pp src Fpath.pp dst
36
-
else
37
-
try
38
-
Unix.rename (Fpath.to_string src) (Fpath.to_string dst);
39
-
Ok ()
40
-
with Unix.Unix_error (e, _, _) ->
41
-
if n < tries then begin
42
-
let d = tries - n + 1 in
43
-
let delay = float_of_int (d * d) +. Random.float (float_of_int d) in
44
-
let delay = Float.min delay 5.0 in
45
-
Log.info (fun m ->
46
-
m "Rename attempt %d/%d failed (%s), retrying in %.1fs"
47
-
n tries (Unix.error_message e) delay);
48
-
Unix.sleepf delay
49
-
end;
50
-
loop (n + 1)
51
-
in
52
-
loop 1
-18
day11/exec/retry.mli
-18
day11/exec/retry.mli
···
1
-
(** Retried operations.
2
-
3
-
For transient failures: retries commands and renames with backoff. *)
4
-
5
-
val exec :
6
-
?tries:int ->
7
-
Eio_unix.Stdenv.base ->
8
-
Bos.Cmd.t ->
9
-
(unit, [> Rresult.R.msg ]) result
10
-
(** [exec ~tries env cmd] runs [cmd] up to [tries] times (default 10),
11
-
sleeping with jittered backoff between attempts. Returns [Ok ()] on
12
-
the first zero-exit run, or [Error] after all attempts fail. *)
13
-
14
-
val rename :
15
-
?tries:int -> Fpath.t -> Fpath.t -> (unit, [> Rresult.R.msg ]) result
16
-
(** [rename ~tries src dst] retries [Unix.rename] up to [tries] times
17
-
(default 10) with exponential backoff. Useful when the target may be
18
-
temporarily locked by another process. *)
-8
day11/exec/run.ml
-8
day11/exec/run.ml
···
63
63
result.output result.errors));
64
64
result
65
65
66
-
let pp ppf t =
67
-
let status_s =
68
-
match t.status with
69
-
| `Exited n -> Printf.sprintf "exited %d" n
70
-
| `Signaled n -> Printf.sprintf "signaled %d" n
71
-
in
72
-
Format.fprintf ppf "[%.2fs %s] %s" t.time status_s
73
-
(String.concat " " t.cmd)
-2
day11/exec/run.mli
-2
day11/exec/run.mli
-33
day11/exec/safe_rename.ml
-33
day11/exec/safe_rename.ml
···
1
-
let src = Logs.Src.create "day11.exec.safe_rename" ~doc:"Race-aware directory placement"
2
-
module Log = (val Logs.src_log src)
3
-
4
-
let dir ~marker_file src dst =
5
-
let dst_s = Fpath.to_string dst in
6
-
let marker_at_dst = Fpath.(dst // marker_file) in
7
-
if Sys.file_exists dst_s then begin
8
-
if Bos.OS.File.exists marker_at_dst |> Result.get_ok then begin
9
-
(* Another worker completed this — clean up our copy *)
10
-
Log.info (fun m ->
11
-
m "Another worker completed %a, removing our copy" Fpath.pp dst);
12
-
Bos.OS.Path.delete ~recurse:true src
13
-
|> Result.map_error (fun (`Msg m) -> `Msg m)
14
-
end else begin
15
-
(* Stale directory from a crash — remove and retry *)
16
-
Log.info (fun m ->
17
-
m "Stale directory at %a (no marker), removing" Fpath.pp dst);
18
-
Bos.OS.Path.delete ~recurse:true dst |> ignore;
19
-
try
20
-
Unix.rename (Fpath.to_string src) dst_s;
21
-
Ok ()
22
-
with Unix.Unix_error (e, _, _) ->
23
-
Rresult.R.error_msgf "safe_rename %a -> %a: %s"
24
-
Fpath.pp src Fpath.pp dst (Unix.error_message e)
25
-
end
26
-
end else begin
27
-
try
28
-
Unix.rename (Fpath.to_string src) dst_s;
29
-
Ok ()
30
-
with Unix.Unix_error (e, _, _) ->
31
-
Rresult.R.error_msgf "safe_rename %a -> %a: %s"
32
-
Fpath.pp src Fpath.pp dst (Unix.error_message e)
33
-
end
-18
day11/exec/safe_rename.mli
-18
day11/exec/safe_rename.mli
···
1
-
(** Race-aware directory placement.
2
-
3
-
Handles the case where multiple workers race to place a completed
4
-
directory at a target location. Uses a marker file to distinguish
5
-
"another worker completed this" from "stale directory from a crash". *)
6
-
7
-
val dir :
8
-
marker_file:Fpath.t ->
9
-
Fpath.t ->
10
-
Fpath.t ->
11
-
(unit, [> Rresult.R.msg ]) result
12
-
(** [dir ~marker_file src dst] atomically renames [src] to [dst].
13
-
14
-
- If [dst] already exists and [marker_file] is present inside it:
15
-
another worker completed this first — remove [src] and return [Ok ()].
16
-
- If [dst] already exists but [marker_file] is absent: stale directory
17
-
from a crash — remove [dst] and retry the rename.
18
-
- Otherwise: rename [src] to [dst] and return [Ok ()]. *)
+1
-310
day11/exec/test/test_exec.ml
+1
-310
day11/exec/test/test_exec.ml
···
63
63
| Failure msg when msg = "not implemented" ->
64
64
Alcotest.fail "not implemented"
65
65
66
-
let test_run_pp () = with_eio @@ fun env ->
67
-
let r = Run.run env Bos.Cmd.(v "echo" % "hi") None in
68
-
let s = Fmt.to_to_string Run.pp r in
69
-
Alcotest.(check bool) "pp produces output"
70
-
true (String.length s > 0)
71
-
72
-
(* ── Worker_pool tests ───────────────────────────────────────────── *)
73
-
74
-
let test_worker_pool_basic () = with_eio @@ fun env ->
75
-
Eio.Switch.run @@ fun sw ->
76
-
Worker_pool.start_workers env sw 2;
77
-
let r = Worker_pool.submit "echo" Bos.Cmd.(v "echo" % "pool") None in
78
-
match r with
79
-
| Ok run ->
80
-
Alcotest.(check string) "stdout" "pool\n" run.Run.output
81
-
| Error e ->
82
-
Alcotest.fail (Printexc.to_string e)
83
-
84
-
let test_worker_pool_failure () = with_eio @@ fun env ->
85
-
Eio.Switch.run @@ fun sw ->
86
-
Worker_pool.start_workers env sw 1;
87
-
let r = Worker_pool.submit "fail" Bos.Cmd.(v "false") None in
88
-
match r with
89
-
| Error (Worker_pool.Worker_failure run) ->
90
-
Alcotest.(check bool) "non-zero exit"
91
-
true (run.Run.status <> `Exited 0)
92
-
| Error e ->
93
-
Alcotest.fail ("unexpected exception: " ^ Printexc.to_string e)
94
-
| Ok _ ->
95
-
Alcotest.fail "expected failure"
96
-
97
-
let test_worker_pool_concurrency () = with_eio @@ fun env ->
98
-
(* 4 jobs that each sleep 0.1s on 2 workers should complete in ~0.2s *)
99
-
Eio.Switch.run @@ fun sw ->
100
-
Worker_pool.start_workers env sw 2;
101
-
let t0 = Unix.gettimeofday () in
102
-
let results = Array.make 4 None in
103
-
Eio.Fiber.all
104
-
(List.init 4 (fun i () ->
105
-
let r =
106
-
Worker_pool.submit "sleep"
107
-
Bos.Cmd.(v "sleep" % "0.1") None
108
-
in
109
-
results.(i) <- Some r));
110
-
let elapsed = Unix.gettimeofday () -. t0 in
111
-
(* Should be ~0.2s, definitely < 0.4s *)
112
-
Alcotest.(check bool) "concurrent (< 0.35s)"
113
-
true (elapsed < 0.35);
114
-
Array.iter (fun r ->
115
-
match r with
116
-
| Some (Ok _) -> ()
117
-
| _ -> Alcotest.fail "job did not succeed")
118
-
results
119
-
120
-
let test_worker_pool_survives_failure () = with_eio @@ fun env ->
121
-
(* A failed job should not kill the pool *)
122
-
Eio.Switch.run @@ fun sw ->
123
-
Worker_pool.start_workers env sw 1;
124
-
let _ = Worker_pool.submit "fail" Bos.Cmd.(v "false") None in
125
-
(* Submit another job — pool should still be alive *)
126
-
let r = Worker_pool.submit "echo" Bos.Cmd.(v "echo" % "alive") None in
127
-
match r with
128
-
| Ok run ->
129
-
Alcotest.(check string) "pool survived" "alive\n" run.Run.output
130
-
| Error e ->
131
-
Alcotest.fail ("pool died: " ^ Printexc.to_string e)
132
-
133
-
(* ── Retry tests ─────────────────────────────────────────────────── *)
134
-
135
-
let test_retry_exec_succeeds () = with_eio @@ fun env ->
136
-
let r = Retry.exec ~tries:3 env Bos.Cmd.(v "true") in
137
-
is_ok "retry true" r
138
-
139
-
let test_retry_exec_exhausts () = with_eio @@ fun env ->
140
-
let r = Retry.exec ~tries:2 env Bos.Cmd.(v "false") in
141
-
is_error "retry false after 2 tries" r
142
-
143
-
let test_retry_rename_succeeds () = with_tmp_dir @@ fun dir ->
144
-
let src = Fpath.(dir / "src") in
145
-
let dst = Fpath.(dir / "dst") in
146
-
mkdir src;
147
-
let r = Retry.rename ~tries:1 src dst in
148
-
is_ok "rename" r;
149
-
Alcotest.(check bool) "dst exists"
150
-
true (Bos.OS.Dir.exists dst |> Result.get_ok);
151
-
Alcotest.(check bool) "src gone"
152
-
false (Bos.OS.Dir.exists src |> Result.get_ok)
153
-
154
-
let test_retry_rename_fails () = with_tmp_dir @@ fun dir ->
155
-
let src = Fpath.(dir / "nonexistent") in
156
-
let dst = Fpath.(dir / "dst") in
157
-
let r = Retry.rename ~tries:1 src dst in
158
-
is_error "rename nonexistent" r
159
-
160
-
(* ── Safe_rename tests ───────────────────────────────────────────── *)
161
-
162
-
let test_safe_rename_happy_path () = with_tmp_dir @@ fun dir ->
163
-
let src = Fpath.(dir / "src") in
164
-
let dst = Fpath.(dir / "dst") in
165
-
mkdir src;
166
-
let marker = Fpath.v "layer.json" in
167
-
write_file Fpath.(src / "layer.json") "{}";
168
-
let r = Safe_rename.dir ~marker_file:marker src dst in
169
-
is_ok "rename" r;
170
-
Alcotest.(check bool) "dst has marker"
171
-
true (Bos.OS.File.exists Fpath.(dst / "layer.json") |> Result.get_ok)
172
-
173
-
let test_safe_rename_race_other_worker_won () = with_tmp_dir @@ fun dir ->
174
-
let src = Fpath.(dir / "src") in
175
-
let dst = Fpath.(dir / "dst") in
176
-
mkdir src;
177
-
mkdir dst;
178
-
let marker = Fpath.v "layer.json" in
179
-
(* Another worker already placed the marker *)
180
-
write_file Fpath.(dst / "layer.json") "{}";
181
-
write_file Fpath.(src / "layer.json") "{}";
182
-
let r = Safe_rename.dir ~marker_file:marker src dst in
183
-
is_ok "race ok" r;
184
-
(* src should be cleaned up *)
185
-
Alcotest.(check bool) "src removed"
186
-
false (Bos.OS.Dir.exists src |> Result.get_ok)
187
-
188
-
let test_safe_rename_stale_dst () = with_tmp_dir @@ fun dir ->
189
-
let src = Fpath.(dir / "src") in
190
-
let dst = Fpath.(dir / "dst") in
191
-
mkdir src;
192
-
mkdir dst;
193
-
let marker = Fpath.v "layer.json" in
194
-
(* dst exists but has no marker — stale from a crash *)
195
-
write_file Fpath.(src / "layer.json") "{}";
196
-
let r = Safe_rename.dir ~marker_file:marker src dst in
197
-
is_ok "stale replaced" r;
198
-
Alcotest.(check bool) "dst has marker"
199
-
true (Bos.OS.File.exists Fpath.(dst / "layer.json") |> Result.get_ok)
200
66
201
67
(* ── Dir_lock tests ──────────────────────────────────────────────── *)
202
68
···
429
295
Alcotest.(check string) "content replaced"
430
296
"v2" (read_file Fpath.(target / "index.html"))
431
297
432
-
(* ── Wait tests ──────────────────────────────────────────────────── *)
433
-
434
-
let test_wait_exists () = with_tmp_dir @@ fun dir ->
435
-
let path = Fpath.(dir / "marker") in
436
-
write_file path "{}";
437
-
Wait.for_file ~max_polls:1 path |> is_ok "exists"
438
-
439
-
let test_wait_timeout () = with_tmp_dir @@ fun dir ->
440
-
let path = Fpath.(dir / "marker") in
441
-
let r = Wait.for_file ~poll_interval:0.01 ~max_polls:3 path in
442
-
is_error "timeout" r
443
-
444
-
(* ── Reporter tests ──────────────────────────────────────────────── *)
445
-
446
-
let test_reporter_writes_log () = with_tmp_dir @@ fun dir ->
447
-
let reporter = Reporter.pid_file_reporter ~dir in
448
-
Logs.set_reporter reporter;
449
-
Logs.set_level (Some Logs.Info);
450
-
Logs.info (fun m -> m "test message %d" 42);
451
-
(* Check the log file exists *)
452
-
let pid = Unix.getpid () in
453
-
let log_file = Fpath.(dir / (string_of_int pid ^ ".log")) in
454
-
Alcotest.(check bool) "log file exists"
455
-
true (Bos.OS.File.exists log_file |> Result.get_ok);
456
-
let contents = read_file log_file in
457
-
Alcotest.(check bool) "contains message"
458
-
true (Astring.String.is_infix ~affix:"test message 42" contents);
459
-
(* Timestamp format: YYYY-MM-DD HH:MM:SS.mmm *)
460
-
Alcotest.(check bool) "has timestamp"
461
-
true (Astring.String.is_infix ~affix:"-" contents);
462
-
(* Reset reporter *)
463
-
Logs.set_reporter Logs.nop_reporter
464
298
465
299
(* ── Util tests ──────────────────────────────────────────────────── *)
466
300
···
479
313
let r = Util.dir_size (Fpath.v "/nonexistent/path/xyz") in
480
314
is_error "nonexistent dir" r
481
315
482
-
(* ── Atomic_publish tests ───────────────────────────────────────── *)
483
-
484
-
let test_atomic_publish_new () =
485
-
with_tmp_dir @@ fun dir ->
486
-
let src = Fpath.(dir / "new-docs") in
487
-
let dst = Fpath.(dir / "docs") in
488
-
mkdir src;
489
-
write_file Fpath.(src / "index.html") "<html>new</html>";
490
-
Atomic_publish.publish ~src ~dst |> ok_or_fail "publish";
491
-
(* src should be gone, dst should exist with contents *)
492
-
Alcotest.(check bool) "dst exists"
493
-
true (Bos.OS.Dir.exists dst |> Result.get_ok);
494
-
Alcotest.(check bool) "src gone"
495
-
false (Bos.OS.Dir.exists src |> Result.get_ok);
496
-
let content = Bos.OS.File.read Fpath.(dst / "index.html") |> Result.get_ok in
497
-
Alcotest.(check string) "content" "<html>new</html>" content
498
-
499
-
let test_atomic_publish_replace () =
500
-
with_tmp_dir @@ fun dir ->
501
-
let src = Fpath.(dir / "new-docs") in
502
-
let dst = Fpath.(dir / "docs") in
503
-
(* Create existing dst *)
504
-
mkdir dst;
505
-
write_file Fpath.(dst / "index.html") "<html>old</html>";
506
-
(* Create new src *)
507
-
mkdir src;
508
-
write_file Fpath.(src / "index.html") "<html>new</html>";
509
-
Atomic_publish.publish ~src ~dst |> ok_or_fail "publish";
510
-
(* dst should have new content, .old should be gone *)
511
-
let content = Bos.OS.File.read Fpath.(dst / "index.html") |> Result.get_ok in
512
-
Alcotest.(check string) "replaced" "<html>new</html>" content;
513
-
Alcotest.(check bool) ".old gone"
514
-
false (Bos.OS.Dir.exists Fpath.(dir / "docs.old") |> Result.get_ok)
515
-
516
-
let test_atomic_publish_missing_src () =
517
-
with_tmp_dir @@ fun dir ->
518
-
let src = Fpath.(dir / "nonexistent") in
519
-
let dst = Fpath.(dir / "docs") in
520
-
mkdir dst;
521
-
write_file Fpath.(dst / "index.html") "<html>original</html>";
522
-
let result = Atomic_publish.publish ~src ~dst in
523
-
(* Should fail, dst should be preserved *)
524
-
Alcotest.(check bool) "returns error" true (Result.is_error result);
525
-
let content = Bos.OS.File.read Fpath.(dst / "index.html") |> Result.get_ok in
526
-
Alcotest.(check string) "preserved" "<html>original</html>" content
527
-
528
-
let test_atomic_publish_recover_old () =
529
-
with_tmp_dir @@ fun dir ->
530
-
let dst = Fpath.(dir / "docs") in
531
-
let old = Fpath.(dir / "docs.old") in
532
-
(* Simulate interrupted publish: dst exists, .old leftover *)
533
-
mkdir dst;
534
-
write_file Fpath.(dst / "index.html") "<html>current</html>";
535
-
mkdir old;
536
-
write_file Fpath.(old / "index.html") "<html>stale</html>";
537
-
Atomic_publish.recover dst;
538
-
(* .old should be cleaned up, dst preserved *)
539
-
Alcotest.(check bool) ".old removed"
540
-
false (Bos.OS.Dir.exists old |> Result.get_ok);
541
-
Alcotest.(check bool) "dst preserved"
542
-
true (Bos.OS.Dir.exists dst |> Result.get_ok)
543
-
544
-
let test_atomic_publish_recover_new_no_dst () =
545
-
with_tmp_dir @@ fun dir ->
546
-
let dst = Fpath.(dir / "docs") in
547
-
let new_ = Fpath.(dir / "docs.new") in
548
-
(* Simulate interrupted publish: .new exists but dst doesn't *)
549
-
mkdir new_;
550
-
write_file Fpath.(new_ / "index.html") "<html>new</html>";
551
-
Atomic_publish.recover dst;
552
-
(* .new should be promoted to dst *)
553
-
Alcotest.(check bool) "dst exists"
554
-
true (Bos.OS.Dir.exists dst |> Result.get_ok);
555
-
Alcotest.(check bool) ".new gone"
556
-
false (Bos.OS.Dir.exists new_ |> Result.get_ok);
557
-
let content = Bos.OS.File.read Fpath.(dst / "index.html") |> Result.get_ok in
558
-
Alcotest.(check string) "promoted" "<html>new</html>" content
559
-
560
-
let test_atomic_publish_recover_new_stale () =
561
-
with_tmp_dir @@ fun dir ->
562
-
let dst = Fpath.(dir / "docs") in
563
-
let new_ = Fpath.(dir / "docs.new") in
564
-
(* Both exist: .new is stale, dst is current *)
565
-
mkdir dst;
566
-
write_file Fpath.(dst / "index.html") "<html>current</html>";
567
-
mkdir new_;
568
-
write_file Fpath.(new_ / "index.html") "<html>stale-new</html>";
569
-
Atomic_publish.recover dst;
570
-
(* .new should be removed, dst preserved *)
571
-
Alcotest.(check bool) ".new removed"
572
-
false (Bos.OS.Dir.exists new_ |> Result.get_ok);
573
-
let content = Bos.OS.File.read Fpath.(dst / "index.html") |> Result.get_ok in
574
-
Alcotest.(check string) "preserved" "<html>current</html>" content
575
-
576
316
(* ── Test registration ───────────────────────────────────────────── *)
577
317
578
318
let () =
···
587
327
test_run_output_file_passthrough;
588
328
Alcotest.test_case "nonexistent binary" `Quick
589
329
test_run_nonexistent_binary;
590
-
Alcotest.test_case "pp" `Quick test_run_pp;
591
-
] );
592
-
( "Worker_pool",
593
-
[
594
-
Alcotest.test_case "basic" `Quick test_worker_pool_basic;
595
-
Alcotest.test_case "failure" `Quick test_worker_pool_failure;
596
-
Alcotest.test_case "concurrency" `Slow
597
-
test_worker_pool_concurrency;
598
-
Alcotest.test_case "survives failure" `Quick
599
-
test_worker_pool_survives_failure;
600
-
] );
601
-
( "Retry",
602
-
[
603
-
Alcotest.test_case "exec succeeds" `Quick test_retry_exec_succeeds;
604
-
Alcotest.test_case "exec exhausts" `Quick test_retry_exec_exhausts;
605
-
Alcotest.test_case "rename succeeds" `Quick
606
-
test_retry_rename_succeeds;
607
-
Alcotest.test_case "rename fails" `Quick test_retry_rename_fails;
608
-
] );
609
-
( "Safe_rename",
610
-
[
611
-
Alcotest.test_case "happy path" `Quick test_safe_rename_happy_path;
612
-
Alcotest.test_case "other worker won" `Quick
613
-
test_safe_rename_race_other_worker_won;
614
-
Alcotest.test_case "stale dst" `Quick test_safe_rename_stale_dst;
615
330
] );
616
331
( "Dir_lock",
617
332
[
···
643
358
Alcotest.test_case "commit replaces existing" `Quick
644
359
test_atomic_swap_commit_replaces_existing;
645
360
] );
646
-
( "Wait",
647
-
[
648
-
Alcotest.test_case "exists" `Quick test_wait_exists;
649
-
Alcotest.test_case "timeout" `Quick test_wait_timeout;
650
-
] );
651
-
( "Reporter",
652
-
[
653
-
Alcotest.test_case "writes log" `Quick test_reporter_writes_log;
654
-
] );
655
-
( "Util",
361
+
( "Util",
656
362
[
657
363
Alcotest.test_case "nproc" `Quick test_nproc;
658
364
Alcotest.test_case "dir_size" `Quick test_dir_size;
659
365
Alcotest.test_case "dir_size nonexistent" `Quick
660
366
test_dir_size_nonexistent;
661
-
] );
662
-
( "Atomic_publish",
663
-
[
664
-
Alcotest.test_case "publish new" `Quick
665
-
test_atomic_publish_new;
666
-
Alcotest.test_case "publish replace" `Quick
667
-
test_atomic_publish_replace;
668
-
Alcotest.test_case "publish preserves on missing src" `Quick
669
-
test_atomic_publish_missing_src;
670
-
Alcotest.test_case "recover .old" `Quick
671
-
test_atomic_publish_recover_old;
672
-
Alcotest.test_case "recover .new (no dst)" `Quick
673
-
test_atomic_publish_recover_new_no_dst;
674
-
Alcotest.test_case "recover .new (stale)" `Quick
675
-
test_atomic_publish_recover_new_stale;
676
367
] );
677
368
]
-13
day11/exec/wait.ml
-13
day11/exec/wait.ml
···
1
-
let for_file ?(poll_interval = 0.5) ?(max_polls = 600) path =
2
-
let path_s = Fpath.to_string path in
3
-
let rec loop n =
4
-
if Sys.file_exists path_s then Ok ()
5
-
else if n >= max_polls then
6
-
Rresult.R.error_msgf "Timed out waiting for %a (%d polls)"
7
-
Fpath.pp path max_polls
8
-
else begin
9
-
Unix.sleepf poll_interval;
10
-
loop (n + 1)
11
-
end
12
-
in
13
-
loop 0
-17
day11/exec/wait.mli
-17
day11/exec/wait.mli
···
1
-
(** Poll for a file to appear.
2
-
3
-
Useful for inter-worker coordination: one worker creates a file
4
-
when done, others poll for it. *)
5
-
6
-
val for_file :
7
-
?poll_interval:float ->
8
-
?max_polls:int ->
9
-
Fpath.t ->
10
-
(unit, [> Rresult.R.msg ]) result
11
-
(** [for_file ?poll_interval ?max_polls path] polls for [path] to
12
-
appear on disk. Returns [Ok ()] once the file exists, or [Error]
13
-
after [max_polls] attempts.
14
-
15
-
@param poll_interval Seconds between polls (default 0.5).
16
-
@param max_polls Maximum number of polls (default 600, i.e. 5 minutes
17
-
at default interval). *)
-38
day11/exec/worker_pool.ml
-38
day11/exec/worker_pool.ml
···
1
-
open Eio
2
-
3
-
exception Worker_failure of Run.t
4
-
5
-
type request = {
6
-
description : string;
7
-
request : Bos.Cmd.t;
8
-
output_file : Fpath.t option;
9
-
}
10
-
11
-
type response = (Run.t, exn) result
12
-
type resolver = response Promise.u
13
-
type t = (request * resolver) Stream.t
14
-
15
-
let stream : t = Stream.create 0
16
-
17
-
let rec run_worker env =
18
-
let { request; output_file; description = _ }, reply = Stream.take stream in
19
-
(try
20
-
let result = Run.run env request output_file in
21
-
match result.status with
22
-
| `Exited 0 -> Promise.resolve reply (Ok result)
23
-
| _ -> Promise.resolve_error reply (Worker_failure result)
24
-
with e -> Promise.resolve_error reply e);
25
-
run_worker env
26
-
27
-
let submit description request output_file =
28
-
let reply, resolve_reply = Promise.create () in
29
-
Stream.add stream ({ description; request; output_file }, resolve_reply);
30
-
Promise.await reply
31
-
32
-
let start_workers env sw n =
33
-
for _ = 0 to n - 1 do
34
-
Fiber.fork_daemon ~sw (fun () ->
35
-
(try run_worker env
36
-
with Stdlib.Exit -> ());
37
-
`Stop_daemon)
38
-
done
-20
day11/exec/worker_pool.mli
-20
day11/exec/worker_pool.mli
···
1
-
(** Eio-based worker pool.
2
-
3
-
Modelled on odoc_driver's [worker_pool.ml]. A pool of daemon fibers
4
-
pulling jobs from a shared unbuffered stream. The pool is started once
5
-
and lives for the duration of the Eio switch. *)
6
-
7
-
exception Worker_failure of Run.t
8
-
(** Raised when a submitted job exits with a non-zero status. The {!Run.t}
9
-
contains the captured output and exit status. *)
10
-
11
-
val start_workers : Eio_unix.Stdenv.base -> Eio.Switch.t -> int -> unit
12
-
(** [start_workers env sw n] spawns [n] daemon fibers that pull jobs from
13
-
the shared stream and execute them. The workers are cancelled when [sw]
14
-
is finished. Call this once per batch run. *)
15
-
16
-
val submit : string -> Bos.Cmd.t -> Fpath.t option -> (Run.t, exn) result
17
-
(** [submit description cmd output_file] submits a job to the pool and
18
-
blocks the current fiber (via {!Eio.Promise.await}) until a worker
19
-
completes it. Returns [Ok run] on zero exit, [Error (Worker_failure run)]
20
-
on non-zero exit, or [Error exn] if the subprocess could not be started. *)
+13
-52
day11/graph/graph.ml
+13
-52
day11/graph/graph.ml
···
1
1
type solution = OpamPackage.Set.t OpamPackage.Map.t
2
2
3
-
let topological_sort solution =
4
-
let remaining = ref (OpamPackage.Map.map OpamPackage.Set.cardinal solution) in
5
-
let result = ref [] in
6
-
let rec loop () =
7
-
let ready =
8
-
OpamPackage.Map.filter (fun _ count -> count = 0) !remaining
9
-
|> OpamPackage.Map.keys
10
-
in
11
-
if ready <> [] then begin
12
-
List.iter (fun pkg ->
13
-
result := pkg :: !result;
14
-
remaining := OpamPackage.Map.remove pkg !remaining;
15
-
(* Decrement counts for packages that depended on this one *)
16
-
remaining := OpamPackage.Map.mapi (fun p count ->
17
-
let deps = OpamPackage.Map.find p solution in
18
-
if OpamPackage.Set.mem pkg deps then count - 1 else count
19
-
) !remaining
20
-
) ready;
21
-
loop ()
22
-
end
23
-
in
24
-
loop ();
25
-
List.rev !result
26
-
27
3
let transitive_deps solution =
28
-
let topo = topological_sort solution in
29
-
let cache = Hashtbl.create (List.length topo) in
30
-
List.iter (fun pkg ->
31
-
let direct = OpamPackage.Map.find pkg solution in
32
-
let transitive =
33
-
OpamPackage.Set.fold (fun dep acc ->
34
-
match Hashtbl.find_opt cache dep with
35
-
| Some trans -> OpamPackage.Set.union acc trans
36
-
| None -> acc
37
-
) direct direct
38
-
in
39
-
Hashtbl.replace cache pkg transitive
40
-
) topo;
41
-
OpamPackage.Map.mapi (fun pkg _ ->
4
+
let cache = Hashtbl.create 64 in
5
+
let rec go pkg =
42
6
match Hashtbl.find_opt cache pkg with
43
7
| Some deps -> deps
44
-
| None -> OpamPackage.Set.empty
45
-
) solution
46
-
47
-
let extract_dag solution root =
48
-
let visited = Hashtbl.create 16 in
49
-
let rec walk pkg =
50
-
if not (Hashtbl.mem visited pkg) then begin
51
-
Hashtbl.replace visited pkg ();
52
-
match OpamPackage.Map.find_opt pkg solution with
53
-
| Some deps -> OpamPackage.Set.iter walk deps
54
-
| None -> ()
55
-
end
8
+
| None ->
9
+
let direct = match OpamPackage.Map.find_opt pkg solution with
10
+
| Some s -> s | None -> OpamPackage.Set.empty in
11
+
let transitive =
12
+
OpamPackage.Set.fold (fun dep acc ->
13
+
OpamPackage.Set.union acc (go dep)
14
+
) direct direct
15
+
in
16
+
Hashtbl.replace cache pkg transitive;
17
+
transitive
56
18
in
57
-
walk root;
58
-
OpamPackage.Map.filter (fun pkg _ -> Hashtbl.mem visited pkg) solution
19
+
OpamPackage.Map.mapi (fun pkg _ -> go pkg) solution
59
20
60
21
let compiler_names = [ "ocaml-base-compiler"; "ocaml-variants"; "ocaml" ]
61
22
-9
day11/graph/graph.mli
-9
day11/graph/graph.mli
···
6
6
type solution = OpamPackage.Set.t OpamPackage.Map.t
7
7
(** A dependency solution: maps each package to its direct dependencies. *)
8
8
9
-
val topological_sort : solution -> OpamPackage.t list
10
-
(** [topological_sort solution] returns packages in build order
11
-
(dependencies before dependents) using Kahn's algorithm. *)
12
-
13
9
val transitive_deps : solution -> solution
14
10
(** [transitive_deps solution] enriches the map so each package maps
15
11
to its full transitive dependency closure. *)
16
-
17
-
val extract_dag : solution -> OpamPackage.t -> solution
18
-
(** [extract_dag solution root] extracts the sub-DAG reachable from
19
-
[root] via DFS. Only packages transitively depended on by [root]
20
-
are included. *)
21
12
22
13
val extract_ocaml_version : solution -> OpamPackage.t option
23
14
(** [extract_ocaml_version solution] finds [ocaml-base-compiler],
+1
-29
day11/graph/test/test_graph.ml
+1
-29
day11/graph/test/test_graph.ml
···
20
20
21
21
(* ── Graph tests ─────────────────────────────────────────────────── *)
22
22
23
-
let test_topological_sort () =
24
-
let s = make_solution () in
25
-
let order = Graph.topological_sort s in
26
-
let names = List.map OpamPackage.to_string order in
27
-
let pos_of p = List.find_index (fun n -> n = p) names |> Option.get in
28
-
Alcotest.(check bool) "c before b" true (pos_of "c.1" < pos_of "b.1");
29
-
Alcotest.(check bool) "b before a" true (pos_of "b.1" < pos_of "a.1");
30
-
Alcotest.(check int) "all 3" 3 (List.length order)
31
-
32
-
let test_topological_sort_single () =
33
-
let s = OpamPackage.Map.singleton (pkg "x.1") OpamPackage.Set.empty in
34
-
let order = Graph.topological_sort s in
35
-
Alcotest.(check int) "one package" 1 (List.length order)
36
-
37
23
let test_transitive_deps () =
38
24
let s = make_solution () in
39
25
let t = Graph.transitive_deps s in
···
45
31
let c_deps = OpamPackage.Map.find (pkg "c.1") t in
46
32
Alcotest.(check bool) "c empty"
47
33
true (OpamPackage.Set.is_empty c_deps)
48
-
49
-
let test_extract_dag () =
50
-
let s = make_solution () in
51
-
let sub = Graph.extract_dag s (pkg "b.1") in
52
-
Alcotest.(check bool) "has b"
53
-
true (OpamPackage.Map.mem (pkg "b.1") sub);
54
-
Alcotest.(check bool) "has c"
55
-
true (OpamPackage.Map.mem (pkg "c.1") sub);
56
-
Alcotest.(check bool) "no a"
57
-
false (OpamPackage.Map.mem (pkg "a.1") sub)
58
34
59
35
let test_extract_ocaml_version () =
60
36
let s =
···
166
142
[
167
143
( "Graph",
168
144
[
169
-
Alcotest.test_case "topological_sort" `Quick test_topological_sort;
170
-
Alcotest.test_case "topological_sort single" `Quick
171
-
test_topological_sort_single;
172
145
Alcotest.test_case "transitive_deps" `Quick test_transitive_deps;
173
-
Alcotest.test_case "extract_dag" `Quick test_extract_dag;
174
-
Alcotest.test_case "extract_ocaml_version" `Quick
146
+
Alcotest.test_case "extract_ocaml_version" `Quick
175
147
test_extract_ocaml_version;
176
148
Alcotest.test_case "extract_ocaml_version none" `Quick
177
149
test_extract_ocaml_version_none;
+4
-4
day11/jtw/build_tools.ml
+4
-4
day11/jtw/build_tools.ml
···
1
-
let build_per_compiler env benv ~np ~packages ~opam_env ~mounts
1
+
let build_per_compiler env benv ~np ~packages ~repos ~mounts
2
2
~extra_repo_dirs ~repo_dir ~solutions =
3
3
Printf.printf "\nBuilding JTW tools from %s...\n%!" repo_dir;
4
4
let compiler_versions =
···
7
7
Printf.printf "Building JTW for %s...\n%!"
8
8
(OpamPackage.to_string compiler_v);
9
9
match Day11_build.Tools.build_tool_from_repo env benv ~np
10
-
~packages ~env:opam_env ~ocaml_version:compiler_v
10
+
~packages ~repos ~ocaml_version:compiler_v
11
11
~mounts ~extra_repo_dirs ~repo_dir
12
12
~extra_target_names:Tool_layer.extra_tool_targets
13
13
~target_name:Tool_layer.tool_target () with
···
21
21
None
22
22
) compiler_versions
23
23
24
-
let build_and_run env benv ~np ~os_dir ~packages ~opam_env ~mounts
24
+
let build_and_run env benv ~np ~os_dir ~packages ~repos ~mounts
25
25
~extra_repo_dirs ~repo_dir ~output ~nodes ~solutions =
26
-
let jtw_tools = build_per_compiler env benv ~np ~packages ~opam_env
26
+
let jtw_tools = build_per_compiler env benv ~np ~packages ~repos
27
27
~mounts ~extra_repo_dirs ~repo_dir ~solutions in
28
28
if jtw_tools = [] then
29
29
Printf.printf "No JTW tools built, skipping generation\n%!"
+4
-4
day11/jtw/build_tools.mli
+4
-4
day11/jtw/build_tools.mli
···
8
8
Eio_unix.Stdenv.base ->
9
9
Day11_build.Types.build_env ->
10
10
np:int ->
11
-
packages:Day11_solver.Git_packages.t ->
12
-
opam_env:(string -> OpamVariable.variable_contents option) ->
11
+
packages:Day11_opam.Git_packages.t ->
12
+
repos:(string * string) list ->
13
13
mounts:Day11_container.Mount.t list ->
14
14
extra_repo_dirs:string list ->
15
15
repo_dir:string ->
···
22
22
Day11_build.Types.build_env ->
23
23
np:int ->
24
24
os_dir:Fpath.t ->
25
-
packages:Day11_solver.Git_packages.t ->
26
-
opam_env:(string -> OpamVariable.variable_contents option) ->
25
+
packages:Day11_opam.Git_packages.t ->
26
+
repos:(string * string) list ->
27
27
mounts:Day11_container.Mount.t list ->
28
28
extra_repo_dirs:string list ->
29
29
repo_dir:string ->
+10
-14
day11/jtw/test/test_jtw_integration.ml
+10
-14
day11/jtw/test/test_jtw_integration.ml
···
23
23
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
24
24
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
25
25
Types.ensure_dirs benv;
26
-
let git_packages, _store, _commit =
27
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
28
-
let opam_env = Day11_solver.Opam_env.std_env
29
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
30
-
~os_family:"debian" ~os_version:"12" () in
26
+
let git_packages, repos_with_shas =
27
+
Day11_opam.Git_packages.of_repositories
28
+
[ (opam_repository, None) ] in
31
29
let jsoo_versions =
32
-
Day11_solver.Git_packages.get_versions git_packages
30
+
Day11_opam.Git_packages.get_versions git_packages
33
31
(OpamPackage.Name.of_string "js_of_ocaml") in
34
32
let jsoo_pkg =
35
33
match OpamPackage.Version.Map.max_binding_opt jsoo_versions with
···
39
37
in
40
38
Printf.printf "Building %s...\n%!" (OpamPackage.to_string jsoo_pkg);
41
39
let tool =
42
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
40
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
43
41
jsoo_pkg
44
42
|> ok_or_fail "build_tool"
45
43
in
···
65
63
let os_dir = Fpath.(scratch_cache_dir / "linux-x86_64") in
66
64
let benv = Types.make_build_env ~base ~os_dir ~uid:1000 ~gid:1000 () in
67
65
Types.ensure_dirs benv;
68
-
let git_packages, _store, _commit =
69
-
Day11_solver.Git_packages.of_opam_repository opam_repository in
70
-
let opam_env = Day11_solver.Opam_env.std_env
71
-
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
72
-
~os_family:"debian" ~os_version:"12" () in
66
+
let git_packages, repos_with_shas =
67
+
Day11_opam.Git_packages.of_repositories
68
+
[ (opam_repository, None) ] in
73
69
(* First build the compiler + jsoo deps via Tools.build_tool *)
74
70
Printf.printf "Building js_of_ocaml toolchain...\n%!";
75
71
let jsoo_versions =
76
-
Day11_solver.Git_packages.get_versions git_packages
72
+
Day11_opam.Git_packages.get_versions git_packages
77
73
(OpamPackage.Name.of_string "js_of_ocaml") in
78
74
let jsoo_pkg =
79
75
match OpamPackage.Version.Map.max_binding_opt jsoo_versions with
···
82
78
| None -> Alcotest.skip ()
83
79
in
84
80
let tool =
85
-
Tools.build_tool env benv ~packages:git_packages ~env:opam_env
81
+
Tools.build_tool env benv ~packages:git_packages ~repos:repos_with_shas
86
82
jsoo_pkg
87
83
|> ok_or_fail "jsoo build"
88
84
in
+135
-188
day11/layer/README.md
+135
-188
day11/layer/README.md
···
1
1
# layer — On-disk layer management
2
2
3
-
The layer abstraction. Knows about the on-disk directory structure
4
-
(`layer.json` format, package symlinks, opam repo subdirectories) but
5
-
nothing about *how* layers are built — that's the container and build
6
-
libraries' concern.
3
+
Data-layer abstraction for the day11 build cache. Knows about the
4
+
on-disk directory structure, JSON metadata format, and file discovery
5
+
within layer trees, but nothing about *how* layers are built — that's
6
+
the container and build libraries' concern.
7
7
8
8
## External dependencies
9
9
10
-
- `exec` (filesystem operations, logging)
11
-
- `yojson` (layer.json serialization)
12
-
- `opam-format` (for `OpamPackage` name/version manipulation, `OpamFile`
13
-
for parsing opam files)
10
+
- `day11_exec` — sudo wrappers, subprocess execution
11
+
- `day11_graph` — `Universe.t` type
12
+
- `yojson` + `ppx_deriving_yojson` — `layer.json` serialization
13
+
- `opam-format` — `OpamPackage` type
14
+
- `bos`, `fpath`, `rresult` — filesystem helpers
14
15
15
-
Note: depends on `opam-format` but NOT on the solver (`opam-0install`)
16
-
or git libraries.
16
+
Does NOT depend on the solver, build pipeline, or container orchestration.
17
17
18
18
## On-disk layout
19
19
20
-
A layer is a directory under `{cache_dir}/{os_key}/`:
20
+
Every layer is a self-contained directory under `{os_dir}/`:
21
21
22
22
```
23
-
build-{hash}/
24
-
layer.json — metadata (package, exit_status, deps, hashes,
25
-
installed_libs, installed_docs, created_at)
26
-
build.log — captured build output
27
-
disk_usage — cached size in bytes
28
-
fs/ — overlay upperdir (new/changed files from build)
29
-
opam-repository/ — opam files for this package and its deps
30
-
repo
31
-
packages/{name}/{name.version}/opam
32
-
33
-
doc-{hash}/
34
-
layer.json — metadata (package, build_hash, dep_doc_hashes,
35
-
doc result with status/html_path/blessed)
36
-
odoc-voodoo-all.log — doc generation log
23
+
build-{hash[:12]}/
24
+
layer.json — typed metadata (see Layer_meta.build_meta)
25
+
layer.log — captured stdout/stderr from the container
26
+
last_used — sentinel file; mtime is the LRU timestamp
27
+
fs/ — overlay upper: new/changed files from the build
37
28
38
29
packages/{pkg.version}/
39
-
build-{hash} — symlink to ../../build-{hash}
40
-
doc-{hash} — symlink to ../../doc-{hash}
41
-
blessed-build — symlink to blessed build layer
42
-
blessed-docs — symlink to blessed doc layer
43
-
history.jsonl — append-only build history
44
-
45
-
universes/{hash}.json — universe membership (package list)
30
+
build-{hash} — symlink to ../../build-{hash[:12]}
31
+
blessed-build — symlink to the chosen canonical build layer
46
32
```
47
33
34
+
A layer's directory name uses the first 12 hex chars of its content
35
+
hash. Cache hits are determined by recomputing the hash from inputs
36
+
(base image, deps, package) and checking whether `{os_dir}/build-{hash[:12]}/layer.json` exists.
37
+
48
38
## Modules
49
39
50
-
### `Layer_info` — layer.json serialization
40
+
### `Layer_type` — in-memory DAG types
51
41
52
42
```ocaml
53
-
val save :
54
-
?installed_libs:string list -> ?installed_docs:string list ->
55
-
Fpath.t -> OpamPackage.t -> OpamPackage.t list -> string list -> int ->
56
-
(unit, [> Rresult.R.msg]) result
57
-
(** [save path pkg deps hashes exit_status] writes layer.json. *)
58
-
59
-
val save_doc :
60
-
?doc_result:Yojson.Safe.t ->
61
-
Fpath.t -> OpamPackage.t -> build_hash:string -> dep_doc_hashes:string list ->
62
-
(unit, [> Rresult.R.msg]) result
43
+
type build = {
44
+
hash : string;
45
+
pkg : OpamPackage.t;
46
+
deps : build list;
47
+
universe : Day11_graph.Universe.t;
48
+
}
49
+
type base = { hash : string; dir : Fpath.t; image : string }
50
+
type tool = { hash : string; dir : Fpath.t; builds : build list }
63
51
64
-
val load_exit_status : Fpath.t -> (int, [> Rresult.R.msg]) result
65
-
val load_package_name : Fpath.t -> (string, [> Rresult.R.msg]) result
66
-
val load_installed_libs : Fpath.t -> (string list, [> Rresult.R.msg]) result
67
-
val load_installed_docs : Fpath.t -> (string list, [> Rresult.R.msg]) result
68
-
val load_doc_failed : Fpath.t -> (bool, [> Rresult.R.msg]) result
69
-
val load_dep_doc_hashes : Fpath.t -> (string list, [> Rresult.R.msg]) result
52
+
val build_dir_name : build -> string
53
+
val build_dir : os_dir:Fpath.t -> build -> Fpath.t
70
54
```
71
55
72
-
### `Package_symlinks` — per-package tracking symlinks
56
+
Recursive: a `build` carries its dep tree inline. Used by both the
57
+
planner (before building) and the executor (after).
73
58
74
-
This module takes `packages_dir` directly — the caller computes
75
-
the path (e.g. `Fpath.(cache_dir / os_key / "packages")`).
59
+
### `Hash` — content-addressed identity
76
60
77
61
```ocaml
78
-
val ensure_layer_symlink :
79
-
packages_dir:Fpath.t -> pkg_str:string ->
80
-
layer_name:string -> (unit, [> Rresult.R.msg]) result
81
-
82
-
val ensure_blessed_symlink :
83
-
packages_dir:Fpath.t -> pkg_str:string ->
84
-
kind:[`Build | `Docs] -> layer_name:string ->
85
-
(unit, [> Rresult.R.msg]) result
62
+
val of_strings : string list -> string
63
+
val base_hash : image:string -> string
64
+
val layer_hash : base_hash:string -> dep_hashes:string list -> pkg:string -> string
86
65
```
87
66
88
-
### `Installed_files` — scan overlay for installed files
67
+
### `Layer_meta` — `layer.json` read/write
89
68
90
69
```ocaml
91
-
val scan_libs : layer_dir:Fpath.t -> string list
92
-
(** Scan fs/home/opam/.opam/default/lib/ for .cmi, .cmti, .cmt, .cma,
93
-
.cmxa, .cmx, .ml, .mli, META, dune-package files. Returns relative
94
-
paths. *)
70
+
type kind = Build | Compile | Link | Doc_all
71
+
type timing = (string * float) list
72
+
type build_meta = { package; kind; exit_status; deps; hashes;
73
+
uid; gid; base_hash; installed_libs; installed_docs;
74
+
patches; failed_dep; disk_usage; timing; created_at }
95
75
96
-
val scan_docs : layer_dir:Fpath.t -> string list
97
-
(** Scan fs/home/opam/.opam/default/doc/ for .mld and odoc-config.sexp
98
-
files. Returns relative paths. *)
76
+
val save_build : ?created_at:string -> Fpath.t -> build_meta -> (unit, _) result
77
+
val load_build : Fpath.t -> (build_meta, _) result
78
+
val load_build_tree : os_dir:Fpath.t -> string -> (Layer_type.build, _) result
99
79
```
100
80
101
-
### `Opam_repo` — opam repository assembly
81
+
Round-trips through an internal wire record so the public type can
82
+
carry typed variants (`kind`) while the on-disk JSON stays open and
83
+
additive-schema-friendly. Unknown phase names in `timing` and unknown
84
+
values for `kind` are tolerated on read.
102
85
103
-
For assembling the opam repository subdirectory inside a layer or temp
104
-
dir. This is pure filesystem work — copies opam files from source repos.
86
+
### `Last_used` — LRU sentinel
105
87
106
88
```ocaml
107
-
val create : Fpath.t -> (Fpath.t, [> Rresult.R.msg]) result
108
-
(** [create parent_dir] creates an opam-repository/ subdir with a repo
109
-
file. Returns the path. *)
89
+
val touch : Fpath.t -> unit
90
+
val get : Fpath.t -> float option
91
+
```
110
92
111
-
val populate :
112
-
opam_repo:Fpath.t -> opam_repositories:Fpath.t list ->
113
-
OpamPackage.t list -> (unit, [> Rresult.R.msg]) result
114
-
(** [populate ~opam_repo ~opam_repositories packages] copies opam files
115
-
for [packages] from [opam_repositories] into [opam_repo]. *)
93
+
Records the last-access time by touching a sentinel file. Cheap enough
94
+
to call from every dep-lookup path. Split off from `Layer_meta` so a
95
+
touch doesn't rewrite the JSON.
116
96
117
-
val find_opam_file :
118
-
Fpath.t list -> OpamPackage.t -> OpamFile.OPAM.t option
119
-
(** [find_opam_file repos pkg] finds and parses the opam file for [pkg]
120
-
in the given repository directories. *)
97
+
### `Installed_files` — content scanning
98
+
99
+
```ocaml
100
+
val scan_libs : layer_dir:Fpath.t -> string list
101
+
val scan_docs : layer_dir:Fpath.t -> string list
121
102
```
122
103
123
-
### `Skeleton` — skeleton layers for cascade failures
104
+
Walks the `fs/` overlay for `.cmi`/`.cmxa`/`META`/etc. (libs) or
105
+
`.mld`/`odoc-config.sexp` (docs). Called after a build to populate
106
+
`build_meta.installed_libs` and `installed_docs`.
124
107
125
-
Takes `layer_dir` directly — the caller computes the path (e.g.
126
-
`Fpath.(cache_dir / os_key / layer_name)`). The caller is also
127
-
responsible for creating package symlinks separately.
108
+
### `Stack` — combining dep layers
128
109
129
110
```ocaml
130
-
val write :
131
-
layer_dir:Fpath.t -> opam_repositories:Fpath.t list ->
132
-
pkg:OpamPackage.t ->
133
-
ordered_deps:OpamPackage.t list -> dep_build_hashes:string list ->
134
-
(unit, [> Rresult.R.msg]) result
135
-
(** Write a skeleton layer with exit_status=-1 and an opam-repository,
136
-
so cascade rebuild can proceed without re-solving. *)
111
+
val merge : env -> layer_dirs:Fpath.t list -> target:Fpath.t -> (unit, _) result
112
+
val plan_lowerdir :
113
+
available:int ->
114
+
merged_overhead:int ->
115
+
entry_cost:(Fpath.t -> int) ->
116
+
Fpath.t list ->
117
+
Fpath.t list * Fpath.t list
137
118
```
138
119
139
-
### `Wait` — inter-worker coordination
120
+
`merge` cp-hardlinks the `fs/` subtree of every layer into a single
121
+
target directory. Near-zero disk cost because it uses `cp --link`.
122
+
123
+
`plan_lowerdir` splits a list of dep layers into "keep separate" and
124
+
"cp-merge" buckets so the resulting overlayfs mount options string
125
+
stays under the kernel's PAGE_SIZE limit. Pure computation — no
126
+
filesystem access. The caller supplies pre-computed byte costs so the
127
+
function doesn't have to know about option syntax.
128
+
129
+
### `Package_symlinks` — per-package tracking
140
130
141
131
```ocaml
142
-
val for_layer_json :
143
-
?poll_interval:float -> ?max_polls:int ->
144
-
Fpath.t -> (unit, [> Rresult.R.msg]) result
145
-
(** Poll for layer.json to appear (created by another parallel worker).
146
-
Defaults: poll every 0.5s, up to 600 polls (5 minutes). Configurable
147
-
for testing. *)
132
+
val ensure_layer_symlink :
133
+
packages_dir:Fpath.t -> pkg_str:string -> layer_name:string ->
134
+
(unit, _) result
148
135
```
149
136
150
-
### `Query` — layer inspection utilities
137
+
Each successful build adds a symlink under `packages/{pkg.version}/`
138
+
pointing to its hash-addressed layer directory. Lets you enumerate
139
+
every layer that's ever been built for a package.
140
+
141
+
### `Scan` — directory enumeration
151
142
152
143
```ocaml
153
-
val universe_hash_of_layer : os_dir:Fpath.t -> string -> string option
154
-
val log_path_of_layer : os_dir:Fpath.t -> string -> Fpath.t option
155
-
val created_at_of_layer : os_dir:Fpath.t -> string -> string option
144
+
val list_layers : Fpath.t -> (string * Fpath.t) list
145
+
val list_package_symlinks :
146
+
?exclude:string list -> Fpath.t -> string -> (string * string) list
156
147
```
157
148
158
-
### `Classify` — build failure classification
149
+
Low-level directory listing. Caller filters and interprets names.
150
+
151
+
### `Import` — bootstrapping from Docker
159
152
160
153
```ocaml
161
-
val classify_build_log : string -> string * string * string option
162
-
(** [classify_build_log content] returns [(status, category, error_opt)]
163
-
by scanning log content for known patterns (transient failures,
164
-
missing depexts, etc). *)
154
+
val from_docker :
155
+
env -> image:string -> layer_dir:Fpath.t -> (unit, _) result
165
156
```
166
157
167
-
Note: `build_result`, `build_node`, and `Dag.build_global_dag` from
168
-
the original plan have moved to the `build` library — they are build
169
-
orchestration concerns, not layer management.
158
+
Creates a base layer by exporting a Docker image's filesystem.
170
159
171
-
### `Solution_json` — solution persistence
160
+
### `Opam_repo` — assembling an opam repo subtree
172
161
173
162
```ocaml
174
-
val to_json : OpamPackage.Set.t OpamPackage.Map.t -> Yojson.Safe.t
175
-
val of_json : Yojson.Safe.t -> OpamPackage.Set.t OpamPackage.Map.t
176
-
val save : Fpath.t -> OpamPackage.Set.t OpamPackage.Map.t -> (unit, [> Rresult.R.msg]) result
177
-
val load : Fpath.t -> (OpamPackage.Set.t OpamPackage.Map.t, [> Rresult.R.msg]) result
178
-
val to_string : OpamPackage.Set.t OpamPackage.Map.t -> string
179
-
val of_string : string -> OpamPackage.Set.t OpamPackage.Map.t
163
+
val create : Fpath.t -> (Fpath.t, _) result
164
+
val populate :
165
+
opam_repo:Fpath.t -> opam_repositories:Fpath.t list ->
166
+
OpamPackage.t list -> (unit, _) result
180
167
```
181
168
182
-
## Source in day10
169
+
Builds a minimal `opam-repository/` tree containing just the opam
170
+
files needed for a package and its deps. Used when building with a
171
+
pinned set of repo state.
183
172
184
-
| day10 file | What moves here |
185
-
|------------|----------------|
186
-
| `util.ml` | `save_layer_info`, `save_doc_layer_info`, `load_layer_info_*`, `ensure_package_*_symlink`, `scan_installed_*_files`, `create_opam_repository`, `populate_opam_repository`, `opam_file`, `write_skeleton_layer`, `wait_for_layer_json`, `solution_*` |
187
-
| `main.ml` | `build_result` type, `build_node` type, `build_global_dag`, `universe_hash_of_layer`, `log_path_of_layer`, `created_at_of_layer` |
188
-
| `day10_lib/batch_util.ml` | `classify_build_log`, `extract_compiler_from_deps`, `matches_any` |
173
+
### `Opamh` — opam switch state helpers
189
174
190
-
## Testing
175
+
```ocaml
176
+
val compiler_packages : OpamPackage.Name.t list
177
+
val dump_state : Fpath.t list -> Fpath.t -> (unit, _) result
178
+
```
179
+
180
+
Identifies compiler packages (`ocaml`, `ocaml-base-compiler`, etc.)
181
+
and writes a `switch-state` file describing what's installed, for
182
+
use inside containers.
191
183
192
-
Needs `yojson` and `opam-format`. Use temp dirs for isolation.
184
+
## Error-handling convention
193
185
194
-
### Unit tests
186
+
| Operation kind | Returns |
187
+
|---|---|
188
+
| Read, maybe-exists lookup | `_ option` (`None` on missing) |
189
+
| Read, must-exist or parse | `(_, [> Rresult.R.msg]) result` |
190
+
| Write / create / mutate | `(_, [> Rresult.R.msg]) result` |
191
+
| Best-effort bookkeeping (e.g. LRU touch) | `unit`, silent on error |
195
192
196
-
- **`Layer_info`** — `save` then `load_exit_status` /
197
-
`load_package_name` / `load_installed_libs` / `load_installed_docs`
198
-
round-trip correctly. Test `save_doc` + `load_doc_failed` +
199
-
`load_dep_doc_hashes`. Verify JSON structure with
200
-
`Yojson.Safe.from_file`.
201
-
- **`Package_symlinks`** — `ensure_layer_symlink` creates a valid
202
-
symlink. Calling it again is idempotent.
203
-
`ensure_blessed_symlink` for both `Build` and `Docs` kinds.
204
-
- **`Installed_files`** — create a mock layer dir with
205
-
`fs/home/opam/.opam/default/lib/` containing `.cmi`, `.cmxa`,
206
-
`META` files. Verify `scan_libs` finds them. Similarly for
207
-
`scan_docs` with `.mld` files.
208
-
- **`Opam_repo`** — `create` makes the `opam-repository/` dir with a
209
-
`repo` file. `populate` copies opam files from source repos.
210
-
`find_opam_file` locates and parses an opam file.
211
-
- **`Skeleton`** — `write` creates a layer dir with `exit_status=-1`
212
-
and an opam-repository. Verify `Layer_info.load_exit_status`
213
-
returns -1.
214
-
- **`Wait`** — start a fiber that creates `layer.json` after 1s,
215
-
verify `for_layer_json` returns `Ok`. Test timeout (no file
216
-
created) returns `Error`.
217
-
- **`Query`** — set up a layer dir with layer.json containing known
218
-
values, verify `universe_hash_of_layer`, `log_path_of_layer`,
219
-
`created_at_of_layer` extract them.
220
-
- **`Classify`** — test with log content matching known patterns:
221
-
"missing system package" → depext failure, "context deadline
222
-
exceeded" → transient, clean exit → success.
223
-
- **`Dag`** — construct a small solution map (3-4 packages), verify
224
-
`build_global_dag` produces the right number of deduplicated nodes
225
-
with correct ordering.
226
-
- **`Solution_json`** — `to_json`/`of_json` round-trip.
227
-
`save`/`load` round-trip. `to_string`/`of_string` round-trip.
193
+
The `Last_used.touch` exception is deliberate — LRU bookkeeping must
194
+
never fail a build, so it catches everything and does nothing on
195
+
error. Any other function that can observably fail returns a
196
+
`Result`.
228
197
229
-
### Failure mode tests
198
+
## Testing
230
199
231
-
- **`Layer_info` — missing file:** `load_exit_status` on a
232
-
nonexistent path → `Error`, not an uncaught exception.
233
-
- **`Layer_info` — corrupt JSON:** write `{broken` to layer.json,
234
-
call all `load_*` functions, verify each returns `Error` (not a
235
-
Yojson parse exception bubbling up).
236
-
- **`Layer_info` — empty file:** 0-byte layer.json → `Error`.
237
-
- **`Layer_info` — missing fields:** valid JSON but with required
238
-
fields removed (e.g. no `exit_status` key), verify `Error` with
239
-
a descriptive message.
240
-
- **`Opam_repo` — missing source repo:** `populate` with a
241
-
nonexistent `opam_repositories` path → `Error`.
242
-
- **`Opam_repo` — missing package:** `populate` requesting a package
243
-
that doesn't exist in any source repo → `Error`.
244
-
- **`Opam_repo` — corrupt opam file:** `find_opam_file` with a
245
-
malformed opam file → returns `None` (not an exception).
246
-
- **`Package_symlinks` — dangling target:** `ensure_layer_symlink`
247
-
pointing to a nonexistent layer dir. Verify the symlink is created
248
-
(dangling is OK — the layer may appear later). Verify `Query`
249
-
functions handle the dangling symlink gracefully.
250
-
- **`Wait` — timeout:** no other fiber creates layer.json, verify
251
-
`for_layer_json` returns `Error` after the polling limit (use a
252
-
short timeout for the test).
253
-
- **`Solution_json` — corrupt JSON:** `load` / `of_json` with
254
-
invalid input → `Error`, not an uncaught exception.
255
-
- **`Query` — missing layer dir:** all three query functions on a
256
-
nonexistent layer name → return `None`.
200
+
Unit tests in `test/` cover every module without requiring root or
201
+
container runtime. Integration tests that actually mount overlayfs
202
+
live in `day11/container/test/test_integration.ml` and are gated on
203
+
`DAY11_INTEGRATION=true`.
+4
day11/layer/cli/dune
+4
day11/layer/cli/dune
+367
day11/layer/cli/layer_cli.ml
+367
day11/layer/cli/layer_cli.ml
···
1
+
(** Low-level layer cache inspection tool.
2
+
3
+
Uses only the day11_layer library — no solver, no build, no doc
4
+
pipeline. Reads layer.json files and the on-disk cache structure
5
+
directly. *)
6
+
7
+
open Cmdliner
8
+
module L = Day11_layer
9
+
10
+
(* ── Helpers ─────────────────────────────────────────────────────────── *)
11
+
12
+
let fpath = Fpath.v
13
+
14
+
(** Status string derived from build_meta. *)
15
+
let status_of (m : L.Layer_meta.build_meta) =
16
+
if m.exit_status = 0 then "ok"
17
+
else if m.failed_dep <> None then "cascade"
18
+
else "fail"
19
+
20
+
(** Kind string for display. *)
21
+
let kind_of (m : L.Layer_meta.build_meta) = L.Layer_meta.string_of_kind m.kind
22
+
23
+
(** Short hash for display. *)
24
+
let short h = if String.length h >= 12 then String.sub h 0 12 else h
25
+
26
+
let load_meta layer_dir =
27
+
L.Layer_meta.load_build Fpath.(layer_dir / "layer.json")
28
+
29
+
(** Walk all layer directories under [os_dir] and apply [f] to each
30
+
[(name, layer_dir, meta)]. Layers without a readable layer.json
31
+
are skipped silently. *)
32
+
let fold_layers os_dir init f =
33
+
L.Scan.list_layers os_dir
34
+
|> List.fold_left (fun acc (name, layer_dir) ->
35
+
match load_meta layer_dir with
36
+
| Ok meta -> f acc name layer_dir meta
37
+
| Error _ -> acc) init
38
+
39
+
(* ── list ────────────────────────────────────────────────────────────── *)
40
+
41
+
let cmd_list os_dir kind status pkg_filter limit sort_lru =
42
+
let os_dir = fpath os_dir in
43
+
let matches name (m : L.Layer_meta.build_meta) =
44
+
(match kind with
45
+
| None -> true
46
+
| Some k -> L.Layer_meta.string_of_kind m.kind = k) &&
47
+
(match status with None -> true | Some s -> status_of m = s) &&
48
+
(match pkg_filter with
49
+
| None -> true
50
+
| Some p ->
51
+
let s = m.package in
52
+
let _ = name in
53
+
(* substring or exact name match *)
54
+
try ignore (Str.search_forward (Str.regexp_string p) s 0); true
55
+
with Not_found -> false)
56
+
in
57
+
let entries = fold_layers os_dir [] (fun acc name layer_dir m ->
58
+
if matches name m
59
+
then (name, layer_dir, m, L.Last_used.get layer_dir) :: acc
60
+
else acc)
61
+
in
62
+
let entries =
63
+
if sort_lru then
64
+
(* Oldest "last used" first; never-used layers sort first as 0.0 *)
65
+
List.sort (fun (_, _, _, a) (_, _, _, b) ->
66
+
let av = match a with Some t -> t | None -> 0.0 in
67
+
let bv = match b with Some t -> t | None -> 0.0 in
68
+
compare av bv) entries
69
+
else
70
+
List.sort (fun (_, _, a, _) (_, _, b, _) ->
71
+
String.compare a.L.Layer_meta.created_at b.L.Layer_meta.created_at)
72
+
entries
73
+
in
74
+
let n_total = List.length entries in
75
+
let entries = match limit with
76
+
| Some n when n > 0 ->
77
+
let rec take k = function
78
+
| [] -> []
79
+
| _ when k = 0 -> []
80
+
| x :: xs -> x :: take (k - 1) xs
81
+
in
82
+
take n entries
83
+
| _ -> entries
84
+
in
85
+
let fmt_lru = function
86
+
| None -> "(never)"
87
+
| Some t ->
88
+
let tm = Unix.gmtime t in
89
+
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
90
+
(tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
91
+
tm.tm_hour tm.tm_min tm.tm_sec
92
+
in
93
+
let date_col_label = if sort_lru then "LAST USED" else "CREATED" in
94
+
Printf.printf "%-14s %-9s %-8s %-19s %s\n"
95
+
"HASH" "KIND" "STATUS" date_col_label "PACKAGE";
96
+
Printf.printf "%-14s %-9s %-8s %-19s %s\n"
97
+
(String.make 12 '-') (String.make 9 '-')
98
+
(String.make 8 '-') (String.make 19 '-') (String.make 30 '-');
99
+
List.iter (fun (name, _dir, (m : L.Layer_meta.build_meta), lru) ->
100
+
let hash = match String.index_opt name '-' with
101
+
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
102
+
| None -> name
103
+
in
104
+
let date_col =
105
+
if sort_lru then fmt_lru lru
106
+
else if String.length m.created_at >= 19
107
+
then String.sub m.created_at 0 19 else m.created_at
108
+
in
109
+
Printf.printf "%-14s %-9s %-8s %-19s %s\n"
110
+
(short hash) (kind_of m) (status_of m) date_col m.package
111
+
) entries;
112
+
Printf.printf "\n(showing %d of %d layers)\n" (List.length entries) n_total;
113
+
0
114
+
115
+
(* ── show ────────────────────────────────────────────────────────────── *)
116
+
117
+
let find_layer_by_prefix os_dir prefix =
118
+
L.Scan.list_layers os_dir
119
+
|> List.filter_map (fun (name, layer_dir) ->
120
+
let h = match String.index_opt name '-' with
121
+
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
122
+
| None -> name
123
+
in
124
+
if String.length h >= String.length prefix
125
+
&& String.sub h 0 (String.length prefix) = prefix
126
+
then Some (name, layer_dir)
127
+
else None)
128
+
129
+
let cmd_show os_dir hash_prefix =
130
+
let os_dir = fpath os_dir in
131
+
match find_layer_by_prefix os_dir hash_prefix with
132
+
| [] ->
133
+
Printf.eprintf "No layer with hash prefix %s\n" hash_prefix; 1
134
+
| _ :: _ :: _ as matches ->
135
+
Printf.eprintf "Ambiguous prefix %s, matches:\n" hash_prefix;
136
+
List.iter (fun (n, _) -> Printf.eprintf " %s\n" n) matches;
137
+
2
138
+
| [ (name, layer_dir) ] ->
139
+
match load_meta layer_dir with
140
+
| Error (`Msg e) ->
141
+
Printf.eprintf "%s: %s\n" name e; 1
142
+
| Ok m ->
143
+
Printf.printf "Layer: %s\n" name;
144
+
Printf.printf "Path: %s\n" (Fpath.to_string layer_dir);
145
+
Printf.printf "Package: %s\n" m.package;
146
+
Printf.printf "Kind: %s\n" (kind_of m);
147
+
Printf.printf "Status: %s (exit %d)\n" (status_of m) m.exit_status;
148
+
Printf.printf "Created: %s\n" m.created_at;
149
+
(match L.Last_used.get layer_dir with
150
+
| Some t ->
151
+
let tm = Unix.gmtime t in
152
+
Printf.printf "Last used: %04d-%02d-%02dT%02d:%02d:%02dZ\n"
153
+
(tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
154
+
tm.tm_hour tm.tm_min tm.tm_sec
155
+
| None -> Printf.printf "Last used: (never recorded)\n");
156
+
Printf.printf "Base: %s\n" m.base_hash;
157
+
Printf.printf "UID/GID: %d:%d\n" m.uid m.gid;
158
+
Printf.printf "Disk: %d bytes\n" m.disk_usage;
159
+
(match m.failed_dep with
160
+
| Some d -> Printf.printf "Failed dep: %s\n" d
161
+
| None -> ());
162
+
Printf.printf "\nDeps (%d):\n" (List.length m.deps);
163
+
List.iter2 (fun d h ->
164
+
Printf.printf " %s %s\n" (short h) d
165
+
) m.deps m.hashes;
166
+
if m.patches <> [] then begin
167
+
Printf.printf "\nPatches (%d):\n" (List.length m.patches);
168
+
List.iter (fun p -> Printf.printf " %s\n" p) m.patches
169
+
end;
170
+
if m.timing <> [] then begin
171
+
Printf.printf "\nTiming (s):\n";
172
+
List.iter (fun (name, secs) ->
173
+
Printf.printf " %-16s %.3f\n" (name ^ ":") secs
174
+
) m.timing
175
+
end;
176
+
if m.installed_libs <> [] then
177
+
Printf.printf "\nInstalled libs: %d files\n"
178
+
(List.length m.installed_libs);
179
+
if m.installed_docs <> [] then
180
+
Printf.printf "Installed docs: %d files\n"
181
+
(List.length m.installed_docs);
182
+
0
183
+
184
+
(* ── tree ────────────────────────────────────────────────────────────── *)
185
+
186
+
let cmd_tree os_dir hash_prefix =
187
+
let os_dir = fpath os_dir in
188
+
match find_layer_by_prefix os_dir hash_prefix with
189
+
| [] -> Printf.eprintf "No layer with hash prefix %s\n" hash_prefix; 1
190
+
| _ :: _ :: _ as ms ->
191
+
Printf.eprintf "Ambiguous prefix:\n";
192
+
List.iter (fun (n, _) -> Printf.eprintf " %s\n" n) ms; 2
193
+
| [ (name, _layer_dir) ] ->
194
+
let full_hash = match String.index_opt name '-' with
195
+
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
196
+
| None -> name
197
+
in
198
+
(* load_build_tree expects the FULL hash, but our layer dirs use
199
+
12-char short hashes. Walk the tree by hand using load_meta. *)
200
+
let visited = Hashtbl.create 32 in
201
+
let rec walk depth name =
202
+
let prefix = String.make (depth * 2) ' ' in
203
+
let layer_dir = Fpath.(os_dir / name) in
204
+
if Hashtbl.mem visited name then
205
+
Printf.printf "%s%s (already shown)\n" prefix name
206
+
else begin
207
+
Hashtbl.add visited name ();
208
+
match load_meta layer_dir with
209
+
| Error _ ->
210
+
Printf.printf "%s%s (no layer.json)\n" prefix name
211
+
| Ok m ->
212
+
Printf.printf "%s%s [%s] %s %s\n"
213
+
prefix name (kind_of m) (status_of m) m.package;
214
+
List.iter (fun h ->
215
+
let dep_name = "build-" ^ short h in
216
+
walk (depth + 1) dep_name
217
+
) m.hashes
218
+
end
219
+
in
220
+
walk 0 ("build-" ^ short full_hash);
221
+
0
222
+
223
+
(* ── stats ───────────────────────────────────────────────────────────── *)
224
+
225
+
let cmd_stats os_dir =
226
+
let os_dir = fpath os_dir in
227
+
let by_kind_status = Hashtbl.create 8 in
228
+
let total_disk = ref 0 in
229
+
let n = fold_layers os_dir 0 (fun acc _ _ m ->
230
+
let key = (kind_of m, status_of m) in
231
+
let cur = try Hashtbl.find by_kind_status key with Not_found -> 0 in
232
+
Hashtbl.replace by_kind_status key (cur + 1);
233
+
total_disk := !total_disk + m.disk_usage;
234
+
acc + 1)
235
+
in
236
+
Printf.printf "Total layers: %d\n" n;
237
+
Printf.printf "Total disk: %d bytes (%.1f GB)\n"
238
+
!total_disk (float_of_int !total_disk /. 1e9);
239
+
Printf.printf "\nBy kind and status:\n";
240
+
let entries = Hashtbl.fold (fun k v acc -> (k, v) :: acc) by_kind_status [] in
241
+
let entries = List.sort compare entries in
242
+
Printf.printf " %-12s %-9s %s\n" "KIND" "STATUS" "COUNT";
243
+
Printf.printf " %-12s %-9s %s\n" "----" "------" "-----";
244
+
List.iter (fun ((kind, status), count) ->
245
+
Printf.printf " %-12s %-9s %d\n" kind status count
246
+
) entries;
247
+
0
248
+
249
+
(* ── package ─────────────────────────────────────────────────────────── *)
250
+
251
+
let cmd_package os_dir pkg =
252
+
let os_dir = fpath os_dir in
253
+
let entries = fold_layers os_dir [] (fun acc name dir m ->
254
+
if m.L.Layer_meta.package = pkg then (name, dir, m) :: acc else acc)
255
+
in
256
+
if entries = [] then begin
257
+
Printf.eprintf "No layers for package %s\n" pkg; 1
258
+
end else begin
259
+
let entries = List.sort (fun (_, _, a) (_, _, b) ->
260
+
String.compare a.L.Layer_meta.created_at b.L.Layer_meta.created_at)
261
+
entries
262
+
in
263
+
Printf.printf "Layers for %s (%d):\n\n" pkg (List.length entries);
264
+
Printf.printf "%-14s %-9s %-8s %-19s %s\n"
265
+
"HASH" "KIND" "STATUS" "CREATED" "DEPS";
266
+
List.iter (fun (name, _, (m : L.Layer_meta.build_meta)) ->
267
+
let hash = match String.index_opt name '-' with
268
+
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
269
+
| None -> name
270
+
in
271
+
let created = if String.length m.created_at >= 19
272
+
then String.sub m.created_at 0 19 else m.created_at in
273
+
Printf.printf "%-14s %-9s %-8s %-19s %d deps\n"
274
+
(short hash) (kind_of m) (status_of m) created (List.length m.deps)
275
+
) entries;
276
+
0
277
+
end
278
+
279
+
(* ── log ─────────────────────────────────────────────────────────────── *)
280
+
281
+
let cmd_log os_dir hash_prefix =
282
+
let os_dir = fpath os_dir in
283
+
match find_layer_by_prefix os_dir hash_prefix with
284
+
| [] -> Printf.eprintf "No layer with hash prefix %s\n" hash_prefix; 1
285
+
| _ :: _ :: _ as ms ->
286
+
Printf.eprintf "Ambiguous prefix:\n";
287
+
List.iter (fun (n, _) -> Printf.eprintf " %s\n" n) ms; 2
288
+
| [ (_name, layer_dir) ] ->
289
+
let log_path = Fpath.(layer_dir / "layer.log") in
290
+
match Bos.OS.File.read log_path with
291
+
| Ok content -> print_string content; 0
292
+
| Error (`Msg e) -> Printf.eprintf "%s\n" e; 1
293
+
294
+
(* ── CLI wiring ──────────────────────────────────────────────────────── *)
295
+
296
+
let os_dir_term =
297
+
let doc = "Path to the OS-specific cache directory containing build-* \
298
+
subdirectories (e.g. /home/jjl25/cache/debian-bookworm-x86_64)" in
299
+
Arg.(required & opt (some string) None
300
+
& info [ "os-dir" ] ~docv:"DIR" ~doc)
301
+
302
+
let kind_term =
303
+
let doc = "Filter by layer kind (build, compile, link, doc-all)" in
304
+
Arg.(value & opt (some string) None & info [ "kind"; "k" ] ~docv:"KIND" ~doc)
305
+
306
+
let status_term =
307
+
let doc = "Filter by status (ok, fail, cascade)" in
308
+
Arg.(value & opt (some string) None
309
+
& info [ "status"; "s" ] ~docv:"STATUS" ~doc)
310
+
311
+
let pkg_filter_term =
312
+
let doc = "Filter by package name (substring match)" in
313
+
Arg.(value & opt (some string) None & info [ "package"; "p" ] ~docv:"PKG" ~doc)
314
+
315
+
let limit_term =
316
+
let doc = "Limit number of results" in
317
+
Arg.(value & opt (some int) None & info [ "limit"; "n" ] ~docv:"N" ~doc)
318
+
319
+
let sort_lru_term =
320
+
let doc = "Sort by last-used time, oldest first \
321
+
(layers never accessed appear first as 'never'). \
322
+
Useful for finding LRU eviction candidates." in
323
+
Arg.(value & flag & info [ "sort-by-lru"; "lru" ] ~doc)
324
+
325
+
let hash_term =
326
+
Arg.(required & pos 0 (some string) None
327
+
& info [] ~docv:"HASH" ~doc:"Layer hash (or prefix)")
328
+
329
+
let pkg_term =
330
+
Arg.(required & pos 0 (some string) None
331
+
& info [] ~docv:"PACKAGE"
332
+
~doc:"Exact package name with version (e.g. zarith.1.14)")
333
+
334
+
let list_cmd =
335
+
let info = Cmd.info "list" ~doc:"List layers in the cache" in
336
+
Cmd.v info Term.(const cmd_list $ os_dir_term $ kind_term
337
+
$ status_term $ pkg_filter_term $ limit_term
338
+
$ sort_lru_term)
339
+
340
+
let show_cmd =
341
+
let info = Cmd.info "show" ~doc:"Show full metadata for one layer" in
342
+
Cmd.v info Term.(const cmd_show $ os_dir_term $ hash_term)
343
+
344
+
let tree_cmd =
345
+
let info = Cmd.info "tree" ~doc:"Show dependency tree of a layer" in
346
+
Cmd.v info Term.(const cmd_tree $ os_dir_term $ hash_term)
347
+
348
+
let stats_cmd =
349
+
let info = Cmd.info "stats" ~doc:"Summary statistics of the cache" in
350
+
Cmd.v info Term.(const cmd_stats $ os_dir_term)
351
+
352
+
let package_cmd =
353
+
let info = Cmd.info "package" ~doc:"List all layers for one package" in
354
+
Cmd.v info Term.(const cmd_package $ os_dir_term $ pkg_term)
355
+
356
+
let log_cmd =
357
+
let info = Cmd.info "log" ~doc:"Print the build log for a layer" in
358
+
Cmd.v info Term.(const cmd_log $ os_dir_term $ hash_term)
359
+
360
+
let main =
361
+
let info = Cmd.info "day11-layer-cli"
362
+
~doc:"Low-level inspection of the day11 layer cache"
363
+
~version:"0.1" in
364
+
Cmd.group info [ list_cmd; show_cmd; tree_cmd; stats_cmd;
365
+
package_cmd; log_cmd ]
366
+
367
+
let () = exit (Cmd.eval' main)
+16
day11/layer/last_used.ml
+16
day11/layer/last_used.ml
···
1
+
let sentinel = "last_used"
2
+
3
+
let touch layer_dir =
4
+
let path = Fpath.(layer_dir / sentinel) |> Fpath.to_string in
5
+
try
6
+
(* Create the file if it doesn't exist (O_CREAT) *)
7
+
let fd = Unix.openfile path [ Unix.O_WRONLY; Unix.O_CREAT ] 0o644 in
8
+
Unix.close fd;
9
+
(* Update mtime to now. utimes with 0.0 means "use current time". *)
10
+
Unix.utimes path 0.0 0.0
11
+
with _ -> ()
12
+
13
+
let get layer_dir =
14
+
let path = Fpath.(layer_dir / sentinel) |> Fpath.to_string in
15
+
try Some (Unix.stat path).st_mtime
16
+
with _ -> None
+20
day11/layer/last_used.mli
+20
day11/layer/last_used.mli
···
1
+
(** Per-layer "last used" timestamp for LRU cache eviction.
2
+
3
+
Each layer has a [last_used] sentinel file in its directory whose
4
+
mtime records the most recent access. The file's content is
5
+
irrelevant — only its mtime matters.
6
+
7
+
This is deliberately split off from {!Layer_meta} so that marking
8
+
a layer as used is cheap — just [utimensat] on a small sentinel
9
+
file, no JSON read/write. *)
10
+
11
+
val touch : Fpath.t -> unit
12
+
(** [touch layer_dir] records that the layer has just been accessed.
13
+
Creates [layer_dir/last_used] if it doesn't exist, or updates its
14
+
mtime if it does. Errors are silently ignored — touch must never
15
+
fail a build. *)
16
+
17
+
val get : Fpath.t -> float option
18
+
(** [get layer_dir] returns the unix timestamp (seconds since epoch)
19
+
of the last touch, or [None] if the sentinel file doesn't exist
20
+
or can't be stat'd. *)
-119
day11/layer/layer_info.ml
-119
day11/layer/layer_info.ml
···
1
-
let format_timestamp t =
2
-
let tm = Unix.localtime t in
3
-
Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d"
4
-
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
5
-
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
6
-
7
-
let save ?installed_libs ?installed_docs ?(extra = []) path ~pkg ~deps
8
-
~hashes ~exit_status ~uid ~gid ~base_hash =
9
-
let now = Unix.time () in
10
-
let fields =
11
-
[ ("package", `String pkg);
12
-
("exit_status", `Int exit_status);
13
-
("deps", `List (List.map (fun d -> `String d) deps));
14
-
("hashes", `List (List.map (fun h -> `String h) hashes));
15
-
("uid", `Int uid);
16
-
("gid", `Int gid);
17
-
("base_hash", `String base_hash);
18
-
("created", `Float now);
19
-
("created_at", `String (format_timestamp now)) ]
20
-
in
21
-
let fields = match installed_libs with
22
-
| None -> fields
23
-
| Some libs ->
24
-
fields @ [ ("installed_libs", `List (List.map (fun s -> `String s) libs)) ]
25
-
in
26
-
let fields = match installed_docs with
27
-
| None -> fields
28
-
| Some docs ->
29
-
fields @ [ ("installed_docs", `List (List.map (fun s -> `String s) docs)) ]
30
-
in
31
-
let fields = fields @ extra in
32
-
try
33
-
Yojson.Safe.to_file (Fpath.to_string path) (`Assoc fields);
34
-
Ok ()
35
-
with exn ->
36
-
Rresult.R.error_msgf "Layer_info.save %a: %s"
37
-
Fpath.pp path (Printexc.to_string exn)
38
-
39
-
let save_skeleton path ~pkg ~failed_dep =
40
-
let now = Unix.time () in
41
-
let fields =
42
-
[ ("package", `String pkg);
43
-
("exit_status", `Int (-1));
44
-
("failed_dep", `String failed_dep);
45
-
("deps", `List []);
46
-
("hashes", `List []);
47
-
("created", `Float now);
48
-
("created_at", `String (format_timestamp now)) ]
49
-
in
50
-
try
51
-
Yojson.Safe.to_file (Fpath.to_string path) (`Assoc fields);
52
-
Ok ()
53
-
with exn ->
54
-
Rresult.R.error_msgf "Layer_info.save_skeleton %a: %s"
55
-
Fpath.pp path (Printexc.to_string exn)
56
-
57
-
let load path =
58
-
let path_s = Fpath.to_string path in
59
-
try Ok (Yojson.Safe.from_file path_s)
60
-
with exn ->
61
-
Rresult.R.error_msgf "Layer_info.load %a: %s"
62
-
Fpath.pp path (Printexc.to_string exn)
63
-
64
-
let load_exit_status path =
65
-
match load path with
66
-
| Error _ as e -> e
67
-
| Ok json ->
68
-
try Ok (Yojson.Safe.Util.(json |> member "exit_status" |> to_int))
69
-
with exn ->
70
-
Rresult.R.error_msgf "load_exit_status %a: %s"
71
-
Fpath.pp path (Printexc.to_string exn)
72
-
73
-
let load_package_name path =
74
-
match load path with
75
-
| Error _ as e -> e
76
-
| Ok json ->
77
-
try Ok (Yojson.Safe.Util.(json |> member "package" |> to_string))
78
-
with exn ->
79
-
Rresult.R.error_msgf "load_package_name %a: %s"
80
-
Fpath.pp path (Printexc.to_string exn)
81
-
82
-
let load_string_list_field path field =
83
-
match load path with
84
-
| Error _ as e -> e
85
-
| Ok json ->
86
-
try
87
-
let open Yojson.Safe.Util in
88
-
match json |> member field with
89
-
| `Null -> Ok []
90
-
| lst -> Ok (lst |> to_list |> List.map to_string)
91
-
with exn ->
92
-
Rresult.R.error_msgf "load_%s %a: %s"
93
-
field Fpath.pp path (Printexc.to_string exn)
94
-
95
-
let load_installed_libs path = load_string_list_field path "installed_libs"
96
-
let load_installed_docs path = load_string_list_field path "installed_docs"
97
-
98
-
let load_uid_gid path =
99
-
match load path with
100
-
| Error _ as e -> e
101
-
| Ok json ->
102
-
try
103
-
let open Yojson.Safe.Util in
104
-
let uid = json |> member "uid" |> to_int in
105
-
let gid = json |> member "gid" |> to_int in
106
-
Ok (uid, gid)
107
-
with exn ->
108
-
Rresult.R.error_msgf "load_uid_gid %a: %s"
109
-
Fpath.pp path (Printexc.to_string exn)
110
-
111
-
let load_base_hash path =
112
-
match load path with
113
-
| Error _ as e -> e
114
-
| Ok json ->
115
-
try Ok (Yojson.Safe.Util.(json |> member "base_hash" |> to_string))
116
-
with exn ->
117
-
Rresult.R.error_msgf "load_base_hash %a: %s"
118
-
Fpath.pp path (Printexc.to_string exn)
119
-
-49
day11/layer/layer_info.mli
-49
day11/layer/layer_info.mli
···
1
-
(** Layer metadata serialization (layer.json).
2
-
3
-
Each layer has a [layer.json] file containing core metadata and
4
-
optional extra fields. Layers are self-describing — they contain
5
-
enough information to be rebuilt without external configuration. *)
6
-
7
-
val save :
8
-
?installed_libs:string list ->
9
-
?installed_docs:string list ->
10
-
?extra:(string * Yojson.Safe.t) list ->
11
-
Fpath.t ->
12
-
pkg:string ->
13
-
deps:string list ->
14
-
hashes:string list ->
15
-
exit_status:int ->
16
-
uid:int ->
17
-
gid:int ->
18
-
base_hash:string ->
19
-
(unit, [> Rresult.R.msg ]) result
20
-
(** [save path ~pkg ~deps ~hashes ~exit_status ~uid ~gid ~base_hash]
21
-
writes a layer.json at [path].
22
-
23
-
Core fields: [package], [exit_status], [deps], [hashes],
24
-
[uid], [gid], [base_hash], [created], [created_at].
25
-
Optional: [installed_libs], [installed_docs], [extra]. *)
26
-
27
-
val save_skeleton :
28
-
Fpath.t ->
29
-
pkg:string ->
30
-
failed_dep:string ->
31
-
(unit, [> Rresult.R.msg ]) result
32
-
(** [save_skeleton path ~pkg ~failed_dep] writes a minimal layer.json
33
-
for a package that was not built because [failed_dep] failed.
34
-
Sets [exit_status] to [-1] and leaves [deps] and [hashes] empty. *)
35
-
36
-
val load : Fpath.t -> (Yojson.Safe.t, [> Rresult.R.msg ]) result
37
-
(** [load path] reads and parses a layer.json file. *)
38
-
39
-
val load_exit_status : Fpath.t -> (int, [> Rresult.R.msg ]) result
40
-
val load_package_name : Fpath.t -> (string, [> Rresult.R.msg ]) result
41
-
val load_installed_libs : Fpath.t -> (string list, [> Rresult.R.msg ]) result
42
-
val load_installed_docs : Fpath.t -> (string list, [> Rresult.R.msg ]) result
43
-
44
-
val load_uid_gid : Fpath.t -> (int * int, [> Rresult.R.msg ]) result
45
-
(** Convenience: load the [uid] and [gid] fields. *)
46
-
47
-
val load_base_hash : Fpath.t -> (string, [> Rresult.R.msg ]) result
48
-
(** Convenience: load the [base_hash] field. *)
49
-
+93
-55
day11/layer/layer_meta.ml
+93
-55
day11/layer/layer_meta.ml
···
1
-
type timing = {
2
-
merge : float; [@default 0.]
3
-
dump_state : float; [@default 0.]
4
-
chown : float; [@default 0.]
5
-
overlay_mount : float; [@default 0.]
6
-
runc_run : float; [@default 0.]
7
-
overlay_umount : float; [@default 0.]
8
-
cleanup : float; [@default 0.]
9
-
extract : float; [@default 0.]
10
-
total : float; [@default 0.]
11
-
} [@@deriving yojson]
1
+
(* ── Layer kind ───────────────────────────────────────────────── *)
2
+
3
+
type kind = Build | Compile | Link | Doc_all
4
+
5
+
let string_of_kind = function
6
+
| Build -> "build"
7
+
| Compile -> "compile"
8
+
| Link -> "link"
9
+
| Doc_all -> "doc-all"
10
+
11
+
let kind_of_string = function
12
+
| "build" -> Build
13
+
| "compile" -> Compile
14
+
| "link" -> Link
15
+
| "doc-all" -> Doc_all
16
+
| _ -> Build (* unknown kinds fall back to Build for forward-compat *)
17
+
18
+
(* ── Phase timing ─────────────────────────────────────────────── *)
12
19
13
-
let empty_timing = {
14
-
merge = 0.; dump_state = 0.; chown = 0.; overlay_mount = 0.;
15
-
runc_run = 0.; overlay_umount = 0.; cleanup = 0.; extract = 0.;
16
-
total = 0.;
17
-
}
20
+
type timing = (string * float) list
18
21
19
-
type build_meta = {
22
+
let empty_timing : timing = []
23
+
24
+
let timing_field name t =
25
+
try List.assoc name t with Not_found -> 0.0
26
+
27
+
(* Serialize as a JSON object. A ppx_deriving_yojson [@of_yojson]
28
+
/ [@to_yojson] on the wire record will use these. *)
29
+
let timing_to_yojson (t : timing) : Yojson.Safe.t =
30
+
`Assoc (List.map (fun (k, v) -> (k, `Float v)) t)
31
+
32
+
let timing_of_yojson (json : Yojson.Safe.t) : (timing, string) result =
33
+
match json with
34
+
| `Assoc kvs ->
35
+
(try
36
+
Ok (List.map (fun (k, v) ->
37
+
match v with
38
+
| `Float f -> (k, f)
39
+
| `Int i -> (k, float_of_int i)
40
+
| _ -> failwith "timing value must be a number") kvs)
41
+
with Failure m -> Error m)
42
+
| `Null -> Ok []
43
+
| _ -> Error "timing must be a JSON object"
44
+
45
+
(* ── Build metadata ───────────────────────────────────────────── *)
46
+
47
+
(* Internal "wire" record mirrors the on-disk JSON with kind as a
48
+
string. The public [build_meta] type uses the typed [kind] and
49
+
conversions happen in save/load. *)
50
+
type build_meta_wire = {
20
51
package : string;
52
+
kind : string; [@default "build"]
21
53
exit_status : int;
22
54
deps : string list;
23
55
hashes : string list;
···
33
65
created_at : string;
34
66
} [@@deriving yojson]
35
67
36
-
type doc_meta = {
68
+
type build_meta = {
37
69
package : string;
38
-
status : string;
39
-
build_hash : string;
40
-
universe : string;
41
-
blessed : bool;
70
+
kind : kind;
71
+
exit_status : int;
72
+
deps : string list;
73
+
hashes : string list;
74
+
uid : int;
75
+
gid : int;
76
+
base_hash : string;
77
+
installed_libs : string list;
78
+
installed_docs : string list;
79
+
patches : string list;
80
+
failed_dep : string option;
81
+
disk_usage : int;
82
+
timing : timing;
42
83
created_at : string;
43
-
} [@@deriving yojson]
84
+
}
85
+
86
+
let wire_of_meta (m : build_meta) : build_meta_wire =
87
+
{ package = m.package; kind = string_of_kind m.kind;
88
+
exit_status = m.exit_status; deps = m.deps; hashes = m.hashes;
89
+
uid = m.uid; gid = m.gid; base_hash = m.base_hash;
90
+
installed_libs = m.installed_libs; installed_docs = m.installed_docs;
91
+
patches = m.patches; failed_dep = m.failed_dep;
92
+
disk_usage = m.disk_usage; timing = m.timing;
93
+
created_at = m.created_at }
44
94
45
-
type jtw_meta = {
46
-
package : string;
47
-
status : string;
48
-
build_hash : string;
49
-
created_at : string;
50
-
} [@@deriving yojson]
95
+
let meta_of_wire (w : build_meta_wire) : build_meta =
96
+
{ package = w.package; kind = kind_of_string w.kind;
97
+
exit_status = w.exit_status; deps = w.deps; hashes = w.hashes;
98
+
uid = w.uid; gid = w.gid; base_hash = w.base_hash;
99
+
installed_libs = w.installed_libs; installed_docs = w.installed_docs;
100
+
patches = w.patches; failed_dep = w.failed_dep;
101
+
disk_usage = w.disk_usage; timing = w.timing;
102
+
created_at = w.created_at }
103
+
104
+
(* ── (de)serialization plumbing ───────────────────────────────── *)
51
105
52
106
let now_iso8601 () =
53
107
let t = Unix.gettimeofday () in
···
68
122
with exn ->
69
123
Rresult.R.error_msgf "load %a: %s" Fpath.pp path (Printexc.to_string exn)
70
124
71
-
let save_build path meta =
72
-
save_json path (build_meta_to_yojson meta)
125
+
let save_build ?created_at path meta =
126
+
let created_at = match created_at with
127
+
| Some s -> s
128
+
| None ->
129
+
if meta.created_at = "" then now_iso8601 () else meta.created_at
130
+
in
131
+
let meta = { meta with created_at } in
132
+
save_json path (build_meta_wire_to_yojson (wire_of_meta meta))
73
133
74
134
let load_build path =
75
135
match load_json path with
76
136
| Error _ as e -> e
77
137
| Ok json ->
78
-
match build_meta_of_yojson json with
79
-
| Ok v -> Ok v
138
+
match build_meta_wire_of_yojson json with
139
+
| Ok w -> Ok (meta_of_wire w)
80
140
| Error msg -> Rresult.R.error_msgf "load_build %a: %s" Fpath.pp path msg
81
-
82
-
let save_doc path meta =
83
-
save_json path (doc_meta_to_yojson meta)
84
-
85
-
let load_doc path =
86
-
match load_json path with
87
-
| Error _ as e -> e
88
-
| Ok json ->
89
-
match doc_meta_of_yojson json with
90
-
| Ok v -> Ok v
91
-
| Error msg -> Rresult.R.error_msgf "load_doc %a: %s" Fpath.pp path msg
92
-
93
-
let save_jtw path meta =
94
-
save_json path (jtw_meta_to_yojson meta)
95
-
96
-
let load_jtw path =
97
-
match load_json path with
98
-
| Error _ as e -> e
99
-
| Ok json ->
100
-
match jtw_meta_of_yojson json with
101
-
| Ok v -> Ok v
102
-
| Error msg -> Rresult.R.error_msgf "load_jtw %a: %s" Fpath.pp path msg
103
141
104
142
let load_build_tree ~os_dir hash =
105
143
let cache : (string, Layer_type.build) Hashtbl.t = Hashtbl.create 16 in
+49
-38
day11/layer/layer_meta.mli
+49
-38
day11/layer/layer_meta.mli
···
1
1
(** Layer metadata types with JSON serialization.
2
2
3
-
Each layer type has its own metadata record. Serialization
4
-
is derived via [ppx_deriving_yojson]. *)
3
+
Each layer has a [layer.json] file containing a {!build_meta}
4
+
record. Readers use {!load_build}; writers use {!save_build}.
5
+
Round-trip is via an internal wire record so that the public
6
+
type can use typed variants (e.g. {!kind}) while the on-disk
7
+
format stays as plain JSON.
5
8
6
-
type timing = {
7
-
merge : float; (** hardlink dep layers into lower dir *)
8
-
dump_state : float; (** write switch-state from packages dirs *)
9
-
chown : float; (** fix overlay upper permissions *)
10
-
overlay_mount : float; (** mount overlayfs *)
11
-
runc_run : float; (** actual container execution *)
12
-
overlay_umount : float;(** unmount overlayfs *)
13
-
cleanup : float; (** remove temp dirs *)
14
-
extract : float; (** move upper to layer, scan files *)
15
-
total : float; (** wall clock for the whole build *)
16
-
} [@@deriving yojson]
9
+
LRU access bookkeeping is deliberately split off into
10
+
{!Last_used} so that marking a layer as used doesn't require
11
+
rewriting its JSON. *)
12
+
13
+
(** {2 Layer kind} *)
14
+
15
+
type kind =
16
+
| Build (** Package build output (upper of a container build) *)
17
+
| Compile (** odoc compile phase *)
18
+
| Link (** odoc link phase *)
19
+
| Doc_all (** odoc compile+link+html in one shot *)
20
+
(** Layer kind. On disk, encoded as the string ["build"], ["compile"],
21
+
["link"], or ["doc-all"]. Unknown strings round-trip as {!Build}. *)
22
+
23
+
val string_of_kind : kind -> string
24
+
val kind_of_string : string -> kind
25
+
26
+
(** {2 Phase timing} *)
27
+
28
+
type timing = (string * float) list
29
+
(** Timing breakdown for a layer build, as an ordered list of
30
+
[(phase_name, seconds)] pairs. On disk, serialized as a JSON
31
+
object where each phase name is a key with a numeric value.
32
+
33
+
The schema is open: callers may record whatever phases they
34
+
find useful (e.g. ["merge"], ["runc_run"], ["total"]) and
35
+
readers should treat unknown phases as opaque. *)
17
36
18
37
val empty_timing : timing
38
+
(** The empty timing list. *)
39
+
40
+
val timing_field : string -> timing -> float
41
+
(** [timing_field name t] returns the value for phase [name] in [t],
42
+
or [0.0] if absent. Convenience for readers that want a specific
43
+
well-known phase. *)
44
+
45
+
(** {2 Build metadata record} *)
19
46
20
47
type build_meta = {
21
48
package : string;
49
+
kind : kind;
22
50
exit_status : int;
23
51
deps : string list;
24
52
hashes : string list;
···
32
60
disk_usage : int;
33
61
timing : timing;
34
62
created_at : string;
35
-
} [@@deriving yojson]
63
+
}
36
64
37
-
type doc_meta = {
38
-
package : string;
39
-
status : string;
40
-
build_hash : string;
41
-
universe : string;
42
-
blessed : bool;
43
-
created_at : string;
44
-
} [@@deriving yojson]
65
+
val save_build :
66
+
?created_at:string ->
67
+
Fpath.t -> build_meta -> (unit, [> Rresult.R.msg ]) result
68
+
(** [save_build path meta] writes [meta] to [path] as JSON. If
69
+
[?created_at] is supplied, it overrides [meta.created_at];
70
+
if omitted and [meta.created_at] is empty, the current time
71
+
(UTC ISO-8601) is used. *)
45
72
46
-
type jtw_meta = {
47
-
package : string;
48
-
status : string;
49
-
build_hash : string;
50
-
created_at : string;
51
-
} [@@deriving yojson]
52
-
53
-
val now_iso8601 : unit -> string
54
-
55
-
val save_build : Fpath.t -> build_meta -> (unit, [> Rresult.R.msg ]) result
56
73
val load_build : Fpath.t -> (build_meta, [> Rresult.R.msg ]) result
57
-
58
-
val save_doc : Fpath.t -> doc_meta -> (unit, [> Rresult.R.msg ]) result
59
-
val load_doc : Fpath.t -> (doc_meta, [> Rresult.R.msg ]) result
60
-
61
-
val save_jtw : Fpath.t -> jtw_meta -> (unit, [> Rresult.R.msg ]) result
62
-
val load_jtw : Fpath.t -> (jtw_meta, [> Rresult.R.msg ]) result
63
74
64
75
val load_build_tree :
65
76
os_dir:Fpath.t -> string ->
-1
day11/layer/layer_type.ml
-1
day11/layer/layer_type.ml
-1
day11/layer/layer_type.mli
-1
day11/layer/layer_type.mli
-38
day11/layer/opam_repo.ml
-38
day11/layer/opam_repo.ml
···
40
40
with exn ->
41
41
Rresult.R.error_msgf "Opam_repo.populate: %s" (Printexc.to_string exn)
42
42
43
-
let save_snapshot ~layer_dir ~pkg ~opam_repositories =
44
-
let name = OpamPackage.name_to_string pkg in
45
-
let pkg_str = OpamPackage.to_string pkg in
46
-
let rel = Fpath.(v "packages" / name / pkg_str) in
47
-
let src =
48
-
List.find_map (fun repo ->
49
-
let candidate = Fpath.(repo // rel / "opam") in
50
-
if Bos.OS.File.exists candidate |> Result.get_ok then Some candidate
51
-
else None
52
-
) opam_repositories
53
-
in
54
-
match src with
55
-
| None ->
56
-
Rresult.R.error_msgf "Opam_repo.save_snapshot: opam file not found for %s"
57
-
pkg_str
58
-
| Some src_opam ->
59
-
let dst_dir = Fpath.(layer_dir / "opam" // rel) in
60
-
let ( >>= ) = Result.bind in
61
-
Bos.OS.Dir.create ~path:true dst_dir >>= fun _created ->
62
-
Bos.OS.File.read src_opam >>= fun content ->
63
-
Bos.OS.File.write Fpath.(dst_dir / "opam") content
64
-
65
-
let find_opam_file repos pkg =
66
-
let name = OpamPackage.name_to_string pkg in
67
-
let pkg_str = OpamPackage.to_string pkg in
68
-
List.find_map (fun repo ->
69
-
let opam_path =
70
-
Fpath.(repo / "packages" / name / pkg_str / "opam")
71
-
in
72
-
let opam_s = Fpath.to_string opam_path in
73
-
if Sys.file_exists opam_s then
74
-
try
75
-
Some (OpamFilename.raw opam_s
76
-
|> OpamFile.make
77
-
|> OpamFile.OPAM.read)
78
-
with _ -> None
79
-
else None
80
-
) repos
-14
day11/layer/opam_repo.mli
-14
day11/layer/opam_repo.mli
···
21
21
[opam_repo]. Packages not found in any repository are silently
22
22
skipped. *)
23
23
24
-
val save_snapshot :
25
-
layer_dir:Fpath.t ->
26
-
pkg:OpamPackage.t ->
27
-
opam_repositories:Fpath.t list ->
28
-
(unit, [> Rresult.R.msg ]) result
29
-
(** [save_snapshot ~layer_dir ~pkg ~opam_repositories] copies the opam
30
-
file for [pkg] into [layer_dir/opam/packages/name/name.version/opam]
31
-
so the layer can be rebuilt without the original repository. *)
32
-
33
-
val find_opam_file :
34
-
Fpath.t list -> OpamPackage.t -> OpamFile.OPAM.t option
35
-
(** [find_opam_file repos pkg] searches [repos] in order for [pkg]'s
36
-
opam file, parses it, and returns [Some opam]. Returns [None] if
37
-
not found. *)
-15
day11/layer/package_symlinks.ml
-15
day11/layer/package_symlinks.ml
···
14
14
with exn ->
15
15
Rresult.R.error_msgf "ensure_layer_symlink %s/%s: %s"
16
16
pkg_str layer_name (Printexc.to_string exn)
17
-
18
-
let ensure_blessed_symlink ~packages_dir ~pkg_str ~name ~layer_name =
19
-
let pkg_dir = Fpath.(packages_dir / pkg_str) in
20
-
let symlink_path = Fpath.(pkg_dir / name) in
21
-
let target = Filename.concat ".." (Filename.concat ".." layer_name) in
22
-
try
23
-
Bos.OS.Dir.create ~path:true pkg_dir |> ignore;
24
-
(try Unix.unlink (Fpath.to_string symlink_path)
25
-
with Unix.Unix_error (Unix.ENOENT, _, _) -> ());
26
-
(try Unix.symlink target (Fpath.to_string symlink_path)
27
-
with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
28
-
Ok ()
29
-
with exn ->
30
-
Rresult.R.error_msgf "ensure_blessed_symlink %s/%s: %s"
31
-
pkg_str name (Printexc.to_string exn)
-11
day11/layer/package_symlinks.mli
-11
day11/layer/package_symlinks.mli
···
13
13
a symlink at [packages_dir/pkg_str/layer_name] pointing to
14
14
[../../layer_name]. Creates the package directory if needed.
15
15
Idempotent — silently succeeds if the symlink already exists. *)
16
-
17
-
val ensure_blessed_symlink :
18
-
packages_dir:Fpath.t ->
19
-
pkg_str:string ->
20
-
name:string ->
21
-
layer_name:string ->
22
-
(unit, [> Rresult.R.msg ]) result
23
-
(** [ensure_blessed_symlink ~packages_dir ~pkg_str ~name ~layer_name]
24
-
creates or updates a symlink called [name] (e.g. ["blessed-build"],
25
-
["blessed-docs"]) at [packages_dir/pkg_str/] pointing to
26
-
[../../layer_name]. The caller determines the symlink name. *)
-19
day11/layer/query.ml
-19
day11/layer/query.ml
···
1
-
let log_path layer_dir =
2
-
let path = Fpath.(layer_dir / "layer.log") in
3
-
if Bos.OS.File.exists path |> Result.get_ok then Some path
4
-
else None
5
-
6
-
let created_at layer_dir =
7
-
let path = Fpath.(layer_dir / "layer.json") in
8
-
match Layer_info.load path with
9
-
| Error _ -> None
10
-
| Ok json ->
11
-
try
12
-
Some Yojson.Safe.Util.(json |> member "created_at" |> to_string)
13
-
with _ -> None
14
-
15
-
let metadata layer_dir =
16
-
let path = Fpath.(layer_dir / "layer.json") in
17
-
match Layer_info.load path with
18
-
| Ok json -> Some json
19
-
| Error _ -> None
-18
day11/layer/query.mli
-18
day11/layer/query.mli
···
1
-
(** Layer inspection utilities.
2
-
3
-
Read-only queries against layer directories. All functions return
4
-
[None] if the layer or its metadata doesn't exist. *)
5
-
6
-
val log_path : Fpath.t -> Fpath.t option
7
-
(** [log_path layer_dir] returns the path to [layer_dir/layer.log]
8
-
if it exists. All layer types use the same log filename. *)
9
-
10
-
val created_at : Fpath.t -> string option
11
-
(** [created_at layer_dir] returns the [created_at] timestamp string
12
-
from [layer_dir/layer.json], or [None] if the layer or field
13
-
doesn't exist. *)
14
-
15
-
val metadata : Fpath.t -> Yojson.Safe.t option
16
-
(** [metadata layer_dir] reads and returns the parsed
17
-
[layer_dir/layer.json], or [None] if it doesn't exist or can't
18
-
be parsed. *)
-18
day11/layer/scan.ml
-18
day11/layer/scan.ml
···
12
12
with _ -> []
13
13
else []
14
14
15
-
let list_layers_matching ~prefix dir =
16
-
list_layers dir
17
-
|> List.filter (fun (name, _) ->
18
-
String.length name >= String.length prefix
19
-
&& String.sub name 0 (String.length prefix) = prefix)
20
-
21
-
let list_packages packages_dir =
22
-
list_layers packages_dir |> List.map fst
23
-
24
15
let list_package_symlinks ?(exclude = []) packages_dir pkg_str =
25
16
let pkg_dir = Fpath.(packages_dir / pkg_str) in
26
17
let pkg_dir_s = Fpath.to_string pkg_dir in
···
42
33
with _ -> []
43
34
else []
44
35
45
-
let read_symlink packages_dir pkg_str name =
46
-
let path = Fpath.(packages_dir / pkg_str / name) in
47
-
let path_s = Fpath.to_string path in
48
-
try
49
-
let stat = Unix.lstat path_s in
50
-
if stat.Unix.st_kind = Unix.S_LNK then
51
-
Some (Unix.readlink path_s)
52
-
else None
53
-
with Unix.Unix_error _ -> None
-19
day11/layer/scan.mli
-19
day11/layer/scan.mli
···
11
11
subdirectories under [dir]. Returns [[]] if the directory
12
12
doesn't exist or can't be read. *)
13
13
14
-
val list_layers_matching :
15
-
prefix:string -> Fpath.t -> (string * Fpath.t) list
16
-
(** [list_layers_matching ~prefix dir] returns only subdirectories
17
-
whose names start with [prefix]. *)
18
-
19
-
(** {2 Package enumeration} *)
20
-
21
-
val list_packages : Fpath.t -> string list
22
-
(** [list_packages packages_dir] returns the names of all
23
-
subdirectories under [packages_dir]. Returns [[]] if the
24
-
directory doesn't exist. *)
25
-
26
14
val list_package_symlinks :
27
15
?exclude:string list ->
28
16
Fpath.t ->
···
33
21
[packages_dir/pkg_str/]. [exclude] is an optional list of
34
22
symlink names to skip (e.g. [["blessed-build"; "blessed-docs"]]). *)
35
23
36
-
val read_symlink :
37
-
Fpath.t -> string -> string -> string option
38
-
(** [read_symlink packages_dir pkg_str name] reads the target of
39
-
symlink [name] in [packages_dir/pkg_str/]. Returns [None] if the
40
-
symlink doesn't exist. The returned target is the raw symlink
41
-
value (e.g. ["../../build-abc"]); use {!Filename.basename} to
42
-
extract the layer name. *)
+23
day11/layer/stack.ml
+23
day11/layer/stack.ml
···
1
1
let src_log = Logs.Src.create "day11.layer.stack" ~doc:"Layer stacking"
2
2
module Log = (val Logs.src_log src_log)
3
3
4
+
let plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs =
5
+
let total_cost =
6
+
List.fold_left (fun acc d -> acc + entry_cost d) 0 layer_dirs
7
+
in
8
+
(* Fast path: every layer fits as its own lowerdir, no merge needed. *)
9
+
if total_cost <= available then (layer_dirs, [])
10
+
else begin
11
+
(* Walk the list taking layers for the separate bucket as long
12
+
as we stay within (available - merged_overhead). Once we'd
13
+
overflow, the rest of the list goes to the merged bucket. *)
14
+
let target = available - merged_overhead in
15
+
let rec aux acc_cost kept = function
16
+
| [] -> (List.rev kept, [])
17
+
| d :: rest ->
18
+
let c = entry_cost d in
19
+
if acc_cost + c <= target then
20
+
aux (acc_cost + c) (d :: kept) rest
21
+
else
22
+
(List.rev kept, d :: rest)
23
+
in
24
+
aux 0 [] layer_dirs
25
+
end
26
+
4
27
let merge env ~layer_dirs ~target =
5
28
(* Collect all layer fs/ dirs that exist *)
6
29
let fs_dirs = List.filter_map (fun layer_dir ->
+29
day11/layer/stack.mli
+29
day11/layer/stack.mli
···
19
19
20
20
Returns [Error] if any copy fails (e.g. a layer dir doesn't
21
21
exist). *)
22
+
23
+
val plan_lowerdir :
24
+
available:int ->
25
+
merged_overhead:int ->
26
+
entry_cost:(Fpath.t -> int) ->
27
+
Fpath.t list ->
28
+
Fpath.t list * Fpath.t list
29
+
(** [plan_lowerdir ~available ~merged_overhead ~entry_cost layer_dirs]
30
+
decides which layers to pass as separate overlayfs lowerdirs and
31
+
which to cp-merge into a single shared dir, so that the resulting
32
+
mount options string fits in the caller's byte budget.
33
+
34
+
Returns [(separate, to_merge)]. The fast path (when all layers
35
+
fit) returns [(layer_dirs, [])] with no merging needed. When
36
+
some must be merged, as many as possible are kept separate
37
+
(taken from the front of the list).
38
+
39
+
Parameters:
40
+
- [available]: the byte budget for the dep-entry portion of the
41
+
mount options string. The caller is responsible for subtracting
42
+
fixed overhead (keyword, separators, base/fs entry, upperdir,
43
+
workdir) before passing this value.
44
+
- [merged_overhead]: extra bytes added to the cost when at least
45
+
one layer must be merged (typically the length of the
46
+
merged-lower path plus its leading colon separator).
47
+
- [entry_cost]: function returning how many bytes a single
48
+
separate-lowerdir entry contributes (typically
49
+
[String.length (Fpath.to_string (dir / "fs")) + 1] for the
50
+
colon). *)
+93
-210
day11/layer/test/test_layer.ml
+93
-210
day11/layer/test/test_layer.ml
···
7
7
8
8
let is_ok msg r = ok_or_fail msg r |> ignore
9
9
10
-
let is_error _msg = function
11
-
| Error _ -> ()
12
-
| Ok _ -> Alcotest.fail "expected Error, got Ok"
13
-
14
-
let pkg s = OpamPackage.of_string s
15
10
let pkg_list ss = List.map OpamPackage.of_string ss
16
11
17
-
(* ── Layer_info tests ────────────────────────────────────────────── *)
18
-
19
-
let test_layer_info_roundtrip () = with_tmp_dir @@ fun dir ->
20
-
let path = Fpath.(dir / "layer.json") in
21
-
Layer_info.save path ~pkg:"yojson.2.2.2"
22
-
~deps:[ "dune.3.0"; "cppo.1.6" ]
23
-
~hashes:[ "abc123"; "def456" ] ~exit_status:0
24
-
~uid:1000 ~gid:1000 ~base_hash:"test"
25
-
|> is_ok "save";
26
-
let rc = Layer_info.load_exit_status path |> ok_or_fail "exit_status" in
27
-
Alcotest.(check int) "exit_status" 0 rc;
28
-
let name = Layer_info.load_package_name path |> ok_or_fail "package_name" in
29
-
Alcotest.(check string) "package_name" "yojson.2.2.2" name
30
-
31
-
let test_layer_info_with_installed () = with_tmp_dir @@ fun dir ->
32
-
let path = Fpath.(dir / "layer.json") in
33
-
Layer_info.save
34
-
~installed_libs:[ "yojson/yojson.cmi"; "yojson/META" ]
35
-
~installed_docs:[ "yojson/index.mld" ]
36
-
path ~pkg:"yojson.2.2.2" ~deps:[] ~hashes:[] ~exit_status:0
37
-
~uid:1000 ~gid:1000 ~base_hash:"test"
38
-
|> is_ok "save";
39
-
let libs = Layer_info.load_installed_libs path |> ok_or_fail "libs" in
40
-
Alcotest.(check (list string)) "installed_libs"
41
-
[ "yojson/yojson.cmi"; "yojson/META" ] libs;
42
-
let docs = Layer_info.load_installed_docs path |> ok_or_fail "docs" in
43
-
Alcotest.(check (list string)) "installed_docs"
44
-
[ "yojson/index.mld" ] docs
45
-
46
-
let test_layer_info_missing_optional_fields () = with_tmp_dir @@ fun dir ->
47
-
let path = Fpath.(dir / "layer.json") in
48
-
Layer_info.save path ~pkg:"x.1" ~deps:[] ~hashes:[] ~exit_status:0
49
-
~uid:1000 ~gid:1000 ~base_hash:"test"
50
-
|> is_ok "save";
51
-
let libs = Layer_info.load_installed_libs path |> ok_or_fail "libs" in
52
-
Alcotest.(check (list string)) "no libs" [] libs;
53
-
let docs = Layer_info.load_installed_docs path |> ok_or_fail "docs" in
54
-
Alcotest.(check (list string)) "no docs" [] docs
55
-
56
-
let test_layer_info_extra_fields () = with_tmp_dir @@ fun dir ->
57
-
let path = Fpath.(dir / "layer.json") in
58
-
let doc_result =
59
-
`Assoc [ ("status", `String "success");
60
-
("html_path", `String "/p/yojson/2.2.2") ]
61
-
in
62
-
Layer_info.save
63
-
~extra:[ ("build_hash", `String "abc123");
64
-
("dep_doc_hashes", `List [ `String "h1"; `String "h2" ]);
65
-
("doc", doc_result) ]
66
-
path ~pkg:"yojson.2.2.2" ~deps:[] ~hashes:[] ~exit_status:0
67
-
~uid:1000 ~gid:1000 ~base_hash:"test"
68
-
|> is_ok "save";
69
-
(* Load raw JSON and extract extra fields *)
70
-
let json = Layer_info.load path |> ok_or_fail "load" in
71
-
let open Yojson.Safe.Util in
72
-
let bh = json |> member "build_hash" |> to_string in
73
-
Alcotest.(check string) "build_hash" "abc123" bh;
74
-
let ddh = json |> member "dep_doc_hashes" |> to_list |> List.map to_string in
75
-
Alcotest.(check (list string)) "dep_doc_hashes" [ "h1"; "h2" ] ddh;
76
-
let status = json |> member "doc" |> member "status" |> to_string in
77
-
Alcotest.(check string) "doc status" "success" status
78
-
79
-
let test_layer_info_load_raw () = with_tmp_dir @@ fun dir ->
80
-
let path = Fpath.(dir / "layer.json") in
81
-
Layer_info.save path ~pkg:"x.1" ~deps:[] ~hashes:[] ~exit_status:42
82
-
~uid:1000 ~gid:1000 ~base_hash:"test"
83
-
|> is_ok "save";
84
-
let json = Layer_info.load path |> ok_or_fail "load" in
85
-
let open Yojson.Safe.Util in
86
-
let rc = json |> member "exit_status" |> to_int in
87
-
Alcotest.(check int) "exit_status via load" 42 rc
88
-
89
-
let test_layer_info_missing_file () =
90
-
is_error "missing" (Layer_info.load_exit_status (Fpath.v "/nonexistent/layer.json"));
91
-
is_error "missing" (Layer_info.load (Fpath.v "/nonexistent/layer.json"))
12
+
(* ── Layer_meta tests ────────────────────────────────────────────── *)
92
13
93
-
let test_layer_info_corrupt_json () = with_tmp_dir @@ fun dir ->
94
-
let path = Fpath.(dir / "layer.json") in
95
-
write_file path "{broken";
96
-
is_error "corrupt" (Layer_info.load_exit_status path);
97
-
is_error "corrupt" (Layer_info.load_package_name path);
98
-
is_error "corrupt" (Layer_info.load path)
99
-
100
-
let test_layer_info_empty_file () = with_tmp_dir @@ fun dir ->
101
-
let path = Fpath.(dir / "layer.json") in
102
-
write_file path "";
103
-
is_error "empty" (Layer_info.load_exit_status path)
104
-
105
-
let test_layer_info_skeleton () = with_tmp_dir @@ fun dir ->
14
+
let test_layer_meta_roundtrip () = with_tmp_dir @@ fun dir ->
106
15
let path = Fpath.(dir / "layer.json") in
107
16
let meta : Layer_meta.build_meta = {
108
-
package = "broken.1.0"; exit_status = -1;
17
+
package = "broken.1.0"; kind = Layer_meta.Build; exit_status = -1;
109
18
deps = ["ocaml.5.4.1"]; hashes = ["build-abc123"];
110
19
uid = 1000; gid = 1000; base_hash = "test";
111
20
installed_libs = []; installed_docs = []; patches = []; failed_dep = None;
112
21
disk_usage = 0; timing = Layer_meta.empty_timing;
113
22
created_at = "2024-01-01T00:00:00Z";
114
23
} in
115
-
Layer_meta.save_build path meta |> is_ok "skeleton";
24
+
Layer_meta.save_build path meta |> is_ok "save";
116
25
let m = Layer_meta.load_build path |> ok_or_fail "load" in
117
26
Alcotest.(check int) "exit_status" (-1) m.exit_status;
118
-
Alcotest.(check string) "package" "broken.1.0" m.package
27
+
Alcotest.(check string) "package" "broken.1.0" m.package;
28
+
Alcotest.(check bool) "kind" true (m.kind = Layer_meta.Build)
119
29
120
30
(* ── Package_symlinks tests ──────────────────────────────────────── *)
121
31
···
140
50
~packages_dir ~pkg_str:"yojson.2.2.2" ~layer_name:"build-abc123"
141
51
|> is_ok "second"
142
52
143
-
let test_blessed_symlink () = with_tmp_dir @@ fun dir ->
144
-
let packages_dir = Fpath.(dir / "packages") in
145
-
Package_symlinks.ensure_blessed_symlink
146
-
~packages_dir ~pkg_str:"yojson.2.2.2" ~name:"blessed-build"
147
-
~layer_name:"build-abc123"
148
-
|> is_ok "create";
149
-
let link = Fpath.(packages_dir / "yojson.2.2.2" / "blessed-build") in
150
-
Alcotest.(check bool) "blessed-build exists" true (symlink_exists link);
151
-
(* Update to different layer *)
152
-
Package_symlinks.ensure_blessed_symlink
153
-
~packages_dir ~pkg_str:"yojson.2.2.2" ~name:"blessed-build"
154
-
~layer_name:"build-def456"
155
-
|> is_ok "update"
156
-
157
53
(* ── Installed_files tests ───────────────────────────────────────── *)
158
54
159
55
let test_scan_libs () = with_tmp_dir @@ fun dir ->
···
210
106
Alcotest.(check bool) "opam file copied"
211
107
true (Bos.OS.File.exists copied |> Result.get_ok)
212
108
213
-
let test_opam_repo_find_opam_file () = with_tmp_dir @@ fun dir ->
214
-
let repo = Fpath.(dir / "repo") in
215
-
let pkg_dir = Fpath.(repo / "packages" / "yojson" / "yojson.2.2.2") in
216
-
mkdir pkg_dir;
217
-
write_file Fpath.(pkg_dir / "opam") {|opam-version: "2.0"
218
-
name: "yojson"
219
-
version: "2.2.2"|};
220
-
let result = Opam_repo.find_opam_file [ repo ] (pkg "yojson.2.2.2") in
221
-
Alcotest.(check bool) "found" true (Option.is_some result)
222
-
223
-
let test_opam_repo_find_missing () = with_tmp_dir @@ fun dir ->
224
-
let result = Opam_repo.find_opam_file [ dir ] (pkg "nonexistent.1.0") in
225
-
Alcotest.(check bool) "not found" true (Option.is_none result)
226
-
227
109
(* ── Skeleton (inline) tests ──────────────────────────────────────── *)
228
110
229
111
let write_skeleton ~layer_dir meta =
···
233
115
let test_skeleton_write () = with_tmp_dir @@ fun dir ->
234
116
let layer_dir = Fpath.(dir / "build-deadbeef") in
235
117
let meta : Layer_meta.build_meta = {
236
-
package = "yojson.2.2.2"; exit_status = -1;
118
+
package = "yojson.2.2.2"; kind = Layer_meta.Build; exit_status = -1;
237
119
deps = ["dune.3.0"]; hashes = ["hash1"];
238
120
uid = 1000; gid = 1000; base_hash = "test";
239
121
installed_libs = []; installed_docs = []; patches = []; failed_dep = None;
···
245
127
| Ok m -> Alcotest.(check int) "exit_status" (-1) m.exit_status
246
128
| Error (`Msg e) -> Alcotest.fail e
247
129
248
-
(* ── Query tests ─────────────────────────────────────────────────── *)
249
-
250
-
let test_query_log_path () = with_tmp_dir @@ fun dir ->
251
-
mkdir dir;
252
-
write_file Fpath.(dir / "layer.log") "log content";
253
-
let result = Query.log_path dir in
254
-
Alcotest.(check bool) "found" true (Option.is_some result)
255
-
256
-
let test_query_created_at () = with_tmp_dir @@ fun dir ->
257
-
mkdir dir;
258
-
write_file Fpath.(dir / "layer.json")
259
-
{|{"created_at": "2024-01-15 10:30:00", "package": "x.1", "exit_status": 0}|};
260
-
let result = Query.created_at dir in
261
-
Alcotest.(check (option string)) "created_at"
262
-
(Some "2024-01-15 10:30:00") result
263
-
264
-
let test_query_metadata () = with_tmp_dir @@ fun dir ->
265
-
mkdir dir;
266
-
write_file Fpath.(dir / "layer.json")
267
-
{|{"package": "x.1", "exit_status": 0}|};
268
-
let result = Query.metadata dir in
269
-
Alcotest.(check bool) "found" true (Option.is_some result)
270
-
271
-
let test_query_missing_layer () = with_tmp_dir @@ fun dir ->
272
-
Alcotest.(check (option string)) "no layer"
273
-
None (Query.created_at Fpath.(dir / "nonexistent"));
274
-
Alcotest.(check bool) "no metadata"
275
-
true (Option.is_none (Query.metadata Fpath.(dir / "nonexistent")))
276
-
277
130
(* ── Scan tests ──────────────────────────────────────────────────── *)
278
131
279
132
let test_list_layers () = with_tmp_dir @@ fun dir ->
···
291
144
true (List.mem "packages" names);
292
145
Alcotest.(check bool) "no file"
293
146
false (List.mem "somefile" names)
294
-
295
-
let test_list_layers_matching () = with_tmp_dir @@ fun dir ->
296
-
mkdir Fpath.(dir / "build-aaa");
297
-
mkdir Fpath.(dir / "build-bbb");
298
-
mkdir Fpath.(dir / "doc-ccc");
299
-
mkdir Fpath.(dir / "packages");
300
-
let builds = Scan.list_layers_matching ~prefix:"build-" dir in
301
-
Alcotest.(check int) "2 builds" 2 (List.length builds);
302
-
let docs = Scan.list_layers_matching ~prefix:"doc-" dir in
303
-
Alcotest.(check int) "1 doc" 1 (List.length docs)
304
147
305
148
let test_list_layers_empty () = with_tmp_dir @@ fun dir ->
306
149
let layers = Scan.list_layers Fpath.(dir / "nonexistent") in
307
150
Alcotest.(check (list string)) "empty" [] (List.map fst layers)
308
151
309
-
let test_list_packages () = with_tmp_dir @@ fun dir ->
310
-
mkdir Fpath.(dir / "yojson.2.2.2");
311
-
mkdir Fpath.(dir / "dune.3.0");
312
-
write_file Fpath.(dir / "somefile") "not a dir";
313
-
let pkgs = Scan.list_packages dir in
314
-
Alcotest.(check bool) "has yojson"
315
-
true (List.mem "yojson.2.2.2" pkgs);
316
-
Alcotest.(check bool) "has dune"
317
-
true (List.mem "dune.3.0" pkgs);
318
-
Alcotest.(check bool) "no file"
319
-
false (List.mem "somefile" pkgs)
320
-
321
152
let test_list_package_symlinks () = with_tmp_dir @@ fun dir ->
322
153
let pkg_dir = Fpath.(dir / "yojson.2.2.2") in
323
154
mkdir pkg_dir;
···
339
170
Alcotest.(check bool) "no blessed"
340
171
false (List.mem "blessed-build" names)
341
172
342
-
let test_read_symlink () = with_tmp_dir @@ fun dir ->
343
-
let pkg_dir = Fpath.(dir / "yojson.2.2.2") in
344
-
mkdir pkg_dir;
345
-
Unix.symlink "../../build-abc" (Fpath.to_string Fpath.(pkg_dir / "blessed-build"));
346
-
let result = Scan.read_symlink dir "yojson.2.2.2" "blessed-build" in
347
-
Alcotest.(check (option string)) "target"
348
-
(Some "../../build-abc") result;
349
-
let missing = Scan.read_symlink dir "yojson.2.2.2" "blessed-docs" in
350
-
Alcotest.(check (option string)) "missing" None missing
351
-
352
173
(* ── Stack tests ─────────────────────────────────────────────────── *)
353
174
354
175
let test_stack_empty () = with_eio @@ fun env ->
···
407
228
let content = Bos.OS.File.read Fpath.(target / "shared.txt") |> Result.get_ok in
408
229
Alcotest.(check string) "first layer wins" "from-layer1" content
409
230
231
+
(* ── plan_lowerdir tests ─────────────────────────────────────────── *)
232
+
233
+
(** Build a long list of fake layer dirs all sharing a common prefix. *)
234
+
let fake_layers ~prefix n =
235
+
List.init n (fun i ->
236
+
Fpath.v (Printf.sprintf "%s/build-%012d" prefix i))
237
+
238
+
(** Cost helper matching what run_in_layers uses: path-to-fs-subdir
239
+
length plus one colon. *)
240
+
let entry_cost d =
241
+
String.length (Fpath.to_string Fpath.(d / "fs")) + 1
242
+
243
+
let test_plan_lowerdir_all_separate () =
244
+
(* Small dep set with short paths — everything should fit. *)
245
+
let layers = fake_layers ~prefix:"/c" 10 in
246
+
let separate, to_merge = Stack.plan_lowerdir
247
+
~available:3900 ~merged_overhead:30 ~entry_cost layers
248
+
in
249
+
Alcotest.(check int) "all kept separate" 10 (List.length separate);
250
+
Alcotest.(check int) "nothing to merge" 0 (List.length to_merge)
251
+
252
+
let test_plan_lowerdir_split () =
253
+
(* 200 fake layers with realistic-ish long paths. 200 × 63 = 12600
254
+
bytes, way over any reasonable budget — must split. *)
255
+
let prefix = "/home/jjl25/cache/debian-bookworm-x86_64" in
256
+
let layers = fake_layers ~prefix 200 in
257
+
let separate, to_merge = Stack.plan_lowerdir
258
+
~available:3900 ~merged_overhead:35 ~entry_cost layers
259
+
in
260
+
Alcotest.(check int) "total preserved" 200
261
+
(List.length separate + List.length to_merge);
262
+
Alcotest.(check bool) "did split" true (to_merge <> []);
263
+
Alcotest.(check bool) "kept some separate" true (separate <> []);
264
+
(* Check the invariant: sum of entry costs for separate + merged
265
+
overhead must be within available. *)
266
+
let sep_cost = List.fold_left (fun a d -> a + entry_cost d) 0 separate in
267
+
Alcotest.(check bool)
268
+
(Printf.sprintf "separate cost %d + merged %d ≤ available 3900"
269
+
sep_cost 35)
270
+
true (sep_cost + 35 <= 3900)
271
+
272
+
let test_plan_lowerdir_empty () =
273
+
let separate, to_merge = Stack.plan_lowerdir
274
+
~available:3900 ~merged_overhead:30 ~entry_cost []
275
+
in
276
+
Alcotest.(check int) "separate" 0 (List.length separate);
277
+
Alcotest.(check int) "to_merge" 0 (List.length to_merge)
278
+
279
+
let test_plan_lowerdir_short_paths_no_split () =
280
+
(* With short /c paths and the usual budget, 150 deps fit. *)
281
+
let layers = fake_layers ~prefix:"/c" 150 in
282
+
let separate, to_merge = Stack.plan_lowerdir
283
+
~available:3900 ~merged_overhead:30 ~entry_cost layers
284
+
in
285
+
Alcotest.(check int) "all separate" 150 (List.length separate);
286
+
Alcotest.(check int) "no merge" 0 (List.length to_merge)
287
+
288
+
let test_plan_lowerdir_boundary () =
289
+
(* Exactly at the boundary: N entries × cost = available. Everything
290
+
should still fit (no merge) since the check is ≤, not <. *)
291
+
let layers = fake_layers ~prefix:"/c" 5 in
292
+
let per = entry_cost (List.hd layers) in (* 19 or so *)
293
+
let separate, to_merge = Stack.plan_lowerdir
294
+
~available:(5 * per) ~merged_overhead:1 ~entry_cost layers
295
+
in
296
+
Alcotest.(check int) "all fit at boundary" 5 (List.length separate);
297
+
Alcotest.(check int) "no merge" 0 (List.length to_merge);
298
+
(* One byte less: can't fit the last one. *)
299
+
let separate, to_merge = Stack.plan_lowerdir
300
+
~available:(5 * per - 1) ~merged_overhead:0 ~entry_cost layers
301
+
in
302
+
Alcotest.(check int) "one short" 4 (List.length separate);
303
+
Alcotest.(check int) "one merged" 1 (List.length to_merge)
304
+
410
305
(* ── Opamh tests ─────────────────────────────────────────────────── *)
411
306
412
307
let test_compiler_packages () =
···
421
316
let () =
422
317
Alcotest.run "day11_layer"
423
318
[
424
-
( "Layer_info",
319
+
( "Layer_meta",
425
320
[
426
-
Alcotest.test_case "roundtrip" `Quick test_layer_info_roundtrip;
427
-
Alcotest.test_case "with installed" `Quick test_layer_info_with_installed;
428
-
Alcotest.test_case "missing optional fields" `Quick
429
-
test_layer_info_missing_optional_fields;
430
-
Alcotest.test_case "extra fields" `Quick test_layer_info_extra_fields;
431
-
Alcotest.test_case "load raw" `Quick test_layer_info_load_raw;
432
-
Alcotest.test_case "missing file" `Quick test_layer_info_missing_file;
433
-
Alcotest.test_case "corrupt JSON" `Quick test_layer_info_corrupt_json;
434
-
Alcotest.test_case "empty file" `Quick test_layer_info_empty_file;
435
-
Alcotest.test_case "skeleton" `Quick test_layer_info_skeleton;
321
+
Alcotest.test_case "roundtrip" `Quick test_layer_meta_roundtrip;
436
322
] );
437
323
( "Package_symlinks",
438
324
[
439
325
Alcotest.test_case "create" `Quick test_symlink_create;
440
326
Alcotest.test_case "idempotent" `Quick test_symlink_idempotent;
441
-
Alcotest.test_case "blessed" `Quick test_blessed_symlink;
442
327
] );
443
328
( "Installed_files",
444
329
[
···
450
335
[
451
336
Alcotest.test_case "create" `Quick test_opam_repo_create;
452
337
Alcotest.test_case "populate" `Quick test_opam_repo_populate;
453
-
Alcotest.test_case "find_opam_file" `Quick test_opam_repo_find_opam_file;
454
-
Alcotest.test_case "find missing" `Quick test_opam_repo_find_missing;
455
338
] );
456
339
( "Skeleton",
457
340
[
458
341
Alcotest.test_case "write" `Quick test_skeleton_write;
459
342
] );
460
-
( "Query",
461
-
[
462
-
Alcotest.test_case "log_path" `Quick test_query_log_path;
463
-
Alcotest.test_case "created_at" `Quick test_query_created_at;
464
-
Alcotest.test_case "metadata" `Quick test_query_metadata;
465
-
Alcotest.test_case "missing layer" `Quick test_query_missing_layer;
466
-
] );
467
343
( "Scan",
468
344
[
469
345
Alcotest.test_case "list_layers" `Quick test_list_layers;
470
-
Alcotest.test_case "list_layers_matching" `Quick test_list_layers_matching;
471
346
Alcotest.test_case "list_layers empty" `Quick test_list_layers_empty;
472
-
Alcotest.test_case "list_packages" `Quick test_list_packages;
473
347
Alcotest.test_case "list_package_symlinks" `Quick test_list_package_symlinks;
474
-
Alcotest.test_case "read_symlink" `Quick test_read_symlink;
475
348
] );
476
349
( "Stack",
477
350
[
···
481
354
Alcotest.test_case "single layer" `Quick test_stack_single_layer;
482
355
Alcotest.test_case "multiple layers" `Quick
483
356
test_stack_multiple_layers;
357
+
Alcotest.test_case "plan_lowerdir all separate" `Quick
358
+
test_plan_lowerdir_all_separate;
359
+
Alcotest.test_case "plan_lowerdir split" `Quick
360
+
test_plan_lowerdir_split;
361
+
Alcotest.test_case "plan_lowerdir empty" `Quick
362
+
test_plan_lowerdir_empty;
363
+
Alcotest.test_case "plan_lowerdir short paths" `Quick
364
+
test_plan_lowerdir_short_paths_no_split;
365
+
Alcotest.test_case "plan_lowerdir boundary" `Quick
366
+
test_plan_lowerdir_boundary;
484
367
] );
485
368
( "Opamh",
486
369
[
+90
day11/opam/deps.ml
+90
day11/opam/deps.ml
···
1
+
let get_extra_doc_deps opamfile =
2
+
let open OpamParserTypes.FullPos in
3
+
let extensions = OpamFile.OPAM.extensions opamfile in
4
+
match OpamStd.String.Map.find_opt "x-extra-doc-deps" extensions with
5
+
| None -> OpamPackage.Name.Set.empty
6
+
| Some value ->
7
+
let extract_name item =
8
+
match item.pelem with
9
+
| String name -> Some name
10
+
| Option (inner, _) ->
11
+
(match inner.pelem with
12
+
| String name -> Some name
13
+
| _ -> None)
14
+
| _ -> None
15
+
in
16
+
let extract_names acc v =
17
+
match v.pelem with
18
+
| List { pelem = items; _ } ->
19
+
List.fold_left (fun acc item ->
20
+
match extract_name item with
21
+
| Some name ->
22
+
OpamPackage.Name.Set.add
23
+
(OpamPackage.Name.of_string name) acc
24
+
| None -> acc
25
+
) acc items
26
+
| _ -> acc
27
+
in
28
+
extract_names OpamPackage.Name.Set.empty value
29
+
30
+
let predefined_depends_variables =
31
+
List.map OpamVariable.Full.of_string [
32
+
"build"; "post"; "with-test"; "with-doc"; "with-dev-setup"; "dev";
33
+
]
34
+
35
+
let recompute_with_post ~packages ~env solution =
36
+
let filter_env pkg v =
37
+
if List.mem v predefined_depends_variables then None
38
+
else match OpamVariable.Full.to_string v with
39
+
| "version" ->
40
+
Some (OpamTypes.S
41
+
(OpamPackage.Version.to_string (OpamPackage.version pkg)))
42
+
| x -> env x
43
+
in
44
+
let solved_pkgs = OpamPackage.Map.fold (fun pkg _ acc -> pkg :: acc)
45
+
solution [] in
46
+
let solved_names = List.fold_left (fun acc p ->
47
+
OpamPackage.Name.Set.add (OpamPackage.name p) acc)
48
+
OpamPackage.Name.Set.empty solved_pkgs in
49
+
List.fold_left (fun acc pkg ->
50
+
let opam =
51
+
try Git_packages.get_package packages pkg
52
+
with Not_found -> OpamFile.OPAM.empty
53
+
in
54
+
let deps =
55
+
OpamFile.OPAM.depends opam
56
+
|> OpamFilter.partial_filter_formula (filter_env pkg)
57
+
|> OpamFilter.filter_deps ~build:true ~post:true ~test:false
58
+
~doc:true ~dev:false ~dev_setup:false ~default:false
59
+
in
60
+
let dep_names =
61
+
OpamFormula.fold_left
62
+
(fun acc (dep_name, _) ->
63
+
OpamPackage.Name.Set.add dep_name acc)
64
+
OpamPackage.Name.Set.empty deps
65
+
in
66
+
let depopts = OpamFile.OPAM.depopts opam in
67
+
let depopt_names =
68
+
OpamFormula.fold_left
69
+
(fun acc (dep_name, _) ->
70
+
if OpamPackage.Name.Set.mem dep_name solved_names
71
+
then OpamPackage.Name.Set.add dep_name acc
72
+
else acc)
73
+
OpamPackage.Name.Set.empty depopts
74
+
in
75
+
let extra_doc_deps = get_extra_doc_deps opam in
76
+
let extra_doc_dep_names =
77
+
OpamPackage.Name.Set.inter extra_doc_deps solved_names
78
+
in
79
+
let all_dep_names =
80
+
OpamPackage.Name.Set.union dep_names depopt_names
81
+
|> OpamPackage.Name.Set.union extra_doc_dep_names
82
+
in
83
+
let dep_pkgs =
84
+
List.filter (fun p ->
85
+
OpamPackage.Name.Set.mem (OpamPackage.name p) all_dep_names)
86
+
solved_pkgs
87
+
|> OpamPackage.Set.of_list
88
+
in
89
+
OpamPackage.Map.add pkg dep_pkgs acc
90
+
) OpamPackage.Map.empty solved_pkgs
+16
day11/opam/deps.mli
+16
day11/opam/deps.mli
···
1
+
(** Dependency recomputation and extra doc deps.
2
+
3
+
Pure functions operating on opam metadata — no solver dependency. *)
4
+
5
+
val get_extra_doc_deps : OpamFile.OPAM.t -> OpamPackage.Name.Set.t
6
+
(** Extract package names from the [x-extra-doc-deps] extension field. *)
7
+
8
+
val recompute_with_post :
9
+
packages:Git_packages.t ->
10
+
env:(string -> OpamVariable.variable_contents option) ->
11
+
OpamPackage.Set.t OpamPackage.Map.t ->
12
+
OpamPackage.Set.t OpamPackage.Map.t
13
+
(** [recompute_with_post ~packages ~env solution] takes an existing
14
+
solution and recomputes the dependency edges with [{post}] deps
15
+
included. The set of solved packages stays the same; only the
16
+
per-package dep sets change. *)
+3
day11/opam/dune
+3
day11/opam/dune
+3
-30
day11/solver/context.ml
+3
-30
day11/solver/context.ml
···
4
4
5
5
type t = {
6
6
env : string -> OpamVariable.variable_contents option;
7
-
packages : Git_packages.t;
7
+
packages : Day11_opam.Git_packages.t;
8
8
pins : (OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t;
9
9
constraints : OpamFormula.version_constraint OpamTypes.name_map;
10
10
test : OpamPackage.Name.Set.t;
···
65
65
| B true -> [ (version, Ok opam) ]
66
66
| _ -> [ (version, Error Unavailable) ])
67
67
| None ->
68
-
let versions = Git_packages.get_versions t.packages name in
68
+
let versions = Day11_opam.Git_packages.get_versions t.packages name in
69
69
let user_constraints = user_restrictions t name in
70
70
OpamPackage.Version.Map.bindings versions
71
71
|> List.filter_map (fun (v, opam) ->
···
99
99
100
100
let with_doc_post ~doc ~post t = { t with doc; post }
101
101
102
-
let get_extra_doc_deps opamfile =
103
-
let open OpamParserTypes.FullPos in
104
-
let extensions = OpamFile.OPAM.extensions opamfile in
105
-
match OpamStd.String.Map.find_opt "x-extra-doc-deps" extensions with
106
-
| None -> OpamPackage.Name.Set.empty
107
-
| Some value ->
108
-
let extract_name item =
109
-
match item.pelem with
110
-
| String name -> Some name
111
-
| Option (inner, _) ->
112
-
(match inner.pelem with
113
-
| String name -> Some name
114
-
| _ -> None)
115
-
| _ -> None
116
-
in
117
-
let extract_names acc v =
118
-
match v.pelem with
119
-
| List { pelem = items; _ } ->
120
-
List.fold_left (fun acc item ->
121
-
match extract_name item with
122
-
| Some name ->
123
-
OpamPackage.Name.Set.add
124
-
(OpamPackage.Name.of_string name) acc
125
-
| None -> acc
126
-
) acc items
127
-
| _ -> acc
128
-
in
129
-
extract_names OpamPackage.Name.Set.empty value
102
+
let get_extra_doc_deps = Day11_opam.Deps.get_extra_doc_deps
130
103
131
104
let extend_with_extra_doc_deps t =
132
105
let new_pins =
+2
-2
day11/solver/context.mli
+2
-2
day11/solver/context.mli
···
1
1
(** Solver context.
2
2
3
-
Reads packages from a {!Git_packages.t} index (built from a git
3
+
Reads packages from a {!Day11_opam.Git_packages.t} index (built from a git
4
4
opam-repository). Implements the interface required by opam-0install's
5
5
solver.
6
6
···
22
22
?post:bool ->
23
23
constraints:OpamFormula.version_constraint OpamTypes.name_map ->
24
24
env:(string -> OpamVariable.variable_contents option) ->
25
-
packages:Git_packages.t ->
25
+
packages:Day11_opam.Git_packages.t ->
26
26
unit ->
27
27
t
28
28
+3
-3
day11/solver/dune
+3
-3
day11/solver/dune
···
1
1
(library
2
2
(name day11_solver)
3
3
(modules :standard \ solver_worker)
4
-
(libraries bos day11_graph fmt fpath git-unix lwt lwt.unix
5
-
opam-0install opam-format rresult yojson unix))
4
+
(libraries bos day11_graph day11_opam fmt fpath
5
+
opam-0install opam-format rresult))
6
6
7
7
(executable
8
8
(name solver_worker)
9
9
(modules solver_worker)
10
10
(public_name day11-solver-worker)
11
-
(libraries day11_solver day11_graph opam-format yojson))
11
+
(libraries cmdliner day11_solver day11_graph opam-format yojson))
day11/solver/git_packages.ml
day11/opam/git_packages.ml
day11/solver/git_packages.ml
day11/opam/git_packages.ml
day11/solver/git_packages.mli
day11/opam/git_packages.mli
day11/solver/git_packages.mli
day11/opam/git_packages.mli
day11/solver/git_utils.ml
day11/opam/git_utils.ml
day11/solver/git_utils.ml
day11/opam/git_utils.ml
day11/solver/git_utils.mli
day11/opam/git_utils.mli
day11/solver/git_utils.mli
day11/opam/git_utils.mli
-94
day11/solver/local_repo.ml
-94
day11/solver/local_repo.ml
···
1
-
let discover_packages_cache : (string, string list) Hashtbl.t = Hashtbl.create 4
2
-
3
-
let discover_packages path =
4
-
match Hashtbl.find_opt discover_packages_cache path with
5
-
| Some pkgs -> pkgs
6
-
| None ->
7
-
let pkgs =
8
-
try
9
-
Sys.readdir path |> Array.to_list
10
-
|> List.filter_map (fun name ->
11
-
match Filename.extension name with
12
-
| ".opam" -> Some (Filename.remove_extension name)
13
-
| _ -> None)
14
-
with Sys_error _ -> []
15
-
in
16
-
Hashtbl.replace discover_packages_cache path pkgs;
17
-
pkgs
18
-
19
-
let repo_hash_cache : (string, string) Hashtbl.t = Hashtbl.create 4
20
-
21
-
let rec repo_hash path =
22
-
match Hashtbl.find_opt repo_hash_cache path with
23
-
| Some h -> h
24
-
| None ->
25
-
let h = repo_hash_impl path in
26
-
Hashtbl.replace repo_hash_cache path h;
27
-
h
28
-
29
-
and repo_hash_impl path =
30
-
let git_dir = Filename.concat path ".git" in
31
-
if Sys.file_exists git_dir then begin
32
-
let head =
33
-
let ic = Unix.open_process_in
34
-
(Printf.sprintf "git -C %s rev-parse HEAD 2>/dev/null"
35
-
(Filename.quote path)) in
36
-
let line = try input_line ic with End_of_file -> "unknown" in
37
-
ignore (Unix.close_process_in ic);
38
-
String.trim line
39
-
in
40
-
let dirty =
41
-
Sys.command (Printf.sprintf "git -C %s diff --quiet 2>/dev/null"
42
-
(Filename.quote path)) <> 0
43
-
in
44
-
if dirty then begin
45
-
let ic = Unix.open_process_in
46
-
(Printf.sprintf "git -C %s diff 2>/dev/null | md5sum"
47
-
(Filename.quote path)) in
48
-
let diff_hash = try input_line ic |> String.split_on_char ' ' |> List.hd
49
-
with End_of_file -> "unknown" in
50
-
ignore (Unix.close_process_in ic);
51
-
Printf.sprintf "local:%s|%s|dirty-%s" path head diff_hash
52
-
end else
53
-
Printf.sprintf "local:%s|%s" path head
54
-
end else begin
55
-
(* Fallback: hash opam file contents *)
56
-
let packages = discover_packages path in
57
-
let contents = List.map (fun pkg ->
58
-
let opam_file = Filename.concat path (pkg ^ ".opam") in
59
-
In_channel.with_open_text opam_file In_channel.input_all
60
-
) packages in
61
-
let combined = String.concat "|" ("local" :: path :: contents) in
62
-
"local:" ^ (Digest.string combined |> Digest.to_hex)
63
-
end
64
-
65
-
let find_for_packages ~local_repos packages =
66
-
List.find_map (fun repo_path ->
67
-
let available = discover_packages repo_path in
68
-
let matches = List.filter (fun pkg -> List.mem pkg available) packages in
69
-
if matches <> [] then Some (repo_path, matches)
70
-
else None
71
-
) local_repos
72
-
73
-
let validate local_repos =
74
-
let errors = List.filter_map (fun path ->
75
-
if not (Sys.file_exists path) then
76
-
Some (Printf.sprintf "--local-repo: directory does not exist: %s" path)
77
-
else if not (Sys.is_directory path) then
78
-
Some (Printf.sprintf "--local-repo: not a directory: %s" path)
79
-
else None
80
-
) local_repos in
81
-
let all_pkgs = List.concat_map (fun path ->
82
-
List.map (fun pkg -> (pkg, path)) (discover_packages path)
83
-
) local_repos in
84
-
let dup_errors = List.filter_map (fun (pkg, path) ->
85
-
let others = List.filter (fun (p, pa) -> p = pkg && pa <> path) all_pkgs in
86
-
if others <> [] then
87
-
Some (Printf.sprintf "--local-repo: package %s found in multiple repos: %s and %s"
88
-
pkg path (snd (List.hd others)))
89
-
else None
90
-
) all_pkgs in
91
-
let dup_errors = List.sort_uniq String.compare dup_errors in
92
-
match errors @ dup_errors with
93
-
| [] -> Ok ()
94
-
| errs -> Error (String.concat "\n" errs)
-25
day11/solver/local_repo.mli
-25
day11/solver/local_repo.mli
···
1
-
(** Local package discovery for --local-repo support.
2
-
3
-
Discovers [.opam] files in local directories, computes cache
4
-
hashes from git state, and validates repo configurations. *)
5
-
6
-
val discover_packages : string -> string list
7
-
(** [discover_packages path] scans [path] for [*.opam] files and
8
-
returns package names (without the [.opam] extension). Results
9
-
are cached per path. *)
10
-
11
-
val repo_hash : string -> string
12
-
(** [repo_hash path] computes a cache hash for the local repo at
13
-
[path]. Uses git HEAD + dirty state if available; falls back
14
-
to hashing opam file contents. Cached per path. *)
15
-
16
-
val find_for_packages :
17
-
local_repos:string list -> string list ->
18
-
(string * string list) option
19
-
(** [find_for_packages ~local_repos packages] returns
20
-
[Some (repo_path, matching_packages)] for the first local repo
21
-
that provides any of the given package names, or [None]. *)
22
-
23
-
val validate : string list -> (unit, string) result
24
-
(** [validate local_repos] checks that all repo paths exist, are
25
-
directories, and contain no duplicate packages across repos. *)
day11/solver/opam_env.ml
day11/opam/opam_env.ml
day11/solver/opam_env.ml
day11/opam/opam_env.ml
day11/solver/opam_env.mli
day11/opam/opam_env.mli
day11/solver/opam_env.mli
day11/opam/opam_env.mli
+4
-172
day11/solver/solve.ml
+4
-172
day11/solver/solve.ml
···
45
45
match OpamPackage.Name.Map.find_opt name pins with
46
46
| Some (_ver, opam) -> opam
47
47
| None ->
48
-
try Git_packages.get_package pkgs target
48
+
try Day11_opam.Git_packages.get_package pkgs target
49
49
with Not_found -> OpamFile.OPAM.empty
50
50
in
51
51
let open OpamParserTypes.FullPos in
···
90
90
match OpamPackage.Name.Map.find_opt (OpamPackage.name pkg) pins with
91
91
| Some (_ver, opam) -> opam
92
92
| None ->
93
-
try Git_packages.get_package pkgs pkg
93
+
try Day11_opam.Git_packages.get_package pkgs pkg
94
94
with Not_found -> OpamFile.OPAM.empty
95
95
in
96
96
let deps =
···
152
152
| Error (msg, _examined) -> Error msg
153
153
154
154
let solve_with_examined ~packages ~env ?constraints ?pins ?prefer_oldest
155
-
?ocaml_version target =
155
+
?(doc = true) ?ocaml_version target =
156
156
let constraints = add_ocaml_constraint ?ocaml_version
157
157
(Option.value ~default:OpamPackage.Name.Map.empty constraints) in
158
158
match solve_internal ~packages ~env ~constraints ?pins
159
-
?prefer_oldest target with
159
+
?prefer_oldest ~doc target with
160
160
| Ok (solution, _doc_deps, examined) -> Ok (solution, examined)
161
161
| Error _ as e -> e
162
162
163
-
let recompute_with_post ~packages ~env solution =
164
-
let filter_env pkg v =
165
-
if List.mem v OpamPackageVar.predefined_depends_variables then None
166
-
else match OpamVariable.Full.to_string v with
167
-
| "version" ->
168
-
Some (OpamTypes.S
169
-
(OpamPackage.Version.to_string (OpamPackage.version pkg)))
170
-
| x -> env x
171
-
in
172
-
let solved_pkgs = OpamPackage.Map.fold (fun pkg _ acc -> pkg :: acc)
173
-
solution [] in
174
-
let solved_names = List.fold_left (fun acc p ->
175
-
OpamPackage.Name.Set.add (OpamPackage.name p) acc)
176
-
OpamPackage.Name.Set.empty solved_pkgs in
177
-
List.fold_left (fun acc pkg ->
178
-
let opam =
179
-
try Git_packages.get_package packages pkg
180
-
with Not_found -> OpamFile.OPAM.empty
181
-
in
182
-
let deps =
183
-
OpamFile.OPAM.depends opam
184
-
|> OpamFilter.partial_filter_formula (filter_env pkg)
185
-
|> OpamFilter.filter_deps ~build:true ~post:true ~test:false
186
-
~doc:true ~dev:false ~dev_setup:false ~default:false
187
-
in
188
-
let dep_names =
189
-
OpamFormula.fold_left
190
-
(fun acc (dep_name, _) ->
191
-
OpamPackage.Name.Set.add dep_name acc)
192
-
OpamPackage.Name.Set.empty deps
193
-
in
194
-
let depopts = OpamFile.OPAM.depopts opam in
195
-
let depopt_names =
196
-
OpamFormula.fold_left
197
-
(fun acc (dep_name, _) ->
198
-
if OpamPackage.Name.Set.mem dep_name solved_names
199
-
then OpamPackage.Name.Set.add dep_name acc
200
-
else acc)
201
-
OpamPackage.Name.Set.empty depopts
202
-
in
203
-
(* Include x-extra-doc-deps that are present in the solution *)
204
-
let extra_doc_deps = Context.get_extra_doc_deps opam in
205
-
let extra_doc_dep_names =
206
-
OpamPackage.Name.Set.inter extra_doc_deps solved_names
207
-
in
208
-
let all_dep_names =
209
-
OpamPackage.Name.Set.union dep_names depopt_names
210
-
|> OpamPackage.Name.Set.union extra_doc_dep_names
211
-
in
212
-
let dep_pkgs =
213
-
List.filter (fun p ->
214
-
OpamPackage.Name.Set.mem (OpamPackage.name p) all_dep_names)
215
-
solved_pkgs
216
-
|> OpamPackage.Set.of_list
217
-
in
218
-
OpamPackage.Map.add pkg dep_pkgs acc
219
-
) OpamPackage.Map.empty solved_pkgs
220
163
221
-
let find_worker_bin () =
222
-
let exe_dir = Filename.dirname Sys.argv.(0) in
223
-
let candidates = [
224
-
Filename.concat exe_dir "solver_worker.exe";
225
-
Filename.concat exe_dir "../solver/solver_worker.exe";
226
-
Filename.concat exe_dir "../../day11/solver/solver_worker.exe";
227
-
"_build/default/day11/solver/solver_worker.exe";
228
-
"day11-solver-worker";
229
-
] in
230
-
match List.find_opt Sys.file_exists candidates with
231
-
| Some p -> p
232
-
| None ->
233
-
let tried = String.concat ", " candidates in
234
-
failwith (Printf.sprintf "solver_worker binary not found (tried: %s, argv0=%s)"
235
-
tried Sys.argv.(0))
236
-
237
-
let parse_result_line line =
238
-
let json = Yojson.Safe.from_string line in
239
-
let open Yojson.Safe.Util in
240
-
let pkg = json |> member "package" |> to_string
241
-
|> OpamPackage.of_string in
242
-
let examined =
243
-
json |> member "examined" |> to_list |> List.map to_string
244
-
|> List.map OpamPackage.Name.of_string
245
-
|> OpamPackage.Name.Set.of_list in
246
-
match json |> member "failed" |> to_bool_option with
247
-
| Some true ->
248
-
let error = json |> member "error" |> to_string in
249
-
(pkg, Error (error, examined))
250
-
| _ ->
251
-
match Day11_graph.Solution_json.of_json
252
-
(json |> member "solution") with
253
-
| Ok solution -> (pkg, Ok (solution, examined))
254
-
| Error (`Msg e) -> (pkg, Error (e, examined))
255
-
256
-
let solve_many ~packages ~env ?constraints ?prefer_oldest ?ocaml_version
257
-
~np ~repos targets =
258
-
if targets = [] then []
259
-
else
260
-
let constraints = add_ocaml_constraint ?ocaml_version
261
-
(Option.value ~default:OpamPackage.Name.Map.empty constraints) in
262
-
let np = min np (List.length targets) in
263
-
if np <= 1 then
264
-
List.map (fun target ->
265
-
let result = solve_internal ~packages ~env ~constraints
266
-
?prefer_oldest target in
267
-
let result = Result.map (fun (solution, _doc_deps, examined) ->
268
-
(solution, examined)) result in
269
-
(target, result)
270
-
) targets
271
-
else begin
272
-
let worker_bin = find_worker_bin () in
273
-
let n = List.length targets in
274
-
(* Partition targets across np workers *)
275
-
let batches = Array.make np [] in
276
-
List.iteri (fun i target ->
277
-
let slot = i mod np in
278
-
batches.(slot) <- target :: batches.(slot)
279
-
) targets;
280
-
let tmp = Filename.get_temp_dir_name () in
281
-
let pid_of = Unix.getpid () in
282
-
(* Spawn workers *)
283
-
let children = List.init np (fun slot ->
284
-
let batch = List.rev batches.(slot) in
285
-
if batch = [] then None
286
-
else
287
-
let output_file = Filename.concat tmp
288
-
(Printf.sprintf "day11_solve_%d_%d.jsonl" pid_of slot) in
289
-
let repo_args = List.concat_map (fun (repo, sha) ->
290
-
[ "--repo"; repo ^ ":" ^ sha ]
291
-
) repos in
292
-
let ocaml_args = match ocaml_version with
293
-
| Some pkg -> [ "--ocaml-version"; OpamPackage.to_string pkg ]
294
-
| None -> [] in
295
-
let args = Array.of_list (
296
-
[ worker_bin ] @ repo_args @
297
-
[ "--output"; output_file ] @
298
-
ocaml_args @
299
-
List.map OpamPackage.to_string batch) in
300
-
let devnull = Unix.openfile "/dev/null"
301
-
[ Unix.O_WRONLY ] 0 in
302
-
let pid = Unix.create_process worker_bin args
303
-
Unix.stdin devnull Unix.stderr in
304
-
Unix.close devnull;
305
-
Some (pid, output_file)
306
-
) in
307
-
(* Wait and collect results *)
308
-
let results = ref [] in
309
-
List.iter (fun child ->
310
-
match child with
311
-
| None -> ()
312
-
| Some (pid, output_file) ->
313
-
let rec wait_pid p =
314
-
try ignore (Unix.waitpid [] p)
315
-
with Unix.Unix_error (Unix.EINTR, _, _) -> wait_pid p
316
-
in
317
-
wait_pid pid;
318
-
(try
319
-
let ic = open_in output_file in
320
-
(try while true do
321
-
let line = input_line ic in
322
-
if line <> "" then
323
-
results := parse_result_line line :: !results
324
-
done with End_of_file -> ());
325
-
close_in ic;
326
-
Sys.remove output_file
327
-
with _ -> ())
328
-
) children;
329
-
ignore n;
330
-
!results
331
-
end
+3
-28
day11/solver/solve.mli
+3
-28
day11/solver/solve.mli
···
5
5
returns a dependency solution. *)
6
6
7
7
val solve :
8
-
packages:Git_packages.t ->
8
+
packages:Day11_opam.Git_packages.t ->
9
9
env:(string -> OpamVariable.variable_contents option) ->
10
10
?constraints:OpamFormula.version_constraint OpamTypes.name_map ->
11
11
?pins:(OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t ->
···
25
25
that version. Otherwise defaults to [>= 4.08]. *)
26
26
27
27
val solve_with_examined :
28
-
packages:Git_packages.t ->
28
+
packages:Day11_opam.Git_packages.t ->
29
29
env:(string -> OpamVariable.variable_contents option) ->
30
30
?constraints:OpamFormula.version_constraint OpamTypes.name_map ->
31
31
?pins:(OpamPackage.Version.t * OpamFile.OPAM.t) OpamPackage.Name.Map.t ->
32
32
?prefer_oldest:bool ->
33
+
?doc:bool ->
33
34
?ocaml_version:OpamPackage.t ->
34
35
OpamPackage.t ->
35
36
(Day11_graph.Graph.solution * OpamPackage.Name.Set.t,
36
37
string * OpamPackage.Name.Set.t) result
37
38
(** Like {!solve} but also returns the examined package set. *)
38
39
39
-
val recompute_with_post :
40
-
packages:Git_packages.t ->
41
-
env:(string -> OpamVariable.variable_contents option) ->
42
-
Day11_graph.Graph.solution ->
43
-
Day11_graph.Graph.solution
44
-
(** [recompute_with_post ~packages ~env solution] takes an existing
45
-
solution (computed with [~post:false]) and recomputes the dependency
46
-
edges with [{post}] deps included. The set of solved packages stays
47
-
the same; only the per-package dep sets change. *)
48
-
49
-
val solve_many :
50
-
packages:Git_packages.t ->
51
-
env:(string -> OpamVariable.variable_contents option) ->
52
-
?constraints:OpamFormula.version_constraint OpamTypes.name_map ->
53
-
?prefer_oldest:bool ->
54
-
?ocaml_version:OpamPackage.t ->
55
-
np:int ->
56
-
repos:(string * string) list ->
57
-
OpamPackage.t list ->
58
-
(OpamPackage.t
59
-
* (Day11_graph.Graph.solution * OpamPackage.Name.Set.t,
60
-
string * OpamPackage.Name.Set.t) result) list
61
-
(** [solve_many ~packages ~env ~np ~repos targets] solves all
62
-
[targets] in parallel by spawning [np] solver_worker processes.
63
-
[repos] is a list of [(repo_path, commit_sha)] pairs passed
64
-
to each worker as [--repo PATH:SHA] arguments. *)
+116
-47
day11/solver/solver_worker.ml
+116
-47
day11/solver/solver_worker.ml
···
3
3
writes each result as one JSON object per line to an output file.
4
4
5
5
Usage: solver_worker --repo PATH[:SHA] ... --output FILE
6
-
[--arch A] [--os O] [--os-distribution D]
6
+
[--pin-dir DIR] ... [--constraint NAME.VERSION] ...
7
+
[--no-doc] [--arch A] [--os O] [--os-distribution D]
7
8
[--os-family F] [--os-version V]
8
9
PKG1 PKG2 ... *)
9
10
10
-
let repos = ref []
11
-
let output = ref ""
12
-
let ocaml_version = ref ""
13
-
let arch = ref "x86_64"
14
-
let os = ref "linux"
15
-
let os_distribution = ref "debian"
16
-
let os_family = ref "debian"
17
-
let os_version = ref "12"
18
-
let targets = ref []
11
+
open Cmdliner
19
12
20
-
let spec = [
21
-
"--repo", Arg.String (fun s ->
13
+
let repo_conv =
14
+
let parse s =
22
15
match String.split_on_char ':' s with
23
-
| [path] -> repos := (path, None) :: !repos
24
-
| path :: rest ->
25
-
let sha = String.concat ":" rest in
26
-
repos := (path, Some sha) :: !repos
27
-
| [] -> ()),
28
-
"PATH[:SHA] opam-repository path with optional commit SHA (repeatable, layered in order)";
29
-
"--output", Arg.Set_string output, "FILE output file (one JSON per line)";
30
-
"--ocaml-version", Arg.Set_string ocaml_version, "PKG compiler version (e.g. ocaml-base-compiler.5.2.1)";
31
-
"--arch", Arg.Set_string arch, "ARCH architecture";
32
-
"--os", Arg.Set_string os, "OS operating system";
33
-
"--os-distribution", Arg.Set_string os_distribution, "DIST distribution";
34
-
"--os-family", Arg.Set_string os_family, "FAM os family";
35
-
"--os-version", Arg.Set_string os_version, "VER os version";
36
-
]
16
+
| [path] -> Ok (path, None)
17
+
| path :: rest -> Ok (path, Some (String.concat ":" rest))
18
+
| [] -> Error (`Msg "empty repo spec")
19
+
in
20
+
let pp fmt (path, sha) =
21
+
match sha with
22
+
| None -> Format.pp_print_string fmt path
23
+
| Some s -> Format.fprintf fmt "%s:%s" path s
24
+
in
25
+
Arg.conv (parse, pp)
26
+
27
+
let repo_term =
28
+
let doc = "opam-repository path with optional commit SHA (repeatable, layered in order)" in
29
+
Arg.(non_empty & opt_all repo_conv [] & info [ "repo" ] ~docv:"PATH[:SHA]" ~doc)
30
+
31
+
let output_term =
32
+
let doc = "Output file (one JSON per line); defaults to stdout" in
33
+
Arg.(value & opt (some string) None & info [ "output" ] ~docv:"FILE" ~doc)
34
+
35
+
let ocaml_version_term =
36
+
let doc = "Compiler version (e.g. ocaml-base-compiler.5.2.1)" in
37
+
Arg.(value & opt (some string) None & info [ "ocaml-version" ] ~docv:"PKG" ~doc)
38
+
39
+
let pin_dir_term =
40
+
let doc = "Directory of .opam files to pin at version dev (repeatable)" in
41
+
Arg.(value & opt_all string [] & info [ "pin-dir" ] ~docv:"DIR" ~doc)
42
+
43
+
let constraint_term =
44
+
let doc = "Pin package at exact version, e.g. NAME.VERSION (repeatable)" in
45
+
Arg.(value & opt_all string [] & info [ "constraint" ] ~docv:"NAME.VERSION" ~doc)
46
+
47
+
let no_doc_term =
48
+
let doc = "Disable doc dependencies" in
49
+
Arg.(value & flag & info [ "no-doc" ] ~doc)
50
+
51
+
let arch_term =
52
+
let doc = "Architecture (default x86_64)" in
53
+
Arg.(value & opt string "x86_64" & info [ "arch" ] ~docv:"ARCH" ~doc)
54
+
55
+
let os_term =
56
+
let doc = "Operating system (default linux)" in
57
+
Arg.(value & opt string "linux" & info [ "os" ] ~docv:"OS" ~doc)
58
+
59
+
let os_distribution_term =
60
+
let doc = "Distribution (default debian)" in
61
+
Arg.(value & opt string "debian" & info [ "os-distribution" ] ~docv:"DIST" ~doc)
62
+
63
+
let os_family_term =
64
+
let doc = "OS family (default debian)" in
65
+
Arg.(value & opt string "debian" & info [ "os-family" ] ~docv:"FAM" ~doc)
66
+
67
+
let os_version_term =
68
+
let doc = "OS version (default 12)" in
69
+
Arg.(value & opt string "12" & info [ "os-version" ] ~docv:"VER" ~doc)
70
+
71
+
let targets_term =
72
+
let doc = "Package(s) to solve" in
73
+
Arg.(non_empty & pos_all string [] & info [] ~docv:"PKG" ~doc)
74
+
75
+
let read_pins_from_dir dir =
76
+
let opam_files = Sys.readdir dir |> Array.to_list
77
+
|> List.filter (fun f -> Filename.check_suffix f ".opam") in
78
+
List.fold_left (fun acc filename ->
79
+
let name = Filename.chop_suffix filename ".opam" in
80
+
let path = Filename.concat dir filename in
81
+
try
82
+
let opam = OpamFile.OPAM.read
83
+
(OpamFile.make (OpamFilename.raw path)) in
84
+
OpamPackage.Name.Map.add
85
+
(OpamPackage.Name.of_string name)
86
+
(OpamPackage.Version.of_string "dev", opam) acc
87
+
with _ -> acc
88
+
) OpamPackage.Name.Map.empty opam_files
89
+
90
+
let parse_constraints constraint_strs =
91
+
List.fold_left (fun acc s ->
92
+
let pkg = OpamPackage.of_string s in
93
+
OpamPackage.Name.Map.add (OpamPackage.name pkg)
94
+
(`Eq, OpamPackage.version pkg) acc
95
+
) OpamPackage.Name.Map.empty constraint_strs
37
96
38
-
let solve_one ~packages ~env ?ocaml_version pkg =
97
+
let solve_one ~packages ~env ~pins ~constraints ~doc ?ocaml_version pkg =
39
98
match Day11_solver.Solve.solve_with_examined ~packages ~env
40
-
?ocaml_version pkg with
99
+
~pins ~constraints ~doc ?ocaml_version pkg with
41
100
| Ok (solution, examined) ->
42
101
`Assoc [
43
102
("package", `String (OpamPackage.to_string pkg));
···
54
113
`String (OpamPackage.Name.to_string n) :: acc) examined []));
55
114
]
56
115
57
-
let () =
58
-
Arg.parse spec (fun s -> targets := s :: !targets)
59
-
"solver_worker: solve packages";
60
-
let targets = List.rev !targets in
61
-
let repo_list = List.rev !repos in
62
-
if repo_list = [] || targets = [] then begin
63
-
Printf.eprintf "Usage: solver_worker --repo PATH[:SHA] ... PKG1 PKG2\n";
64
-
exit 1
65
-
end;
116
+
let run repo_list output ocaml_version pin_dirs constraint_strs no_doc
117
+
arch os os_distribution os_family os_version targets =
66
118
let packages, _repos_with_shas =
67
-
Day11_solver.Git_packages.of_repositories repo_list in
68
-
let env = Day11_solver.Opam_env.std_env
69
-
~arch:!arch ~os:!os ~os_distribution:!os_distribution
70
-
~os_family:!os_family ~os_version:!os_version () in
71
-
let oc = if !output = "" then stdout
72
-
else open_out !output in
119
+
Day11_opam.Git_packages.of_repositories repo_list in
120
+
let env = Day11_opam.Opam_env.std_env
121
+
~arch ~os ~os_distribution ~os_family ~os_version () in
122
+
let oc = match output with
123
+
| None -> stdout
124
+
| Some path -> open_out path in
73
125
let ocaml_version =
74
-
if !ocaml_version = "" then None
75
-
else Some (OpamPackage.of_string !ocaml_version) in
126
+
Option.map OpamPackage.of_string ocaml_version in
127
+
let pins = List.fold_left (fun acc dir ->
128
+
OpamPackage.Name.Map.union (fun _a b -> b) acc
129
+
(read_pins_from_dir dir)
130
+
) OpamPackage.Name.Map.empty pin_dirs in
131
+
let constraints = parse_constraints constraint_strs in
132
+
let doc = not no_doc in
76
133
List.iter (fun target_str ->
77
134
let pkg = OpamPackage.of_string target_str in
78
-
let json = solve_one ~packages ~env ?ocaml_version pkg in
135
+
let json = solve_one ~packages ~env ~pins ~constraints ~doc
136
+
?ocaml_version pkg in
79
137
output_string oc (Yojson.Safe.to_string json);
80
138
output_char oc '\n';
81
139
flush oc
82
140
) targets;
83
-
if !output <> "" then close_out oc
141
+
if output <> None then close_out oc
142
+
143
+
let cmd =
144
+
let doc = "Solve packages and write solutions as JSON lines" in
145
+
let info = Cmd.info "solver_worker" ~doc in
146
+
Cmd.v info
147
+
Term.(const run $ repo_term $ output_term $ ocaml_version_term
148
+
$ pin_dir_term $ constraint_term $ no_doc_term
149
+
$ arch_term $ os_term $ os_distribution_term $ os_family_term
150
+
$ os_version_term $ targets_term)
151
+
152
+
let () = exit (Cmd.eval cmd)
+2
-2
day11/solver/test/test_doc_deps.ml
+2
-2
day11/solver/test/test_doc_deps.ml
···
14
14
in
15
15
Printf.printf "Using opam-repository: %s\n%!" opam_repo;
16
16
let git_packages, _ =
17
-
Day11_solver.Git_packages.of_repositories [ (opam_repo, None) ] in
17
+
Day11_opam.Git_packages.of_repositories [ (opam_repo, None) ] in
18
18
Bos.OS.Dir.set_default_tmp (Fpath.v (Filename.get_temp_dir_name ()));
19
-
let env = Day11_solver.Opam_env.std_env
19
+
let env = Day11_opam.Opam_env.std_env
20
20
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
21
21
~os_family:"debian" ~os_version:"12" () in
22
22
+16
-69
day11/solver/test/test_solver.ml
+16
-69
day11/solver/test/test_solver.ml
···
19
19
(* ── Opam_env tests ──────────────────────────────────────────────── *)
20
20
21
21
let test_std_env () =
22
-
let env = Opam_env.std_env
22
+
let env = Day11_opam.Opam_env.std_env
23
23
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
24
24
~os_family:"debian" ~os_version:"12" () in
25
25
Alcotest.(check (option string)) "arch"
···
30
30
(env "os" |> Option.map (function OpamTypes.S s -> s | _ -> "?"))
31
31
32
32
let test_std_env_ocaml_native () =
33
-
let env = Opam_env.std_env
33
+
let env = Day11_opam.Opam_env.std_env
34
34
~ocaml_native:false
35
35
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
36
36
~os_family:"debian" ~os_version:"12" () in
···
40
40
OpamTypes.B b -> string_of_bool b | _ -> "?"))
41
41
42
42
let test_std_env_unknown () =
43
-
let env = Opam_env.std_env
43
+
let env = Day11_opam.Opam_env.std_env
44
44
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
45
45
~os_family:"debian" ~os_version:"12" () in
46
46
Alcotest.(check bool) "unknown returns None"
···
62
62
Alcotest.(check bool) "file exists"
63
63
true (Bos.OS.File.exists path |> Result.get_ok)
64
64
65
-
(* ── Local_repo tests ────────────────────────────────────────────── *)
66
-
67
-
let test_discover_packages () = with_tmp_dir @@ fun dir ->
68
-
write_file Fpath.(dir / "mylib.opam") {|opam-version: "2.0"|};
69
-
write_file Fpath.(dir / "mylib2.opam") {|opam-version: "2.0"|};
70
-
write_file Fpath.(dir / "README.md") "not an opam file";
71
-
let pkgs = Local_repo.discover_packages (Fpath.to_string dir) in
72
-
Alcotest.(check bool) "has mylib"
73
-
true (List.mem "mylib" pkgs);
74
-
Alcotest.(check bool) "has mylib2"
75
-
true (List.mem "mylib2" pkgs);
76
-
Alcotest.(check bool) "no README"
77
-
false (List.mem "README" pkgs)
78
-
79
-
let test_discover_empty () = with_tmp_dir @@ fun dir ->
80
-
let pkgs = Local_repo.discover_packages (Fpath.to_string dir) in
81
-
Alcotest.(check (list string)) "empty" [] pkgs
82
-
83
-
let test_find_for_packages () = with_tmp_dir @@ fun dir ->
84
-
write_file Fpath.(dir / "mylib.opam") {|opam-version: "2.0"|};
85
-
let dir_s = Fpath.to_string dir in
86
-
let result = Local_repo.find_for_packages
87
-
~local_repos:[ dir_s ] [ "mylib"; "other" ] in
88
-
match result with
89
-
| Some (path, matches) ->
90
-
Alcotest.(check string) "path" dir_s path;
91
-
Alcotest.(check bool) "has mylib"
92
-
true (List.mem "mylib" matches)
93
-
| None -> Alcotest.fail "expected Some"
94
-
95
-
let test_find_for_packages_none () = with_tmp_dir @@ fun dir ->
96
-
let result = Local_repo.find_for_packages
97
-
~local_repos:[ Fpath.to_string dir ] [ "nonexistent" ] in
98
-
Alcotest.(check bool) "none" true (Option.is_none result)
99
-
100
-
let test_validate_ok () = with_tmp_dir @@ fun dir ->
101
-
write_file Fpath.(dir / "mylib.opam") {|opam-version: "2.0"|};
102
-
let r = Local_repo.validate [ Fpath.to_string dir ] in
103
-
Alcotest.(check bool) "ok" true (Result.is_ok r)
104
-
105
-
let test_validate_missing () =
106
-
let r = Local_repo.validate [ "/nonexistent/path/xyz" ] in
107
-
Alcotest.(check bool) "error" true (Result.is_error r)
108
-
109
65
(* ── Solve tests (needs opam-repository git repo) ────────────────── *)
110
66
111
67
let test_solve_astring () =
112
68
let opam_repo = opam_repository () in
113
69
let packages, _store, _commit =
114
-
Git_packages.of_opam_repository opam_repo in
115
-
let env = Opam_env.std_env
70
+
Day11_opam.Git_packages.of_opam_repository opam_repo in
71
+
let env = Day11_opam.Opam_env.std_env
116
72
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
117
73
~os_family:"debian" ~os_version:"12" () in
118
74
let result = Solve.solve ~packages ~env
119
75
(pkg "astring.0.8.5") in
120
76
match result with
121
77
| Ok solution ->
122
-
let topo = Day11_graph.Graph.topological_sort solution in
123
-
let names = List.map OpamPackage.to_string topo in
78
+
let names = OpamPackage.Map.keys solution
79
+
|> List.map OpamPackage.to_string in
124
80
Alcotest.(check bool) "has astring"
125
81
true (List.exists (fun n ->
126
82
Astring.String.is_prefix ~affix:"astring" n) names);
···
134
90
let test_solve_nonexistent () =
135
91
let opam_repo = opam_repository () in
136
92
let packages, _store, _commit =
137
-
Git_packages.of_opam_repository opam_repo in
138
-
let env = Opam_env.std_env
93
+
Day11_opam.Git_packages.of_opam_repository opam_repo in
94
+
let env = Day11_opam.Opam_env.std_env
139
95
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
140
96
~os_family:"debian" ~os_version:"12" () in
141
97
let result = Solve.solve ~packages ~env
···
157
113
let test_odig_odoc_needs_separate_link () =
158
114
let opam_repo = opam_repository () in
159
115
let packages, _store, _commit =
160
-
Git_packages.of_opam_repository opam_repo in
161
-
let env = Opam_env.std_env
116
+
Day11_opam.Git_packages.of_opam_repository opam_repo in
117
+
let env = Day11_opam.Opam_env.std_env
162
118
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
163
119
~os_family:"debian" ~os_version:"12" () in
164
120
let target = pkg "odig.0.0.9" in
···
167
123
| Error diag ->
168
124
Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
169
125
| Ok compile_deps ->
170
-
let link_deps = Solve.recompute_with_post ~packages ~env compile_deps in
126
+
let link_deps = Day11_opam.Deps.recompute_with_post ~packages ~env compile_deps in
171
127
(* odoc should be in the solution *)
172
128
let odoc_pkg = OpamPackage.Map.fold (fun p _ acc ->
173
129
if OpamPackage.Name.to_string (OpamPackage.name p) = "odoc"
···
191
147
let test_recompute_with_post () =
192
148
let opam_repo = opam_repository () in
193
149
let packages, _store, _commit =
194
-
Git_packages.of_opam_repository opam_repo in
195
-
let env = Opam_env.std_env
150
+
Day11_opam.Git_packages.of_opam_repository opam_repo in
151
+
let env = Day11_opam.Opam_env.std_env
196
152
~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
197
153
~os_family:"debian" ~os_version:"12" () in
198
154
let target = pkg "odig.0.0.9" in
···
201
157
| Error diag ->
202
158
Alcotest.fail (Printf.sprintf "Solve failed: %s" diag)
203
159
| Ok compile_deps ->
204
-
let link_deps = Solve.recompute_with_post ~packages ~env compile_deps in
160
+
let link_deps = Day11_opam.Deps.recompute_with_post ~packages ~env compile_deps in
205
161
(* Same set of packages in both graphs *)
206
162
let compile_pkgs = OpamPackage.Map.fold (fun p _ acc ->
207
163
OpamPackage.Set.add p acc) compile_deps OpamPackage.Set.empty in
···
255
211
Alcotest.test_case "to_string" `Quick test_dot_to_string;
256
212
Alcotest.test_case "save" `Quick test_dot_save;
257
213
] );
258
-
( "Local_repo",
259
-
[
260
-
Alcotest.test_case "discover_packages" `Quick test_discover_packages;
261
-
Alcotest.test_case "discover empty" `Quick test_discover_empty;
262
-
Alcotest.test_case "find_for_packages" `Quick test_find_for_packages;
263
-
Alcotest.test_case "find none" `Quick test_find_for_packages_none;
264
-
Alcotest.test_case "validate ok" `Quick test_validate_ok;
265
-
Alcotest.test_case "validate missing" `Quick test_validate_missing;
266
-
] );
267
-
( "Solve",
214
+
( "Solve",
268
215
[
269
216
Alcotest.test_case "solve astring" `Slow test_solve_astring;
270
217
Alcotest.test_case "solve nonexistent" `Slow test_solve_nonexistent;
+3
day11/solver_pool/dune
+3
day11/solver_pool/dune
+101
day11/solver_pool/solver_pool.ml
+101
day11/solver_pool/solver_pool.ml
···
1
+
let find_worker_bin () =
2
+
let exe_dir = Filename.dirname Sys.argv.(0) in
3
+
let candidates = [
4
+
Filename.concat exe_dir "solver_worker.exe";
5
+
Filename.concat exe_dir "../solver/solver_worker.exe";
6
+
Filename.concat exe_dir "../../day11/solver/solver_worker.exe";
7
+
"_build/default/day11/solver/solver_worker.exe";
8
+
"day11-solver-worker";
9
+
] in
10
+
match List.find_opt Sys.file_exists candidates with
11
+
| Some p -> p
12
+
| None ->
13
+
let tried = String.concat ", " candidates in
14
+
failwith (Printf.sprintf "solver_worker binary not found (tried: %s, argv0=%s)"
15
+
tried Sys.argv.(0))
16
+
17
+
let parse_result_line line =
18
+
let json = Yojson.Safe.from_string line in
19
+
let open Yojson.Safe.Util in
20
+
let pkg = json |> member "package" |> to_string
21
+
|> OpamPackage.of_string in
22
+
let examined =
23
+
json |> member "examined" |> to_list |> List.map to_string
24
+
|> List.map OpamPackage.Name.of_string
25
+
|> OpamPackage.Name.Set.of_list in
26
+
match json |> member "failed" |> to_bool_option with
27
+
| Some true ->
28
+
let error = json |> member "error" |> to_string in
29
+
(pkg, Error (error, examined))
30
+
| _ ->
31
+
match Day11_graph.Solution_json.of_json
32
+
(json |> member "solution") with
33
+
| Ok solution -> (pkg, Ok (solution, examined))
34
+
| Error (`Msg e) -> (pkg, Error (e, examined))
35
+
36
+
let solve_many ?(pin_dirs = []) ?(constraints = []) ?(doc = true)
37
+
?ocaml_version ~np ~repos targets =
38
+
if targets = [] then []
39
+
else
40
+
let np = max 1 (min np (List.length targets)) in
41
+
let worker_bin = find_worker_bin () in
42
+
let batches = Array.make np [] in
43
+
List.iteri (fun i target ->
44
+
let slot = i mod np in
45
+
batches.(slot) <- target :: batches.(slot)
46
+
) targets;
47
+
let tmp = Filename.get_temp_dir_name () in
48
+
let pid_of = Unix.getpid () in
49
+
let children = List.init np (fun slot ->
50
+
let batch = List.rev batches.(slot) in
51
+
if batch = [] then None
52
+
else
53
+
let output_file = Filename.concat tmp
54
+
(Printf.sprintf "day11_solve_%d_%d.jsonl" pid_of slot) in
55
+
let repo_args = List.concat_map (fun (repo, sha) ->
56
+
[ "--repo"; repo ^ ":" ^ sha ]
57
+
) repos in
58
+
let ocaml_args = match ocaml_version with
59
+
| Some pkg -> [ "--ocaml-version"; OpamPackage.to_string pkg ]
60
+
| None -> [] in
61
+
let pin_args = List.concat_map (fun dir ->
62
+
[ "--pin-dir"; dir ]
63
+
) pin_dirs in
64
+
let constraint_args = List.concat_map (fun pkg ->
65
+
[ "--constraint"; OpamPackage.to_string pkg ]
66
+
) constraints in
67
+
let doc_args = if doc then [] else [ "--no-doc" ] in
68
+
let args = Array.of_list (
69
+
[ worker_bin ] @ repo_args @
70
+
[ "--output"; output_file ] @
71
+
ocaml_args @ pin_args @ constraint_args @ doc_args @
72
+
List.map OpamPackage.to_string batch) in
73
+
let devnull = Unix.openfile "/dev/null"
74
+
[ Unix.O_WRONLY ] 0 in
75
+
let pid = Unix.create_process worker_bin args
76
+
Unix.stdin devnull Unix.stderr in
77
+
Unix.close devnull;
78
+
Some (pid, output_file)
79
+
) in
80
+
let results = ref [] in
81
+
List.iter (fun child ->
82
+
match child with
83
+
| None -> ()
84
+
| Some (pid, output_file) ->
85
+
let rec wait_pid p =
86
+
try ignore (Unix.waitpid [] p)
87
+
with Unix.Unix_error (Unix.EINTR, _, _) -> wait_pid p
88
+
in
89
+
wait_pid pid;
90
+
(try
91
+
let ic = open_in output_file in
92
+
(try while true do
93
+
let line = input_line ic in
94
+
if line <> "" then
95
+
results := parse_result_line line :: !results
96
+
done with End_of_file -> ());
97
+
close_in ic;
98
+
Sys.remove output_file
99
+
with _ -> ())
100
+
) children;
101
+
!results
+22
day11/solver_pool/solver_pool.mli
+22
day11/solver_pool/solver_pool.mli
···
1
+
(** Parallel solving via solver_worker subprocesses.
2
+
3
+
Spawns solver_worker processes to solve packages in parallel.
4
+
No in-process solver dependency — all solving happens out-of-process. *)
5
+
6
+
val solve_many :
7
+
?pin_dirs:string list ->
8
+
?constraints:OpamPackage.t list ->
9
+
?doc:bool ->
10
+
?ocaml_version:OpamPackage.t ->
11
+
np:int ->
12
+
repos:(string * string) list ->
13
+
OpamPackage.t list ->
14
+
(OpamPackage.t
15
+
* (Day11_graph.Graph.solution * OpamPackage.Name.Set.t,
16
+
string * OpamPackage.Name.Set.t) result) list
17
+
(** [solve_many ?pin_dirs ?constraints ?doc ?ocaml_version ~np ~repos targets]
18
+
solves all [targets] in parallel by spawning [np] solver_worker processes.
19
+
[repos] is a list of [(repo_path, commit_sha)] pairs.
20
+
[pin_dirs] are directories of [.opam] files pinned at version [dev].
21
+
[constraints] pins packages at exact versions.
22
+
[doc] controls whether doc dependencies are included (default [true]). *)