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
6let src = Logs.Src.create "requests.one" ~doc:"One-shot HTTP Requests"
7
8module Log = (val Logs.src_log src : Logs.LOG)
9
10(* Redirect handling - delegated to shared Redirect module *)
11
12(* Helper to create TCP connection to host:port *)
13let connect_tcp ~sw ~net ~host ~port =
14 Log.debug (fun m -> m "Connecting to %s:%d" host port);
15 (* Resolve hostname to IP address *)
16 let addrs =
17 Eio.Net.getaddrinfo_stream net host ~service:(string_of_int port)
18 in
19 match addrs with
20 | addr :: _ ->
21 Log.debug (fun m -> m "Resolved %s, connecting..." host);
22 Eio.Net.connect ~sw net addr
23 | [] ->
24 Log.err (fun m -> m "Failed to resolve hostname: %s" host);
25 raise (Error.err (Error.Dns_resolution_failed { hostname = host }))
26
27(** Minimum TLS version configuration - re-exported from Tls_config. *)
28type tls_version = Tls_config.tls_version =
29 | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
30 | TLS_1_3
31 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
32
33(** Negotiated protocol after TLS handshake *)
34type negotiated_protocol =
35 | Http1 (** HTTP/1.x (including plain HTTP) *)
36 | Http2 (** HTTP/2 negotiated via ALPN *)
37
38(* Track whether TLS tracing has been suppressed *)
39let tls_tracing_suppressed = ref false
40
41(* Suppress TLS tracing debug output (hexdumps) unless explicitly enabled *)
42let suppress_tls_tracing () =
43 if not !tls_tracing_suppressed then begin
44 tls_tracing_suppressed := true;
45 match
46 List.find_opt
47 (fun s -> Logs.Src.name s = "tls.tracing")
48 (Logs.Src.list ())
49 with
50 | Some tls_src -> (
51 (* Only suppress if currently at Debug level *)
52 match Logs.Src.level tls_src with
53 | Some Logs.Debug -> Logs.Src.set_level tls_src (Some Logs.Warning)
54 | _ -> ())
55 | None -> ()
56 end
57
58(* Helper to wrap connection with TLS if needed.
59 Returns the TLS flow and the negotiated protocol. *)
60let wrap_tls flow ~host ~verify_tls ~tls_config ~min_tls_version =
61 Log.debug (fun m ->
62 m "Wrapping connection with TLS for %s (verify=%b)" host verify_tls);
63
64 (* Get or create TLS config with minimum version enforcement *)
65 let tls_cfg =
66 match tls_config with
67 | Some cfg -> cfg
68 | None -> Tls_config.client ~verify_tls ~min_tls_version ~host ()
69 in
70
71 (* Get domain name for SNI *)
72 let domain =
73 match Domain_name.of_string host with
74 | Ok dn -> (
75 match Domain_name.host dn with
76 | Ok d -> d
77 | Error (`Msg msg) ->
78 Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
79 raise
80 (Error.err
81 (Error.Tls_handshake_failed
82 { host; reason = "Invalid hostname: " ^ msg })))
83 | Error (`Msg msg) ->
84 Log.err (fun m -> m "Invalid hostname for TLS: %s (%s)" host msg);
85 raise
86 (Error.err
87 (Error.Tls_handshake_failed
88 { host; reason = "Invalid hostname: " ^ msg }))
89 in
90
91 let tls_flow = Tls_eio.client_of_flow ~host:domain tls_cfg flow in
92 (* Suppress TLS tracing after first connection creates the tls.tracing source *)
93 suppress_tls_tracing ();
94
95 (* Check negotiated ALPN protocol *)
96 let protocol =
97 match Tls_eio.epoch tls_flow with
98 | Ok epoch -> (
99 match epoch.Tls.Core.alpn_protocol with
100 | Some "h2" ->
101 Log.info (fun m -> m "ALPN negotiated HTTP/2 for %s" host);
102 Http2
103 | Some proto ->
104 Log.debug (fun m -> m "ALPN negotiated %s for %s" proto host);
105 Http1
106 | None ->
107 Log.debug (fun m ->
108 m "No ALPN negotiated for %s, using HTTP/1.1" host);
109 Http1)
110 | Error () ->
111 Log.debug (fun m ->
112 m "Could not get TLS epoch for %s, using HTTP/1.1" host);
113 Http1
114 in
115
116 ( (tls_flow :> [ `Close | `Flow | `R | `Shutdown | `W ] Eio.Resource.t),
117 protocol )
118
119(* Parse URL and connect directly (no pooling).
120 Returns the flow and the negotiated protocol. *)
121let connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config
122 ~min_tls_version =
123 let uri = Uri.of_string url in
124
125 (* Extract host and port *)
126 let host =
127 match Uri.host uri with
128 | Some h -> h
129 | None ->
130 raise
131 (Error.err
132 (Error.Invalid_url { url; reason = "URL must contain a host" }))
133 in
134
135 let is_https = Uri.scheme uri = Some "https" in
136 let default_port = if is_https then 443 else 80 in
137 let port = Option.value (Uri.port uri) ~default:default_port in
138
139 (* Apply connection timeout if specified *)
140 let connect_fn () =
141 let tcp_flow = connect_tcp ~sw ~net ~host ~port in
142 if is_https then
143 wrap_tls tcp_flow ~host ~verify_tls ~tls_config ~min_tls_version
144 else
145 ( (tcp_flow :> [ `Close | `Flow | `R | `Shutdown | `W ] Eio.Resource.t),
146 Http1 )
147 in
148
149 match Option.bind timeout Timeout.total with
150 | Some seconds ->
151 Log.debug (fun m -> m "Setting connection timeout: %.2f seconds" seconds);
152 Eio.Time.with_timeout_exn clock seconds connect_fn
153 | None -> connect_fn ()
154
155let h2_direct_response ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress =
156 match
157 H2_adapter.one_request ~sw ~flow ~uri ~headers ~body ~method_
158 ~auto_decompress ()
159 with
160 | Ok resp ->
161 (resp.H2_adapter.status, resp.H2_adapter.headers, resp.H2_adapter.body)
162 | Error msg ->
163 raise
164 (Error.err (Error.Invalid_request { reason = "HTTP/2 error: " ^ msg }))
165
166let direct_request ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config
167 ~min_tls_version ~uri ~headers ~body ~method_ ~expect_100 ~auto_decompress =
168 let flow, protocol =
169 connect_to_url ~sw ~clock ~net ~url ~timeout ~verify_tls ~tls_config
170 ~min_tls_version
171 in
172 match protocol with
173 | Http2 ->
174 Log.debug (fun m -> m "[One] Using HTTP/2 for %s" url);
175 h2_direct_response ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress
176 | Http1 ->
177 Http_client.request_100_continue_decompress ~expect_100 ~clock ~sw
178 ~method_ ~uri ~headers ~body ~auto_decompress flow
179
180let prepare_one_headers ~headers ~body ~auth ~allow_insecure_auth
181 ~auto_decompress ~url =
182 let headers = Option.value headers ~default:Headers.empty in
183 let headers =
184 if not (Headers.mem `User_agent headers) then
185 Headers.set `User_agent Version.user_agent headers
186 else headers
187 in
188 let headers =
189 Option.fold ~none:headers auth ~some:(fun a ->
190 Log.debug (fun m -> m "Applying authentication");
191 Auth.apply_secure ~allow_insecure_auth ~url a headers)
192 in
193 let headers =
194 Option.bind body Body.content_type
195 |> Option.fold ~none:headers ~some:(fun mime ->
196 Headers.content_type mime headers)
197 in
198 if auto_decompress && not (Headers.mem `Accept_encoding headers) then
199 Headers.set `Accept_encoding "gzip, deflate" headers
200 else headers
201
202let proxy_http_request ~sw ~net ~clock ~method_ ~uri_to_fetch
203 ~headers_for_request ~request_body ~auto_decompress ~expect_100_config
204 ~proxy:p =
205 Log.debug (fun m ->
206 m "[One] Routing HTTP request via proxy %s:%d" p.Proxy.host p.Proxy.port);
207 let flow = connect_tcp ~sw ~net ~host:p.Proxy.host ~port:p.Proxy.port in
208 let flow =
209 (flow :> [ `Close | `Flow | `R | `Shutdown | `W ] Eio.Resource.t)
210 in
211 let proxy_auth =
212 match p.Proxy.auth with
213 | Some auth ->
214 let auth_headers = Auth.apply auth Headers.empty in
215 Headers.find `Authorization auth_headers
216 | None -> None
217 in
218 Http_write.write_and_flush flow (fun w ->
219 Http_write.request_via_proxy w ~sw ~method_ ~uri:uri_to_fetch
220 ~headers:headers_for_request ~body:request_body ~proxy_auth);
221 let limits = Response_limits.default in
222 let buf_read = Http_read.of_flow ~max_size:65536 flow in
223 let _version, status, resp_headers, body_str =
224 Http_read.response ~limits ~method_ buf_read
225 in
226 let body_str =
227 match (auto_decompress, Headers.find `Content_encoding resp_headers) with
228 | true, Some encoding ->
229 Http_client.decompress_body ~limits ~content_encoding:encoding body_str
230 | _ -> body_str
231 in
232 (status, resp_headers, body_str)
233
234let dispatch_request ~sw ~clock ~net ~method_ ~request_body ~expect_100_config
235 ~proxy ~timeout ~verify_tls ~tls_config ~min_tls_version ~auto_decompress
236 ~uri_to_fetch ~headers_for_request ~use_proxy ~is_https ~url_to_fetch =
237 match (use_proxy, is_https, proxy) with
238 | false, _, _ ->
239 direct_request ~sw ~clock ~net ~url:url_to_fetch ~timeout ~verify_tls
240 ~tls_config ~min_tls_version ~uri:uri_to_fetch
241 ~headers:headers_for_request ~body:request_body ~method_
242 ~expect_100:expect_100_config ~auto_decompress
243 | true, false, Some p ->
244 proxy_http_request ~sw ~net ~clock ~method_ ~uri_to_fetch
245 ~headers_for_request ~request_body ~auto_decompress ~expect_100_config
246 ~proxy:p
247 | true, true, Some p ->
248 Log.debug (fun m ->
249 m "[One] Routing HTTPS request via proxy %s:%d (CONNECT tunnel)"
250 p.Proxy.host p.Proxy.port);
251 let target_host = Uri.host uri_to_fetch |> Option.value ~default:"" in
252 let target_port = Uri.port uri_to_fetch |> Option.value ~default:443 in
253 let tunnel_flow =
254 Proxy_tunnel.connect_with_tls ~sw ~net ~clock ~proxy:p ~target_host
255 ~target_port ?tls_config ()
256 in
257 Http_client.request_100_continue_decompress ~expect_100:expect_100_config
258 ~clock ~sw ~method_ ~uri:uri_to_fetch ~headers:headers_for_request
259 ~body:request_body ~auto_decompress tunnel_flow
260 | true, _, None ->
261 let flow, _protocol =
262 connect_to_url ~sw ~clock ~net ~url:url_to_fetch ~timeout ~verify_tls
263 ~tls_config ~min_tls_version
264 in
265 Http_client.request_100_continue_decompress ~expect_100:expect_100_config
266 ~clock ~sw ~method_ ~uri:uri_to_fetch ~headers:headers_for_request
267 ~body:request_body ~auto_decompress flow
268
269(* Redirect-following loop extracted as module-level function for size *)
270let rec with_redirects ~sw ~clock ~net ~method_ ~request_body ~expect_100_config
271 ~proxy ~timeout ~verify_tls ~tls_config ~min_tls_version ~auto_decompress
272 ~follow_redirects ~max_redirects ~original_uri ~headers_for_request
273 url_to_fetch redirects_left =
274 let uri_to_fetch = Uri.of_string url_to_fetch in
275 let use_proxy =
276 match proxy with
277 | None -> false
278 | Some p -> not (Proxy.should_bypass p url_to_fetch)
279 in
280 let is_https = Uri.scheme uri_to_fetch = Some "https" in
281 let status, resp_headers, response_body_str =
282 dispatch_request ~sw ~clock ~net ~method_ ~request_body ~expect_100_config
283 ~proxy ~timeout ~verify_tls ~tls_config ~min_tls_version ~auto_decompress
284 ~uri_to_fetch ~headers_for_request ~use_proxy ~is_https ~url_to_fetch
285 in
286 Log.info (fun m -> m "Received response: status=%d" status);
287
288 if follow_redirects && status >= 300 && status < 400 then begin
289 if redirects_left <= 0 then begin
290 Log.err (fun m ->
291 m "Too many redirects (%d) for %s" max_redirects
292 (Uri.to_string original_uri));
293 raise
294 (Error.err
295 (Error.Too_many_redirects
296 {
297 url = Uri.to_string original_uri;
298 count = max_redirects;
299 max = max_redirects;
300 }))
301 end;
302
303 match Headers.find `Location resp_headers with
304 | None ->
305 Log.debug (fun m -> m "Redirect response missing Location header");
306 (status, resp_headers, response_body_str, url_to_fetch)
307 | Some location ->
308 let _ = Redirect.validate_url location in
309 Log.info (fun m ->
310 m "Following redirect to %s (%d remaining)" location redirects_left);
311 let redirect_uri = Uri.of_string location in
312 let headers_for_redirect =
313 if Redirect.same_origin original_uri redirect_uri then
314 headers_for_request
315 else Redirect.strip_sensitive_headers headers_for_request
316 in
317 with_redirects ~sw ~clock ~net ~method_ ~request_body ~expect_100_config
318 ~proxy ~timeout ~verify_tls ~tls_config ~min_tls_version
319 ~auto_decompress ~follow_redirects ~max_redirects ~original_uri
320 ~headers_for_request:headers_for_redirect location (redirects_left - 1)
321 end
322 else (status, resp_headers, response_body_str, url_to_fetch)
323
324(* Main request implementation - completely stateless *)
325let request ~sw ~clock ~net ?headers ?body ?auth ?timeout
326 ?(follow_redirects = true) ?(max_redirects = 10) ?(verify_tls = true)
327 ?tls_config ?(auto_decompress = true) ?(min_tls_version = TLS_1_2)
328 ?(expect_100_continue = `Threshold Expect_continue.default_threshold)
329 ?(allow_insecure_auth = false) ?proxy ~method_ url =
330 let start_time = Unix.gettimeofday () in
331 Log.debug (fun m ->
332 m "[One] Executing %s request to %s" (Method.to_string method_) url);
333
334 let headers =
335 prepare_one_headers ~headers ~body ~auth ~allow_insecure_auth
336 ~auto_decompress ~url
337 in
338 let request_body = Option.value ~default:Body.empty body in
339 let original_uri = Uri.of_string url in
340 let expect_100_timeout =
341 Option.bind timeout Timeout.expect_100_continue |> Option.value ~default:1.0
342 in
343 let expect_100_config =
344 Expect_continue.of_config ~timeout:expect_100_timeout expect_100_continue
345 in
346
347 let final_status, final_headers, final_body_str, final_url =
348 with_redirects ~sw ~clock ~net ~method_ ~request_body ~expect_100_config
349 ~proxy ~timeout ~verify_tls ~tls_config ~min_tls_version ~auto_decompress
350 ~follow_redirects ~max_redirects ~original_uri
351 ~headers_for_request:headers url max_redirects
352 in
353
354 let elapsed = Unix.gettimeofday () -. start_time in
355 Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
356
357 let body_flow = Eio.Flow.string_source final_body_str in
358
359 Response.Private.make ~sw ~status:final_status ~headers:final_headers
360 ~body:body_flow ~url:final_url ~elapsed
361
362(* Convenience methods *)
363let get ~sw ~clock ~net ?headers ?auth ?timeout ?follow_redirects ?max_redirects
364 ?verify_tls ?tls_config ?min_tls_version ?allow_insecure_auth ?proxy url =
365 request ~sw ~clock ~net ?headers ?auth ?timeout ?follow_redirects
366 ?max_redirects ?verify_tls ?tls_config ?min_tls_version ?allow_insecure_auth
367 ?proxy ~expect_100_continue:`Disabled (* GET has no body *) ~method_:`GET
368 url
369
370let post ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
371 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy url =
372 request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
373 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy
374 ~method_:`POST url
375
376let put ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
377 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy url =
378 request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
379 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy
380 ~method_:`PUT url
381
382let delete ~sw ~clock ~net ?headers ?auth ?timeout ?verify_tls ?tls_config
383 ?min_tls_version ?allow_insecure_auth ?proxy url =
384 request ~sw ~clock ~net ?headers ?auth ?timeout ?verify_tls ?tls_config
385 ?min_tls_version ?allow_insecure_auth ?proxy
386 ~expect_100_continue:`Disabled (* DELETE typically has no body *)
387 ~method_:`DELETE url
388
389let head ~sw ~clock ~net ?headers ?auth ?timeout ?verify_tls ?tls_config
390 ?min_tls_version ?allow_insecure_auth ?proxy url =
391 request ~sw ~clock ~net ?headers ?auth ?timeout ?verify_tls ?tls_config
392 ?min_tls_version ?allow_insecure_auth ?proxy
393 ~expect_100_continue:`Disabled (* HEAD has no body *) ~method_:`HEAD url
394
395let patch ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
396 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy url =
397 request ~sw ~clock ~net ?headers ?body ?auth ?timeout ?verify_tls ?tls_config
398 ?min_tls_version ?expect_100_continue ?allow_insecure_auth ?proxy
399 ~method_:`PATCH url
400
401let upload ~sw ~clock ~net ?headers ?auth ?timeout ?method_ ?mime ?length
402 ?on_progress ?verify_tls ?tls_config ?min_tls_version ?expect_100_continue
403 ?allow_insecure_auth ?proxy ~source url =
404 let method_ = Option.value method_ ~default:`POST in
405 let mime = Option.value mime ~default:Mime.octet_stream in
406
407 (* Wrap source with progress tracking if callback provided *)
408 let tracked_source =
409 match on_progress with
410 | None -> source
411 | Some callback ->
412 (* For now, progress tracking is not implemented for uploads
413 due to complexity of wrapping Eio.Flow.source.
414 This would require creating a custom flow wrapper. *)
415 let _ = callback in
416 source
417 in
418
419 let body = Body.of_stream ?length mime tracked_source in
420 request ~sw ~clock ~net ?headers ~body ?auth ?timeout ?verify_tls ?tls_config
421 ?min_tls_version ?allow_insecure_auth ?proxy ?expect_100_continue ~method_
422 url
423
424let download ~sw ~clock ~net ?headers ?auth ?timeout ?on_progress ?verify_tls
425 ?tls_config ?min_tls_version ?allow_insecure_auth ?proxy url ~sink =
426 let response =
427 get ~sw ~clock ~net ?headers ?auth ?timeout ?verify_tls ?tls_config
428 ?min_tls_version ?allow_insecure_auth ?proxy url
429 in
430
431 try
432 (* Get content length for progress tracking *)
433 let total = Response.content_length response in
434
435 let body = Response.body response in
436
437 (* Stream data to sink with optional progress *)
438 match on_progress with
439 | None ->
440 (* No progress tracking, just copy directly *)
441 Eio.Flow.copy body sink
442 | Some progress_fn ->
443 (* Copy with progress tracking *)
444 (* We need to intercept the flow to track bytes *)
445 (* For now, just do a simple copy - proper progress tracking needs flow wrapper *)
446 progress_fn ~received:0L ~total;
447 Eio.Flow.copy body sink;
448 progress_fn ~received:(Option.value total ~default:0L) ~total;
449
450 (* Response auto-closes with switch *)
451 ()
452 with e ->
453 (* Response auto-closes with switch *)
454 raise e