open Model
open Json
let limitations = [
"guest first-stage table state only; tlb and second-stage permissions are not observed";
"ordinary explicit accesses only; implicit supervisor accesses and cross-page operations are not modelled";
"pausing vcpus does not quiesce dma, device models, or other memory writers";
"permissions describe architectural access, not speculative execution" ]
let permissions p = Object ["writable", Bool p.writable; "user", Bool p.user; "executable", Bool p.executable]
let context c =
let r = c.registers and f = c.features in
Object ["source", String c.source; "consistency", String c.consistency; "identity", String c.identity;
"domid", Int c.domid; "vcpu", Int c.vcpu;
"root", hex (Address.Physical.to_int64 (Model.root c)); "root_override", option hex c.root_override;
"features", Object ["phys_bits", Int f.phys_bits; "nx", Bool f.nx; "gb_pages", Bool f.gb_pages];
"registers", Object ["cr0", hex r.cr0; "cr2", hex r.cr2; "cr3", hex r.cr3; "cr4", hex r.cr4;
"efer", hex r.efer; "rflags", hex r.rflags; "rip", hex r.rip]]
let step (s : step) = Object ["level", Int s.level; "table", hex (Address.Physical.to_int64 s.table);
"index", Int s.index; "entry_address", hex Int64.(add (Address.Physical.to_int64 s.table) (of_int (s.index * 8)));
"raw", hex s.raw; "effective", permissions s.effective]
let mapping (m : mapping) = Object [
"virtual", hex (Address.Virtual.to_int64 m.virtual_address);
"physical", hex (Address.Physical.to_int64 m.physical_address);
"page_size", hex m.size; "permissions", permissions m.permissions; "leaf", hex m.leaf;
"trace", List (List.map step m.trace)]
let fault f = Object ["vector", Int f.vector; "error_code", Int f.error_code;
"reason", String f.reason; "level", option (fun n -> Int n) f.level]
let outcome = function
| Mapped m -> Object ["status", String "mapped"; "mapping", mapping m]
| Fault f -> Object ["status", String "fault"; "fault", fault f]
| Incomplete reason -> Object ["status", String "incomplete"; "reason", String reason]
let state = function
| Paging.Present m -> Object ["status", String "mapped"; "mapping", mapping m]
| Paging.Unknown reason -> Object ["status", String "incomplete"; "reason", String reason]
| Paging.Broken reason -> Object ["status", String "invalid"; "reason", String reason]
let region (r : Paging.region) = Object ["start", hex r.start; "length", hex r.length; "state", state r.state]
let change (c : Analysis.change) = Object ["start", hex c.start; "length", hex c.length;
"kinds", List (List.map string c.kinds); "before", option state c.before; "after", option state c.after]
let alias (a : Analysis.alias) = Object ["physical", hex a.physical; "length", hex a.length;
"writable", mapping a.writable; "executable", mapping a.executable]
let envelope command c complete fields = Object (
["schema", String "scope.report.v1"; "command", String command; "context", context c;
"complete", Bool complete; "limitations", List (List.map string limitations)] @ fields)
let rights p = Printf.sprintf "r%c%c/%c" (if p.writable then 'w' else '-')
(if p.executable then 'x' else '-') (if p.user then 'u' else 's')
let print_context c =
Printf.printf "source=%S identity=%S domid=%d vcpu=%d cr3=%s root=%s phys_bits=%d nx=%b gb_pages=%b\n"
c.source c.identity c.domid c.vcpu (Address.hex c.registers.cr3)
(Address.hex (Address.Physical.to_int64 (Model.root c))) c.features.phys_bits c.features.nx c.features.gb_pages;
Printf.printf "consistency=%S\n" c.consistency;
Printf.printf "scope=guest-table-state tlb=unobserved second-stage=unobserved\n"
let print_step (s : step) =
Printf.printf "l%d table=%s index=%03x raw=%s effective=%s\n" s.level
(Address.hex (Address.Physical.to_int64 s.table)) s.index (Address.hex s.raw) (rights s.effective)
let print_mapping m = Printf.printf "%s -> %s size=%s %s\n"
(Address.hex (Address.Virtual.to_int64 m.virtual_address))
(Address.hex (Address.Physical.to_int64 m.physical_address)) (Address.hex m.size) (rights m.permissions)
let print_result result =
List.iter print_step result.trace;
match result.outcome with
| Mapped m -> print_mapping m
| Fault f -> Printf.printf "fault vector=%d error=0x%x level=%s reason=%s\n" f.vector f.error_code
(match f.level with None -> "-" | Some n -> string_of_int n) f.reason
| Incomplete reason -> Printf.printf "incomplete reason=%s\n" reason
let print_region (r : Paging.region) = match r.state with
| Paging.Present m -> print_mapping m
| Paging.Unknown reason -> Printf.printf "%s length=%s incomplete=%s\n" (Address.hex r.start) (Address.hex r.length) reason
| Paging.Broken reason -> Printf.printf "%s length=%s invalid=%s\n" (Address.hex r.start) (Address.hex r.length) reason