~james/scope

feat(report): serialise walks and mapping changes with replay fixtures

commit
e8f5f1b8ca985632f06e3dd63ed410c950dee329 browse tree
parent
bad0d419288bdacd5dc519179ac697656082c4e2
author
james <j@cpl0.zip>
signature
Verified ~james signed with a key registered by ~james
date
2026-10-20 15:33 UTC

5 files changed, +150 −0

examples/after added

Binary file.

examples/before added

Binary file.

lib/demo.ml added

@@ -0,0 +1,29 @@
1+open Model
2+
3+let context = {
4+ registers = { cr0 = 0x80010001L; cr2 = 0L; cr3 = 0x1000L; cr4 = 0x20L;
5+ efer = 0xd00L; rflags = 2L; rip = 0L };
6+ features = { phys_bits = 48; nx = true; gb_pages = true };
7+ root_override = None;
8+ source = "synthetic fixture"; consistency = "immutable synthetic tables";
9+ identity = "scope-demo"; domid = 0; vcpu = 0;
10+}
11+
12+let page entries =
13+ let bytes = Bytes.make 4096 '\000' in
14+ List.iter (fun (index, entry) -> Bytes.set_int64_le bytes (index * 8) entry) entries;
15+ Bytes.to_string bytes
16+
17+let frames ~after = [
18+ 0x1000L, page [0, 0x2007L];
19+ 0x2000L, page [0, 0x3007L];
20+ 0x3000L, page [2, (if after then 0x4003L else 0x4001L); 4, 0x5003L];
21+ 0x4000L, page [0, 0x9003L];
22+ 0x5000L, page [0, Int64.logor 0x8000000000000000L (if after then 0xa003L else 0x9003L)] ]
23+
24+let capture ~after = Capture.make context (List.map (fun (address, bytes) -> Address.Physical.of_int64 address, Ok bytes) (frames ~after))
25+
26+let write directory =
27+ if not (Sys.file_exists directory) then Unix.mkdir directory 0o755;
28+ Capture.save (Filename.concat directory "before") (capture ~after:false);
29+ Capture.save (Filename.concat directory "after") (capture ~after:true)

lib/json.ml added

@@ -0,0 +1,36 @@
1+type t = Null | Bool of bool | Int of int | String of string | List of t list | Object of (string * t) list
2+
3+let string s = String s
4+let hex x = String (Address.hex x)
5+let option f = function None -> Null | Some x -> f x
6+
7+let rec output channel = function
8+ | Null -> output_string channel "null"
9+ | Bool b -> output_string channel (string_of_bool b)
10+ | Int n -> output_string channel (string_of_int n)
11+ | String s ->
12+ output_char channel '"';
13+ String.iter (function
14+ | '"' -> output_string channel "\\\""
15+ | '\\' -> output_string channel "\\\\"
16+ | '\n' -> output_string channel "\\n"
17+ | '\r' -> output_string channel "\\r"
18+ | '\t' -> output_string channel "\\t"
19+ | c when Char.code c < 32 || Char.code c > 126 ->
20+ Printf.fprintf channel "\\u%04x" (Char.code c)
21+ | c -> output_char channel c) s;
22+ output_char channel '"'
23+ | List values ->
24+ output_char channel '[';
25+ List.iteri (fun i value -> if i > 0 then output_char channel ','; output channel value) values;
26+ output_char channel ']'
27+ | Object fields ->
28+ output_char channel '{';
29+ List.iteri (fun i (key, value) ->
30+ if i > 0 then output_char channel ',';
31+ output channel (String key);
32+ output_char channel ':';
33+ output channel value) fields;
34+ output_char channel '}'
35+
36+let print value = output stdout value; output_char stdout '\n'

lib/report.ml added

@@ -0,0 +1,85 @@
1+open Model
2+open Json
3+
4+let limitations = [
5+ "guest first-stage table state only; tlb and second-stage permissions are not observed";
6+ "ordinary explicit accesses only; implicit supervisor accesses and cross-page operations are not modelled";
7+ "pausing vcpus does not quiesce dma, device models, or other memory writers";
8+ "permissions describe architectural access, not speculative execution" ]
9+
10+let permissions p = Object ["writable", Bool p.writable; "user", Bool p.user; "executable", Bool p.executable]
11+
12+let context c =
13+ let r = c.registers and f = c.features in
14+ Object ["source", String c.source; "consistency", String c.consistency; "identity", String c.identity;
15+ "domid", Int c.domid; "vcpu", Int c.vcpu;
16+ "root", hex (Address.Physical.to_int64 (Model.root c)); "root_override", option hex c.root_override;
17+ "features", Object ["phys_bits", Int f.phys_bits; "nx", Bool f.nx; "gb_pages", Bool f.gb_pages];
18+ "registers", Object ["cr0", hex r.cr0; "cr2", hex r.cr2; "cr3", hex r.cr3; "cr4", hex r.cr4;
19+ "efer", hex r.efer; "rflags", hex r.rflags; "rip", hex r.rip]]
20+
21+let step (s : step) = Object ["level", Int s.level; "table", hex (Address.Physical.to_int64 s.table);
22+ "index", Int s.index; "entry_address", hex Int64.(add (Address.Physical.to_int64 s.table) (of_int (s.index * 8)));
23+ "raw", hex s.raw; "effective", permissions s.effective]
24+
25+let mapping (m : mapping) = Object [
26+ "virtual", hex (Address.Virtual.to_int64 m.virtual_address);
27+ "physical", hex (Address.Physical.to_int64 m.physical_address);
28+ "page_size", hex m.size; "permissions", permissions m.permissions; "leaf", hex m.leaf;
29+ "trace", List (List.map step m.trace)]
30+
31+let fault f = Object ["vector", Int f.vector; "error_code", Int f.error_code;
32+ "reason", String f.reason; "level", option (fun n -> Int n) f.level]
33+
34+let outcome = function
35+ | Mapped m -> Object ["status", String "mapped"; "mapping", mapping m]
36+ | Fault f -> Object ["status", String "fault"; "fault", fault f]
37+ | Incomplete reason -> Object ["status", String "incomplete"; "reason", String reason]
38+
39+let state = function
40+ | Paging.Present m -> Object ["status", String "mapped"; "mapping", mapping m]
41+ | Paging.Unknown reason -> Object ["status", String "incomplete"; "reason", String reason]
42+ | Paging.Broken reason -> Object ["status", String "invalid"; "reason", String reason]
43+
44+let region (r : Paging.region) = Object ["start", hex r.start; "length", hex r.length; "state", state r.state]
45+
46+let change (c : Analysis.change) = Object ["start", hex c.start; "length", hex c.length;
47+ "kinds", List (List.map string c.kinds); "before", option state c.before; "after", option state c.after]
48+
49+let alias (a : Analysis.alias) = Object ["physical", hex a.physical; "length", hex a.length;
50+ "writable", mapping a.writable; "executable", mapping a.executable]
51+
52+let envelope command c complete fields = Object (
53+ ["schema", String "scope.report.v1"; "command", String command; "context", context c;
54+ "complete", Bool complete; "limitations", List (List.map string limitations)] @ fields)
55+
56+let rights p = Printf.sprintf "r%c%c/%c" (if p.writable then 'w' else '-')
57+ (if p.executable then 'x' else '-') (if p.user then 'u' else 's')
58+
59+let print_context c =
60+ Printf.printf "source=%S identity=%S domid=%d vcpu=%d cr3=%s root=%s phys_bits=%d nx=%b gb_pages=%b\n"
61+ c.source c.identity c.domid c.vcpu (Address.hex c.registers.cr3)
62+ (Address.hex (Address.Physical.to_int64 (Model.root c))) c.features.phys_bits c.features.nx c.features.gb_pages;
63+ Printf.printf "consistency=%S\n" c.consistency;
64+ Printf.printf "scope=guest-table-state tlb=unobserved second-stage=unobserved\n"
65+
66+let print_step (s : step) =
67+ Printf.printf "l%d table=%s index=%03x raw=%s effective=%s\n" s.level
68+ (Address.hex (Address.Physical.to_int64 s.table)) s.index (Address.hex s.raw) (rights s.effective)
69+
70+let print_mapping m = Printf.printf "%s -> %s size=%s %s\n"
71+ (Address.hex (Address.Virtual.to_int64 m.virtual_address))
72+ (Address.hex (Address.Physical.to_int64 m.physical_address)) (Address.hex m.size) (rights m.permissions)
73+
74+let print_result result =
75+ List.iter print_step result.trace;
76+ match result.outcome with
77+ | Mapped m -> print_mapping m
78+ | Fault f -> Printf.printf "fault vector=%d error=0x%x level=%s reason=%s\n" f.vector f.error_code
79+ (match f.level with None -> "-" | Some n -> string_of_int n) f.reason
80+ | Incomplete reason -> Printf.printf "incomplete reason=%s\n" reason
81+
82+let print_region (r : Paging.region) = match r.state with
83+ | Paging.Present m -> print_mapping m
84+ | Paging.Unknown reason -> Printf.printf "%s length=%s incomplete=%s\n" (Address.hex r.start) (Address.hex r.length) reason
85+ | Paging.Broken reason -> Printf.printf "%s length=%s invalid=%s\n" (Address.hex r.start) (Address.hex r.length) reason