gazagnaire.org
Logging, runtime tracing, and the obs performance profiler for OCaml
13 kB
379 lines
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** Cmdliner terms for ergonomic logging configuration.
7
8 Provides RUST_LOG-style configuration via:
9 - Verbosity flags: [-q], [-v], [-vv], [-vvv]
10 - Log spec: [--log=level,src:level,...]
11 - JSON output: [--json]
12 - Tracing log sources: [--trace FILE] *)
13
14open Cmdliner
15
16(** {1 Verbosity Flags} *)
17
18let observability_docs = "OBSERVABILITY"
19
20let quiet =
21 let doc =
22 "Suppress non-error log records. This still allows explicit application \
23 output written by the command itself."
24 in
25 Arg.(value & flag & info [ "q"; "quiet" ] ~docs:observability_docs ~doc)
26
27let verbosity =
28 let doc =
29 "Increase log verbosity. Use once for info, twice for debug, and three \
30 times to also enable log sources whose name ends in $(b,.tracing)."
31 in
32 Arg.(value & flag_all & info [ "v"; "verbose" ] ~docs:observability_docs ~doc)
33
34let level_of_verbosity ~quiet ~verbosity =
35 if quiet then Some Logs.Error
36 else
37 match List.length verbosity with
38 | 0 -> Some Logs.Warning
39 | 1 -> Some Logs.Info
40 | _ -> Some Logs.Debug
41
42let enable_tracing ~verbosity = List.length verbosity >= 3
43
44(** {1 Log Spec Parsing} *)
45
46type directive =
47 | Global of Logs.level option
48 | Source of string * Logs.level option
49
50let parse_directive s =
51 let s = String.trim s in
52 if s = "" then None
53 else
54 match String.index_opt s ':' with
55 | None -> (
56 (* Bare level = global setting *)
57 match Logs.level_of_string s with
58 | Ok lvl -> Some (Global lvl)
59 | Error _ ->
60 Fmt.epr "Warning: invalid log level '%s'@." s;
61 None)
62 | Some i -> (
63 let src = String.sub s 0 i in
64 let lvl_s = String.sub s (i + 1) (String.length s - i - 1) in
65 match Logs.level_of_string lvl_s with
66 | Ok lvl -> Some (Source (src, lvl))
67 | Error _ ->
68 Fmt.epr "Warning: invalid log level '%s' for source '%s'@." lvl_s
69 src;
70 None)
71
72let parse_log_spec spec =
73 let directives = String.split_on_char ',' spec in
74 let global = ref None in
75 let sources = ref [] in
76 List.iter
77 (fun d ->
78 match parse_directive d with
79 | Some (Global lvl) -> global := lvl
80 | Some (Source (src, lvl)) -> sources := (src, lvl) :: !sources
81 | None -> ())
82 directives;
83 (!global, List.rev !sources)
84
85(** {1 Source Filtering} *)
86
87let apply_source_overrides specs =
88 let all_sources = Logs.Src.list () in
89 List.iter
90 (fun (prefix, lvl) ->
91 List.iter
92 (fun src ->
93 let name = Logs.Src.name src in
94 (* Match exact name or prefix with dot separator *)
95 if
96 String.equal name prefix
97 || String.length name > String.length prefix
98 && String.sub name 0 (String.length prefix) = prefix
99 && name.[String.length prefix] = '.'
100 then Logs.Src.set_level src lvl)
101 all_sources)
102 specs
103
104let configure_tracing_sources ~enable =
105 let level = if enable then Some Logs.Debug else Some Logs.Warning in
106 List.iter
107 (fun src ->
108 let name = Logs.Src.name src in
109 (* Match *.tracing sources *)
110 if
111 String.length name > 8
112 && String.sub name (String.length name - 8) 8 = ".tracing"
113 then Logs.Src.set_level src level)
114 (Logs.Src.list ())
115
116(** {1 Trace File Reporter} *)
117
118let level_string = function
119 | Logs.App -> "app"
120 | Logs.Error -> "error"
121 | Logs.Warning -> "warning"
122 | Logs.Info -> "info"
123 | Logs.Debug -> "debug"
124
125let write_json_trace ppf ~ts ~name ~level_s msg k =
126 Fmt.pf ppf {|{"ts":"%s","src":"%s","level":"%s","msg":"%s"}@.|} ts name
127 level_s (String.escaped msg);
128 k ()
129
130let write_tracing_entry ~json ppf ts name level fmt k =
131 if json then
132 Fmt.kstr
133 (fun msg ->
134 write_json_trace ppf ~ts ~name ~level_s:(level_string level) msg k)
135 fmt
136 else Fmt.kpf (fun _ -> k ()) ppf ("%s %s " ^^ fmt ^^ "@.") ts name
137
138let is_tracing_src name =
139 String.length name > 8
140 && String.sub name (String.length name - 8) 8 = ".tracing"
141
142let report_tracing ~json ppf ~name level ~over k msgf =
143 msgf @@ fun ?header:_ ?tags:_ fmt ->
144 let k _ =
145 over ();
146 k ()
147 in
148 let ts = Ptime_clock.now () |> Ptime.to_rfc3339 in
149 write_tracing_entry ~json ppf ts name level fmt k
150
151let trace_reporter ~json file_path =
152 let oc = open_out file_path in
153 let ppf = Format.formatter_of_out_channel oc in
154 let report src level ~over k msgf =
155 let name = Logs.Src.name src in
156 if is_tracing_src name then
157 report_tracing ~json ppf ~name level ~over k msgf
158 else (
159 over ();
160 k ())
161 in
162 { Logs.report }
163
164(** {1 Cmdliner Terms} *)
165
166let log app_name =
167 let env_name = String.uppercase_ascii app_name ^ "_LOG" in
168 let env =
169 Fmt.kstr
170 (fun doc -> Cmd.Env.info env_name ~doc)
171 "Log configuration for %s. Format: LEVEL[,SRC:LEVEL,...]. Example: \
172 debug,tls.tracing:warning"
173 app_name
174 in
175 let doc =
176 "Set log level and per-source overrides. Format: LEVEL[,SRC:LEVEL,...]. \
177 Examples: $(b,debug), $(b,info,tls.tracing:warning), $(b,conpool:debug). \
178 Source names match exactly or by dot-separated prefix. Levels: error, \
179 warning, info, debug."
180 in
181 Arg.(
182 value
183 & opt (some string) None
184 & info [ "log" ] ~env ~docs:observability_docs ~doc ~docv:"SPEC")
185
186let trace_file =
187 let doc =
188 "Write log records from sources whose name ends in $(b,.tracing) to \
189 $(docv). This is the old logs-side protocol trace stream: useful for \
190 verbose hexdumps and parser state logs. It is not a memtrace allocation \
191 trace and not an ocaml-probe Runtime_events capture."
192 in
193 Arg.(
194 value
195 & opt (some string) None
196 & info [ "trace" ] ~docs:observability_docs ~doc ~docv:"FILE")
197
198let json =
199 let doc =
200 "Enable JSON mode. By default logs are emitted with json-logs; commands \
201 that produce their own JSON may pass a custom reporter to keep stdout \
202 reserved for command output."
203 in
204 Arg.(value & flag & info [ "json" ] ~docs:observability_docs ~doc)
205
206let err_invalid_tag s =
207 Error (`Msg (Fmt.str "Invalid tag format '%s', expected KEY=VALUE" s))
208
209let parse_tag s =
210 match String.index_opt s '=' with
211 | None -> err_invalid_tag s
212 | Some i ->
213 let key = String.sub s 0 i in
214 let value = String.sub s (i + 1) (String.length s - i - 1) in
215 Ok (key, value)
216
217let log_tag_conv = Arg.conv (parse_tag, fun ppf (k, v) -> Fmt.pf ppf "%s=%s" k v)
218
219let log_tags =
220 let doc =
221 "Add a base tag to JSON log output. Can be repeated. Format: KEY=VALUE. \
222 Tags are attached to every JSON log record. Example: $(b,--log-tag \
223 env=prod --log-tag region=us-east-1)."
224 in
225 Arg.(
226 value & opt_all log_tag_conv []
227 & info [ "log-tag" ] ~docs:observability_docs ~doc ~docv:"TAG")
228
229(** {1 Setup} *)
230
231type json_reporter =
232 app:string -> base:(string * string) list -> unit -> Logs.reporter
233
234let default_json_reporter : json_reporter =
235 fun ~app ~base () -> Json_logs.reporter ~app ~base ()
236
237let reporter ?(dst = Fmt.stderr) () = Logs_fmt.reporter ~app:dst ~dst ()
238
239(** {1 Test Setup} *)
240
241let setup_test ?(level = Logs.Debug) () =
242 (* Check TEST_LOG environment variable for level override. Supports
243 RUST_LOG-style syntax: "level" or "level,src:level,src:level" *)
244 let global_level, source_overrides =
245 match Sys.getenv_opt "TEST_LOG" with
246 | None -> (Some level, [])
247 | Some spec ->
248 let global, sources = parse_log_spec spec in
249 let lvl = match global with Some l -> Some l | None -> Some level in
250 (lvl, sources)
251 in
252 Fmt_tty.setup_std_outputs ();
253 Logs.set_level global_level;
254 Logs.set_reporter (Logs_fmt.reporter ());
255 apply_source_overrides source_overrides
256
257type log_flags = { quiet : bool; json : bool }
258
259let current_json = ref false
260let json_enabled () = !current_json
261
262(** POSIX NO_COLOR: any non-empty value disables ANSI colour on stdout/stderr.
263 Exposed as a cmdliner flag so it is documented in [--help] and composed into
264 the log setup pipeline alongside [Fmt_cli.style_renderer]. An explicit
265 [--color=always] still wins — same precedence as POSIX. See
266 https://no-color.org. *)
267let no_color_term =
268 let env =
269 Cmd.Env.info "NO_COLOR"
270 ~doc:
271 "If set to any non-empty value, disable ANSI colour in all output. \
272 Overridden by an explicit --color=always. See https://no-color.org."
273 in
274 Arg.(
275 value & flag
276 & info [ "no-color" ] ~env ~docs:observability_docs
277 ~doc:"Disable ANSI colour.")
278
279let setup_log ~json_reporter app_name style_renderer no_color { quiet; json }
280 verbosity log_spec trace_file base_tags =
281 Observe_memtrace.Memtrace.trace_if_requested ~context:app_name ();
282 (* Adopt an inherited trace context, if a parent handed one down through
283 OBS_TRACEPARENT, so this process's spans descend from the remote span that
284 started the work. A no-op when the variable is absent. *)
285 (match
286 Option.bind
287 (Sys.getenv_opt Probe.Traceparent.env_var)
288 Probe.Traceparent.of_string
289 with
290 | Some tp -> Probe.adopt tp
291 | None -> ());
292 (* Like MEMTRACE, OBS_COLLECTOR is honored with no tool-local flag: when obs
293 run sets it, this process becomes a producer and streams its runtime_events
294 -- and, unless the program already drives memtrace itself, its allocation
295 trace -- to the collector for the duration of the run. *)
296 (match Observe_producer.Forwarder.start_if_requested ~memtrace:true () with
297 | None -> ()
298 | Some stop -> at_exit stop);
299 current_json := json;
300 let style_renderer =
301 match style_renderer with
302 | Some _ -> style_renderer (* explicit --color wins *)
303 | None when no_color -> Some `None
304 | None -> None
305 in
306 Fmt_tty.setup_std_outputs ?style_renderer ();
307 (* Parse --log / <APP>_LOG spec *)
308 let global_override, source_overrides =
309 match log_spec with Some spec -> parse_log_spec spec | None -> (None, [])
310 in
311 (* Set reporter: JSON (via json_reporter) or Fmt (with optional trace file) *)
312 let main_reporter =
313 if json then json_reporter ~app:app_name ~base:base_tags ()
314 else Logs_fmt.reporter ()
315 in
316 let reporter =
317 match trace_file with
318 | Some path ->
319 (* Combine main reporter with trace file reporter *)
320 let trace_rep = trace_reporter ~json path in
321 let report src level ~over k msgf =
322 (* Send to both reporters *)
323 trace_rep.Logs.report src level
324 ~over:(fun () -> ())
325 (fun () -> main_reporter.Logs.report src level ~over k msgf)
326 msgf
327 in
328 { Logs.report }
329 | None -> main_reporter
330 in
331 Logs.set_reporter reporter;
332 (* Set global level: --log override > -q/-v flags *)
333 let level =
334 match global_override with
335 | Some lvl -> Some lvl
336 | None -> level_of_verbosity ~quiet ~verbosity
337 in
338 Logs.set_level level;
339 (* Configure tracing sources: -vvv or --trace enables them *)
340 let enable_trace = enable_tracing ~verbosity || Option.is_some trace_file in
341 configure_tracing_sources ~enable:enable_trace;
342 (* Apply per-source overrides from --log *)
343 apply_source_overrides source_overrides
344
345let setup ?json_reporter app_name =
346 let json_reporter =
347 match json_reporter with
348 | None -> Some default_json_reporter (* default: use json-logs *)
349 | Some None -> None (* explicitly disabled *)
350 | Some (Some r) -> Some r (* custom reporter *)
351 in
352 match json_reporter with
353 | None ->
354 (* JSON disabled: no --json flag or --log-tag exposed *)
355 let go style_renderer no_color flags verbosity log_spec trace_file =
356 setup_log
357 ~json_reporter:(fun ~app:_ ~base:_ () -> Logs_fmt.reporter ())
358 app_name style_renderer no_color flags verbosity log_spec trace_file
359 []
360 in
361 Term.(
362 const go $ Fmt_cli.style_renderer () $ no_color_term
363 $ Term.(const (fun quiet -> { quiet; json = false }) $ quiet)
364 $ verbosity $ log app_name $ trace_file)
365 | Some r ->
366 (* JSON enabled: expose --json flag and --log-tag *)
367 let flags_term =
368 Term.(const (fun quiet json -> { quiet; json }) $ quiet $ json)
369 in
370 let go style_renderer no_color flags verbosity log_spec trace_file
371 log_tags =
372 setup_log ~json_reporter:r app_name style_renderer no_color flags
373 verbosity log_spec trace_file log_tags
374 in
375 Term.(
376 const go $ Fmt_cli.style_renderer () $ no_color_term $ flags_term
377 $ verbosity $ log app_name $ trace_file $ log_tags)
378
379module Memtrace = Observe_memtrace.Memtrace