jon.recoil.org
this repo has no description
js_top_worker: add CRC verification to preloaded package detection
Bake module CRCs into dynamic_cmis.json when building universes, then
verify at require-time that preloaded modules match the universe version.
Three defensive checks:
- All modules loaded: package is preloaded (skip import)
- No modules loaded: package is not preloaded (import normally)
- Partial: warn and import (something is wrong)
- CRC mismatch: warn and import (version skew between binary and universe)
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
+27
-2
bin/jtw.ml
+27
-2
bin/jtw.ml
···
3
3
("dcs_url", `String dcs.dcs_url);
4
4
("dcs_toplevel_modules", `List (List.map (fun s -> `String s) dcs.dcs_toplevel_modules));
5
5
("dcs_file_prefixes", `List (List.map (fun s -> `String s) dcs.dcs_file_prefixes));
6
+
("dcs_module_crcs", `Assoc (List.map (fun (k, v) -> (k, `String v)) dcs.dcs_module_crcs));
6
7
]
8
+
9
+
(** Read the self-CRC from a .cmi file. Returns the hex digest of the
10
+
compilation unit's interface, or None if the file can't be read. *)
11
+
let cmi_self_crc cmi_path =
12
+
try
13
+
let cmi = Cmi_format.read_cmi (Fpath.to_string cmi_path) in
14
+
match cmi.Cmi_format.cmi_crcs with
15
+
| (_, Some crc) :: _ -> Some (Digest.to_hex crc)
16
+
| _ -> None
17
+
with _ -> None
18
+
19
+
(** For a list of toplevel module names and the directory containing their
20
+
.cmi files, return a (module_name, hex_crc) association list. *)
21
+
let read_module_crcs dir modules =
22
+
List.filter_map (fun modname ->
23
+
let cmi_path = Fpath.(dir / (String.uncapitalize_ascii modname ^ ".cmi")) in
24
+
match cmi_self_crc cmi_path with
25
+
| Some crc -> Some (modname, crc)
26
+
| None -> None)
27
+
modules
7
28
8
29
(** Try to relativize a path against findlib_dir. If the result contains
9
30
".." (indicating the path is in a different tree), fall back to extracting
···
58
79
| Some prefix -> Fpath.(v prefix / "lib" // d)
59
80
| None -> Fpath.(v "lib" // d)
60
81
in
82
+
let toplevel_modules = List.map String.capitalize_ascii non_hidden in
61
83
let dcs =
62
84
{
63
85
Js_top_worker.Impl.dcs_url = Fpath.to_string dcs_url_path;
64
-
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
86
+
dcs_toplevel_modules = toplevel_modules;
65
87
dcs_file_prefixes = prefixes;
88
+
dcs_module_crcs = read_module_crcs dir toplevel_modules;
66
89
}
67
90
in
68
91
( dir,
···
401
424
let prefixes = Util.StringSet.(of_list prefixes |> to_list) in
402
425
let d = relativize_or_fallback ~findlib_dir dir in
403
426
(* dcs_url is relative to the package's own findlib_index.json *)
427
+
let toplevel_modules = List.map String.capitalize_ascii non_hidden in
404
428
let dcs = {
405
429
Js_top_worker.Impl.dcs_url = Fpath.(v "lib" // d |> to_string);
406
-
dcs_toplevel_modules = List.map String.capitalize_ascii non_hidden;
430
+
dcs_toplevel_modules = toplevel_modules;
407
431
dcs_file_prefixes = prefixes;
432
+
dcs_module_crcs = read_module_crcs dir toplevel_modules;
408
433
} in
409
434
let dcs_json = Yojson.Safe.to_string (dynamic_cmis_to_json dcs) in
410
435
let dcs_dir = Fpath.(pkg_output_dir / "lib" // d) in
+45
-2
lib/findlibish.ml
+45
-2
lib/findlibish.ml
···
33
33
| None -> false
34
34
| Some g -> Symtable.is_global_defined g
35
35
36
+
let module_crc module_name =
37
+
try Some (Digest.to_hex (Env.crc_of_unit module_name))
38
+
with Not_found -> None
39
+
36
40
let is_package_preloaded (dcs : Js_top_worker.Impl.dynamic_cmis) =
37
-
List.exists is_module_available dcs.dcs_toplevel_modules
41
+
match dcs.dcs_toplevel_modules with
42
+
| [] -> false
43
+
| modules ->
44
+
let loaded = List.filter is_module_available modules in
45
+
let n_loaded = List.length loaded in
46
+
let n_total = List.length modules in
47
+
if n_loaded = 0 then false
48
+
else if n_loaded <> n_total then begin
49
+
Jslib.log
50
+
"WARNING: package partially preloaded (%d/%d modules). \
51
+
Loaded: [%s], missing: [%s]"
52
+
n_loaded n_total
53
+
(String.concat ", " loaded)
54
+
(String.concat ", "
55
+
(List.filter (fun m -> not (is_module_available m)) modules));
56
+
false
57
+
end else
58
+
(* All modules are linked. Verify CRCs match if available. *)
59
+
let mismatches = List.filter_map (fun modname ->
60
+
match List.assoc_opt modname dcs.dcs_module_crcs, module_crc modname with
61
+
| Some expected, Some actual when expected <> actual ->
62
+
Some (Printf.sprintf "%s (universe=%s binary=%s)" modname expected actual)
63
+
| _ -> None)
64
+
modules
65
+
in
66
+
match mismatches with
67
+
| [] -> true
68
+
| ms ->
69
+
Jslib.log
70
+
"WARNING: package preloaded but CRC mismatch: %s"
71
+
(String.concat ", " ms);
72
+
false
38
73
39
74
let rec read_libraries_from_pkg_defs ~library_name ~dir meta_uri pkg_expr =
40
75
try
···
121
156
json |> member "dcs_toplevel_modules" |> to_list |> List.map to_string in
122
157
let dcs_file_prefixes =
123
158
json |> member "dcs_file_prefixes" |> to_list |> List.map to_string in
124
-
Ok { Js_top_worker.Impl.dcs_url; dcs_toplevel_modules; dcs_file_prefixes }
159
+
let dcs_module_crcs =
160
+
match json |> member "dcs_module_crcs" with
161
+
| `Assoc pairs ->
162
+
List.filter_map (fun (k, v) ->
163
+
match v with `String s -> Some (k, s) | _ -> None) pairs
164
+
| _ -> []
165
+
in
166
+
Ok { Js_top_worker.Impl.dcs_url; dcs_toplevel_modules; dcs_file_prefixes;
167
+
dcs_module_crcs }
125
168
with e ->
126
169
Error (`Msg (Printf.sprintf "Failed to parse dynamic_cmis JSON: %s" (Printexc.to_string e))))
127
170