gazagnaire.org
forked from
anil.recoil.org/ocaml-requests
A batteries included HTTP/1.1 client in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** HTTP request timing metrics
7
8 Per Recommendation #12: Detailed timing breakdown for requests, similar to
9 curl's --write-out timing variables.
10
11 Timing phases:
12 {[
13 |--DNS--|--Connect--|--TLS--|--Request--|--Wait--|--Content--|
14 ^ ^ ^ ^ ^ ^
15 namelookup connect ssl_handsh send ttfb total
16 ]} *)
17
18let src = Logs.Src.create "requests.timing" ~doc:"HTTP request timing"
19
20module Log = (val Logs.src_log src : Logs.LOG)
21
22type t = {
23 dns_lookup : float option; (** Time for DNS resolution *)
24 tcp_connect : float option; (** Time to establish TCP connection *)
25 tls_handshake : float option; (** Time for TLS handshake (HTTPS only) *)
26 request_sent : float option; (** Time to send request *)
27 time_to_first_byte : float option;
28 (** Time from request sent to first byte received *)
29 content_transfer : float option; (** Time to transfer response body *)
30 total : float; (** Total request time *)
31}
32(** Timing metrics for a single request *)
33
34let empty =
35 {
36 dns_lookup = None;
37 tcp_connect = None;
38 tls_handshake = None;
39 request_sent = None;
40 time_to_first_byte = None;
41 content_transfer = None;
42 total = 0.0;
43 }
44
45let v ?dns_lookup ?tcp_connect ?tls_handshake ?request_sent ?time_to_first_byte
46 ?content_transfer ~total () =
47 {
48 dns_lookup;
49 tcp_connect;
50 tls_handshake;
51 request_sent;
52 time_to_first_byte;
53 content_transfer;
54 total;
55 }
56
57let dns_lookup t = t.dns_lookup
58let tcp_connect t = t.tcp_connect
59let tls_handshake t = t.tls_handshake
60let request_sent t = t.request_sent
61let time_to_first_byte t = t.time_to_first_byte
62let content_transfer t = t.content_transfer
63let total t = t.total
64
65(** Connection setup time (DNS + TCP + TLS) *)
66let connection_time t =
67 let dns = Option.value t.dns_lookup ~default:0.0 in
68 let tcp = Option.value t.tcp_connect ~default:0.0 in
69 let tls = Option.value t.tls_handshake ~default:0.0 in
70 Some (dns +. tcp +. tls)
71
72(** Server processing time (TTFB - request send time) *)
73let server_time t =
74 match (t.time_to_first_byte, t.request_sent) with
75 | Some ttfb, Some send -> Some (ttfb -. send)
76 | _ -> None
77
78(** Pretty-print timing in human readable format *)
79let pp ppf t =
80 let pp_opt ppf = function
81 | Some v -> Fmt.pf ppf "%.3fms" (v *. 1000.0)
82 | None -> Fmt.pf ppf "-"
83 in
84 Fmt.pf ppf
85 "@[<v>Timing:@,\
86 DNS lookup: %a@,\
87 TCP connect: %a@,\
88 TLS handshake: %a@,\
89 Request sent: %a@,\
90 Time to 1st byte: %a@,\
91 Content transfer: %a@,\
92 Total: %.3fms@]"
93 pp_opt t.dns_lookup pp_opt t.tcp_connect pp_opt t.tls_handshake pp_opt
94 t.request_sent pp_opt t.time_to_first_byte pp_opt t.content_transfer
95 (t.total *. 1000.0)
96
97let to_string t = Fmt.str "%a" pp t
98
99(** Convert to JSON-like association list for logging/debugging *)
100let to_assoc t =
101 let add_opt name = function Some v -> [ (name, v) ] | None -> [] in
102 add_opt "dns_lookup" t.dns_lookup
103 @ add_opt "tcp_connect" t.tcp_connect
104 @ add_opt "tls_handshake" t.tls_handshake
105 @ add_opt "request_sent" t.request_sent
106 @ add_opt "time_to_first_byte" t.time_to_first_byte
107 @ add_opt "content_transfer" t.content_transfer
108 @ [ ("total", t.total) ]
109
110(** {1 Timer for Collecting Metrics}
111
112 Use this during request execution to collect timing data. *)
113
114type timer = {
115 start : float;
116 mutable dns_end : float option;
117 mutable connect_end : float option;
118 mutable tls_end : float option;
119 mutable send_end : float option;
120 mutable ttfb : float option;
121 mutable transfer_end : float option;
122}
123
124let start () =
125 {
126 start = Unix.gettimeofday ();
127 dns_end = None;
128 connect_end = None;
129 tls_end = None;
130 send_end = None;
131 ttfb = None;
132 transfer_end = None;
133 }
134
135let mark_dns timer = timer.dns_end <- Some (Unix.gettimeofday ())
136let mark_connect timer = timer.connect_end <- Some (Unix.gettimeofday ())
137let mark_tls timer = timer.tls_end <- Some (Unix.gettimeofday ())
138let mark_send timer = timer.send_end <- Some (Unix.gettimeofday ())
139let mark_ttfb timer = timer.ttfb <- Some (Unix.gettimeofday ())
140let mark_transfer_end timer = timer.transfer_end <- Some (Unix.gettimeofday ())
141
142let finish timer =
143 let now = Unix.gettimeofday () in
144 let total = now -. timer.start in
145
146 let calc_phase start_time end_time =
147 Option.map
148 (fun e -> e -. Option.value start_time ~default:timer.start)
149 end_time
150 in
151
152 {
153 dns_lookup = calc_phase (Some timer.start) timer.dns_end;
154 tcp_connect = calc_phase timer.dns_end timer.connect_end;
155 tls_handshake = calc_phase timer.connect_end timer.tls_end;
156 request_sent =
157 calc_phase
158 (if Option.is_some timer.tls_end then timer.tls_end
159 else timer.connect_end)
160 timer.send_end;
161 time_to_first_byte = calc_phase timer.send_end timer.ttfb;
162 content_transfer = calc_phase timer.ttfb timer.transfer_end;
163 total;
164 }
165
166(** Log timing metrics *)
167let log_timing ?(level = Logs.Debug) t = Log.msg level (fun m -> m "%a" pp t)