anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>.
3
4 All rights reserved.
5
6 Redistribution and use in source and binary forms, with or without
7 modification, are permitted provided that the following conditions are met:
8
9 1. Redistributions of source code must retain the above copyright notice,
10 this list of conditions and the following disclaimer.
11
12 2. Redistributions in binary form must reproduce the above copyright notice,
13 this list of conditions and the following disclaimer in the documentation
14 and/or other materials provided with the distribution.
15
16 3. Neither the name of the copyright holder nor the names of its contributors
17 may be used to endorse or promote products derived from this software
18 without specific prior written permission.
19
20 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
24 LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25 CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26 SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27 INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28 CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29 ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30 POSSIBILITY OF SUCH DAMAGE.
31 SPDX-License-Identifier: BSD-3-Clause
32 ---------------------------------------------------------------------------*)
33
34(** HTTP Protocol Abstraction Layer.
35
36 This module provides a unified interface for making HTTP requests
37 over either HTTP/1.1 or HTTP/2, with automatic protocol selection
38 via TLS ALPN negotiation.
39
40 {2 Protocol Selection}
41
42 For HTTPS connections, ALPN (Application-Layer Protocol Negotiation)
43 is used during the TLS handshake to agree on the protocol:
44 - If both client and server support HTTP/2, "h2" is selected
45 - Otherwise, "http/1.1" is used as fallback
46
47 For plain HTTP connections, only HTTP/1.1 is used (h2c not supported).
48
49 See {{:https://datatracker.ietf.org/doc/html/rfc9113#section-3}RFC 9113 Section 3}
50 for protocol identification requirements. *)
51
52let src = Logs.Src.create "h2.protocol" ~doc:"HTTP Protocol Abstraction"
53module Log = (val Logs.src_log src : Logs.LOG)
54
55(* ============================================================
56 Protocol Selection Mode
57 ============================================================ *)
58
59(** Protocol selection mode.
60
61 Controls how the HTTP protocol version is selected for connections. *)
62type mode =
63 | Auto
64 (** Use ALPN negotiation for HTTPS, prefer HTTP/2 if available.
65 Falls back to HTTP/1.1 if peer doesn't support HTTP/2. *)
66 | Http1_only
67 (** Force HTTP/1.1 only, no ALPN negotiation for HTTP/2.
68 Use when connecting to servers known to have HTTP/2 issues. *)
69 | Http2_only
70 (** Require HTTP/2, fail if not available.
71 Use when HTTP/2 features (multiplexing, etc) are required. *)
72
73let pp_mode fmt = function
74 | Auto -> Format.fprintf fmt "Auto"
75 | Http1_only -> Format.fprintf fmt "Http1_only"
76 | Http2_only -> Format.fprintf fmt "Http2_only"
77
78let mode_to_string = function
79 | Auto -> "auto"
80 | Http1_only -> "http1-only"
81 | Http2_only -> "http2-only"
82
83(* ============================================================
84 ALPN Protocol List Generation
85 ============================================================ *)
86
87(** Get ALPN protocols for TLS configuration based on mode.
88
89 @param mode Protocol selection mode
90 @return List of ALPN protocol identifiers in preference order *)
91let alpn_protocols mode =
92 match mode with
93 | Auto ->
94 (* Prefer HTTP/2, fallback to HTTP/1.1 *)
95 ["h2"; "http/1.1"]
96 | Http1_only ->
97 (* Only HTTP/1.1 *)
98 ["http/1.1"]
99 | Http2_only ->
100 (* Only HTTP/2 *)
101 ["h2"]
102
103(* ============================================================
104 Negotiated Protocol
105 ============================================================ *)
106
107(** The negotiated HTTP protocol for a connection. *)
108type negotiated =
109 | Http1_1
110 (** HTTP/1.1 protocol *)
111 | Http2
112 (** HTTP/2 protocol *)
113
114let pp_negotiated fmt = function
115 | Http1_1 -> Format.fprintf fmt "HTTP/1.1"
116 | Http2 -> Format.fprintf fmt "HTTP/2"
117
118let negotiated_to_string = function
119 | Http1_1 -> "HTTP/1.1"
120 | Http2 -> "HTTP/2"
121
122(** Parse ALPN result string to negotiated protocol. *)
123let negotiated_of_alpn = function
124 | "h2" -> Some Http2
125 | "http/1.1" -> Some Http1_1
126 | _ -> None
127
128(** Get the default protocol when ALPN is not available.
129
130 For plain HTTP connections (no TLS), HTTP/1.1 is always used.
131 For TLS connections without ALPN, HTTP/1.1 is the safe default. *)
132let default_protocol () = Http1_1
133
134(* ============================================================
135 TLS Configuration with ALPN
136 ============================================================ *)
137
138(** Create TLS configuration with ALPN protocols.
139
140 @param mode Protocol selection mode
141 @param verify_tls Whether to verify server certificate
142 @param host Hostname for SNI
143 @return TLS client configuration with ALPN protocols configured *)
144let create_tls_config ~mode ~verify_tls ~host:_ () =
145 let alpn = alpn_protocols mode in
146 Log.debug (fun m -> m "Creating TLS config with ALPN: %s"
147 (String.concat ", " alpn));
148
149 (* Build authenticator *)
150 let authenticator =
151 if verify_tls then
152 match Ca_certs.authenticator () with
153 | Ok auth -> auth
154 | Error (`Msg msg) ->
155 Log.err (fun m -> m "Failed to load CA certificates: %s" msg);
156 failwith ("CA certificates error: " ^ msg)
157 else
158 (* No verification *)
159 fun ?ip:_ ~host:_ _ -> Ok None
160 in
161
162 (* Create config with ALPN *)
163 match Tls.Config.client
164 ~authenticator
165 ~alpn_protocols:alpn
166 ~version:(`TLS_1_2, `TLS_1_3)
167 ()
168 with
169 | Ok cfg -> cfg
170 | Error (`Msg msg) ->
171 Log.err (fun m -> m "Failed to create TLS config: %s" msg);
172 failwith ("TLS config error: " ^ msg)
173
174(** Get negotiated ALPN protocol from TLS epoch data.
175
176 After TLS handshake, the epoch data contains the negotiated ALPN.
177
178 @param epoch TLS epoch data from handshake
179 @return Negotiated protocol, or None if ALPN not used *)
180let get_alpn_from_epoch epoch =
181 epoch.Tls.Core.alpn_protocol
182
183(* ============================================================
184 Protocol Detection
185 ============================================================ *)
186
187(** Detect the negotiated protocol after TLS handshake.
188
189 @param mode Protocol selection mode
190 @param alpn_result ALPN result from TLS epoch (if any)
191 @return Negotiated protocol
192
193 @raise Failure if Http2_only mode but HTTP/2 not negotiated *)
194let detect_protocol ~mode alpn_result =
195 match alpn_result with
196 | Some alpn ->
197 Log.debug (fun m -> m "ALPN negotiated: %s" alpn);
198 (match negotiated_of_alpn alpn with
199 | Some proto -> proto
200 | None ->
201 Log.warn (fun m -> m "Unknown ALPN result: %s, defaulting to HTTP/1.1" alpn);
202 Http1_1)
203 | None ->
204 Log.debug (fun m -> m "No ALPN result, using default protocol");
205 match mode with
206 | Http2_only ->
207 failwith "HTTP/2 required but ALPN negotiation failed or not supported"
208 | Auto | Http1_only ->
209 default_protocol ()
210
211(* ============================================================
212 Request/Response Types
213 ============================================================ *)
214
215(** HTTP request representation.
216
217 A protocol-agnostic request that can be sent over HTTP/1.1 or HTTP/2. *)
218type request = {
219 meth : string;
220 (** HTTP method (GET, POST, etc) *)
221 uri : Uri.t;
222 (** Request URI *)
223 headers : (string * string) list;
224 (** Request headers (name, value) pairs *)
225 body : string option;
226 (** Optional request body *)
227}
228
229(** Create a request.
230
231 @param meth HTTP method
232 @param uri Request URI (can be absolute or path-only)
233 @param headers Request headers
234 @param body Optional request body
235 @return Request value *)
236let make_request ~meth ~uri ?(headers = []) ?body () =
237 { meth; uri; headers; body }
238
239(** Create request from string components.
240
241 @param meth HTTP method
242 @param scheme URL scheme (http or https)
243 @param host Hostname
244 @param port Optional port number
245 @param path Request path (defaults to "/")
246 @param query Optional query parameters
247 @param headers Request headers
248 @param body Optional request body *)
249let make_request_from_strings ~meth ~scheme ~host ?port ?(path="/") ?(query=[]) ?(headers = []) ?body () =
250 let uri = Uri.make ~scheme ~host ?port ~path ~query () in
251 { meth; uri; headers; body }
252
253(** HTTP response representation.
254
255 A protocol-agnostic response that can come from HTTP/1.1 or HTTP/2. *)
256type response = {
257 status : int;
258 (** HTTP status code *)
259 headers : (string * string) list;
260 (** Response headers *)
261 body : string;
262 (** Response body *)
263 protocol : negotiated;
264 (** Protocol used for this response *)
265}
266
267(** Pretty print response. *)
268let pp_response fmt r =
269 Format.fprintf fmt "Response{status=%d; protocol=%a; body_len=%d}"
270 r.status pp_negotiated r.protocol (String.length r.body)
271
272(* ============================================================
273 Connection State
274 ============================================================ *)
275
276(** Protocol-specific connection state.
277
278 This is an internal type that tracks the state needed for
279 making requests over a specific protocol. *)
280type connection_state =
281 | Http1_state
282 (** HTTP/1.1 connection - stateless, each request is independent *)
283 | Http2_state of H2_connection.t
284 (** HTTP/2 connection - maintains multiplexed state *)
285
286(** A protocol-aware connection.
287
288 Wraps the underlying transport with protocol-specific state. *)
289type connection = {
290 protocol : negotiated;
291 (** Negotiated protocol *)
292 state : connection_state;
293 (** Protocol-specific state *)
294}
295
296(** Create a connection with detected protocol.
297
298 @param protocol Negotiated protocol
299 @return Connection value *)
300let create_connection ~protocol =
301 let state = match protocol with
302 | Http1_1 -> Http1_state
303 | Http2 ->
304 let conn = H2_connection.create H2_connection.Client in
305 Http2_state conn
306 in
307 { protocol; state }
308
309(** Get the protocol for a connection. *)
310let connection_protocol conn = conn.protocol
311
312(** Get the HTTP/2 connection state, if using HTTP/2. *)
313let get_h2_connection conn =
314 match conn.state with
315 | Http2_state c -> Some c
316 | Http1_state -> None
317
318(** Check if connection is using HTTP/2. *)
319let is_http2 conn = conn.protocol = Http2
320
321(** Check if connection is using HTTP/1.1. *)
322let is_http1 conn = conn.protocol = Http1_1
323
324(* ============================================================
325 Request Conversion for HTTP/2
326 ============================================================ *)
327
328(** Convert request to HTTP/2 pseudo-headers.
329
330 HTTP/2 uses pseudo-headers (prefixed with ':') instead of the
331 request line. See RFC 9113 Section 8.3.1.
332
333 @param request The request to convert
334 @return List of HPACK headers including pseudo-headers *)
335let request_to_h2_headers request =
336 let uri = request.uri in
337 let scheme = Uri.scheme uri |> Option.value ~default:"https" in
338 let authority = match Uri.host uri, Uri.port uri with
339 | Some h, Some p -> Printf.sprintf "%s:%d" h p
340 | Some h, None -> h
341 | None, _ -> ""
342 in
343 let path =
344 let p = Uri.path uri in
345 let q = Uri.query uri in
346 if q = [] then
347 (if p = "" then "/" else p)
348 else
349 let query_str = Uri.encoded_of_query q in
350 (if p = "" then "/" else p) ^ "?" ^ query_str
351 in
352
353 (* Pseudo-headers must come first *)
354 let pseudo_headers = [
355 { H2_hpack.name = ":method"; value = request.meth; sensitive = false };
356 { H2_hpack.name = ":scheme"; value = scheme; sensitive = false };
357 { H2_hpack.name = ":authority"; value = authority; sensitive = false };
358 { H2_hpack.name = ":path"; value = path; sensitive = false };
359 ] in
360
361 (* Convert regular headers *)
362 let regular_headers = List.map (fun (name, value) ->
363 (* HTTP/2 requires lowercase header names *)
364 let name_lower = String.lowercase_ascii name in
365 (* Mark Authorization and Cookie as sensitive *)
366 let sensitive = name_lower = "authorization" || name_lower = "cookie" in
367 { H2_hpack.name = name_lower; value; sensitive }
368 ) request.headers in
369
370 pseudo_headers @ regular_headers
371
372(** Convert HTTP/2 response headers to header list.
373
374 Extracts the :status pseudo-header and regular headers.
375
376 @param h2_headers HPACK headers from response
377 @return (status_code, headers list) *)
378let h2_headers_to_response h2_headers =
379 let fold_header (status, headers) (h : H2_hpack.header) =
380 if h.name = ":status" then
381 (int_of_string h.value, headers)
382 else if String.length h.name > 0 && h.name.[0] = ':' then
383 (status, headers) (* Skip other pseudo-headers *)
384 else
385 (status, (h.name, h.value) :: headers)
386 in
387 let status, headers = List.fold_left fold_header (200, []) h2_headers in
388 (status, List.rev headers)
389
390(* ============================================================
391 Pretty Printing
392 ============================================================ *)
393
394let pp_request fmt r =
395 Format.fprintf fmt "Request{%s %a; headers=%d; body=%s}"
396 r.meth Uri.pp r.uri
397 (List.length r.headers)
398 (match r.body with Some b -> string_of_int (String.length b) | None -> "none")