~james/scope

feat(cli): expose capture replay and watch commands with regression checks

commit
e557cd7d08fb8f5d6ddf4afedb5447c1e8ce23bf browse tree
parent
6c84b333c77146dbe1c7ad9d266f9e07640a5736
author
james <j@cpl0.zip>
signature
Verified ~james signed with a key registered by ~james
date
2026-10-24 11:09 UTC

5 files changed, +669 −0

bin/dune added

@@ -0,0 +1,4 @@
1+(executable
2+ (name main)
3+ (public_name scope)
4+ (libraries scope unix))

bin/main.ml added

@@ -0,0 +1,309 @@
1+open Scope
2+open Model
3+
4+exception Usage of string
5+exception Interrupted of int
6+
7+let usage = "scope 0.1.0\n\n\
8+ scope info CAPTURE\n\
9+ scope walk CAPTURE ADDRESS\n\
10+ scope explain CAPTURE ADDRESS --access read|write|execute --privilege supervisor|user\n\
11+ scope mappings CAPTURE\n\
12+ scope aliases CAPTURE\n\
13+ scope diff BEFORE AFTER [--include-ad]\n\
14+ scope capture DOMAIN OUTPUT --vcpu N --phys-bits N --nx on|off --gb-pages on|off [--pause]\n\
15+ scope watch DOMAIN DIRECTORY --vcpu N --phys-bits N --nx on|off --gb-pages on|off [--pause]\n\
16+ scope import TRANSCRIPT OUTPUT\n\
17+ scope demo DIRECTORY\n\n\
18+addresses are unsigned decimal or 0x-prefixed hexadecimal\n\
19+exit status: 0 success, 1 fault or findings, 2 incomplete or operational failure, 64 usage\n"
20+
21+type options = {
22+ mutable json : bool;
23+ mutable root : int64 option;
24+ mutable max_entries : int;
25+ mutable max_pages : int;
26+ mutable max_pairs : int;
27+ mutable include_ad : bool;
28+ mutable access : access option;
29+ mutable privilege : privilege option;
30+ mutable ac : bool option;
31+ mutable vcpu : int option;
32+ mutable phys_bits : int option;
33+ mutable nx : bool option;
34+ mutable gb_pages : bool option;
35+ mutable pause : bool;
36+ mutable first : int64 option;
37+ mutable last : int64 option;
38+ mutable source : string;
39+ mutable interval : float;
40+ mutable count : int;
41+ mutable retain : int;
42+ mutable scan_aliases : bool;
43+}
44+
45+let boolean = function "on" -> true | "off" -> false | _ -> raise (Usage "expected on or off")
46+let required name = function Some value -> value | None -> raise (Usage ("missing " ^ name))
47+
48+let parse () =
49+ let options = { json = false; root = None; max_entries = 2_000_000; max_pages = 65536;
50+ max_pairs = 100_000; include_ad = false; access = None; privilege = None; ac = None;
51+ vcpu = None; phys_bits = None; nx = None; gb_pages = None; pause = false;
52+ first = None; last = None; source = "offline import";
53+ interval = 2.; count = 0; retain = 32; scan_aliases = false } in
54+ let positional = ref [] in
55+ let seen = Hashtbl.create 16 in
56+ let wrap flag action = fun value ->
57+ if Hashtbl.mem seen flag then raise (Usage ("duplicate option " ^ flag));
58+ Hashtbl.add seen flag ();
59+ action value
60+ in
61+ let specs = [
62+ "--interval", Arg.Float (wrap "--interval" (fun n -> options.interval <- n)), "SECONDS delay after each watch sample";
63+ "--count", Arg.Int (wrap "--count" (fun n -> options.count <- n)), "N watch samples, zero means until interrupted";
64+ "--retain", Arg.Int (wrap "--retain" (fun n -> options.retain <- n)), "N evidence pairs to retain";
65+ "--aliases", Arg.Unit (wrap "--aliases" (fun () -> options.scan_aliases <- true)), " scan writable/executable aliases while watching";
66+ "--json", Arg.Unit (wrap "--json" (fun () -> options.json <- true)), " emit scope.report.v1 json";
67+ "--root", Arg.String (wrap "--root" (fun s -> options.root <- Some (Address.parse s))), "ADDRESS select root while preserving captured cr3";
68+ "--max-entries", Arg.Int (wrap "--max-entries" (fun n -> options.max_entries <- n)), "N traversal budget";
69+ "--max-pages", Arg.Int (wrap "--max-pages" (fun n -> options.max_pages <- n)), "N capture page budget";
70+ "--max-pairs", Arg.Int (wrap "--max-pairs" (fun n -> options.max_pairs <- n)), "N alias output budget";
71+ "--include-ad", Arg.Unit (wrap "--include-ad" (fun () -> options.include_ad <- true)), " include accessed and dirty changes";
72+ "--access", Arg.Symbol (["read"; "write"; "execute"], wrap "--access" (fun s ->
73+ options.access <- Some (match s with "read" -> Read | "write" -> Write | _ -> Execute))), " requested access";
74+ "--privilege", Arg.Symbol (["supervisor"; "user"], wrap "--privilege" (fun s ->
75+ options.privilege <- Some (if s = "user" then User else Supervisor))), " access privilege";
76+ "--ac", Arg.String (wrap "--ac" (fun s -> options.ac <- Some (boolean s))), "on|off override captured ac for explicit data accesses";
77+ "--vcpu", Arg.Int (wrap "--vcpu" (fun n -> options.vcpu <- Some n)), "N vcpu to capture";
78+ "--phys-bits", Arg.Int (wrap "--phys-bits" (fun n -> options.phys_bits <- Some n)), "N guest maxphyaddr";
79+ "--nx", Arg.String (wrap "--nx" (fun s -> options.nx <- Some (boolean s))), "on|off guest nx capability";
80+ "--gb-pages", Arg.String (wrap "--gb-pages" (fun s -> options.gb_pages <- Some (boolean s))), "on|off guest 1 gib page capability";
81+ "--pause", Arg.Unit (wrap "--pause" (fun () -> options.pause <- true)), " hold a controller pause during capture";
82+ "--start", Arg.String (wrap "--start" (fun s -> options.first <- Some (Address.parse s))), "ADDRESS select overlapping regions";
83+ "--end", Arg.String (wrap "--end" (fun s -> options.last <- Some (Address.parse s))), "ADDRESS inclusive range end";
84+ "--source", Arg.String (wrap "--source" (fun s -> options.source <- s)), "TEXT import provenance";
85+ ] in
86+ Arg.parse_argv Sys.argv specs (fun value -> positional := value :: !positional) usage;
87+ if options.max_entries < 1 || options.max_pages < 1 || options.max_pairs < 1 then raise (Usage "budgets must be positive");
88+ if not (Float.is_finite options.interval) || options.interval <= 0. || options.count < 0 || options.retain < 1 then
89+ raise (Usage "watch interval and retention must be positive; count must be nonnegative");
90+ (match options.first, options.last with Some a, Some b when Address.compare a b > 0 ->
91+ raise (Usage "range start exceeds range end") | _ -> ());
92+ options, List.rev !positional, seen
93+
94+let selected options (region : Paging.region) =
95+ (match options.first with None -> true | Some first -> Address.compare (Paging.last region) first >= 0) &&
96+ (match options.last with None -> true | Some last -> Address.compare region.start last <= 0)
97+
98+let complete regions = List.for_all (fun (region : Paging.region) ->
99+ match region.state with Paging.Unknown _ -> false | _ -> true) regions
100+
101+let invalid regions = List.exists (fun (region : Paging.region) ->
102+ match region.state with Paging.Broken _ -> true | _ -> false) regions
103+
104+let run options positional seen =
105+ let command = match positional with command :: _ -> command | [] -> raise (Usage usage) in
106+ let allowed = ["--json"] @ (match command with
107+ | "info" -> []
108+ | "walk" -> ["--root"]
109+ | "explain" -> ["--root"; "--access"; "--privilege"; "--ac"]
110+ | "mappings" -> ["--root"; "--max-entries"; "--start"; "--end"]
111+ | "aliases" -> ["--root"; "--max-entries"; "--max-pairs"; "--start"; "--end"]
112+ | "diff" -> ["--root"; "--max-entries"; "--start"; "--end"; "--include-ad"]
113+ | "capture" -> ["--root"; "--max-pages"; "--vcpu"; "--phys-bits"; "--nx"; "--gb-pages"; "--pause"]
114+ | "watch" -> ["--root"; "--max-pages"; "--max-entries"; "--max-pairs"; "--vcpu"; "--phys-bits";
115+ "--nx"; "--gb-pages"; "--pause"; "--interval"; "--count"; "--retain"; "--aliases";
116+ "--include-ad"; "--start"; "--end"]
117+ | "import" -> ["--source"]
118+ | "demo" -> []
119+ | _ -> raise (Usage ("unknown command: " ^ command))) in
120+ Hashtbl.iter (fun flag () -> if not (List.mem flag allowed) then raise (Usage (flag ^ " does not apply to " ^ command))) seen;
121+ let load path =
122+ let capture = Capture.load path in
123+ match options.root with None -> capture | Some root -> Capture.with_root capture root
124+ in
125+ let enumerate capture = Paging.enumerate ~max_entries:options.max_entries (Capture.context capture) (Capture.read capture) in
126+ let output_context capture = if not options.json then Report.print_context (Capture.context capture) in
127+ let emit capture complete fields = Json.print (Report.envelope command (Capture.context capture) complete fields) in
128+ match positional with
129+ | ["watch"; domain; directory] ->
130+ let domid = try int_of_string domain with Failure _ -> raise (Usage "invalid domain id") in
131+ let vcpu = required "--vcpu" options.vcpu in
132+ let features = { phys_bits = required "--phys-bits" options.phys_bits;
133+ nx = required "--nx" options.nx; gb_pages = required "--gb-pages" options.gb_pages } in
134+ let capture () = Xen.capture ~domid ~vcpu ~pause:options.pause ~features ~root:options.root ~max_pages:options.max_pages in
135+ let emit (event : Watch.event) =
136+ let context = Capture.context event.after in
137+ if options.json then Json.print (Report.envelope "watch" context event.complete [
138+ "event", Json.String event.kind; "sample", Json.Int event.sample;
139+ "time", Json.String (Printf.sprintf "%.6f" event.time);
140+ "evidence", (if event.directory = "" then Json.Null else Json.String event.directory);
141+ "summary", Json.Object ["mappings", Json.Int event.mappings; "mapped_virtual_bytes", Json.hex event.bytes;
142+ "executable", Json.Int event.executable; "writable", Json.Int event.writable; "huge", Json.Int event.huge];
143+ "context_changes", Json.List (List.map Json.string event.context_changes);
144+ "changes", Json.List (List.map Report.change event.changes);
145+ "aliases", Json.List (List.map Report.alias event.aliases)])
146+ else begin
147+ Printf.printf "time=%.3f sample=%d event=%s root=%s mappings=%d bytes=%s executable=%d writable=%d huge=%d complete=%b\n"
148+ event.time event.sample event.kind (Address.hex (Address.Physical.to_int64 (Model.root context)))
149+ event.mappings (Address.hex event.bytes) event.executable event.writable event.huge event.complete;
150+ List.iter (fun (change : Analysis.change) ->
151+ Printf.printf " %s length=%s changes=%s\n" (Address.hex change.start) (Address.hex change.length)
152+ (String.concat "," change.kinds);
153+ List.iter (fun (label, state) -> match state with
154+ | Some (Paging.Present m) -> Printf.printf " %s physical=%s page_size=%s %s\n"
155+ label (Address.hex (Address.Physical.to_int64 m.physical_address)) (Address.hex m.size) (Report.rights m.permissions)
156+ | _ -> ()) ["before", change.before; "after", change.after]) event.changes;
157+ if event.directory <> "" then Printf.printf " evidence=%S aliases=%d context_changes=%s\n"
158+ event.directory (List.length event.aliases) (String.concat "," event.context_changes);
159+ if event.directory <> "" then List.iter (fun (alias : Analysis.alias) ->
160+ Printf.printf " alias physical=%s length=%s writable=%s executable=%s\n"
161+ (Address.hex alias.physical) (Address.hex alias.length)
162+ (Address.hex (Address.Virtual.to_int64 alias.writable.virtual_address))
163+ (Address.hex (Address.Virtual.to_int64 alias.executable.virtual_address))) event.aliases
164+ end;
165+ flush stdout
166+ in
167+ (try Watch.run ~capture ~wait:Unix.sleepf ~emit ~directory ~interval:options.interval
168+ ~count:options.count ~retain:options.retain ~max_entries:options.max_entries ~max_pairs:options.max_pairs
169+ ~include_ad:options.include_ad ~scan_aliases:options.scan_aliases ~selected:(selected options) ()
170+ with Interrupted _ -> 0)
171+ | ["demo"; directory] ->
172+ Demo.write directory;
173+ if options.json then Json.print (Json.Object ["schema", Json.String "scope.report.v1";
174+ "command", Json.String "demo"; "directory", Json.String directory])
175+ else Printf.printf "captures=%s/before,%s/after source=synthetic\n" directory directory;
176+ 0
177+ | ["import"; transcript; destination] ->
178+ let capture = Capture.import ~source:options.source transcript in
179+ let complete = Capture.complete capture in
180+ Capture.save destination capture;
181+ if options.json then emit capture complete ["path", Json.String destination; "pages", Json.Int (Capture.pages capture)]
182+ else Printf.printf "capture=%s pages=%d complete=%b\n" destination (Capture.pages capture) complete;
183+ if complete then 0 else 2
184+ | ["capture"; domain; destination] ->
185+ let domid = try int_of_string domain with Failure _ -> raise (Usage "invalid domain id") in
186+ let vcpu = required "--vcpu" options.vcpu in
187+ let features = { phys_bits = required "--phys-bits" options.phys_bits;
188+ nx = required "--nx" options.nx; gb_pages = required "--gb-pages" options.gb_pages } in
189+ let capture = Xen.capture ~domid ~vcpu ~pause:options.pause ~features ~root:options.root ~max_pages:options.max_pages in
190+ let complete = Capture.complete capture in
191+ Capture.save destination capture;
192+ output_context capture;
193+ if options.json then emit capture complete ["path", Json.String destination; "pages", Json.Int (Capture.pages capture)]
194+ else Printf.printf "capture=%s pages=%d complete=%b\n" destination (Capture.pages capture) complete;
195+ if complete then 0 else 2
196+ | ["info"; path] ->
197+ let capture = load path in
198+ let complete = Capture.complete capture in
199+ output_context capture;
200+ if options.json then emit capture complete ["pages", Json.Int (Capture.pages capture); "xen_available", Json.Bool (Xen.available ())]
201+ else Printf.printf "pages=%d complete=%b xen_available=%b\n" (Capture.pages capture) complete (Xen.available ());
202+ if complete then 0 else 2
203+ | [("walk" | "explain"); path; address] ->
204+ let capture = load path in
205+ let context = Capture.context capture in
206+ let address = Address.Virtual.of_int64 (Address.parse address) in
207+ let request = if command = "walk" then None else Some {
208+ access = required "--access" options.access;
209+ privilege = required "--privilege" options.privilege;
210+ ac = Option.value options.ac ~default:(Address.bit context.registers.rflags 18) } in
211+ let result = match request with
212+ | None -> Paging.walk context (Capture.read capture) address
213+ | Some request -> Paging.explain context (Capture.read capture) address request
214+ in
215+ let complete = match result.outcome with Incomplete _ -> false | _ -> true in
216+ output_context capture;
217+ if options.json then emit capture complete [
218+ "address", Json.hex (Address.Virtual.to_int64 address);
219+ "error_code_scope", Json.String (if request = None then "structural_bits_only" else "request");
220+ "request", Json.option (fun (request : request) -> Json.Object ["access", Json.String (access_name request.access);
221+ "privilege", Json.String (privilege_name request.privilege); "ac", Json.Bool request.ac]) request;
222+ "trace", Json.List (List.map Report.step result.trace); "result", Report.outcome result.outcome]
223+ else begin
224+ if request = None then print_endline "access=unspecified error_code=structural-bits-only";
225+ Option.iter (fun (request : request) -> Printf.printf "access=%s privilege=%s ac=%b\n"
226+ (access_name request.access) (privilege_name request.privilege) request.ac) request;
227+ Report.print_result result
228+ end;
229+ (match result.outcome with Mapped _ -> 0 | Fault _ -> 1 | Incomplete _ -> 2)
230+ | ["mappings"; path] ->
231+ let capture = load path in
232+ let regions = enumerate capture |> List.filter (selected options) in
233+ let complete = complete regions in
234+ output_context capture;
235+ if options.json then emit capture complete ["regions", Json.List (List.map Report.region regions)]
236+ else List.iter Report.print_region regions;
237+ if not complete then 2 else if invalid regions then 1 else 0
238+ | ["aliases"; path] ->
239+ let capture = load path in
240+ let regions = enumerate capture |> List.filter (selected options) in
241+ let complete = complete regions in
242+ let aliases = Analysis.aliases ~max_pairs:options.max_pairs regions in
243+ output_context capture;
244+ if options.json then emit capture complete ["aliases", Json.List (List.map Report.alias aliases);
245+ "regions", Json.List (List.filter_map (fun region ->
246+ match region.Paging.state with Paging.Present _ -> None | _ -> Some (Report.region region)) regions)]
247+ else begin
248+ List.iter (fun (alias : Analysis.alias) ->
249+ Printf.printf "physical=%s length=%s writable=%s executable=%s\n"
250+ (Address.hex alias.physical) (Address.hex alias.length)
251+ (Address.hex (Address.Virtual.to_int64 alias.writable.virtual_address))
252+ (Address.hex (Address.Virtual.to_int64 alias.executable.virtual_address));
253+ List.iter Report.print_step alias.writable.trace;
254+ List.iter Report.print_step alias.executable.trace) aliases;
255+ List.iter (fun region -> match region.Paging.state with Paging.Present _ -> () | _ -> Report.print_region region) regions
256+ end;
257+ if not complete then 2 else if aliases = [] && not (invalid regions) then 0 else 1
258+ | ["diff"; before; after] ->
259+ let a = load before and b = load after in
260+ let context_changes = Model.context_changes (Capture.context a) (Capture.context b) in
261+ let ra = enumerate a and rb = enumerate b in
262+ let changes = Analysis.diff ~include_ad:options.include_ad ra rb |> List.filter (fun (c : Analysis.change) ->
263+ selected options { Paging.start = c.start; length = c.length; state = Paging.Unknown "" }) in
264+ let complete = not (List.exists (fun (c : Analysis.change) -> List.mem "incomplete" c.kinds) changes) in
265+ if options.json then emit a complete ["after_context", Report.context (Capture.context b);
266+ "context_changes", Json.List (List.map Json.string context_changes);
267+ "include_ad", Json.Bool options.include_ad; "changes", Json.List (List.map Report.change changes)]
268+ else begin
269+ Report.print_context (Capture.context a);
270+ print_endline "after:";
271+ Report.print_context (Capture.context b);
272+ Printf.printf "context_changes=%s include_ad=%b\n" (String.concat "," context_changes) options.include_ad;
273+ List.iter (fun (c : Analysis.change) ->
274+ Printf.printf "%s length=%s changes=%s\n" (Address.hex c.start) (Address.hex c.length) (String.concat "," c.kinds);
275+ let print label = function
276+ | None -> Printf.printf " %s absent\n" label
277+ | Some (Paging.Present m) -> Printf.printf " %s physical=%s page_size=%s %s leaf=%s\n" label
278+ (Address.hex (Address.Physical.to_int64 m.physical_address)) (Address.hex m.size)
279+ (Report.rights m.permissions) (Address.hex m.leaf)
280+ | Some (Paging.Unknown reason) -> Printf.printf " %s incomplete=%s\n" label reason
281+ | Some (Paging.Broken reason) -> Printf.printf " %s invalid=%s\n" label reason
282+ in
283+ print "before" c.before;
284+ print "after" c.after) changes
285+ end;
286+ if not complete then 2 else if changes = [] && context_changes = [] then 0 else 1
287+ | _ -> raise (Usage ("wrong arguments for " ^ command ^ "\n" ^ usage))
288+
289+let () =
290+ Sys.set_signal Sys.sigint (Sys.Signal_handle (fun signal -> raise (Interrupted signal)));
291+ Sys.set_signal Sys.sigterm (Sys.Signal_handle (fun signal -> raise (Interrupted signal)));
292+ let json = Array.exists ((=) "--json") Sys.argv in
293+ let fail code reason =
294+ if json then Json.output stderr (Json.Object ["schema", Json.String "scope.report.v1";
295+ "error", Json.String reason; "complete", Json.Bool false])
296+ else Printf.eprintf "scope: %s\n" reason;
297+ if json then output_char stderr '\n';
298+ exit code
299+ in
300+ try
301+ let options, positional, seen = parse () in
302+ exit (run options positional seen)
303+ with
304+ | Usage reason | Arg.Bad reason -> fail 64 reason
305+ | Arg.Help text -> print_string text; exit 0
306+ | Invalid_argument reason | Failure reason | Sys_error reason | Model.Limit reason -> fail 2 reason
307+ | Fun.Finally_raised exn -> fail 2 ("cleanup failed: " ^ Printexc.to_string exn)
308+ | Unix.Unix_error (error, operation, path) -> fail 2 (operation ^ " " ^ path ^ ": " ^ Unix.error_message error)
309+ | Interrupted signal -> fail 2 (Printf.sprintf "interrupted by signal %d" signal)

test/check.ml added

@@ -0,0 +1,273 @@
1+open Scope
2+open Model
3+
4+let count = ref 0
5+let check condition message = incr count; if not condition then failwith message
6+let virtual_address = Address.Virtual.of_int64
7+let physical_address = Address.Physical.of_int64
8+let supervisor access = { access; privilege = Supervisor; ac = false }
9+let user access = { access; privilege = User; ac = false }
10+
11+let capture ?(context = Demo.context) pages =
12+ Capture.make context (List.map (fun (address, page) -> physical_address address, Ok page) pages)
13+
14+let tables ?(upper = 7L) ?(middle = 7L) ?(parent = 7L) ?(leaf = 7L) () = [
15+ 0x1000L, Demo.page [0, Int64.logor 0x2000L upper];
16+ 0x2000L, Demo.page [0, Int64.logor 0x3000L middle];
17+ 0x3000L, Demo.page [0, Int64.logor 0x4000L parent];
18+ 0x4000L, Demo.page [0, Int64.logor 0x9000L leaf] ]
19+
20+let explain capture ?(address = 0L) request =
21+ Paging.explain (Capture.context capture) (Capture.read capture) (virtual_address address) request
22+
23+let expect_fault ?level vector code result = match result.outcome with
24+ | Fault f ->
25+ check (f.vector = vector) "fault vector";
26+ check (f.error_code = code) (Printf.sprintf "error code: expected %x got %x (%s)" code f.error_code f.reason);
27+ Option.iter (fun level -> check (f.level = Some level) "fault level") level
28+ | _ -> failwith "expected fault"
29+
30+let expect_mapped result = match result.outcome with
31+ | Mapped m -> check true "mapped"; m
32+ | Fault f -> failwith ("unexpected fault: " ^ f.reason)
33+ | Incomplete reason -> failwith ("unexpected incomplete: " ^ reason)
34+
35+let rejects action =
36+ check (try action (); false with Invalid_argument _ | Model.Limit _ -> true) "expected rejection"
37+
38+let permissions () =
39+ for upper = 0 to 7 do
40+ for middle = 0 to 7 do
41+ for parent = 0 to 7 do
42+ for leaf = 0 to 7 do
43+ let flags x = Int64.of_int (1 lor ((x land 1) lsl 1) lor ((x land 2) lsl 1))
44+ |> fun bits -> if x land 4 <> 0 then Int64.logor bits Int64.min_int else bits in
45+ let capture = capture (tables ~upper:(flags upper) ~middle:(flags middle)
46+ ~parent:(flags parent) ~leaf:(flags leaf) ()) in
47+ let mapping = expect_mapped (Paging.walk (Capture.context capture) (Capture.read capture) (virtual_address 0L)) in
48+ check (mapping.permissions.writable = (upper land middle land parent land leaf land 1 <> 0)) "write accumulation";
49+ check (mapping.permissions.user = (upper land middle land parent land leaf land 2 <> 0)) "user accumulation";
50+ check (mapping.permissions.executable = ((upper lor middle lor parent lor leaf) land 4 = 0)) "nx accumulation"
51+ done
52+ done
53+ done
54+ done;
55+ let c = capture (tables ~parent:5L ()) in
56+ expect_fault ~level:2 14 3 (explain c (supervisor Write));
57+ expect_fault ~level:2 14 7 (explain c (user Write));
58+ let context = { Demo.context with registers = { Demo.context.registers with cr0 = 0x80000001L } } in
59+ ignore (expect_mapped (explain (capture ~context (tables ~parent:5L ())) (supervisor Write)));
60+ expect_fault 14 5 (explain (capture (tables ~upper:3L ())) (user Read));
61+ expect_fault 14 17 (explain (capture (tables ~parent:0x8000000000000007L ())) (supervisor Execute));
62+ let context = { Demo.context with registers = { Demo.context.registers with cr4 = 0x100020L } } in
63+ expect_fault 14 17 (explain (capture ~context (tables ())) (supervisor Execute));
64+ let context = { Demo.context with registers = { Demo.context.registers with cr4 = 0x200020L } } in
65+ let c = capture ~context (tables ()) in
66+ expect_fault 14 1 (explain c (supervisor Read));
67+ expect_fault 14 3 (explain c (supervisor Write));
68+ ignore (expect_mapped (explain c { access = Write; privilege = Supervisor; ac = true }));
69+ ignore (expect_mapped (explain c (supervisor Execute)))
70+
71+let translation () =
72+ let c = capture (tables ()) in
73+ let m = expect_mapped (explain c ~address:0xabcL (supervisor Read)) in
74+ check (Address.Physical.to_int64 m.physical_address = 0x9abcL) "4k offset";
75+ expect_fault 13 0 (explain c ~address:0x0000800000000000L (supervisor Read));
76+ expect_fault 13 0 (explain c ~address:0xffff7fffffffffffL (supervisor Read));
77+ let c = capture [0x1000L, Demo.page [511, 0x2007L]; 0x2000L, Demo.page [511, 0x3007L];
78+ 0x3000L, Demo.page [511, 0x4007L]; 0x4000L, Demo.page [511, 0x9007L]] in
79+ let m = expect_mapped (explain c ~address:(-1L) (supervisor Read)) in
80+ check (Address.Physical.to_int64 m.physical_address = 0x9fffL) "upper canonical address";
81+ let regions = Paging.enumerate (Capture.context c) (Capture.read c) in
82+ check (List.length regions = 1 && (List.hd regions).start = 0xfffffffffffff000L) "upper enumeration";
83+ let c = capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x3007L];
84+ 0x3000L, Demo.page [0, 0x201087L]] in
85+ let m = expect_mapped (explain c ~address:0x1fffffL (supervisor Read)) in
86+ check (m.size = 0x200000L && Address.Physical.to_int64 m.physical_address = 0x3fffffL) "2m pat and offset";
87+ let c = capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x40001087L]] in
88+ let m = expect_mapped (explain c ~address:0x3fffffffL (supervisor Read)) in
89+ check (m.size = 0x40000000L && Address.Physical.to_int64 m.physical_address = 0x7fffffffL) "1g pat and offset";
90+ let c = capture (tables ~leaf:0x87L ()) in
91+ ignore (expect_mapped (explain c (supervisor Read)));
92+ let context = { Demo.context with registers = { Demo.context.registers with cr3 = 0x1abcL; cr4 = 0x20020L } } in
93+ ignore (expect_mapped (explain (capture ~context (tables ())) (supervisor Read)))
94+
95+let invalid () =
96+ expect_fault ~level:4 14 9 (explain (capture (tables ~upper:0x87L ())) (supervisor Read));
97+ expect_fault ~level:1 14 9 (explain (capture (tables ~leaf:0x1000000000007L ())) (supervisor Read));
98+ let context = { Demo.context with registers = { Demo.context.registers with efer = 0x500L } } in
99+ expect_fault 14 9 (explain (capture ~context (tables ~leaf:0x8000000000000007L ())) (supervisor Read));
100+ let context = { Demo.context with features = { Demo.context.features with gb_pages = false } } in
101+ let c = capture ~context [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x87L]] in
102+ expect_fault 14 9 (explain c (supervisor Read));
103+ let c = capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x3007L]; 0x3000L, Demo.page [0, 0x2087L]] in
104+ expect_fault 14 9 (explain c (supervisor Read));
105+ let c = capture (tables ~parent:0L ()) in
106+ expect_fault ~level:2 14 0 (explain c (supervisor Read));
107+ let c = capture (tables ~parent:0L ~upper:1L ()) in
108+ expect_fault ~level:2 14 6 (explain c (user Write));
109+ List.iter (fun bit -> rejects (fun () ->
110+ Model.validate { Demo.context with registers = { Demo.context.registers with cr4 = Int64.logor 0x20L (Int64.shift_left 1L bit) } })) [12; 22; 23; 24];
111+ let context = { Demo.context with registers = { Demo.context.registers with cr3 = 0x1abcL } } in
112+ ignore (expect_mapped (explain (capture ~context (tables ())) (supervisor Read)));
113+ rejects (fun () -> ignore (Address.parse "-1"));
114+ rejects (fun () -> ignore (Address.parse "18446744073709551616"));
115+ check (Address.parse "18446744073709551615" = -1L) "unsigned decimal parsing"
116+
117+let incomplete () =
118+ let c = capture [0x1000L, Demo.page [0, 0x2007L]] in
119+ check (match (explain c (supervisor Read)).outcome with Incomplete _ -> true | _ -> false) "missing table is incomplete";
120+ let regions = Paging.enumerate (Capture.context c) (Capture.read c) in
121+ check (List.length regions = 1 && (List.hd regions).length = 0x8000000000L) "missing subtree range";
122+ let c = Capture.make Demo.context [] in
123+ let regions = Paging.enumerate Demo.context (Capture.read c) in
124+ check (List.length regions = 2) "missing root covers both canonical halves";
125+ let c = Demo.capture ~after:false in
126+ rejects (fun () -> ignore (Paging.enumerate ~max_entries:1 Demo.context (Capture.read c)));
127+ rejects (fun () -> ignore (Capture.collect ~max_pages:1 Demo.context (Capture.read c)));
128+ let reads = ref 0 in
129+ let collected = Capture.collect Demo.context (fun address -> incr reads; Capture.read c address) in
130+ check (!reads = 5 && Capture.pages collected = 5) "capture memoises table frames"
131+
132+let regions capture = Paging.enumerate (Capture.context capture) (Capture.read capture)
133+
134+let diff () =
135+ let a = Demo.capture ~after:false and b = Demo.capture ~after:true in
136+ let changes = Analysis.diff (regions a) (regions b) in
137+ check (List.length changes = 2) "demo diff count";
138+ check ((List.hd changes).kinds = ["permissions"]) "parent permission diff";
139+ check ((List.nth changes 1).kinds = ["backing"]) "backing diff";
140+ check (Analysis.diff (regions a) (regions a) = []) "identity diff";
141+ let a = capture (tables ()) in
142+ let b = capture (tables ~leaf:0x67L ()) in
143+ check (Analysis.diff (regions a) (regions b) = []) "ignore ad by default";
144+ check ((List.hd (Analysis.diff ~include_ad:true (regions a) (regions b))).kinds = ["accessed_dirty"]) "include ad";
145+ let huge = capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x3007L]; 0x3000L, Demo.page [0, 0x87L]] in
146+ let small = capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x3007L];
147+ 0x3000L, Demo.page [0, 0x4007L]; 0x4000L, Demo.page (List.init 512 (fun index -> index, Int64.logor 7L (Int64.of_int (index * 4096))))] in
148+ let changes = Analysis.diff (regions huge) (regions small) in
149+ check (List.length changes = 512 && List.for_all (fun (c : Analysis.change) -> c.kinds = ["page_size"]) changes) "huge split preserves backing";
150+ let partial = Capture.make Demo.context [] in
151+ let changes = Analysis.diff (regions partial) (regions a) in
152+ check (List.for_all (fun (c : Analysis.change) -> c.kinds = ["incomplete"]) changes) "incomplete is not removal"
153+
154+let aliases () =
155+ let pairs = Analysis.aliases (regions (Demo.capture ~after:false)) in
156+ check (List.length pairs = 1) "demo alias";
157+ let pair = List.hd pairs in
158+ check (pair.physical = 0x9000L && pair.length = 4096L) "alias overlap";
159+ check (Analysis.aliases (regions (Demo.capture ~after:true)) = []) "demo resolved alias";
160+ let make_mapping va pa size permissions = {
161+ virtual_address = virtual_address va; physical_address = physical_address pa;
162+ size; permissions; leaf = 0L; trace = [] } in
163+ let writable = { unrestricted with executable = false } in
164+ let executable = { unrestricted with writable = false } in
165+ let a = make_mapping 0L 0x200000L 0x200000L executable in
166+ let b = make_mapping 0x800000L 0x201000L 4096L writable in
167+ let pairs = Analysis.aliases [
168+ { Paging.start = 0L; length = a.size; state = Paging.Present a };
169+ { Paging.start = 0x800000L; length = b.size; state = Paging.Present b } ] in
170+ check (List.length pairs = 1 && (List.hd pairs).physical = 0x201000L && (List.hd pairs).length = 4096L) "partial huge alias"
171+
172+let codec () =
173+ let path = Filename.temp_file "scope" ".capture" in
174+ Fun.protect ~finally:(fun () -> Sys.remove path) (fun () ->
175+ let original = Demo.capture ~after:false in
176+ Capture.save path original;
177+ let loaded = Capture.load path in
178+ check (Capture.context original = Capture.context loaded) "context roundtrip";
179+ check (regions original = regions loaded) "table roundtrip";
180+ let channel = open_out_gen [Open_wronly; Open_binary] 0o600 path in
181+ seek_out channel 32;
182+ output_char channel '\255';
183+ close_out channel;
184+ rejects (fun () -> ignore (Capture.load path)));
185+ rejects (fun () -> ignore (Capture.make Demo.context [physical_address 0x1000L, Ok "short"]));
186+ rejects (fun () -> ignore (Capture.make Demo.context [physical_address 0x1001L, Ok (Demo.page [])]));
187+ rejects (fun () -> ignore (capture [0x1000L, Demo.page []; 0x1000L, Demo.page []]))
188+
189+let generated () =
190+ let random = Random.State.make [|0x5c0; 0x2026|] in
191+ let generate () =
192+ let entries = List.init 64 (fun index ->
193+ let frame = Random.State.int random 16 in
194+ let flags = Int64.of_int (1 lor (Random.State.int random 4 lsl 1)) in
195+ let flags = if Random.State.bool random then Int64.logor flags Int64.min_int else flags in
196+ index, if Random.State.int random 4 = 0 then 0L else Int64.logor (Int64.of_int (frame * 4096)) flags) in
197+ capture [0x1000L, Demo.page [0, 0x2007L]; 0x2000L, Demo.page [0, 0x3007L];
198+ 0x3000L, Demo.page [0, 0x4007L]; 0x4000L, Demo.page entries]
199+ in
200+ for _ = 1 to 64 do
201+ let a = generate () and b = generate () in
202+ let changes = Analysis.diff (regions a) (regions b) in
203+ for index = 0 to 63 do
204+ let address = Int64.of_int (index * 4096) in
205+ let state capture = match (explain capture ~address (supervisor Read)).outcome with
206+ | Mapped m -> Some (Paging.Present m)
207+ | Fault _ -> None
208+ | Incomplete _ -> failwith "generated graph unexpectedly incomplete"
209+ in
210+ let expected = Analysis.differences ~include_ad:false (state a) (state b) in
211+ let observed = List.find_opt (fun (c : Analysis.change) ->
212+ Address.compare address c.start >= 0 && Address.compare address (Int64.pred (Int64.add c.start c.length)) <= 0) changes
213+ |> Option.map (fun (c : Analysis.change) -> c.kinds) |> Option.value ~default:[] in
214+ check (expected = observed) "interval diff agrees with point translations"
215+ done;
216+ let mappings = regions a |> List.filter_map (fun r -> match r.Paging.state with Paging.Present m -> Some m | _ -> None) in
217+ let physical m = Address.Physical.to_int64 m.physical_address in
218+ let virtual_raw m = Address.Virtual.to_int64 m.virtual_address in
219+ let expected = List.concat_map (fun w -> List.filter_map (fun x ->
220+ if w.permissions.writable && x.permissions.executable && virtual_raw w <> virtual_raw x && physical w = physical x then
221+ Some (physical w, 4096L, virtual_raw w, virtual_raw x) else None) mappings) mappings |> List.sort compare in
222+ let actual = Analysis.aliases (regions a) |> List.map (fun (a : Analysis.alias) ->
223+ a.physical, a.length, virtual_raw a.writable, virtual_raw a.executable) |> List.sort compare in
224+ check (expected = actual) "alias sweep agrees with pairwise overlap oracle"
225+ done;
226+ let self = capture [0x1000L, Demo.page [0, 0x1007L]] in
227+ let reads = ref 0 in
228+ let closed = Capture.collect Demo.context (fun address -> incr reads; Capture.read self address) in
229+ check (!reads = 1 && Capture.pages closed = 1) "recursive mapping is read once across levels";
230+ ignore (expect_mapped (explain closed (supervisor Read)));
231+ let context = { Demo.context with registers = { Demo.context.registers with cr3 = 0x1000L } } in
232+ let exploding = capture ~context [0x1000L, Demo.page (List.init 512 (fun index -> index, 0x1007L))] in
233+ rejects (fun () -> ignore (Paging.enumerate ~max_entries:4096 context (Capture.read exploding)))
234+
235+let watch () =
236+ let base = Filename.temp_file "scopewatch" "" in
237+ Sys.remove base;
238+ let a = Demo.capture ~after:false and b = Demo.capture ~after:true in
239+ let switched = capture ~context:{ Demo.context with registers = { Demo.context.registers with cr3 = 0x6000L } }
240+ ((0x6000L, Demo.page [0, 0x2007L]) :: Demo.frames ~after:true) in
241+ let samples = ref [a; b; b; Capture.make Demo.context []; b; switched] in
242+ let events = ref [] in
243+ let capture () = match !samples with x :: xs -> samples := xs; x | [] -> failwith "sample exhaustion" in
244+ let status = Watch.run ~capture ~wait:(fun _ -> ()) ~emit:(fun event -> events := event :: !events)
245+ ~directory:base ~interval:0.1 ~count:6 ~retain:2 ~max_entries:10000 ~max_pairs:100
246+ ~include_ad:false ~scan_aliases:true ~selected:(fun _ -> true) () in
247+ check (status = 2) "watch remembers incomplete samples";
248+ let events = List.rev !events in
249+ check (List.map (fun (e : Watch.event) -> e.kind) events =
250+ ["baseline"; "change"; "sample"; "incomplete"; "sample"; "address_space"]) "watch transitions";
251+ check (List.length (List.nth events 1).changes = 2) "watch semantic changes";
252+ check ((List.hd events).mappings = 2 && (List.hd events).bytes = 8192L) "watch statistics";
253+ check (List.length (List.hd events).aliases = 1) "watch alias baseline";
254+ check (Array.length (Sys.readdir base) = 2) "watch bounded retention";
255+ let pair = Filename.concat base "00000006" in
256+ check (Capture.context (Capture.load (Filename.concat pair "before")) = Capture.context b) "watch preserves last complete baseline";
257+ check ((List.nth events 5).changes = []) "watch does not diff unrelated roots";
258+ Array.iter (fun name -> let path = Filename.concat base name in
259+ Array.iter (fun child -> Sys.remove (Filename.concat path child)) (Sys.readdir path);
260+ Unix.rmdir path) (Sys.readdir base);
261+ Unix.rmdir base
262+
263+let () =
264+ permissions ();
265+ translation ();
266+ invalid ();
267+ incomplete ();
268+ diff ();
269+ aliases ();
270+ codec ();
271+ generated ();
272+ watch ();
273+ Printf.printf "%d checks passed\n" !count

test/cli.py added

@@ -0,0 +1,75 @@
1+import json
2+from pathlib import Path
3+import subprocess
4+import sys
5+import tempfile
6+
7+
8+executable = str(Path(sys.argv[1]).resolve())
9+checks = 0
10+
11+
12+def run(*args, status=0, structured=True):
13+ global checks
14+ command = [executable, *map(str, args)]
15+ if structured:
16+ command.append("--json")
17+ result = subprocess.run(command, capture_output=True, text=True, timeout=10)
18+ assert result.returncode == status, (command, result.returncode, result.stdout, result.stderr)
19+ checks += 1
20+ if structured:
21+ value = json.loads(result.stdout if result.stdout else result.stderr)
22+ assert value["schema"] == "scope.report.v1"
23+ return value
24+ return result.stdout
25+
26+
27+with tempfile.TemporaryDirectory(prefix="scope") as directory:
28+ root = Path(directory)
29+ run("demo", root)
30+ before, after = root / "before", root / "after"
31+ assert run("info", before)["pages"] == 5
32+ result = run("walk", before, "0x400abc")
33+ assert result["result"]["mapping"]["physical"] == "0x0000000000009abc"
34+ result = run("explain", before, "0x400000", "--access", "write", "--privilege", "supervisor", status=1)
35+ assert result["result"]["fault"]["level"] == 2
36+ assert result["result"]["fault"]["error_code"] == 3
37+ assert len(run("aliases", before, status=1)["aliases"]) == 1
38+ assert run("aliases", after)["aliases"] == []
39+ assert len(run("diff", before, after, status=1)["changes"]) == 2
40+ assert run("diff", before, before)["changes"] == []
41+ assert len(run("mappings", before, "--start", "0x800000")["regions"]) == 1
42+ assert run("walk", before, "0x800000000000", status=1)["result"]["fault"]["vector"] == 13
43+ overridden = run("walk", before, "0x400000", "--root", "0x6000", status=2)
44+ assert overridden["complete"] is False
45+ assert overridden["context"]["registers"]["cr3"] == "0x0000000000001000"
46+ assert overridden["context"]["root"] == "0x0000000000006000"
47+ run("explain", before, "0x400000", status=64)
48+ run("walk", before, "0x400000", "--include-ad", status=64)
49+ run("walk", before, "0x400000", "--root", "0x1000", "--root", "0x2000", status=64)
50+ run("mappings", before, "--max-entries", "1", status=2)
51+ run("capture", "0", root / "capture", "--vcpu", "0", "--phys-bits", "48", "--nx", "on", "--gb-pages", "on", status=2)
52+ run("walk", before, "-1", status=64)
53+ run("unknown", status=64)
54+ run("watch", "7", root / "history", "--interval", "nan", status=64)
55+ run("watch", "7", root / "history", "--retain", "0", status=64)
56+ run("walk", before, "0x400000", "--count", "2", status=64)
57+ run("info", root / "missing", status=2)
58+ text = run("explain", before, "0x400000", "--access", "write", "--privilege", "supervisor", status=1, structured=False)
59+ assert "level=2" in text and "error=0x3" in text
60+ damaged = root / "damaged"
61+ damaged.write_bytes(before.read_bytes()[:-1])
62+ run("info", damaged, status=2)
63+ transcript = root / "transcript"
64+ transcript.write_text("context 0x80010001 0x0 0x1000 0x20 0xd00 0x2 0x0 48 1 1\nmissing 0x1000 permission denied\n")
65+ run("import", transcript, root / "partial", "--source", 'quote" and newline\n', status=2)
66+ assert run("walk", root / "partial", "0x0", status=2)["result"]["reason"] == "permission denied"
67+ partial = run("diff", before, root / "partial", status=2)
68+ assert all(change["kinds"] == ["incomplete"] for change in partial["changes"])
69+ page = (0x83).to_bytes(8, "little") + bytes(4088)
70+ transcript.write_text("context 0x80010001 0x0 0x1000 0x20 0xd00 0x2 0x0 48 1 1\npage 0x1000 " + page.hex() + "\n")
71+ run("import", transcript, root / "invalid")
72+ assert run("mappings", root / "invalid", status=1)["regions"][0]["state"]["status"] == "invalid"
73+ assert run("aliases", root / "invalid", status=1)["aliases"] == []
74+
75+print(f"{checks} cli checks passed")

test/dune added

@@ -0,0 +1,8 @@
1+(test
2+ (name check)
3+ (libraries scope unix))
4+
5+(rule
6+ (alias runtest)
7+ (deps cli.py)
8+ (action (run python3 %{dep:cli.py} %{exe:../bin/main.exe})))