feat(watch): retain changed captures and reset baselines on root changes
1 files changed, +94 −0
- lib/watch.ml added +94 −0
lib/watch.ml added
| @@ -0,0 +1,94 @@ | ||
| 1 | +open Model | |
| 2 | + | |
| 3 | +type event = { | |
| 4 | + sample : int; | |
| 5 | + time : float; | |
| 6 | + kind : string; | |
| 7 | + before : Capture.t option; | |
| 8 | + after : Capture.t; | |
| 9 | + changes : Analysis.change list; | |
| 10 | + context_changes : string list; | |
| 11 | + aliases : Analysis.alias list; | |
| 12 | + complete : bool; | |
| 13 | + directory : string; | |
| 14 | + mappings : int; | |
| 15 | + bytes : int64; | |
| 16 | + executable : int; | |
| 17 | + writable : int; | |
| 18 | + huge : int; | |
| 19 | +} | |
| 20 | + | |
| 21 | +let run ~capture ~wait ~emit ~directory ~interval ~count ~retain ~max_entries ~max_pairs | |
| 22 | + ~include_ad ~scan_aliases ~selected () = | |
| 23 | + if count < 0 || retain < 1 || not (Float.is_finite interval) || interval <= 0. then | |
| 24 | + invalid_arg "invalid watch sampling or retention settings"; | |
| 25 | + if Sys.file_exists directory then invalid_arg "watch output directory must not already exist"; | |
| 26 | + Unix.mkdir directory 0o700; | |
| 27 | + let retained = Queue.create () in | |
| 28 | + let previous = ref None and identity = ref None in | |
| 29 | + let findings = ref false and incomplete = ref false in | |
| 30 | + let statistics = ref (0, 0L, 0, 0, 0) in | |
| 31 | + let notify sample kind before after changes context_changes aliases complete path = | |
| 32 | + let mappings, bytes, executable, writable, huge = !statistics in | |
| 33 | + emit { sample; time = Unix.gettimeofday (); kind; before; after; changes; context_changes; | |
| 34 | + aliases; complete; directory = path; mappings; bytes; executable; writable; huge } | |
| 35 | + in | |
| 36 | + let publish sample kind before after changes context_changes aliases complete = | |
| 37 | + let path = Filename.concat directory (Printf.sprintf "%08d" sample) in | |
| 38 | + Unix.mkdir path 0o700; | |
| 39 | + Option.iter (Capture.save (Filename.concat path "before")) before; | |
| 40 | + Capture.save (Filename.concat path "after") after; | |
| 41 | + Queue.add path retained; | |
| 42 | + while Queue.length retained > retain do | |
| 43 | + let oldest = Queue.take retained in | |
| 44 | + List.iter (fun name -> let file = Filename.concat oldest name in | |
| 45 | + if Sys.file_exists file then Unix.unlink file) ["before"; "after"]; | |
| 46 | + Unix.rmdir oldest | |
| 47 | + done; | |
| 48 | + notify sample kind before after changes context_changes aliases complete path | |
| 49 | + in | |
| 50 | + let rec loop sample = | |
| 51 | + let after = capture () in | |
| 52 | + let context = Capture.context after in | |
| 53 | + (match !identity with | |
| 54 | + | None -> identity := Some context.identity | |
| 55 | + | Some expected when expected <> context.identity -> failwith "domain identity changed between watch samples" | |
| 56 | + | _ -> ()); | |
| 57 | + let regions = Paging.enumerate ~max_entries context (Capture.read after) |> List.filter selected in | |
| 58 | + statistics := List.fold_left (fun (n, bytes, x, w, huge) region -> match region.Paging.state with | |
| 59 | + | Paging.Present m -> n + 1, Int64.add bytes m.size, | |
| 60 | + x + (if m.permissions.executable then 1 else 0), w + (if m.permissions.writable then 1 else 0), | |
| 61 | + huge + (if m.size > 4096L then 1 else 0) | |
| 62 | + | _ -> n, bytes, x, w, huge) (0, 0L, 0, 0, 0) regions; | |
| 63 | + let complete = List.for_all (fun r -> match r.Paging.state with Paging.Unknown _ -> false | _ -> true) regions in | |
| 64 | + let aliases = if scan_aliases then Analysis.aliases ~max_pairs regions else [] in | |
| 65 | + if aliases <> [] || List.exists (fun r -> match r.Paging.state with Paging.Broken _ -> true | _ -> false) regions then | |
| 66 | + findings := true; | |
| 67 | + if not complete then begin | |
| 68 | + incomplete := true; | |
| 69 | + publish sample "incomplete" !previous after [] [] aliases false | |
| 70 | + end else begin | |
| 71 | + (match !previous with | |
| 72 | + | None -> publish sample "baseline" None after [] [] aliases true | |
| 73 | + | Some before -> | |
| 74 | + let earlier = Capture.context before in | |
| 75 | + let context_changes = Model.context_changes earlier context in | |
| 76 | + if Model.root earlier <> Model.root context then | |
| 77 | + publish sample "address_space" (Some before) after [] context_changes aliases true | |
| 78 | + else begin | |
| 79 | + let before_regions = Paging.enumerate ~max_entries earlier (Capture.read before) in | |
| 80 | + let changes = Analysis.diff ~include_ad before_regions regions |> List.filter (fun (c : Analysis.change) -> | |
| 81 | + selected { Paging.start = c.start; length = c.length; state = Paging.Unknown "" }) in | |
| 82 | + if changes <> [] || context_changes <> [] then begin | |
| 83 | + findings := true; | |
| 84 | + publish sample "change" (Some before) after changes context_changes aliases true | |
| 85 | + end else notify sample "sample" (Some before) after [] [] aliases true "" | |
| 86 | + end); | |
| 87 | + previous := Some after | |
| 88 | + end; | |
| 89 | + if count = 0 || sample < count then begin wait interval; loop (sample + 1) end | |
| 90 | + in | |
| 91 | + (try loop 1 with exn -> | |
| 92 | + if Array.length (Sys.readdir directory) = 0 then Unix.rmdir directory; | |
| 93 | + raise exn); | |
| 94 | + if !incomplete then 2 else if !findings then 1 else 0 | |