gazagnaire.org
Logging, runtime tracing, and the obs performance profiler for OCaml
observe: new package with the cmdliner observability terms
One Observe.setup term replaces the vlog + Memtrace.term pair every
binary composed by hand: verbosity flags (-q/-v/-vv/-vvv), RUST_LOG
style --log, --json output, --trace FILE log capture, --probe FILE
runtime_events capture, and --memtrace allocation tracing. vlog is
removed in a follow-up commit once its users have migrated.
author
Thomas Gazagnaire
date
(Jun 11, 2026, 2:43 PM -0700)
commit
70ccd52b
70ccd52b34cbe8c94bce76495a3c385aaad0598a
+1482
+17
.gitignore
+17
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version = 0.29.0
+21
LICENSE.md
+21
LICENSE.md
···
1
+
MIT License
2
+
3
+
Copyright (c) 2025 Thomas Gazagnaire
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy
6
+
of this software and associated documentation files (the "Software"), to deal
7
+
in the Software without restriction, including without limitation the rights
8
+
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9
+
copies of the Software, and to permit persons to whom the Software is
10
+
furnished to do so, subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17
+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18
+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19
+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20
+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21
+
SOFTWARE.
+165
README.md
+165
README.md
···
1
+
# ocaml-observe
2
+
3
+
Cmdliner terms for CLI observability.
4
+
5
+
## Overview
6
+
7
+
**ocaml-observe** provides Cmdliner terms for the observability controls most
8
+
OCaml command-line tools need: log verbosity, per-source log filtering, JSON log
9
+
output, `*.tracing` log-source files, `ocaml-probe` Runtime_events capture, and
10
+
memtrace allocation tracing.
11
+
12
+
## Features
13
+
14
+
- **Verbosity flags**: `-q`, `-v`, `-vv`, `-vvv`
15
+
- **RUST_LOG-style configuration**: `--log=level,src:level,...`
16
+
- **JSON output**: `--json` for structured logging
17
+
- **Tracing log sources**: `--trace FILE` to capture `*.tracing` log sources
18
+
- **Runtime probes**: `--probe FILE` to capture `ocaml-probe` events as
19
+
Catapult/Perfetto trace JSON
20
+
- **Memtrace**: `--memtrace FILE` to capture allocation traces
21
+
- **Environment variable**: `<APP>_LOG` (e.g., `MYAPP_LOG`)
22
+
23
+
## Installation
24
+
25
+
Install with opam:
26
+
27
+
<!-- $MDX skip -->
28
+
```sh
29
+
$ opam install ocaml-observe
30
+
```
31
+
32
+
If opam cannot find the package, it may not yet be released in the public
33
+
`opam-repository`. Add the overlay repository, then install it:
34
+
35
+
<!-- $MDX skip -->
36
+
```sh
37
+
$ opam repo add samoht https://tangled.org/gazagnaire.org/opam-overlay.git
38
+
$ opam update
39
+
$ opam install ocaml-observe
40
+
```
41
+
42
+
## Usage
43
+
44
+
```ocaml
45
+
open Cmdliner
46
+
47
+
let run () =
48
+
Logs.info (fun m -> m "Starting...");
49
+
Ok ()
50
+
51
+
let cmd =
52
+
let info = Cmd.info "myapp" in
53
+
Cmd.v info Term.(const run $ Observe.setup "myapp")
54
+
55
+
let main () = exit (Cmd.eval_result cmd)
56
+
```
57
+
58
+
### Command Line
59
+
60
+
<!-- $MDX non-deterministic=command -->
61
+
```sh
62
+
$ myapp -q # errors only
63
+
$ myapp # warnings (default)
64
+
$ myapp -v # info level
65
+
$ myapp -vv # debug level
66
+
$ myapp -vvv # debug + *.tracing log sources
67
+
68
+
$ myapp --log=debug # set level via flag
69
+
$ myapp --log=info,http:debug # global info, http at debug
70
+
$ myapp --log=warn,tls.tracing:debug # enable specific tracing
71
+
72
+
$ MYAPP_LOG=debug myapp # set level via env var
73
+
74
+
$ myapp --json # JSON output
75
+
$ myapp --trace protocol.log # write *.tracing log-source output
76
+
$ myapp --probe probes.json # write Catapult probe trace
77
+
$ myapp --memtrace app.ctf # write memtrace allocation trace
78
+
```
79
+
80
+
### Verbosity Levels
81
+
82
+
| Flag | Level | `*.tracing` sources |
83
+
|--------|---------|---------------------|
84
+
| `-q` | Error | Silenced |
85
+
| (none) | Warning | Silenced |
86
+
| `-v` | Info | Silenced |
87
+
| `-vv` | Debug | Silenced |
88
+
| `-vvv` | Debug | Enabled |
89
+
90
+
The `-vv` flag gives you application-level debug output without noisy
91
+
`*.tracing` sources. Use `-vvv` or `--trace FILE` when you need full protocol log
92
+
traces.
93
+
94
+
### JSON Output
95
+
96
+
With `--json`, use the optional `json_reporter` parameter to enable JSON log output:
97
+
98
+
```ocaml
99
+
open Cmdliner
100
+
101
+
let run () = `Ok ()
102
+
103
+
let json_reporter ~app:_ ~base:_ () = Logs.nop_reporter
104
+
105
+
let cmd =
106
+
let info = Cmd.info "myapp" in
107
+
Cmd.v info
108
+
Term.(const run $ Observe.setup ~json_reporter:(Some json_reporter) "myapp")
109
+
```
110
+
111
+
Requires the `json-logs` package.
112
+
113
+
### Probe Capture
114
+
115
+
Libraries that emit `ocaml-probe` events can be captured from any CLI using the
116
+
standard setup term:
117
+
118
+
<!-- $MDX non-deterministic=command -->
119
+
```sh
120
+
$ myapp --probe probes.json
121
+
```
122
+
123
+
The output is Catapult Trace Event Format JSON, suitable for `chrome://tracing`
124
+
or Perfetto. Probe capture starts the OCaml `Runtime_events` ring automatically.
125
+
126
+
### Memtrace
127
+
128
+
`Observe.setup` also exposes the `nox-memtrace` CLI terms:
129
+
130
+
<!-- $MDX non-deterministic=command -->
131
+
```sh
132
+
$ myapp --memtrace app.ctf
133
+
$ myapp --memtrace app.ctf --memtrace-rate 1e-6
134
+
```
135
+
136
+
This writes a memtrace `.ctf` allocation trace for analysis with
137
+
`memtrace_hotspots` or other memtrace tooling.
138
+
139
+
## API
140
+
141
+
- `Observe.setup` - Main cmdliner term combining all flags
142
+
- `Observe.quiet` - Term for `-q`/`--quiet`
143
+
- `Observe.verbosity` - Term for `-v`/`--verbose`
144
+
- `Observe.log_term` - Term for `--log` with env var
145
+
- `Observe.json` - Term for `--json`
146
+
- `Observe.trace_file` - Term for `--trace FILE`
147
+
- `Observe.probe_file` - Term for `--probe FILE`
148
+
- `Observe.probe_format` - Term for `--probe-format FORMAT`
149
+
- `Observe.probe_config` - Combined optional probe capture term
150
+
- `Observe.parse_log_spec` - Parse RUST_LOG-style spec
151
+
- `Observe.apply_source_overrides` - Apply per-source levels
152
+
- `Observe.configure_tracing_sources` - Enable/disable `*.tracing` sources
153
+
154
+
## Related Work
155
+
156
+
- [logs.cli](https://erratique.ch/software/logs) - Basic Cmdliner integration
157
+
in the Logs library. Provides `--verbosity` and `-v` flags. ocaml-observe
158
+
extends this with RUST_LOG-style per-source control, JSON output, trace-log
159
+
output, runtime probe capture, and memtrace.
160
+
- [env_logger](https://docs.rs/env_logger/) (Rust) - The inspiration for the `--log` flag syntax and `<APP>_LOG` environment variable pattern.
161
+
- [debug](https://www.npmjs.com/package/debug) (Node.js) - Popular namespace-based debug logging. Similar concept of per-source control.
162
+
163
+
## Licence
164
+
165
+
MIT License. See [LICENSE.md](LICENSE.md) for details.
+7
dune
+7
dune
+40
dune-project
+40
dune-project
···
1
+
(lang dune 3.21)
2
+
(using mdx 0.4)
3
+
4
+
(name ocaml-observe)
5
+
6
+
(generate_opam_files true)
7
+
(implicit_transitive_deps false)
8
+
9
+
(license MIT)
10
+
11
+
(authors "Thomas Gazagnaire <thomas@gazagnaire.org>")
12
+
13
+
(maintainers "Thomas Gazagnaire <thomas@gazagnaire.org>")
14
+
15
+
16
+
(source (tangled gazagnaire.org/ocaml-observe))
17
+
18
+
19
+
(package
20
+
(name ocaml-observe)
21
+
(synopsis "Cmdliner terms for CLI observability")
22
+
(tags (org:blacksun logging))
23
+
(description
24
+
"Provides Cmdliner terms for CLI observability: Logs verbosity flags (-q, -v, -vv, -vvv), RUST_LOG-style filtering (--log=level,src:level), JSON logs (--json), *.tracing log-source files (--trace FILE), and ocaml-probe runtime capture (--probe FILE).")
25
+
(depends
26
+
(ocaml (>= 4.14))
27
+
(logs (>= 0.7))
28
+
(fmt (>= 0.9))
29
+
base-unix
30
+
(cmdliner (>= 1.2))
31
+
(ptime (>= 1.0))
32
+
bytesrw
33
+
nox-json
34
+
nox-catapult
35
+
json-logs
36
+
nox-memtrace
37
+
ocaml-probe
38
+
(mdx :with-test)
39
+
nox-tty
40
+
(alcotest :with-test)))
+25
lib/dune
+25
lib/dune
···
1
+
(library
2
+
(name observe)
3
+
(public_name ocaml-observe)
4
+
(libraries
5
+
logs
6
+
logs.fmt
7
+
fmt
8
+
fmt.cli
9
+
fmt.tty
10
+
cmdliner
11
+
ptime
12
+
ptime.clock.os
13
+
bytesrw
14
+
nox-json
15
+
nox-catapult
16
+
json-logs
17
+
nox-memtrace
18
+
ocaml-probe
19
+
runtime_events
20
+
nox-tty
21
+
unix))
22
+
23
+
(mdx
24
+
(files observe.mli)
25
+
(libraries ocaml-observe cmdliner logs alcotest))
+620
lib/observe.ml
+620
lib/observe.ml
···
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
+
- Tracing log sources: [--trace FILE]
13
+
- Runtime probe capture: [--probe FILE]
14
+
- Allocation tracing: [--memtrace FILE] *)
15
+
16
+
open Cmdliner
17
+
18
+
(** {1 Verbosity Flags} *)
19
+
20
+
let observability_docs = "OBSERVABILITY"
21
+
22
+
let quiet =
23
+
let doc =
24
+
"Suppress non-error log records. This still allows explicit application \
25
+
output written by the command itself."
26
+
in
27
+
Arg.(value & flag & info [ "q"; "quiet" ] ~docs:observability_docs ~doc)
28
+
29
+
let verbosity =
30
+
let doc =
31
+
"Increase log verbosity. Use once for info, twice for debug, and three \
32
+
times to also enable log sources whose name ends in $(b,.tracing)."
33
+
in
34
+
Arg.(value & flag_all & info [ "v"; "verbose" ] ~docs:observability_docs ~doc)
35
+
36
+
let level_of_verbosity ~quiet ~verbosity =
37
+
if quiet then Some Logs.Error
38
+
else
39
+
match List.length verbosity with
40
+
| 0 -> Some Logs.Warning
41
+
| 1 -> Some Logs.Info
42
+
| _ -> Some Logs.Debug
43
+
44
+
let enable_tracing ~verbosity = List.length verbosity >= 3
45
+
46
+
(** {1 Log Spec Parsing} *)
47
+
48
+
type directive =
49
+
| Global of Logs.level option
50
+
| Source of string * Logs.level option
51
+
52
+
let parse_directive s =
53
+
let s = String.trim s in
54
+
if s = "" then None
55
+
else
56
+
match String.index_opt s ':' with
57
+
| None -> (
58
+
(* Bare level = global setting *)
59
+
match Logs.level_of_string s with
60
+
| Ok lvl -> Some (Global lvl)
61
+
| Error _ ->
62
+
Fmt.epr "Warning: invalid log level '%s'@." s;
63
+
None)
64
+
| Some i -> (
65
+
let src = String.sub s 0 i in
66
+
let lvl_s = String.sub s (i + 1) (String.length s - i - 1) in
67
+
match Logs.level_of_string lvl_s with
68
+
| Ok lvl -> Some (Source (src, lvl))
69
+
| Error _ ->
70
+
Fmt.epr "Warning: invalid log level '%s' for source '%s'@." lvl_s
71
+
src;
72
+
None)
73
+
74
+
let parse_log_spec spec =
75
+
let directives = String.split_on_char ',' spec in
76
+
let global = ref None in
77
+
let sources = ref [] in
78
+
List.iter
79
+
(fun d ->
80
+
match parse_directive d with
81
+
| Some (Global lvl) -> global := lvl
82
+
| Some (Source (src, lvl)) -> sources := (src, lvl) :: !sources
83
+
| None -> ())
84
+
directives;
85
+
(!global, List.rev !sources)
86
+
87
+
(** {1 Source Filtering} *)
88
+
89
+
let apply_source_overrides specs =
90
+
let all_sources = Logs.Src.list () in
91
+
List.iter
92
+
(fun (prefix, lvl) ->
93
+
List.iter
94
+
(fun src ->
95
+
let name = Logs.Src.name src in
96
+
(* Match exact name or prefix with dot separator *)
97
+
if
98
+
String.equal name prefix
99
+
|| String.length name > String.length prefix
100
+
&& String.sub name 0 (String.length prefix) = prefix
101
+
&& name.[String.length prefix] = '.'
102
+
then Logs.Src.set_level src lvl)
103
+
all_sources)
104
+
specs
105
+
106
+
let configure_tracing_sources ~enable =
107
+
let level = if enable then Some Logs.Debug else Some Logs.Warning in
108
+
List.iter
109
+
(fun src ->
110
+
let name = Logs.Src.name src in
111
+
(* Match *.tracing sources *)
112
+
if
113
+
String.length name > 8
114
+
&& String.sub name (String.length name - 8) 8 = ".tracing"
115
+
then Logs.Src.set_level src level)
116
+
(Logs.Src.list ())
117
+
118
+
(** {1 Trace File Reporter} *)
119
+
120
+
let level_string = function
121
+
| Logs.App -> "app"
122
+
| Logs.Error -> "error"
123
+
| Logs.Warning -> "warning"
124
+
| Logs.Info -> "info"
125
+
| Logs.Debug -> "debug"
126
+
127
+
let write_json_trace ppf ~ts ~name ~level_s msg k =
128
+
Fmt.pf ppf {|{"ts":"%s","src":"%s","level":"%s","msg":"%s"}@.|} ts name
129
+
level_s (String.escaped msg);
130
+
k ()
131
+
132
+
let write_tracing_entry ~json ppf ts name level fmt k =
133
+
if json then
134
+
Fmt.kstr
135
+
(fun msg ->
136
+
write_json_trace ppf ~ts ~name ~level_s:(level_string level) msg k)
137
+
fmt
138
+
else Fmt.kpf (fun _ -> k ()) ppf ("%s %s " ^^ fmt ^^ "@.") ts name
139
+
140
+
let is_tracing_src name =
141
+
String.length name > 8
142
+
&& String.sub name (String.length name - 8) 8 = ".tracing"
143
+
144
+
let report_tracing ~json ppf ~name level ~over k msgf =
145
+
msgf @@ fun ?header:_ ?tags:_ fmt ->
146
+
let k _ =
147
+
over ();
148
+
k ()
149
+
in
150
+
let ts = Ptime_clock.now () |> Ptime.to_rfc3339 in
151
+
write_tracing_entry ~json ppf ts name level fmt k
152
+
153
+
let trace_reporter ~json file_path =
154
+
let oc = open_out file_path in
155
+
let ppf = Format.formatter_of_out_channel oc in
156
+
let report src level ~over k msgf =
157
+
let name = Logs.Src.name src in
158
+
if is_tracing_src name then
159
+
report_tracing ~json ppf ~name level ~over k msgf
160
+
else (
161
+
over ();
162
+
k ())
163
+
in
164
+
{ Logs.report }
165
+
166
+
(** {1 Probe Capture} *)
167
+
168
+
type probe_format = Catapult
169
+
type probe_config = { file : string; format : probe_format }
170
+
171
+
module Probe_capture = struct
172
+
type scalar = String | Int | Int64 | Float | Bool
173
+
174
+
type descriptor = {
175
+
name : string;
176
+
kind : string;
177
+
fields : (string * scalar) list;
178
+
}
179
+
180
+
type t = { close : unit -> unit }
181
+
182
+
exception Parse_error of string
183
+
184
+
let fail_parse fmt = Fmt.kstr (fun s -> raise (Parse_error s)) fmt
185
+
let pid = Unix.getpid ()
186
+
let ts_us ts = Int64.to_float (Runtime_events.Timestamp.to_int64 ts) /. 1000.
187
+
let tid ring = ring
188
+
189
+
let skip_spaces s i =
190
+
let len = String.length s in
191
+
let rec loop i = if i < len && s.[i] = ' ' then loop (i + 1) else i in
192
+
loop i
193
+
194
+
let read_atom s i =
195
+
let i = skip_spaces s i in
196
+
let len = String.length s in
197
+
let rec loop j = if j >= len || s.[j] = ' ' then j else loop (j + 1) in
198
+
let j = loop i in
199
+
if i = j then fail_parse "expected atom at byte %d" i;
200
+
(String.sub s i (j - i), j)
201
+
202
+
let read_len_string s i =
203
+
let i = skip_spaces s i in
204
+
let len = String.length s in
205
+
let rec digits j =
206
+
if j >= len then fail_parse "unterminated length at byte %d" i;
207
+
match s.[j] with
208
+
| ':' -> j
209
+
| '0' .. '9' -> digits (j + 1)
210
+
| c -> fail_parse "bad length byte %C at byte %d" c j
211
+
in
212
+
let colon = digits i in
213
+
let n =
214
+
try int_of_string (String.sub s i (colon - i))
215
+
with Failure _ -> fail_parse "invalid length at byte %d" i
216
+
in
217
+
let start = colon + 1 in
218
+
if start + n > len then fail_parse "length %d exceeds packet size" n;
219
+
(String.sub s start n, start + n)
220
+
221
+
let read_named_value_head s i =
222
+
let name, i = read_len_string s i in
223
+
if i >= String.length s || s.[i] <> '=' then
224
+
fail_parse "expected '=' after field %S" name;
225
+
(name, i + 1)
226
+
227
+
let scalar_of_string = function
228
+
| "string" -> String
229
+
| "int" -> Int
230
+
| "int64" -> Int64
231
+
| "float" -> Float
232
+
| "bool" -> Bool
233
+
| s -> fail_parse "unknown scalar type %S" s
234
+
235
+
let json_of_scalar scalar s =
236
+
match scalar with
237
+
| String -> Json.string s
238
+
| Int -> Json.int (int_of_string s)
239
+
| Int64 -> Json.int64 (Int64.of_string s)
240
+
| Float -> Json.any_float (float_of_string s)
241
+
| Bool -> Json.bool (bool_of_string s)
242
+
243
+
let read_field_value s i = function
244
+
| String ->
245
+
let value, i = read_len_string s i in
246
+
(Json.string value, i)
247
+
| scalar ->
248
+
let value, i = read_atom s i in
249
+
(json_of_scalar scalar value, i)
250
+
251
+
let parse_metadata payload =
252
+
let tag, i = read_atom payload 0 in
253
+
if tag <> "meta" then fail_parse "not metadata";
254
+
let id_s, i = read_atom payload i in
255
+
let kind, i = read_atom payload i in
256
+
let name, i = read_len_string payload i in
257
+
let doc, i = read_len_string payload i in
258
+
let fields = ref [] in
259
+
let i = ref i in
260
+
while skip_spaces payload !i < String.length payload do
261
+
let field, j = read_named_value_head payload !i in
262
+
let scalar_s, j = read_atom payload j in
263
+
fields := (field, scalar_of_string scalar_s) :: !fields;
264
+
i := j
265
+
done;
266
+
(Int64.of_string id_s, { name; kind; fields = List.rev !fields }, doc)
267
+
268
+
let parse_data descriptors payload =
269
+
let phase, i = read_atom payload 0 in
270
+
let id_s, i = read_atom payload i in
271
+
let span_id, i = read_atom payload i in
272
+
let parent, i = read_atom payload i in
273
+
let id = Int64.of_string id_s in
274
+
let desc = Hashtbl.find_opt descriptors id in
275
+
let args = ref [] in
276
+
if phase <> "span-end" then
277
+
Option.iter
278
+
(fun desc ->
279
+
let i = ref i in
280
+
List.iter
281
+
(fun (expected_name, scalar) ->
282
+
let name, j = read_named_value_head payload !i in
283
+
let value, j = read_field_value payload j scalar in
284
+
let name = if name = expected_name then expected_name else name in
285
+
args := (name, value) :: !args;
286
+
i := j)
287
+
desc.fields)
288
+
desc;
289
+
let add_opt_arg name value =
290
+
if value <> "-" then args := (name, Json.string value) :: !args
291
+
in
292
+
add_opt_arg "span_id" span_id;
293
+
add_opt_arg "parent" parent;
294
+
(phase, id, desc, List.rev !args)
295
+
296
+
let metadata_event ~ring ~ts id desc doc =
297
+
Catapult.Event.instant ~pid ~tid:(tid ring) ~ts:(ts_us ts)
298
+
~name:"ocaml_probe.metadata"
299
+
~args:
300
+
[
301
+
("id", Json.int64 id);
302
+
("probe.name", Json.string desc.name);
303
+
("probe.kind", Json.string desc.kind);
304
+
("doc", Json.string doc);
305
+
]
306
+
()
307
+
308
+
let data_event ~ring ~ts user_name phase desc args =
309
+
let name = Option.fold ~none:user_name ~some:(fun d -> d.name) desc in
310
+
let ph =
311
+
match phase with
312
+
| "event" -> Catapult.Phase.Instant
313
+
| "span-begin" -> Catapult.Phase.Duration_begin
314
+
| "span-end" -> Catapult.Phase.Duration_end
315
+
| _ -> Catapult.Phase.Instant
316
+
in
317
+
Catapult.Event.v ~pid ~tid:(tid ring) ~ts:(ts_us ts) ~name ~args ph
318
+
319
+
let raw_event ~ring ~ts user_name payload error =
320
+
Catapult.Event.instant ~pid ~tid:(tid ring) ~ts:(ts_us ts)
321
+
~name:"ocaml_probe.decode_error"
322
+
~args:
323
+
[
324
+
("event", Json.string user_name);
325
+
("payload", Json.string payload);
326
+
("error", Json.string error);
327
+
]
328
+
()
329
+
330
+
let start_catapult file =
331
+
Runtime_events.start ();
332
+
let oc = open_out file in
333
+
let writer = Bytesrw.Bytes.Writer.of_out_channel oc in
334
+
let trace = Catapult.Writer.of_writer writer in
335
+
let descriptors = Hashtbl.create 64 in
336
+
let stop = Atomic.make false in
337
+
let cursor = Runtime_events.create_cursor None in
338
+
let emit event = Catapult.Writer.event trace event in
339
+
let handle_user ring ts user packet =
340
+
let user_name = Runtime_events.User.name user in
341
+
let payload = Probe.Consumer.packet_payload packet in
342
+
try
343
+
if user_name = "ocaml_probe.metadata" then (
344
+
let id, desc, doc = parse_metadata payload in
345
+
Hashtbl.replace descriptors id desc;
346
+
emit (metadata_event ~ring ~ts id desc doc))
347
+
else
348
+
let phase, _id, desc, args = parse_data descriptors payload in
349
+
emit (data_event ~ring ~ts user_name phase desc args)
350
+
with
351
+
| Parse_error error -> emit (raw_event ~ring ~ts user_name payload error)
352
+
| Failure error -> emit (raw_event ~ring ~ts user_name payload error)
353
+
| Invalid_argument error ->
354
+
emit (raw_event ~ring ~ts user_name payload error)
355
+
in
356
+
let callbacks =
357
+
Runtime_events.Callbacks.create ()
358
+
|> Runtime_events.Callbacks.add_user_event Probe.Consumer.packet_type
359
+
handle_user
360
+
in
361
+
let rec drain () =
362
+
let n = Runtime_events.read_poll cursor callbacks (Some 1024) in
363
+
if n > 0 then drain ()
364
+
in
365
+
let domain =
366
+
Domain.spawn (fun () ->
367
+
while not (Atomic.get stop) do
368
+
let n = Runtime_events.read_poll cursor callbacks (Some 1024) in
369
+
if n = 0 then Unix.sleepf 0.01
370
+
done;
371
+
drain ();
372
+
Runtime_events.free_cursor cursor)
373
+
in
374
+
let close () =
375
+
Atomic.set stop true;
376
+
Domain.join domain;
377
+
Catapult.Writer.close trace;
378
+
close_out_noerr oc
379
+
in
380
+
{ close }
381
+
382
+
let start { file; format = Catapult } =
383
+
let capture = start_catapult file in
384
+
let closed = Atomic.make false in
385
+
let close () =
386
+
if Atomic.compare_and_set closed false true then capture.close ()
387
+
in
388
+
at_exit close;
389
+
close
390
+
end
391
+
392
+
(** {1 Cmdliner Terms} *)
393
+
394
+
let log_term app_name =
395
+
let env_name = String.uppercase_ascii app_name ^ "_LOG" in
396
+
let env =
397
+
Fmt.kstr
398
+
(fun doc -> Cmd.Env.info env_name ~doc)
399
+
"Log configuration for %s. Format: LEVEL[,SRC:LEVEL,...]. Example: \
400
+
debug,tls.tracing:warning"
401
+
app_name
402
+
in
403
+
let doc =
404
+
"Set log level and per-source overrides. Format: LEVEL[,SRC:LEVEL,...]. \
405
+
Examples: $(b,debug), $(b,info,tls.tracing:warning), $(b,conpool:debug). \
406
+
Source names match exactly or by dot-separated prefix. Levels: error, \
407
+
warning, info, debug."
408
+
in
409
+
Arg.(
410
+
value
411
+
& opt (some string) None
412
+
& info [ "log" ] ~env ~docs:observability_docs ~doc ~docv:"SPEC")
413
+
414
+
let trace_file =
415
+
let doc =
416
+
"Write log records from sources whose name ends in $(b,.tracing) to \
417
+
$(docv). This is the old logs-side protocol trace stream: useful for \
418
+
verbose hexdumps and parser state logs. It is not a memtrace allocation \
419
+
trace and not an ocaml-probe Runtime_events capture."
420
+
in
421
+
Arg.(
422
+
value
423
+
& opt (some string) None
424
+
& info [ "trace" ] ~docs:observability_docs ~doc ~docv:"FILE")
425
+
426
+
let probe_file =
427
+
let doc =
428
+
"Capture typed $(b,ocaml-probe) Runtime_events to $(docv) in Catapult \
429
+
Trace Event Format. Use this for spans and structured protocol events \
430
+
that can be opened in Perfetto or chrome://tracing. The Runtime_events \
431
+
ring is started automatically."
432
+
in
433
+
Arg.(
434
+
value
435
+
& opt (some string) None
436
+
& info [ "probe" ] ~docs:observability_docs ~doc ~docv:"FILE")
437
+
438
+
let probe_format =
439
+
let doc =
440
+
"Output format for $(b,--probe). Supported value: $(b,catapult), the \
441
+
Chrome/Perfetto Trace Event Format JSON."
442
+
in
443
+
let formats = [ ("catapult", Catapult) ] in
444
+
Arg.(
445
+
value
446
+
& opt (enum formats) Catapult
447
+
& info [ "probe-format" ] ~docs:observability_docs ~doc ~docv:"FORMAT")
448
+
449
+
let probe_config =
450
+
Cmdliner.Term.(
451
+
const (fun probe_file probe_format ->
452
+
Option.map (fun file -> { file; format = probe_format }) probe_file)
453
+
$ probe_file $ probe_format)
454
+
455
+
let json =
456
+
let doc =
457
+
"Enable JSON mode. By default logs are emitted with json-logs; commands \
458
+
that produce their own JSON may pass a custom reporter to keep stdout \
459
+
reserved for command output."
460
+
in
461
+
Arg.(value & flag & info [ "json" ] ~docs:observability_docs ~doc)
462
+
463
+
let err_invalid_tag s =
464
+
Error (`Msg (Fmt.str "Invalid tag format '%s', expected KEY=VALUE" s))
465
+
466
+
let parse_tag s =
467
+
match String.index_opt s '=' with
468
+
| None -> err_invalid_tag s
469
+
| Some i ->
470
+
let key = String.sub s 0 i in
471
+
let value = String.sub s (i + 1) (String.length s - i - 1) in
472
+
Ok (key, value)
473
+
474
+
let log_tag_conv = Arg.conv (parse_tag, fun ppf (k, v) -> Fmt.pf ppf "%s=%s" k v)
475
+
476
+
let log_tags =
477
+
let doc =
478
+
"Add a base tag to JSON log output. Can be repeated. Format: KEY=VALUE. \
479
+
Tags are attached to every JSON log record. Example: $(b,--log-tag \
480
+
env=prod --log-tag region=us-east-1)."
481
+
in
482
+
Arg.(
483
+
value & opt_all log_tag_conv []
484
+
& info [ "log-tag" ] ~docs:observability_docs ~doc ~docv:"TAG")
485
+
486
+
(** {1 Setup} *)
487
+
488
+
type json_reporter =
489
+
app:string -> base:(string * string) list -> unit -> Logs.reporter
490
+
491
+
let default_json_reporter : json_reporter =
492
+
fun ~app ~base () -> Json_logs.reporter ~app ~base ()
493
+
494
+
let reporter ?(dst = Fmt.stderr) () = Logs_fmt.reporter ~app:dst ~dst ()
495
+
496
+
(** {1 Test Setup} *)
497
+
498
+
let setup_test ?(level = Logs.Debug) () =
499
+
(* Check TEST_LOG environment variable for level override. Supports
500
+
RUST_LOG-style syntax: "level" or "level,src:level,src:level" *)
501
+
let global_level, source_overrides =
502
+
match Sys.getenv_opt "TEST_LOG" with
503
+
| None -> (Some level, [])
504
+
| Some spec ->
505
+
let global, sources = parse_log_spec spec in
506
+
let lvl = match global with Some l -> Some l | None -> Some level in
507
+
(lvl, sources)
508
+
in
509
+
Fmt_tty.setup_std_outputs ();
510
+
Logs.set_level global_level;
511
+
Logs.set_reporter (Tty.Display.logs_reporter (Logs_fmt.reporter ()));
512
+
apply_source_overrides source_overrides
513
+
514
+
type log_flags = { quiet : bool; json : bool }
515
+
516
+
let current_json = ref false
517
+
let json_enabled () = !current_json
518
+
519
+
(** POSIX NO_COLOR: any non-empty value disables ANSI colour on stdout/stderr.
520
+
Exposed as a cmdliner flag so it is documented in [--help] and composed into
521
+
the log setup pipeline alongside [Fmt_cli.style_renderer]. An explicit
522
+
[--color=always] still wins — same precedence as POSIX. See
523
+
https://no-color.org. *)
524
+
let no_color_term =
525
+
let env =
526
+
Cmd.Env.info "NO_COLOR"
527
+
~doc:
528
+
"If set to any non-empty value, disable ANSI colour in all output. \
529
+
Overridden by an explicit --color=always. See https://no-color.org."
530
+
in
531
+
Arg.(
532
+
value & flag
533
+
& info [ "no-color" ] ~env ~docs:observability_docs
534
+
~doc:"Disable ANSI colour.")
535
+
536
+
let setup_log ~json_reporter app_name style_renderer no_color { quiet; json }
537
+
verbosity log_spec trace_file probe_config _memtrace base_tags =
538
+
current_json := json;
539
+
let style_renderer =
540
+
match style_renderer with
541
+
| Some _ -> style_renderer (* explicit --color wins *)
542
+
| None when no_color -> Some `None
543
+
| None -> None
544
+
in
545
+
Fmt_tty.setup_std_outputs ?style_renderer ();
546
+
(* Parse --log / <APP>_LOG spec *)
547
+
let global_override, source_overrides =
548
+
match log_spec with Some spec -> parse_log_spec spec | None -> (None, [])
549
+
in
550
+
(* Set reporter: JSON (via json_reporter) or Fmt (with optional trace file) *)
551
+
let main_reporter =
552
+
if json then json_reporter ~app:app_name ~base:base_tags ()
553
+
else Logs_fmt.reporter ()
554
+
in
555
+
let reporter =
556
+
match trace_file with
557
+
| Some path ->
558
+
(* Combine main reporter with trace file reporter *)
559
+
let trace_rep = trace_reporter ~json path in
560
+
let report src level ~over k msgf =
561
+
(* Send to both reporters *)
562
+
trace_rep.Logs.report src level
563
+
~over:(fun () -> ())
564
+
(fun () -> main_reporter.Logs.report src level ~over k msgf)
565
+
msgf
566
+
in
567
+
{ Logs.report }
568
+
| None -> main_reporter
569
+
in
570
+
Logs.set_reporter (Tty.Display.logs_reporter reporter);
571
+
(* Set global level: --log override > -q/-v flags *)
572
+
let level =
573
+
match global_override with
574
+
| Some lvl -> Some lvl
575
+
| None -> level_of_verbosity ~quiet ~verbosity
576
+
in
577
+
Logs.set_level level;
578
+
(* Configure tracing sources: -vvv or --trace enables them *)
579
+
let enable_trace = enable_tracing ~verbosity || Option.is_some trace_file in
580
+
configure_tracing_sources ~enable:enable_trace;
581
+
(* Apply per-source overrides from --log *)
582
+
apply_source_overrides source_overrides;
583
+
Option.iter
584
+
(fun config ->
585
+
let (_close : unit -> unit) = Probe_capture.start config in
586
+
())
587
+
probe_config
588
+
589
+
let setup ?json_reporter app_name =
590
+
let json_reporter =
591
+
match json_reporter with
592
+
| None -> Some default_json_reporter (* default: use json-logs *)
593
+
| Some None -> None (* explicitly disabled *)
594
+
| Some (Some r) -> Some r (* custom reporter *)
595
+
in
596
+
let flags_term =
597
+
Term.(const (fun quiet json -> { quiet; json }) $ quiet $ json)
598
+
in
599
+
match json_reporter with
600
+
| None ->
601
+
(* JSON disabled: no --json flag or --log-tag exposed *)
602
+
let setup_log' style_renderer no_color flags verbosity log_spec trace_file
603
+
probe_config memtrace =
604
+
setup_log
605
+
~json_reporter:(fun ~app:_ ~base:_ () -> Logs_fmt.reporter ())
606
+
app_name style_renderer no_color flags verbosity log_spec trace_file
607
+
probe_config memtrace []
608
+
in
609
+
Term.(
610
+
const setup_log' $ Fmt_cli.style_renderer () $ no_color_term
611
+
$ Term.(const (fun quiet -> { quiet; json = false }) $ quiet)
612
+
$ verbosity $ log_term app_name $ trace_file $ probe_config
613
+
$ Memtrace.term)
614
+
| Some r ->
615
+
(* JSON enabled: expose --json flag and --log-tag *)
616
+
Term.(
617
+
const (setup_log ~json_reporter:r app_name)
618
+
$ Fmt_cli.style_renderer () $ no_color_term $ flags_term $ verbosity
619
+
$ log_term app_name $ trace_file $ probe_config $ Memtrace.term
620
+
$ log_tags)
+214
lib/observe.mli
+214
lib/observe.mli
···
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
+
{b ocaml-observe} provides cmdliner terms that configure the {!Logs} library
9
+
with:
10
+
- Verbosity flags: [-q], [-v], [-vv], [-vvv]
11
+
- RUST_LOG-style configuration: [--log=level,src:level,...]
12
+
- JSON output: [--json]
13
+
- Tracing log sources: [--trace FILE]
14
+
- Runtime probe capture: [--probe FILE]
15
+
- Allocation tracing: [--memtrace FILE]
16
+
17
+
{2 Quick Start}
18
+
19
+
{[
20
+
let run_app () =
21
+
Logs.app (fun m -> m "myapp started");
22
+
Logs.info (fun m -> m "config loaded")
23
+
24
+
let cmd =
25
+
let open Cmdliner in
26
+
Cmd.v (Cmd.info "myapp")
27
+
Cmdliner.Term.(const run_app $ Observe.setup "myapp")
28
+
]}
29
+
30
+
{2 Command Line Usage}
31
+
32
+
{v
33
+
myapp -vv # debug level
34
+
myapp --log=info,http:debug # info + http at debug
35
+
MYAPP_LOG=debug myapp # via env var
36
+
myapp --json # structured output
37
+
myapp --trace protocol.log # *.tracing log-source output
38
+
myapp --probe probes.json # ocaml-probe Catapult trace
39
+
myapp --memtrace app.ctf # memtrace allocation trace
40
+
v}
41
+
42
+
{2 Verbosity Levels}
43
+
44
+
{v
45
+
| Flag | Level | *.tracing sources |
46
+
|--------|---------|-------------------|
47
+
| -q | Error | Silenced |
48
+
| (none) | Warning | Silenced |
49
+
| -v | Info | Silenced |
50
+
| -vv | Debug | Silenced |
51
+
| -vvv | Debug | Enabled |
52
+
v} *)
53
+
54
+
(** {1 Setup} *)
55
+
56
+
type json_reporter =
57
+
app:string -> base:(string * string) list -> unit -> Logs.reporter
58
+
(** A function that creates a {!Logs.reporter} for JSON output. Called with the
59
+
application name and base tags collected from [--log-tag] flags. *)
60
+
61
+
val reporter : ?dst:Format.formatter -> unit -> Logs.reporter
62
+
(** [reporter ()] is a plain-text {!Logs} reporter that writes every level
63
+
(including [App]) to [dst] (default {!Fmt.stderr}).
64
+
65
+
Use it as the {!type-json_reporter} of {!setup} for a tool that prints its
66
+
own JSON on stdout. By default [--json] sends log messages through
67
+
{!Json_logs.reporter}, so warnings and errors are emitted as JSON records
68
+
and [tool --json] appears to print two JSON documents. With this reporter,
69
+
stdout carries only the tool's JSON while log lines stay readable on stderr,
70
+
so [tool --json | jq] consumes a single object and a human still sees the
71
+
warnings. *)
72
+
73
+
val setup :
74
+
?json_reporter:json_reporter option -> string -> unit Cmdliner.Term.t
75
+
(** [setup ?json_reporter app_name] returns a cmdliner term that configures
76
+
logging for application [app_name].
77
+
78
+
The term provides these flags:
79
+
- [-q], [--quiet]: Error level only
80
+
- [-v], [--verbose]: Increase verbosity (can be repeated)
81
+
- [--log=SPEC]: RUST_LOG-style configuration
82
+
- [--json]: Enable JSON output (uses {!Json_logs.reporter} by default)
83
+
- [--log-tag=KEY=VALUE]: Add base tags to JSON output (can be repeated)
84
+
- [--trace=FILE]: Write [*.tracing] log-source output to file
85
+
- [--probe=FILE]: Capture [ocaml-probe] Runtime_events to Catapult TEF
86
+
- [--probe-format=catapult]: Select probe output format
87
+
- [--memtrace=FILE]: Write a memtrace allocation trace
88
+
- [--memtrace-rate=RATE]: Override memtrace sampling rate
89
+
- [--memtrace-context=CTX]: Add memtrace context metadata
90
+
91
+
Environment variable [$APP_NAME_LOG] is also checked (e.g., [MYAPP_LOG]).
92
+
93
+
JSON output automatically includes hostname, pid, and app name, plus any
94
+
tags added via [--log-tag].
95
+
96
+
@param json_reporter
97
+
Controls JSON output behaviour:
98
+
- Omitted (default): uses {!Json_logs.reporter} when [--json] is passed
99
+
- [Some custom_fn]: uses [custom_fn] when [--json] is passed
100
+
- [None]: disables JSON output ([--json] and [--log-tag] flags not
101
+
exposed) *)
102
+
103
+
(** {1 Individual Terms}
104
+
105
+
For advanced use cases where you need more control. *)
106
+
107
+
val quiet : bool Cmdliner.Term.t
108
+
(** [quiet] is the term for [-q]/[--quiet] flag. *)
109
+
110
+
val verbosity : bool list Cmdliner.Term.t
111
+
(** [verbosity] is the term for [-v]/[--verbose] flags. Length indicates
112
+
verbosity level. *)
113
+
114
+
val log_term : string -> string option Cmdliner.Term.t
115
+
(** [log_term app_name] returns a term for [--log] with environment variable
116
+
[$APP_NAME_LOG]. *)
117
+
118
+
val trace_file : string option Cmdliner.Term.t
119
+
(** Term for [--trace FILE] flag. *)
120
+
121
+
type probe_format = Catapult (** Probe export format. *)
122
+
123
+
type probe_config = private { file : string; format : probe_format }
124
+
(** Probe capture configuration from [--probe] / [--probe-format]. *)
125
+
126
+
val probe_file : string option Cmdliner.Term.t
127
+
(** Term for [--probe FILE] flag. *)
128
+
129
+
val probe_format : probe_format Cmdliner.Term.t
130
+
(** Term for [--probe-format FORMAT] flag. *)
131
+
132
+
val probe_config : probe_config option Cmdliner.Term.t
133
+
(** Combined optional probe capture term. *)
134
+
135
+
val json : bool Cmdliner.Term.t
136
+
(** [json] is the term for [--json] flag. *)
137
+
138
+
val json_enabled : unit -> bool
139
+
(** [json_enabled ()] is [true] after setup when [--json] was passed. *)
140
+
141
+
val log_tags : (string * string) list Cmdliner.Term.t
142
+
(** Term for [--log-tag KEY=VALUE] flags. *)
143
+
144
+
(** {1 Parsing Utilities} *)
145
+
146
+
val parse_log_spec :
147
+
string -> Logs.level option * (string * Logs.level option) list
148
+
(** [parse_log_spec spec] parses a RUST_LOG-style specification. Returns
149
+
[(global_level, source_overrides)].
150
+
151
+
Examples:
152
+
- ["debug"] -> [Some Debug, []]
153
+
- ["info,http:debug"] -> [Some Info, [("http", Some Debug)]]
154
+
- ["conpool:warning"] -> [None, [("conpool", Some Warning)]]. *)
155
+
156
+
val apply_source_overrides : (string * Logs.level option) list -> unit
157
+
(** [apply_source_overrides overrides] sets log levels for matching sources.
158
+
Sources are matched by exact name or prefix (e.g., ["http"] matches
159
+
["http.client"], ["http.server"]). *)
160
+
161
+
val configure_tracing_sources : enable:bool -> unit
162
+
(** [configure_tracing_sources ~enable] enables or silences all [*.tracing] log
163
+
sources. When [enable] is false, tracing sources are set to Warning level to
164
+
suppress verbose protocol output. *)
165
+
166
+
(** {1 Verbosity Helpers} *)
167
+
168
+
val level_of_verbosity : quiet:bool -> verbosity:bool list -> Logs.level option
169
+
(** [level_of_verbosity ~quiet ~verbosity] computes the log level from flags.
170
+
- [quiet=true]: Error
171
+
- [verbosity=[]]: Warning
172
+
- [verbosity=[_]]: Info
173
+
- [verbosity=[_;_]] or more: Debug. *)
174
+
175
+
val enable_tracing : verbosity:bool list -> bool
176
+
(** [enable_tracing ~verbosity] returns [true] if verbosity >= 3 (i.e., [-vvv]).
177
+
*)
178
+
179
+
(** {1 Test Setup} *)
180
+
181
+
val setup_test : ?level:Logs.level -> unit -> unit
182
+
(** [setup_test ?level ()] configures logging for tests.
183
+
184
+
Sets up {!Logs_fmt.reporter} with the specified level (default: Debug).
185
+
Since Alcotest captures output by default and only shows it on failure,
186
+
debug-level logging is appropriate for tests.
187
+
188
+
Checks the [TEST_LOG] environment variable for level override, supporting
189
+
the same RUST_LOG-style syntax as [--log]:
190
+
- [TEST_LOG=info] - set global level to info
191
+
- [TEST_LOG=warning,conpool:debug] - warning globally, debug for conpool
192
+
- [TEST_LOG=http:debug,tls:warning] - per-source overrides only
193
+
194
+
{2 Usage}
195
+
196
+
In [test.ml]:
197
+
{[
198
+
let run () =
199
+
Observe.setup_test ~level:Logs.Debug ();
200
+
Alcotest.run "mylib" []
201
+
]}
202
+
203
+
Run with reduced noise:
204
+
{v TEST_LOG=warning dune test v}
205
+
206
+
Debug a specific source:
207
+
{v TEST_LOG=warning,conpool:debug dune test v}
208
+
209
+
{2 Comparison with Other Ecosystems}
210
+
211
+
This follows patterns from other languages:
212
+
- Rust: [RUST_LOG=warn,mycrate::module=debug]
213
+
- Go (IPFS): [GOLOG_LOG_LEVEL=error,subsystem=debug]
214
+
- Node.js: [DEBUG=prefix:*] or [LOG_LEVEL=debug]. *)
+49
ocaml-observe.opam
+49
ocaml-observe.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "Cmdliner terms for CLI observability"
4
+
description:
5
+
"Provides Cmdliner terms for CLI observability: Logs verbosity flags (-q, -v, -vv, -vvv), RUST_LOG-style filtering (--log=level,src:level), JSON logs (--json), *.tracing log-source files (--trace FILE), and ocaml-probe runtime capture (--probe FILE)."
6
+
maintainer: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
7
+
authors: ["Thomas Gazagnaire <thomas@gazagnaire.org>"]
8
+
license: "MIT"
9
+
tags: ["org:blacksun" "logging"]
10
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-observe"
11
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-observe/issues"
12
+
depends: [
13
+
"dune" {>= "3.21"}
14
+
"ocaml" {>= "4.14"}
15
+
"logs" {>= "0.7"}
16
+
"fmt" {>= "0.9"}
17
+
"base-unix"
18
+
"cmdliner" {>= "1.2"}
19
+
"ptime" {>= "1.0"}
20
+
"bytesrw"
21
+
"nox-json"
22
+
"nox-catapult"
23
+
"json-logs"
24
+
"nox-memtrace"
25
+
"ocaml-probe"
26
+
"mdx" {with-test}
27
+
"nox-tty"
28
+
"alcotest" {with-test}
29
+
"odoc" {with-doc}
30
+
]
31
+
build: [
32
+
["dune" "subst"] {dev}
33
+
[
34
+
"dune"
35
+
"build"
36
+
"-p"
37
+
name
38
+
"-j"
39
+
jobs
40
+
"@install"
41
+
"@runtest" {with-test}
42
+
"@doc" {with-doc}
43
+
]
44
+
]
45
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-observe"
46
+
x-maintenance-intent: ["(latest)"]
47
+
x-quality-build: "2026-04-15"
48
+
x-quality-cram: "2026-04-15"
49
+
x-quality-test: "2026-04-15"
+3
ocaml-observe.opam.template
+3
ocaml-observe.opam.template
+119
test/cram/cli.t/run.t
+119
test/cram/cli.t/run.t
···
1
+
Test ocaml-observe CLI flags
2
+
3
+
$ export NO_COLOR=1
4
+
5
+
Default: warning level, tracing silenced
6
+
$ test_cli.exe 2>&1
7
+
test_cli.exe: [ERROR] error message
8
+
test_cli.exe: [WARNING] warning message
9
+
10
+
Quiet mode: errors only
11
+
$ test_cli.exe -q 2>&1
12
+
test_cli.exe: [ERROR] error message
13
+
14
+
Verbose: info level
15
+
$ test_cli.exe -v 2>&1
16
+
test_cli.exe: [ERROR] error message
17
+
test_cli.exe: [WARNING] warning message
18
+
test_cli.exe: [INFO] info message
19
+
20
+
Very verbose: debug level (tracing still silenced)
21
+
$ test_cli.exe -vv 2>&1
22
+
test_cli.exe: [ERROR] error message
23
+
test_cli.exe: [WARNING] warning message
24
+
test_cli.exe: [INFO] info message
25
+
test_cli.exe: [DEBUG] debug message
26
+
27
+
Triple verbose: debug + tracing enabled
28
+
$ test_cli.exe -vvv 2>&1
29
+
test_cli.exe: [ERROR] error message
30
+
test_cli.exe: [WARNING] warning message
31
+
test_cli.exe: [INFO] info message
32
+
test_cli.exe: [DEBUG] debug message
33
+
test_cli.exe: [DEBUG] trace message
34
+
35
+
Using --log flag for global level
36
+
$ test_cli.exe --log=error 2>&1
37
+
test_cli.exe: [ERROR] error message
38
+
39
+
$ test_cli.exe --log=info 2>&1
40
+
test_cli.exe: [ERROR] error message
41
+
test_cli.exe: [WARNING] warning message
42
+
test_cli.exe: [INFO] info message
43
+
44
+
Using --log flag for per-source override
45
+
$ test_cli.exe --log=warning,test:debug 2>&1
46
+
test_cli.exe: [ERROR] error message
47
+
test_cli.exe: [WARNING] warning message
48
+
test_cli.exe: [INFO] info message
49
+
test_cli.exe: [DEBUG] debug message
50
+
test_cli.exe: [DEBUG] trace message
51
+
52
+
Enable tracing via --log
53
+
$ test_cli.exe --log=warning,test.tracing:debug 2>&1
54
+
test_cli.exe: [ERROR] error message
55
+
test_cli.exe: [WARNING] warning message
56
+
test_cli.exe: [DEBUG] trace message
57
+
58
+
Combined: global + per-source
59
+
$ test_cli.exe --log=debug,test.tracing:warning 2>&1
60
+
test_cli.exe: [ERROR] error message
61
+
test_cli.exe: [WARNING] warning message
62
+
test_cli.exe: [INFO] info message
63
+
test_cli.exe: [DEBUG] debug message
64
+
65
+
Environment variable
66
+
$ TEST_LOG=info test_cli.exe 2>&1
67
+
test_cli.exe: [ERROR] error message
68
+
test_cli.exe: [WARNING] warning message
69
+
test_cli.exe: [INFO] info message
70
+
71
+
Help output shows all flags
72
+
$ test_cli.exe --help=plain 2>&1 | grep -E '^ (-q|--quiet|-v|--verbose|--log|--json|--trace|--probe|--memtrace)'
73
+
--json
74
+
--log=SPEC (absent TEST_LOG env)
75
+
--log-tag=TAG
76
+
--memtrace=FILE (absent MEMTRACE env)
77
+
--memtrace-context=CTX (absent MEMTRACE_CONTEXT env)
78
+
--memtrace-rate=RATE (absent MEMTRACE_RATE env)
79
+
--probe=FILE
80
+
--probe-format=FORMAT (absent=catapult)
81
+
-q, --quiet
82
+
--trace=FILE
83
+
-v, --verbose
84
+
85
+
Probe capture writes Catapult trace events
86
+
$ test_cli.exe --probe probe.json 2>&1
87
+
test_cli.exe: [ERROR] error message
88
+
test_cli.exe: [WARNING] warning message
89
+
90
+
$ grep -o 'ocaml_probe.metadata' probe.json | head -n 1
91
+
ocaml_probe.metadata
92
+
93
+
$ grep -o 'ocaml-observe.test.event' probe.json | head -n 1
94
+
ocaml-observe.test.event
95
+
96
+
JSON output: default level (warning) - includes app, hostname, pid
97
+
$ test_cli.exe --json 2>&1 | sed 's/"timestamp":"[^"]*"/"timestamp":"..."/g; s/"hostname":"[^"]*"/"hostname":"..."/g; s/"pid":"[^"]*"/"pid":"..."/g'
98
+
{"timestamp":"...","level":"error","source":"test","message":"error message","app":"test","hostname":"...","pid":"..."}
99
+
{"timestamp":"...","level":"warning","source":"test","message":"warning message","app":"test","hostname":"...","pid":"..."}
100
+
101
+
JSON output: verbose level
102
+
$ test_cli.exe --json -v 2>&1 | sed 's/"timestamp":"[^"]*"/"timestamp":"..."/g; s/"hostname":"[^"]*"/"hostname":"..."/g; s/"pid":"[^"]*"/"pid":"..."/g'
103
+
{"timestamp":"...","level":"error","source":"test","message":"error message","app":"test","hostname":"...","pid":"..."}
104
+
{"timestamp":"...","level":"warning","source":"test","message":"warning message","app":"test","hostname":"...","pid":"..."}
105
+
{"timestamp":"...","level":"info","source":"test","message":"info message","app":"test","hostname":"...","pid":"..."}
106
+
107
+
JSON output: with custom tags
108
+
$ test_cli.exe --json --log-tag env=test --log-tag region=local 2>&1 | sed 's/"timestamp":"[^"]*"/"timestamp":"..."/g; s/"hostname":"[^"]*"/"hostname":"..."/g; s/"pid":"[^"]*"/"pid":"..."/g'
109
+
{"timestamp":"...","level":"error","source":"test","message":"error message","app":"test","hostname":"...","pid":"...","env":"test","region":"local"}
110
+
{"timestamp":"...","level":"warning","source":"test","message":"warning message","app":"test","hostname":"...","pid":"...","env":"test","region":"local"}
111
+
112
+
JSON disabled: --json flag not exposed
113
+
$ test_cli_no_json.exe --help=plain 2>&1 | grep -E '^\s+--json' || echo "no --json flag"
114
+
no --json flag
115
+
116
+
$ test_cli_no_json.exe -v 2>&1
117
+
test_cli_no_json.exe: [ERROR] error message
118
+
test_cli_no_json.exe: [WARNING] warning message
119
+
test_cli_no_json.exe: [INFO] info message
+4
test/cram/dune
+4
test/cram/dune
+3
test/cram/helpers/dune
+3
test/cram/helpers/dune
+45
test/cram/helpers/test_cli.ml
+45
test/cram/helpers/test_cli.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI for ocaml-observe cram tests. *)
7
+
8
+
open Cmdliner
9
+
10
+
(* Create a test log source *)
11
+
let src = Logs.Src.create "test" ~doc:"Test source"
12
+
13
+
module Log = (val Logs.src_log src : Logs.LOG)
14
+
15
+
(* Create a tracing source *)
16
+
let tracing_src = Logs.Src.create "test.tracing" ~doc:"Test tracing source"
17
+
18
+
module Trace = (val Logs.src_log tracing_src : Logs.LOG)
19
+
20
+
type probe_payload = { message : string; answer : int }
21
+
22
+
let probe_event =
23
+
Probe.event "ocaml-observe.test.event" ~doc:"Observe probe fixture event"
24
+
Probe.Fields.(
25
+
obj (fun message answer -> ({ message; answer } : probe_payload))
26
+
|> field "message" string ~enc:(fun t -> t.message)
27
+
|> field "answer" int ~enc:(fun t -> t.answer)
28
+
|> seal)
29
+
30
+
let run _config =
31
+
Probe.emit probe_event { message = "probe message"; answer = 42 };
32
+
Log.err (fun m -> m "error message");
33
+
Log.warn (fun m -> m "warning message");
34
+
Log.info (fun m -> m "info message");
35
+
Log.debug (fun m -> m "debug message");
36
+
Trace.debug (fun m -> m "trace message")
37
+
38
+
let suite = ("cli", [ Alcotest.test_case "noop" `Quick ignore ])
39
+
40
+
let cmd =
41
+
let doc = "Test CLI for ocaml-observe" in
42
+
let info = Cmd.info "test-cli" ~doc in
43
+
Cmd.v info Term.(const run $ Observe.setup "test")
44
+
45
+
let () = exit (Cmd.eval cmd)
+9
test/cram/helpers/test_cli.mli
+9
test/cram/helpers/test_cli.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI executable for ocaml-observe cram tests. *)
7
+
8
+
val suite : string * unit Alcotest.test_case list
9
+
(** Alcotest suite exercising the CLI logging setup. *)
+26
test/cram/helpers/test_cli_no_json.ml
+26
test/cram/helpers/test_cli_no_json.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI with JSON disabled. *)
7
+
8
+
open Cmdliner
9
+
10
+
let src = Logs.Src.create "test" ~doc:"Test source"
11
+
12
+
module Log = (val Logs.src_log src : Logs.LOG)
13
+
14
+
let run () =
15
+
Log.err (fun m -> m "error message");
16
+
Log.warn (fun m -> m "warning message");
17
+
Log.info (fun m -> m "info message")
18
+
19
+
let suite = ("cli_no_json", [ Alcotest.test_case "noop" `Quick ignore ])
20
+
21
+
let cmd =
22
+
let doc = "Test CLI for ocaml-observe with JSON disabled" in
23
+
let info = Cmd.info "test-cli-no-json" ~doc in
24
+
Cmd.v info Term.(const run $ Observe.setup ~json_reporter:None "test")
25
+
26
+
let () = exit (Cmd.eval cmd)
+9
test/cram/helpers/test_cli_no_json.mli
+9
test/cram/helpers/test_cli_no_json.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test CLI executable for ocaml-observe cram tests (JSON disabled). *)
7
+
8
+
val suite : string * unit Alcotest.test_case list
9
+
(** Alcotest suite exercising the CLI logging setup. *)
+6
test/test.ml
+6
test/test.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let () = Alcotest.run "ocaml-observe" [ Test_observe.suite ]
+85
test/test_observe.ml
+85
test/test_observe.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for Observe. *)
7
+
8
+
let test_parse_log_spec_global () =
9
+
let level, srcs = Observe.parse_log_spec "debug" in
10
+
Alcotest.(check (option (of_pp Logs.pp_level)))
11
+
"global level" (Some Logs.Debug) level;
12
+
Alcotest.(check (list (pair string (option (of_pp Logs.pp_level)))))
13
+
"no sources" [] srcs
14
+
15
+
let test_parse_log_spec_source () =
16
+
let level, srcs = Observe.parse_log_spec "info,http:debug" in
17
+
Alcotest.(check (option (of_pp Logs.pp_level)))
18
+
"global info" (Some Logs.Info) level;
19
+
Alcotest.(check int) "one source" 1 (List.length srcs);
20
+
let src_name, src_level = List.hd srcs in
21
+
Alcotest.(check string) "source name" "http" src_name;
22
+
Alcotest.(check (option (of_pp Logs.pp_level)))
23
+
"source level" (Some Logs.Debug) src_level
24
+
25
+
let test_parse_spec_src_only () =
26
+
let level, srcs = Observe.parse_log_spec "conpool:warning" in
27
+
Alcotest.(check (option (of_pp Logs.pp_level))) "no global" None level;
28
+
Alcotest.(check int) "one source" 1 (List.length srcs);
29
+
let src_name, src_level = List.hd srcs in
30
+
Alcotest.(check string) "source name" "conpool" src_name;
31
+
Alcotest.(check (option (of_pp Logs.pp_level)))
32
+
"source level" (Some Logs.Warning) src_level
33
+
34
+
let test_level_of_verbosity_quiet () =
35
+
let level = Observe.level_of_verbosity ~quiet:true ~verbosity:[] in
36
+
Alcotest.(check (option (of_pp Logs.pp_level)))
37
+
"quiet=error" (Some Logs.Error) level
38
+
39
+
let test_level_of_verbosity_default () =
40
+
let level = Observe.level_of_verbosity ~quiet:false ~verbosity:[] in
41
+
Alcotest.(check (option (of_pp Logs.pp_level)))
42
+
"default=warning" (Some Logs.Warning) level
43
+
44
+
let test_level_of_verbosity_v () =
45
+
let level = Observe.level_of_verbosity ~quiet:false ~verbosity:[ true ] in
46
+
Alcotest.(check (option (of_pp Logs.pp_level)))
47
+
"-v=info" (Some Logs.Info) level
48
+
49
+
let test_level_of_verbosity_vv () =
50
+
let level =
51
+
Observe.level_of_verbosity ~quiet:false ~verbosity:[ true; true ]
52
+
in
53
+
Alcotest.(check (option (of_pp Logs.pp_level)))
54
+
"-vv=debug" (Some Logs.Debug) level
55
+
56
+
let test_enable_tracing_false () =
57
+
Alcotest.(check bool)
58
+
"no tracing by default" false
59
+
(Observe.enable_tracing ~verbosity:[])
60
+
61
+
let test_enable_tracing_vvv () =
62
+
Alcotest.(check bool)
63
+
"tracing at -vvv" true
64
+
(Observe.enable_tracing ~verbosity:[ true; true; true ])
65
+
66
+
let suite =
67
+
( "observe",
68
+
[
69
+
Alcotest.test_case "parse_log_spec global" `Quick
70
+
test_parse_log_spec_global;
71
+
Alcotest.test_case "parse_log_spec source" `Quick
72
+
test_parse_log_spec_source;
73
+
Alcotest.test_case "parse_log_spec src only" `Quick
74
+
test_parse_spec_src_only;
75
+
Alcotest.test_case "level_of_verbosity quiet" `Quick
76
+
test_level_of_verbosity_quiet;
77
+
Alcotest.test_case "level_of_verbosity default" `Quick
78
+
test_level_of_verbosity_default;
79
+
Alcotest.test_case "level_of_verbosity -v" `Quick
80
+
test_level_of_verbosity_v;
81
+
Alcotest.test_case "level_of_verbosity -vv" `Quick
82
+
test_level_of_verbosity_vv;
83
+
Alcotest.test_case "enable_tracing false" `Quick test_enable_tracing_false;
84
+
Alcotest.test_case "enable_tracing -vvv" `Quick test_enable_tracing_vvv;
85
+
] )
+9
test/test_observe.mli
+9
test/test_observe.mli
···
1
+
(** Tests for the Observe module. *)
2
+
3
+
(*---------------------------------------------------------------------------
4
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
5
+
SPDX-License-Identifier: MIT
6
+
---------------------------------------------------------------------------*)
7
+
8
+
val suite : string * unit Alcotest.test_case list
9
+
(** [suite] is the Alcotest test suite for [Observe]. *)