ocaml http/1, http/2 and websocket client and server library
gdiazlo.tngl.sh
1(** Logging module for HCS HTTP library.
2
3 Provides structured logging for HTTP events including requests, responses,
4 connections, and errors. The module is runtime-agnostic and uses a
5 callback-based approach for flexibility.
6
7 {1 Usage}
8
9 {[
10 (* Use built-in stderr logger *)
11 let logger = Hcs.Log.stderr ()
12
13 (* Use null logger (no output) *)
14 let logger = Hcs.Log.null
15
16 (* Use custom logger *)
17 let logger =
18 Hcs.Log.custom (fun level msg ->
19 match level with
20 | Hcs.Log.Error -> Printf.eprintf "[ERROR] %s\n%!" msg
21 | _ ->
22 Printf.printf "[%s] %s\n%!" (Hcs.Log.level_to_string level) msg)
23 ]} *)
24
25(** {1 Types} *)
26
27(** Log levels *)
28type level =
29 | Debug (** Detailed debugging information *)
30 | Info (** General information about operations *)
31 | Warn (** Warning conditions *)
32 | Error (** Error conditions *)
33
34(** HTTP method for logging (simplified) *)
35type http_method =
36 | GET
37 | POST
38 | PUT
39 | DELETE
40 | PATCH
41 | HEAD
42 | OPTIONS
43 | CONNECT
44 | TRACE
45 | Other of string
46
47(** Log events - structured events that can be logged *)
48type event =
49 | Request_start of {
50 id : string;
51 meth : http_method;
52 uri : string;
53 headers : (string * string) list;
54 } (** Request started *)
55 | Request_end of {
56 id : string;
57 status : int;
58 duration_ms : float;
59 body_size : int option;
60 } (** Request completed *)
61 | Connection_open of {
62 host : string;
63 port : int;
64 protocol : string; (** "http/1.1" or "h2" *)
65 } (** Connection opened *)
66 | Connection_close of { host : string; port : int; reason : string }
67 (** Connection closed *)
68 | Connection_reuse of { host : string; port : int }
69 (** Connection reused from pool *)
70 | Tls_handshake of {
71 host : string;
72 protocol : string; (** TLS version *)
73 cipher : string option;
74 } (** TLS handshake completed *)
75 | Retry of {
76 id : string;
77 attempt : int;
78 reason : string;
79 delay_ms : float option;
80 } (** Request retry *)
81 | Redirect of {
82 id : string;
83 from_uri : string;
84 to_uri : string;
85 status : int;
86 } (** Following redirect *)
87 | Error of { id : string option; error : string; context : string option }
88 (** Error occurred *)
89 | Custom of { name : string; data : (string * string) list }
90 (** Custom event *)
91
92type logger = level -> event -> unit
93(** Logger function type *)
94
95(** {1 Level operations} *)
96
97(** Convert level to string *)
98let level_to_string = function
99 | Debug -> "DEBUG"
100 | Info -> "INFO"
101 | Warn -> "WARN"
102 | Error -> "ERROR"
103
104(** Parse level from string *)
105let level_of_string = function
106 | "DEBUG" | "debug" -> Some Debug
107 | "INFO" | "info" -> Some Info
108 | "WARN" | "warn" | "WARNING" | "warning" -> Some Warn
109 | "ERROR" | "error" -> Some Error
110 | _ -> None
111
112(** Compare log levels (for filtering) *)
113let level_to_int = function Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
114
115let level_gte l1 l2 = level_to_int l1 >= level_to_int l2
116
117(** {1 HTTP method operations} *)
118
119let method_to_string = function
120 | GET -> "GET"
121 | POST -> "POST"
122 | PUT -> "PUT"
123 | DELETE -> "DELETE"
124 | PATCH -> "PATCH"
125 | HEAD -> "HEAD"
126 | OPTIONS -> "OPTIONS"
127 | CONNECT -> "CONNECT"
128 | TRACE -> "TRACE"
129 | Other s -> s
130
131let method_of_h1 (m : Httpun_types.Method.t) : http_method =
132 match m with
133 | `GET -> GET
134 | `POST -> POST
135 | `PUT -> PUT
136 | `DELETE -> DELETE
137 | `HEAD -> HEAD
138 | `OPTIONS -> OPTIONS
139 | `CONNECT -> CONNECT
140 | `TRACE -> TRACE
141 | `Other s -> Other s
142
143(** {1 Event formatting} *)
144
145(** Format event as a human-readable string *)
146let event_to_string = function
147 | Request_start { id; meth; uri; headers = _ } ->
148 Buf.build64 (fun b ->
149 Buf.string b "Request[";
150 Buf.string b id;
151 Buf.string b "] ";
152 Buf.string b (method_to_string meth);
153 Buf.char b ' ';
154 Buf.string b uri)
155 | Request_end { id; status; duration_ms; body_size } ->
156 Buf.build64 (fun b ->
157 Buf.string b "Request[";
158 Buf.string b id;
159 Buf.string b "] completed: status=";
160 Buf.int b status;
161 Buf.string b ", duration=";
162 Buf.float2 b duration_ms;
163 Buf.string b "ms";
164 match body_size with
165 | Some s ->
166 Buf.string b ", ";
167 Buf.int b s;
168 Buf.string b " bytes"
169 | None -> ())
170 | Connection_open { host; port; protocol } ->
171 Buf.build64 (fun b ->
172 Buf.string b "Connection opened: ";
173 Buf.string b host;
174 Buf.char b ':';
175 Buf.int b port;
176 Buf.string b " (";
177 Buf.string b protocol;
178 Buf.char b ')')
179 | Connection_close { host; port; reason } ->
180 Buf.build64 (fun b ->
181 Buf.string b "Connection closed: ";
182 Buf.string b host;
183 Buf.char b ':';
184 Buf.int b port;
185 Buf.string b " (";
186 Buf.string b reason;
187 Buf.char b ')')
188 | Connection_reuse { host; port } ->
189 Buf.build64 (fun b ->
190 Buf.string b "Connection reused: ";
191 Buf.string b host;
192 Buf.char b ':';
193 Buf.int b port)
194 | Tls_handshake { host; protocol; cipher } ->
195 Buf.build64 (fun b ->
196 Buf.string b "TLS handshake: ";
197 Buf.string b host;
198 Buf.string b " (";
199 Buf.string b protocol;
200 (match cipher with
201 | Some c ->
202 Buf.string b ", cipher=";
203 Buf.string b c
204 | None -> ());
205 Buf.char b ')')
206 | Retry { id; attempt; reason; delay_ms } ->
207 Buf.build64 (fun b ->
208 Buf.string b "Request[";
209 Buf.string b id;
210 Buf.string b "] retry #";
211 Buf.int b attempt;
212 Buf.string b ": ";
213 Buf.string b reason;
214 match delay_ms with
215 | Some d ->
216 Buf.string b ", delay=";
217 Buf.float0 b d;
218 Buf.string b "ms"
219 | None -> ())
220 | Redirect { id; from_uri; to_uri; status } ->
221 Buf.build64 (fun b ->
222 Buf.string b "Request[";
223 Buf.string b id;
224 Buf.string b "] redirect ";
225 Buf.int b status;
226 Buf.string b ": ";
227 Buf.string b from_uri;
228 Buf.string b " -> ";
229 Buf.string b to_uri)
230 | Error { id; error; context } ->
231 Buf.build64 (fun b ->
232 Buf.string b "Error";
233 (match id with
234 | Some i ->
235 Buf.char b '[';
236 Buf.string b i;
237 Buf.string b "] "
238 | None -> ());
239 Buf.string b ": ";
240 Buf.string b error;
241 match context with
242 | Some c ->
243 Buf.string b " (";
244 Buf.string b c;
245 Buf.char b ')'
246 | None -> ())
247 | Custom { name; data } ->
248 Buf.build64 (fun b ->
249 Buf.string b "Custom[";
250 Buf.string b name;
251 Buf.string b "]: ";
252 let first = ref true in
253 List.iter
254 (fun (k, v) ->
255 if !first then first := false else Buf.string b ", ";
256 Buf.string b k;
257 Buf.char b '=';
258 Buf.string b v)
259 data)
260
261(** Format event as JSON string *)
262let event_to_json = function
263 | Request_start { id; meth; uri; headers } ->
264 Buf.build64 (fun b ->
265 Buf.string b {|{"event":"request_start","id":|};
266 Buf.json_string_quoted b id;
267 Buf.string b {|,"method":|};
268 Buf.json_string_quoted b (method_to_string meth);
269 Buf.string b {|,"uri":|};
270 Buf.json_string_quoted b uri;
271 Buf.string b {|,"headers":{|};
272 let first = ref true in
273 List.iter
274 (fun (k, v) ->
275 if !first then first := false else Buf.char b ',';
276 Buf.json_string_quoted b k;
277 Buf.char b ':';
278 Buf.json_string_quoted b v)
279 headers;
280 Buf.string b "}}")
281 | Request_end { id; status; duration_ms; body_size } ->
282 Buf.build64 (fun b ->
283 Buf.string b {|{"event":"request_end","id":|};
284 Buf.json_string_quoted b id;
285 Buf.string b {|,"status":|};
286 Buf.int b status;
287 Buf.string b {|,"duration_ms":|};
288 Buf.float2 b duration_ms;
289 (match body_size with
290 | Some s ->
291 Buf.string b {|,"body_size":|};
292 Buf.int b s
293 | None -> ());
294 Buf.char b '}')
295 | Connection_open { host; port; protocol } ->
296 Buf.build64 (fun b ->
297 Buf.string b {|{"event":"connection_open","host":|};
298 Buf.json_string_quoted b host;
299 Buf.string b {|,"port":|};
300 Buf.int b port;
301 Buf.string b {|,"protocol":|};
302 Buf.json_string_quoted b protocol;
303 Buf.char b '}')
304 | Connection_close { host; port; reason } ->
305 Buf.build64 (fun b ->
306 Buf.string b {|{"event":"connection_close","host":|};
307 Buf.json_string_quoted b host;
308 Buf.string b {|,"port":|};
309 Buf.int b port;
310 Buf.string b {|,"reason":|};
311 Buf.json_string_quoted b reason;
312 Buf.char b '}')
313 | Connection_reuse { host; port } ->
314 Buf.build64 (fun b ->
315 Buf.string b {|{"event":"connection_reuse","host":|};
316 Buf.json_string_quoted b host;
317 Buf.string b {|,"port":|};
318 Buf.int b port;
319 Buf.char b '}')
320 | Tls_handshake { host; protocol; cipher } ->
321 Buf.build64 (fun b ->
322 Buf.string b {|{"event":"tls_handshake","host":|};
323 Buf.json_string_quoted b host;
324 Buf.string b {|,"protocol":|};
325 Buf.json_string_quoted b protocol;
326 (match cipher with
327 | Some c ->
328 Buf.string b {|,"cipher":|};
329 Buf.json_string_quoted b c
330 | None -> ());
331 Buf.char b '}')
332 | Retry { id; attempt; reason; delay_ms } ->
333 Buf.build64 (fun b ->
334 Buf.string b {|{"event":"retry","id":|};
335 Buf.json_string_quoted b id;
336 Buf.string b {|,"attempt":|};
337 Buf.int b attempt;
338 Buf.string b {|,"reason":|};
339 Buf.json_string_quoted b reason;
340 (match delay_ms with
341 | Some d ->
342 Buf.string b {|,"delay_ms":|};
343 Buf.float0 b d
344 | None -> ());
345 Buf.char b '}')
346 | Redirect { id; from_uri; to_uri; status } ->
347 Buf.build64 (fun b ->
348 Buf.string b {|{"event":"redirect","id":|};
349 Buf.json_string_quoted b id;
350 Buf.string b {|,"from":|};
351 Buf.json_string_quoted b from_uri;
352 Buf.string b {|,"to":|};
353 Buf.json_string_quoted b to_uri;
354 Buf.string b {|,"status":|};
355 Buf.int b status;
356 Buf.char b '}')
357 | Error { id; error; context } ->
358 Buf.build64 (fun b ->
359 Buf.string b {|{"event":"error"|};
360 (match id with
361 | Some i ->
362 Buf.string b {|,"id":|};
363 Buf.json_string_quoted b i
364 | None -> ());
365 Buf.string b {|,"error":|};
366 Buf.json_string_quoted b error;
367 (match context with
368 | Some c ->
369 Buf.string b {|,"context":|};
370 Buf.json_string_quoted b c
371 | None -> ());
372 Buf.char b '}')
373 | Custom { name; data } ->
374 Buf.build64 (fun b ->
375 Buf.string b {|{"event":"custom","name":|};
376 Buf.json_string_quoted b name;
377 Buf.string b {|,"data":{|};
378 let first = ref true in
379 List.iter
380 (fun (k, v) ->
381 if !first then first := false else Buf.char b ',';
382 Buf.json_string_quoted b k;
383 Buf.char b ':';
384 Buf.json_string_quoted b v)
385 data;
386 Buf.string b "}}")
387
388(** {1 Built-in Loggers} *)
389
390(** Null logger - discards all events *)
391let null : logger = fun _ _ -> ()
392
393(** Stderr logger with optional minimum level filter *)
394let stderr ?(min_level = Debug) ?(json = false) () : logger =
395 fun level event ->
396 if level_gte level min_level then
397 let formatted =
398 if json then event_to_json event else event_to_string event
399 in
400 Printf.eprintf "[%s] %s\n%!" (level_to_string level) formatted
401
402(** Stdout logger with optional minimum level filter *)
403let stdout ?(min_level = Debug) ?(json = false) () : logger =
404 fun level event ->
405 if level_gte level min_level then
406 let formatted =
407 if json then event_to_json event else event_to_string event
408 in
409 Printf.printf "[%s] %s\n%!" (level_to_string level) formatted
410
411(** Custom logger from a simple callback *)
412let custom (f : level -> string -> unit) : logger =
413 fun level event -> f level (event_to_string event)
414
415(** Custom logger with JSON output *)
416let custom_json (f : level -> string -> unit) : logger =
417 fun level event -> f level (event_to_json event)
418
419(** Combine multiple loggers *)
420let combine (loggers : logger list) : logger =
421 fun level event -> List.iter (fun logger -> logger level event) loggers
422
423(** Filter logger by minimum level *)
424let with_min_level (min_level : level) (logger : logger) : logger =
425 fun level event -> if level_gte level min_level then logger level event
426
427(** {1 Request ID generation} *)
428
429(** Counter for unique request IDs *)
430let request_id_counter = ref 0
431
432(** Generate a unique request ID *)
433let generate_request_id () =
434 incr request_id_counter;
435 let random = Random.int 0xFFFF in
436 let buf = Buffer.create 32 in
437 Buffer.add_string buf "req-";
438 let n = !request_id_counter in
439 let s = string_of_int n in
440 for _ = 1 to 6 - String.length s do
441 Buffer.add_char buf '0'
442 done;
443 Buffer.add_string buf s;
444 Buffer.add_char buf '-';
445 let hex_buf = Buffer.create 8 in
446 Buf.hex hex_buf random;
447 let hx = Buffer.contents hex_buf in
448 for _ = 1 to 4 - String.length hx do
449 Buffer.add_char buf '0'
450 done;
451 Buffer.add_string buf hx;
452 Buffer.contents buf