this repo has no description
patrick.sirref.org
1open Libbpf
2open Libbpf_maps
3
4type format = Csv | Json
5
6let obj_path = "opentrace.bpf.o"
7let obj_file = [%blob "opentrace.bpf.o"]
8
9let program_names =
10 [
11 "tracepoint__syscalls__sys_enter_openat";
12 "tracepoint__syscalls__sys_enter_openat2";
13 "tracepoint__syscalls__sys_exit_openat";
14 "tracepoint__syscalls__sys_exit_openat2";
15 "trace_io_uring_openat_entry";
16 "trace_io_uring_openat_ret";
17 ]
18
19let json_to_lexemes json : Jsonm.lexeme list =
20 let rec loop acc = function
21 | `String _ as s -> s :: acc
22 | `Int i -> `Float (Int.to_float i) :: acc
23 | `O assoc ->
24 let lexemes =
25 List.fold_left
26 (fun vacc (k, v) -> loop (`Name k :: vacc) v)
27 (`Os :: acc) assoc
28 in
29 `Oe :: lexemes
30 in
31 loop [] json |> List.rev
32
33module Flags = struct
34 include Config
35end
36
37let print_position ppf lexbuf =
38 let open Lexing in
39 let pos = lexbuf.lex_curr_p in
40 Fmt.pf ppf "%s:%d:%d" pos.pos_fname pos.pos_lnum
41 (pos.pos_cnum - pos.pos_bol + 1)
42
43let parse_with_error lexbuf =
44 try Ok (Parser.filter Lexer.read lexbuf) with
45 | Lexer.SyntaxError msg ->
46 Error (Fmt.str "%a: %s\n" print_position lexbuf msg)
47 | Parser.Error -> Error (Fmt.str "%a: syntax error\n" print_position lexbuf)
48
49let filter_of_string s =
50 let lex = Lexing.from_string s in
51 let filter = parse_with_error lex in
52 Result.iter (Fmt.pr "filter: %a\n%!" Filter.pp) filter;
53 filter
54
55module Open_event = struct
56 open Ctypes
57
58 type t
59 type kind = Open_ | Openat | Openat2 | Uring
60
61 let kind_to_string = function
62 | Open_ -> "open"
63 | Openat -> "openat"
64 | Openat2 -> "openat2"
65 | Uring -> "Uring"
66
67 let kind_of_int = function
68 | 0 -> Open_
69 | 1 -> Openat
70 | 2 -> Openat2
71 | 3 -> Uring
72 | n -> failwith ("Invalid kind of open syscall: " ^ string_of_int n)
73
74 let t : t structure typ = Ctypes.structure "event"
75 let ( -: ) ty label = Ctypes.field t label ty
76 let pid = uint32_t -: "e_pid"
77 let cgid = uint64_t -: "e_cgid"
78 let comm = array 16 char -: "e_comm"
79 let kind = int -: "e_kind"
80 let flags = int -: "e_flags"
81 let mode = uint32_t -: "e_mode"
82 let filename = array 256 char -: "e_filename"
83 let ret = int -: "e_ret"
84 let () = seal t
85
86 let char_array_as_string a =
87 let len = CArray.length a in
88 let b = Buffer.create len in
89 try
90 for i = 0 to len - 1 do
91 let c = CArray.get a i in
92 if c = '\x00' then raise Exit else Buffer.add_char b c
93 done;
94 Buffer.contents b
95 with Exit -> Buffer.contents b
96
97 let get_pid s = getf s pid |> Unsigned.UInt32.to_int
98 let get_cgid s = getf s cgid |> Unsigned.UInt64.to_int64
99 let get_comm s = getf s comm |> char_array_as_string
100 let get_flags s = getf s flags
101 let get_mode s = getf s mode |> Unsigned.UInt32.to_int
102 let get_fname s = getf s filename |> char_array_as_string
103 let get_kind s = getf s kind |> kind_of_int
104 let get_ret s = getf s ret
105 let csv_header = "pid,cgid,comm,kind,flags,mode,filename,return\n"
106
107 let to_csv_row event =
108 Format.sprintf "%i,%Ld,%S,%s,%i,%i,\"%s\",%i%!" (get_pid event)
109 (get_cgid event) (get_comm event)
110 (get_kind event |> kind_to_string)
111 (get_flags event) (get_mode event) (get_fname event) (get_ret event)
112
113 let to_json event =
114 `O
115 [
116 ("pid", `Int (get_pid event));
117 ("cgid", `Int (Int64.to_int @@ get_cgid event));
118 ("comm", `String (get_comm event));
119 ("kind", `String (get_kind event |> kind_to_string));
120 ("flags", `Int (get_flags event));
121 ("mode", `Int (get_mode event));
122 ("fname", `String (get_fname event));
123 ("ret", `Int (get_ret event));
124 ]
125end
126
127let run_ring_buffer bpf_callback =
128 let dir = Filename.temp_dir "opentrace-" "" in
129 let full_obj_path = Filename.concat dir obj_path in
130 Out_channel.with_open_bin full_obj_path (fun oc ->
131 Out_channel.output_string oc obj_file);
132 with_bpf_object_open_load_link ~obj_path:full_obj_path ~program_names
133 bpf_callback
134
135let ringbuffer_polling_callback ~poll rb_cb exit_cb =
136 let bpf_callback obj _links =
137 (* Set signal handlers *)
138 let exitting = ref true in
139 let sig_handler = Sys.Signal_handle (fun _ -> exitting := false) in
140 Sys.(set_signal sigint sig_handler);
141 Sys.(set_signal sigterm sig_handler);
142
143 let map = Libbpf.bpf_object_find_map_by_name obj "rb" in
144 let callback : RingBuffer.callback =
145 fun _ data _ ->
146 let event = Ctypes.(!@(from_voidp Open_event.t data)) in
147 rb_cb event
148 in
149 RingBuffer.init map ~callback @@ fun rb ->
150 while !exitting do
151 let _ : int = RingBuffer.poll rb ~timeout:1 in
152 exit_cb exitting;
153 Unix.sleepf poll
154 done
155 in
156 bpf_callback
157
158let filter_event_by_flag event flags =
159 match flags with
160 | None -> true
161 | Some f -> Filter.satisfies f (Open_event.get_flags event)
162
163let all poll no_header open_flags =
164 if no_header then () else Format.printf "%s" Open_event.csv_header;
165 let callback event =
166 if filter_event_by_flag event open_flags then
167 Format.printf "%s\n%!" (Open_event.to_csv_row event);
168 0
169 in
170 let bpf_callback = ringbuffer_polling_callback ~poll callback (fun _ -> ()) in
171 run_ring_buffer bpf_callback
172
173let with_cgroup flag fn =
174 if not flag then fn None
175 else
176 let filename =
177 Filename.temp_dir ~temp_dir:"/sys/fs/cgroup" "opentrace-" ""
178 in
179 Fun.protect
180 ~finally:(fun () -> Sys.rmdir filename)
181 (fun () -> fn (Some (Filename.concat filename "cgroup.procs")))
182
183let exec format output user poll (prog, args) open_flags_filter cgroups =
184 let output =
185 match output with
186 | Some file -> file
187 | None ->
188 let ext = match format with Csv -> "csv" | Json -> "json" in
189 "trace." ^ ext
190 in
191 let uid =
192 match user with
193 | None -> Unix.getenv "SUDO_UID" |> int_of_string
194 | Some user -> (
195 match int_of_string_opt user with
196 | Some uid -> uid
197 | None -> (Unix.getpwnam user).pw_uid)
198 in
199 let start_process = Condition.create () in
200 let mutex = Mutex.create () in
201 let pid = Atomic.make None in
202 let exit_status = Atomic.make None in
203 let cgroup = Atomic.make None in
204 let _domain =
205 Domain.spawn @@ fun () ->
206 Eio_posix.run @@ fun env ->
207 try
208 Mutex.lock mutex;
209 Condition.wait start_process mutex;
210 Eio.Switch.run @@ fun sw ->
211 with_cgroup cgroups @@ fun group ->
212 let process = Spawn.make_process group (Some uid) in
213 let p = Eio.Process.spawn process ~sw (prog :: args) in
214 Atomic.set pid (Some (Eio.Process.pid p));
215 let stat =
216 Option.map
217 (fun c ->
218 Eio.Path.stat ~follow:true Eio.Path.(env#fs / Filename.dirname c))
219 group
220 in
221 Atomic.set cgroup (Option.map (fun v -> v.Eio.File.Stat.ino) stat);
222 let status = Eio.Process.await p in
223 Atomic.set exit_status (Some status)
224 with e ->
225 Mutex.unlock mutex;
226 Fmt.epr "Error creating process %s\n" (Printexc.to_string e);
227 Atomic.set exit_status (Some (`Exited (-1)))
228 in
229 Out_channel.with_open_bin output @@ fun oc ->
230 let encoder = Jsonm.encoder ~minify:false (`Channel oc) in
231 let encode l =
232 Jsonm.encode encoder (`Lexeme l) |> function `Ok -> () | _ -> assert false
233 in
234 let finish () =
235 Jsonm.encode encoder `End |> function `Ok -> () | _ -> assert false
236 in
237 let () =
238 (* Header *)
239 match format with
240 | Csv -> Out_channel.output_string oc Open_event.csv_header
241 | Json -> encode `As
242 in
243 let callback event =
244 match (Atomic.get cgroup, Atomic.get pid) with
245 | _, None -> 0
246 | _, Some pid ->
247 (if
248 (if cgroups then
249 Int64.equal
250 (Open_event.get_cgid event)
251 (Option.get (Atomic.get cgroup))
252 else Int.equal (Open_event.get_pid event) pid)
253 && filter_event_by_flag event open_flags_filter
254 then
255 match format with
256 | Csv ->
257 Out_channel.output_string oc (Open_event.to_csv_row event);
258 Out_channel.output_char oc '\n'
259 | Json ->
260 List.iter encode (json_to_lexemes (Open_event.to_json event)));
261 0
262 in
263 let spawned = ref false in
264 let exit_callback exitting =
265 if not !spawned then (
266 Condition.broadcast start_process;
267 spawned := true);
268 Option.iter
269 (fun _ ->
270 exitting := false;
271 match format with
272 | Json ->
273 encode `Ae;
274 finish ()
275 | _ -> ())
276 (Atomic.get exit_status)
277 in
278 let bpf_callback = ringbuffer_polling_callback ~poll callback exit_callback in
279 run_ring_buffer bpf_callback
280
281open Cmdliner
282open Cmdliner.Term.Syntax
283
284let polling =
285 let doc = "The number of seconds to sleep between polls of the ringbuffer" in
286 Arg.(value & opt float 0.1 & info [ "p"; "poll" ] ~doc ~docv:"POLL")
287
288let no_header =
289 let doc = "Disable printing the CSV header" in
290 Arg.(value & flag & info [ "no-header" ] ~doc)
291
292let cgroups =
293 let doc = "Enable cgroup creation and tracing" in
294 Arg.(value & flag & info [ "cgroups" ] ~doc)
295
296let flag_conv =
297 let of_string s = filter_of_string s in
298 let pp = Filter.pp in
299 Arg.conv' (of_string, pp)
300
301let open_flags_filter =
302 let doc =
303 "Filter open events that include these flags (e.g. O_RDONLY, O_CREAT). \
304 Note the filter wants ALL of the flags to be present not just one of \
305 them."
306 in
307 Arg.(value & opt (some flag_conv) None & info [ "flags" ] ~doc)
308
309let user =
310 let doc = "Username or UID to execute program as" in
311 Arg.(value & opt (some string) None & info [ "u"; "user" ] ~doc ~docv:"USER")
312
313let format_conv : format Arg.conv =
314 let of_string s =
315 match String.lowercase_ascii s with
316 | "csv" -> Ok Csv
317 | "json" -> Ok Json
318 | _ -> Error (`Msg ("Unknown format: " ^ s))
319 in
320 let to_string = function Csv -> "csv" | Json -> "json" in
321 let pp ppf v = Fmt.string ppf (to_string v) in
322 Arg.conv ~docv:"FORMAT" (of_string, pp)
323
324let format =
325 let doc = "Output format" in
326 Arg.(value & opt format_conv Csv & info [ "f"; "format" ] ~docv:"FORMAT" ~doc)
327
328let output =
329 let doc =
330 "Output file for trace. Defaults to trace.<csv|json> depending on the \
331 format."
332 in
333 Arg.(
334 value & opt (some string) None & info [ "o"; "output" ] ~docv:"OUTPUT" ~doc)
335
336let all_cmd =
337 let doc = "Trace all open system calls." in
338 let man =
339 [
340 `P
341 "All calls to open will be traced and written to standard out in CSV \
342 format.";
343 ]
344 in
345 Cmd.v (Cmd.info ~doc ~man "all")
346 @@
347 let+ polling = polling
348 and+ no_header = no_header
349 and+ open_flags_filter = open_flags_filter in
350 all polling no_header open_flags_filter
351
352let exec_cmd =
353 let doc = "Execute a program and trace its open system calls." in
354 let man =
355 [
356 `P
357 "$(b,opentrace exec -- COMMAND) will execute COMMAND and trace only \
358 those open calls from that program.";
359 `P "Opentrace will include the children of the main process.";
360 ]
361 in
362 Cmd.v (Cmd.info ~doc ~man "exec")
363 @@
364 let+ prog =
365 Arg.(required & pos 0 (some string) None & Arg.info [] ~docv:"PROG")
366 and+ user = user
367 and+ format = format
368 and+ output = output
369 and+ args = Arg.(value & pos_right 0 string [] & Arg.info [] ~docv:"ARGS")
370 and+ open_flags_filter = open_flags_filter
371 and+ cgroups = cgroups
372 and+ poll = polling in
373 exec format output user poll (prog, args) open_flags_filter cgroups
374
375let opentrace_cmd =
376 let doc = "Trace all open system calls" in
377 let man =
378 [
379 `S Manpage.s_description;
380 `P "$(tool) traces all open system calls.";
381 `P
382 "$(tool) can be used either to run an executable directly or to trace \
383 all open calls.";
384 ]
385 in
386 let default = Term.(ret (const (`Help (`Auto, None)))) in
387 Cmd.group (Cmd.info ~doc ~man "opentrace") ~default [ all_cmd; exec_cmd ]
388
389let main () = Cmd.eval opentrace_cmd
390let () = if !Sys.interactive then () else exit (main ())