gazagnaire.org
Cmdliner terms for ergonomic logging configuration
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3 SPDX-License-Identifier: MIT
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 - Protocol tracing: [--trace FILE] *)
13
14open Cmdliner
15
16(** {1 Verbosity Flags} *)
17
18let quiet =
19 let doc = "Suppress output except errors." in
20 Arg.(value & flag & info [ "q"; "quiet" ] ~doc)
21
22let verbosity =
23 let doc =
24 "Increase verbosity. Use once for info, twice for debug, three times to \
25 enable protocol tracing."
26 in
27 Arg.(value & flag_all & info [ "v"; "verbose" ] ~doc)
28
29let level_of_verbosity ~quiet ~verbosity =
30 if quiet then Some Logs.Error
31 else
32 match List.length verbosity with
33 | 0 -> Some Logs.Warning
34 | 1 -> Some Logs.Info
35 | _ -> Some Logs.Debug
36
37let enable_tracing ~verbosity = List.length verbosity >= 3
38
39(** {1 Log Spec Parsing} *)
40
41type directive =
42 | Global of Logs.level option
43 | Source of string * Logs.level option
44
45let parse_directive s =
46 let s = String.trim s in
47 if s = "" then None
48 else
49 match String.index_opt s ':' with
50 | None -> (
51 (* Bare level = global setting *)
52 match Logs.level_of_string s with
53 | Ok lvl -> Some (Global lvl)
54 | Error _ ->
55 Fmt.epr "Warning: invalid log level '%s'@." s;
56 None)
57 | Some i -> (
58 let src = String.sub s 0 i in
59 let lvl_s = String.sub s (i + 1) (String.length s - i - 1) in
60 match Logs.level_of_string lvl_s with
61 | Ok lvl -> Some (Source (src, lvl))
62 | Error _ ->
63 Fmt.epr "Warning: invalid log level '%s' for source '%s'@." lvl_s
64 src;
65 None)
66
67let parse_log_spec spec =
68 let directives = String.split_on_char ',' spec in
69 let global = ref None in
70 let sources = ref [] in
71 List.iter
72 (fun d ->
73 match parse_directive d with
74 | Some (Global lvl) -> global := lvl
75 | Some (Source (src, lvl)) -> sources := (src, lvl) :: !sources
76 | None -> ())
77 directives;
78 (!global, List.rev !sources)
79
80(** {1 Source Filtering} *)
81
82let apply_source_overrides specs =
83 let all_sources = Logs.Src.list () in
84 List.iter
85 (fun (prefix, lvl) ->
86 List.iter
87 (fun src ->
88 let name = Logs.Src.name src in
89 (* Match exact name or prefix with dot separator *)
90 if
91 String.equal name prefix
92 || String.length name > String.length prefix
93 && String.sub name 0 (String.length prefix) = prefix
94 && name.[String.length prefix] = '.'
95 then Logs.Src.set_level src lvl)
96 all_sources)
97 specs
98
99let configure_tracing_sources ~enable =
100 let level = if enable then Some Logs.Debug else Some Logs.Warning in
101 List.iter
102 (fun src ->
103 let name = Logs.Src.name src in
104 (* Match *.tracing sources *)
105 if
106 String.length name > 8
107 && String.sub name (String.length name - 8) 8 = ".tracing"
108 then Logs.Src.set_level src level)
109 (Logs.Src.list ())
110
111(** {1 Trace File Reporter} *)
112
113let level_string = function
114 | Logs.App -> "app"
115 | Logs.Error -> "error"
116 | Logs.Warning -> "warning"
117 | Logs.Info -> "info"
118 | Logs.Debug -> "debug"
119
120let write_json_trace ppf ~ts ~name ~level_s msg k =
121 Fmt.pf ppf {|{"ts":"%s","src":"%s","level":"%s","msg":"%s"}@.|} ts name
122 level_s (String.escaped msg);
123 k ()
124
125let write_tracing_entry ~json ppf ts name level fmt k =
126 if json then
127 Fmt.kstr
128 (fun msg ->
129 write_json_trace ppf ~ts ~name ~level_s:(level_string level) msg k)
130 fmt
131 else Fmt.kpf (fun _ -> k ()) ppf ("%s %s " ^^ fmt ^^ "@.") ts name
132
133let is_tracing_src name =
134 String.length name > 8
135 && String.sub name (String.length name - 8) 8 = ".tracing"
136
137let report_tracing ~json ppf ~name level ~over k msgf =
138 msgf @@ fun ?header:_ ?tags:_ fmt ->
139 let k _ =
140 over ();
141 k ()
142 in
143 let ts = Ptime_clock.now () |> Ptime.to_rfc3339 in
144 write_tracing_entry ~json ppf ts name level fmt k
145
146let trace_reporter ~json file_path =
147 let oc = open_out file_path in
148 let ppf = Format.formatter_of_out_channel oc in
149 let report src level ~over k msgf =
150 let name = Logs.Src.name src in
151 if is_tracing_src name then
152 report_tracing ~json ppf ~name level ~over k msgf
153 else (
154 over ();
155 k ())
156 in
157 { Logs.report }
158
159(** {1 Cmdliner Terms} *)
160
161let log_term app_name =
162 let env_name = String.uppercase_ascii app_name ^ "_LOG" in
163 let env =
164 Cmd.Env.info env_name
165 ~doc:
166 (Fmt.str
167 "Log configuration for %s. Format: LEVEL[,SRC:LEVEL,...]. Example: \
168 debug,tls.tracing:warning"
169 app_name)
170 in
171 let doc =
172 "Set log level and per-source overrides. Format: LEVEL[,SRC:LEVEL,...]. \
173 Examples: $(b,debug), $(b,info,tls.tracing:warning), $(b,conpool:debug). \
174 Levels: error, warning, info, debug."
175 in
176 Arg.(value & opt (some string) None & info [ "log" ] ~env ~doc ~docv:"SPEC")
177
178let trace_file =
179 let doc =
180 "Write protocol traces to $(docv). Automatically enables tracing sources."
181 in
182 Arg.(value & opt (some string) None & info [ "trace" ] ~doc ~docv:"FILE")
183
184let json =
185 let doc = "Output as JSON (affects both data output and logs)." in
186 Arg.(value & flag & info [ "json" ] ~doc)
187
188let err_invalid_tag s =
189 Error (`Msg (Fmt.str "Invalid tag format '%s', expected KEY=VALUE" s))
190
191let parse_tag s =
192 match String.index_opt s '=' with
193 | None -> err_invalid_tag s
194 | Some i ->
195 let key = String.sub s 0 i in
196 let value = String.sub s (i + 1) (String.length s - i - 1) in
197 Ok (key, value)
198
199let log_tag_conv = Arg.conv (parse_tag, fun ppf (k, v) -> Fmt.pf ppf "%s=%s" k v)
200
201let log_tags =
202 let doc =
203 "Add a tag to JSON log output. Can be repeated. Format: KEY=VALUE. \
204 Example: $(b,--log-tag env=prod --log-tag region=us-east-1)."
205 in
206 Arg.(value & opt_all log_tag_conv [] & info [ "log-tag" ] ~doc ~docv:"TAG")
207
208(** {1 Setup} *)
209
210type json_reporter =
211 app:string -> base:(string * string) list -> unit -> Logs.reporter
212
213let default_json_reporter : json_reporter =
214 fun ~app ~base () -> Json_logs.reporter ~app ~base ()
215
216(** {1 Test Setup} *)
217
218let setup_test ?(level = Logs.Debug) () =
219 (* Check TEST_LOG environment variable for level override.
220 Supports RUST_LOG-style syntax: "level" or "level,src:level,src:level" *)
221 let global_level, source_overrides =
222 match Sys.getenv_opt "TEST_LOG" with
223 | None -> (Some level, [])
224 | Some spec ->
225 let global, sources = parse_log_spec spec in
226 let lvl = match global with Some l -> Some l | None -> Some level in
227 (lvl, sources)
228 in
229 Fmt_tty.setup_std_outputs ();
230 Logs.set_level global_level;
231 Logs.set_reporter (Logs_fmt.reporter ());
232 apply_source_overrides source_overrides
233
234type log_flags = { quiet : bool; json : bool }
235
236let setup_log ~json_reporter app_name style_renderer { quiet; json } verbosity
237 log_spec trace_file base_tags =
238 Fmt_tty.setup_std_outputs ?style_renderer ();
239 (* Parse --log / <APP>_LOG spec *)
240 let global_override, source_overrides =
241 match log_spec with Some spec -> parse_log_spec spec | None -> (None, [])
242 in
243 (* Set reporter: JSON (via json_reporter) or Fmt (with optional trace file) *)
244 let main_reporter =
245 if json then json_reporter ~app:app_name ~base:base_tags ()
246 else Logs_fmt.reporter ()
247 in
248 let reporter =
249 match trace_file with
250 | Some path ->
251 (* Combine main reporter with trace file reporter *)
252 let trace_rep = trace_reporter ~json path in
253 let report src level ~over k msgf =
254 (* Send to both reporters *)
255 trace_rep.Logs.report src level
256 ~over:(fun () -> ())
257 (fun () -> main_reporter.Logs.report src level ~over k msgf)
258 msgf
259 in
260 { Logs.report }
261 | None -> main_reporter
262 in
263 Logs.set_reporter reporter;
264 (* Set global level: --log override > -q/-v flags *)
265 let level =
266 match global_override with
267 | Some lvl -> Some lvl
268 | None -> level_of_verbosity ~quiet ~verbosity
269 in
270 Logs.set_level level;
271 (* Configure tracing sources: -vvv or --trace enables them *)
272 let enable_trace = enable_tracing ~verbosity || Option.is_some trace_file in
273 configure_tracing_sources ~enable:enable_trace;
274 (* Apply per-source overrides from --log *)
275 apply_source_overrides source_overrides
276
277let setup ?json_reporter app_name =
278 let json_reporter =
279 match json_reporter with
280 | None -> Some default_json_reporter (* default: use json-logs *)
281 | Some None -> None (* explicitly disabled *)
282 | Some (Some r) -> Some r (* custom reporter *)
283 in
284 let flags_term =
285 Term.(const (fun quiet json -> { quiet; json }) $ quiet $ json)
286 in
287 match json_reporter with
288 | None ->
289 (* JSON disabled: no --json flag or --log-tag exposed *)
290 let setup_log' style_renderer flags verbosity log_spec trace_file =
291 setup_log
292 ~json_reporter:(fun ~app:_ ~base:_ () -> Logs_fmt.reporter ())
293 app_name style_renderer flags verbosity log_spec trace_file []
294 in
295 Term.(
296 const setup_log' $ Fmt_cli.style_renderer ()
297 $ Term.(const (fun quiet -> { quiet; json = false }) $ quiet)
298 $ verbosity $ log_term app_name $ trace_file)
299 | Some r ->
300 (* JSON enabled: expose --json flag and --log-tag *)
301 Term.(
302 const (setup_log ~json_reporter:r app_name)
303 $ Fmt_cli.style_renderer () $ flags_term $ verbosity $ log_term app_name
304 $ trace_file $ log_tags)