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(** OCaml HTTP client library with streaming support *)
7
8let src = Logs.Src.create "requests" ~doc:"HTTP Client Library"
9
10module Log = (val Logs.src_log src : Logs.LOG)
11module Method = Method
12module Mime = Mime
13module Headers = Headers
14module Http_date = Http_date
15module Http_version = Http_version
16module Auth = Auth
17module Proxy = Proxy
18module Proxy_tunnel = Proxy_tunnel
19module Timeout = Timeout
20module Body = Body
21module Response = Response
22module One = One
23module Http_client = Http_client
24module Status = Status
25module Error = Error
26module Retry = Retry
27module Cache_control = Cache_control
28module Response_limits = Response_limits
29module Expect_continue = Expect_continue
30module Version = Version
31module Link = Link
32module Timing = Timing
33module Header_name = Header_name
34module Header_parsing = Header_parsing
35module Websocket = Websocket
36module Signature = Signature
37
38(** Minimum TLS version configuration - re-exported from Tls_config. *)
39type tls_version = Tls_config.tls_version =
40 | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
41 | TLS_1_3
42 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
43
44(* Main API - Session functionality with connection pooling *)
45
46(** Protocol hint for endpoints - remembers ALPN negotiation results. *)
47type protocol_hint = H1 | H2
48
49type t =
50 | T : {
51 sw : Eio.Switch.t;
52 clock : [> float Eio.Time.clock_ty ] Eio.Resource.t;
53 net : [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t;
54 http_pool : unit Conpool.t;
55 (** HTTP/1.x pool - exclusive access, no protocol state *)
56 https_pool : unit Conpool.t;
57 (** HTTPS pool - exclusive access, no protocol state *)
58 h2_pool : H2_conpool_handler.h2_state Conpool.t;
59 (** HTTP/2 pool - shared access with H2 client state *)
60 protocol_hints : (string, protocol_hint) Hashtbl.t;
61 (** Maps "host:port" to protocol hint from ALPN *)
62 protocol_hints_mutex : Eio.Mutex.t;
63 cookie_jar : Cookeio_jar.t;
64 cookie_mutex : Eio.Mutex.t;
65 default_headers : Headers.t;
66 auth : Auth.t option;
67 timeout : Timeout.t;
68 follow_redirects : bool;
69 max_redirects : int;
70 verify_tls : bool;
71 tls_config : Tls.Config.client option;
72 retry : Retry.config option;
73 persist_cookies : bool;
74 xdg : Xdge.t option;
75 auto_decompress : bool;
76 expect_100_continue : Expect_continue.t;
77 (** 100-continue configuration *)
78 base_url : string option;
79 (** Per Recommendation #11: Base URL for relative paths *)
80 xsrf_cookie_name : string option;
81 (** Per Recommendation #24: XSRF cookie name *)
82 xsrf_header_name : string;
83 (** Per Recommendation #24: XSRF header name *)
84 proxy : Proxy.config option; (** HTTP/HTTPS proxy configuration *)
85 allow_insecure_auth : bool; (** Allow auth over HTTP for dev/testing *)
86 nonce_counter : Auth.Nonce_counter.t;
87 (** Digest auth nonce count tracker *)
88 (* Statistics - mutable but NOTE: when sessions are derived via record update
89 syntax ({t with field = value}), these are copied not shared. Each derived
90 session has independent statistics. Use the same session object to track
91 cumulative stats. *)
92 mutable requests_made : int;
93 mutable total_time : float;
94 mutable retries_count : int;
95 }
96 -> t
97
98let connection_pools ~sw ~net ~clock ?http_pool ?https_pool ~tls_config
99 ~max_connections_per_host ~connection_idle_timeout ~connection_lifetime () =
100 let pool_config =
101 Conpool.Config.v ~max_connections_per_endpoint:max_connections_per_host
102 ~max_idle_time:connection_idle_timeout
103 ~max_connection_lifetime:connection_lifetime ()
104 in
105 let http_pool =
106 match http_pool with
107 | Some p -> p
108 | None -> Conpool.basic ~sw ~net ~clock ~config:pool_config ()
109 in
110 let https_pool =
111 match https_pool with
112 | Some p -> p
113 | None ->
114 Conpool.basic ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
115 in
116 let h2_pool =
117 Conpool.v ~sw ~net ~clock ?tls:tls_config ~config:pool_config
118 ~protocol:H2_conpool_handler.h2_protocol ()
119 in
120 (http_pool, https_pool, h2_pool)
121
122let resolve_cookie_jar ~cookie_jar ~persist_cookies ~xdg ~clock =
123 match (cookie_jar, persist_cookies, xdg) with
124 | Some jar, _, _ -> jar
125 | None, true, Some xdg_ctx ->
126 let data_dir = Xdge.data_dir xdg_ctx in
127 let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
128 Cookeio_jar.load ~clock cookie_file
129 | None, _, _ -> Cookeio_jar.v ()
130
131let normalize_base_url base_url =
132 Option.map
133 (fun url ->
134 if String.length url > 0 && url.[String.length url - 1] = '/' then
135 String.sub url 0 (String.length url - 1)
136 else url)
137 base_url
138
139let resolve_xdg ~xdg ~persist_cookies env_fs =
140 match (xdg, persist_cookies) with
141 | Some x, _ -> Some x
142 | None, true -> Some (Xdge.v env_fs "requests")
143 | None, false -> None
144
145let build_expect_100_config ~expect_100_continue ~timeout =
146 let expect_100_timeout =
147 Timeout.expect_100_continue timeout |> Option.value ~default:1.0
148 in
149 Expect_continue.of_config ~timeout:expect_100_timeout expect_100_continue
150
151let session ~sw ~clock ~net ~http_pool ~https_pool ~h2_pool ~protocol_hints
152 ~cookie_jar ~default_headers ~auth ~timeout ~follow_redirects ~max_redirects
153 ~verify_tls ~tls_config ~retry ~persist_cookies ~xdg ~auto_decompress
154 ~expect_100_config ~base_url ~xsrf_cookie_name ~xsrf_header_name ~proxy
155 ~allow_insecure_auth =
156 T
157 {
158 sw;
159 clock;
160 net;
161 http_pool;
162 https_pool;
163 h2_pool;
164 protocol_hints;
165 protocol_hints_mutex = Eio.Mutex.create ();
166 cookie_jar;
167 cookie_mutex = Eio.Mutex.create ();
168 default_headers;
169 auth;
170 timeout;
171 follow_redirects;
172 max_redirects;
173 verify_tls;
174 tls_config;
175 retry;
176 persist_cookies;
177 xdg;
178 auto_decompress;
179 expect_100_continue = expect_100_config;
180 base_url;
181 xsrf_cookie_name;
182 xsrf_header_name;
183 proxy;
184 allow_insecure_auth;
185 nonce_counter = Auth.Nonce_counter.create ();
186 requests_made = 0;
187 total_time = 0.0;
188 retries_count = 0;
189 }
190
191let v ~sw ?http_pool ?https_pool ?cookie_jar ?(default_headers = Headers.empty)
192 ?auth ?(timeout = Timeout.default) ?(follow_redirects = true)
193 ?(max_redirects = 10) ?(verify_tls = true) ?tls_config
194 ?(min_tls_version = TLS_1_2) ?(max_connections_per_host = 10)
195 ?(connection_idle_timeout = 60.0) ?(connection_lifetime = 300.0) ?retry
196 ?(persist_cookies = false) ?xdg ?(auto_decompress = true)
197 ?(expect_100_continue = `Threshold Expect_continue.default_threshold)
198 ?base_url ?(xsrf_cookie_name = Some "XSRF-TOKEN")
199 (* Per Recommendation #24 *) ?(xsrf_header_name = "X-XSRF-TOKEN") ?proxy
200 ?(allow_insecure_auth = false) env =
201 Crypto_rng_unix.use_default ();
202 (* avsm: is this bad to do twice? very common footgun to forget to initialise *)
203 let clock = env#clock in
204 let net = env#net in
205 let xdg = resolve_xdg ~xdg ~persist_cookies env#fs in
206 (* Create TLS config for HTTPS pool if needed
207 Per Recommendation #6: Enforce minimum TLS version *)
208 let tls_config =
209 Tls_config.client_opt ?existing_config:tls_config ~verify_tls
210 ~min_tls_version ~host:"session-init" ()
211 in
212 let http_pool, https_pool, h2_pool =
213 connection_pools ~sw ~net ~clock ?http_pool ?https_pool ~tls_config
214 ~max_connections_per_host ~connection_idle_timeout ~connection_lifetime ()
215 in
216 let protocol_hints = Hashtbl.create 32 in
217 Log.info (fun m ->
218 m
219 "Created Requests session with connection pools (max_per_host=%d, \
220 TLS=%b)"
221 max_connections_per_host
222 (Option.is_some tls_config));
223 let cookie_jar =
224 resolve_cookie_jar ~cookie_jar ~persist_cookies ~xdg ~clock
225 in
226 let expect_100_config =
227 build_expect_100_config ~expect_100_continue ~timeout
228 in
229 let base_url = normalize_base_url base_url in
230 session ~sw ~clock ~net ~http_pool ~https_pool ~h2_pool ~protocol_hints
231 ~cookie_jar ~default_headers ~auth ~timeout ~follow_redirects ~max_redirects
232 ~verify_tls ~tls_config ~retry ~persist_cookies ~xdg ~auto_decompress
233 ~expect_100_config ~base_url ~xsrf_cookie_name ~xsrf_header_name ~proxy
234 ~allow_insecure_auth
235
236let set_default_header (T t) key value =
237 T
238 {
239 t with
240 default_headers =
241 Headers.set (Header_name.of_string key) value t.default_headers;
242 }
243
244let remove_default_header (T t) key =
245 T
246 {
247 t with
248 default_headers =
249 Headers.remove (Header_name.of_string key) t.default_headers;
250 }
251
252let set_auth (T t) auth =
253 Log.debug (fun m -> m "Setting authentication method");
254 T { t with auth = Some auth }
255
256let clear_auth (T t) =
257 Log.debug (fun m -> m "Clearing authentication");
258 T { t with auth = None }
259
260let set_timeout (T t) timeout =
261 Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);
262 T { t with timeout }
263
264let set_retry (T t) config =
265 Log.debug (fun m ->
266 m "Setting retry config: max_retries=%d" config.Retry.max_retries);
267 T { t with retry = Some config }
268
269let cookies (T t) = t.cookie_jar
270let clear_cookies (T t) = Cookeio_jar.clear t.cookie_jar
271
272let set_proxy (T t) config =
273 Log.debug (fun m ->
274 m "Setting proxy: %s:%d" config.Proxy.host config.Proxy.port);
275 T { t with proxy = Some config }
276
277let clear_proxy (T t) =
278 Log.debug (fun m -> m "Clearing proxy configuration");
279 T { t with proxy = None }
280
281let proxy (T t) = t.proxy
282
283(* Redirect handling - delegated to shared Redirect module *)
284
285(** {1 URL Resolution and Path Templating}
286
287 Per Recommendation #11: Base URL support with RFC 3986 resolution. Per
288 Recommendation #29: Path parameter templating. *)
289
290(** Check if a URL is relative (no scheme) *)
291let is_relative_url url =
292 let uri = Uri.of_string url in
293 Option.is_none (Uri.scheme uri)
294
295(** Resolve a URL against a base URL per RFC 3986 Section 5. If the URL is
296 already absolute, return it unchanged. If base_url is None, return the
297 original URL. *)
298let resolve_url ?base_url url =
299 match base_url with
300 | None -> url
301 | Some base ->
302 if is_relative_url url then begin
303 let base_uri = Uri.of_string base in
304 let rel_uri = Uri.of_string url in
305 let scheme = Uri.scheme base_uri |> Option.value ~default:"https" in
306 let resolved = Uri.resolve scheme base_uri rel_uri in
307 Log.debug (fun m ->
308 m "Resolved relative URL %s against base %s -> %s" url base
309 (Uri.to_string resolved));
310 Uri.to_string resolved
311 end
312 else url (* Already absolute *)
313
314(** Substitute path parameters in a URL template. Per Recommendation #29 and RFC
315 6570 (simplified). Template: ["/users/\{id\}/posts/\{post_id\}"] Params:
316 [[("id", "123"); ("post_id", "456")]] Result: ["/users/123/posts/456"]
317 Values are automatically URL-encoded. *)
318let substitute_path_params url params =
319 List.fold_left
320 (fun url (key, value) ->
321 let pattern = "{" ^ key ^ "}" in
322 let encoded_value = Uri.pct_encode value in
323 let rec replace s =
324 match String.split_on_char '{' s with
325 | [] -> ""
326 | [ single ] -> single
327 | before :: rest ->
328 let rest_str = String.concat "{" rest in
329 if
330 String.length rest_str >= String.length key + 1
331 && String.sub rest_str 0 (String.length key) = key
332 && rest_str.[String.length key] = '}'
333 then
334 before ^ encoded_value
335 ^ String.sub rest_str
336 (String.length key + 1)
337 (String.length rest_str - String.length key - 1)
338 else before ^ "{" ^ replace rest_str
339 in
340 if String.length pattern > 0 then replace url else url)
341 url params
342
343(** {1 XSRF Token Handling}
344
345 Per Recommendation #24: Automatically inject XSRF tokens from cookies. *)
346
347(** Extract XSRF token from cookies and add to headers if: 1. xsrf_cookie_name
348 is configured 2. The cookie exists 3. The request is same-origin (security)
349*)
350let apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url
351 headers =
352 match xsrf_cookie_name with
353 | None -> headers (* XSRF handling disabled *)
354 | Some cookie_name -> (
355 let uri = Uri.of_string url in
356 let domain = Uri.host uri |> Option.value ~default:"" in
357 let path = Uri.path uri in
358 let is_secure = Uri.scheme uri = Some "https" in
359
360 (* Get cookies for this domain *)
361 let cookies =
362 Cookeio_jar.cookies cookie_jar ~clock ~domain ~path ~is_secure
363 in
364
365 (* Find the XSRF token cookie *)
366 let xsrf_value =
367 List.find_map
368 (fun cookie ->
369 if Cookeio.name cookie = cookie_name then
370 Some (Cookeio.value cookie)
371 else None)
372 cookies
373 in
374
375 match xsrf_value with
376 | Some token ->
377 Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name);
378 (* XSRF header name is configurable, use string variant *)
379 Headers.set_string xsrf_header_name token headers
380 | None -> headers)
381
382let h2_conn_response ~sw ~h2_pool ~endpoint ~uri ~headers ~body ~method_
383 ~auto_decompress =
384 Eio.Switch.run (fun conn_sw ->
385 let h2_conn = Conpool.connection ~sw:conn_sw h2_pool endpoint in
386 match
387 H2_conpool_handler.request ~state:h2_conn.Conpool.state ~uri ~headers
388 ~body ~method_ ~auto_decompress ()
389 with
390 | Ok resp ->
391 (resp.H2_adapter.status, resp.H2_adapter.headers, resp.H2_adapter.body)
392 | Error msg ->
393 raise
394 (Error.err
395 (Error.Invalid_request { reason = "HTTP/2 error: " ^ msg })))
396
397let h2_alpn_response ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress =
398 match
399 H2_adapter.request ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress
400 ()
401 with
402 | Ok resp ->
403 (resp.H2_adapter.status, resp.H2_adapter.headers, resp.H2_adapter.body)
404 | Error msg ->
405 raise
406 (Error.err (Error.Invalid_request { reason = "HTTP/2 error: " ^ msg }))
407
408let pooled_h1_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body
409 ~method_ ~auto_decompress ~expect_100 =
410 Eio.Switch.run (fun conn_sw ->
411 let conn_info = Conpool.connection ~sw:conn_sw pool endpoint in
412 Http_client.request_100_continue_decompress ~expect_100 ~clock
413 ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress
414 conn_info.Conpool.flow)
415
416let pooled_with_h1_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body
417 ~method_ ~auto_decompress ~expect_100 =
418 Conpool.with_connection pool endpoint (fun conn ->
419 Http_client.request_100_continue_decompress ~expect_100 ~clock
420 ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress
421 conn.Conpool.flow)
422
423let update_protocol_hint ~protocol_hints_mutex ~protocol_hints ~endpoint_key
424 ~is_h2 =
425 let hint = if is_h2 then H2 else H1 in
426 Eio.Mutex.use_rw ~protect:true protocol_hints_mutex (fun () ->
427 Hashtbl.replace protocol_hints endpoint_key hint);
428 Log.debug (fun m ->
429 m "Learned protocol for %s: %s" endpoint_key
430 (if is_h2 then "H2" else "H1"))
431
432let alpn_detect_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body
433 ~method_ ~auto_decompress ~expect_100 ~is_https ~protocol_hints_mutex
434 ~protocol_hints ~endpoint_key ~url =
435 Eio.Switch.run (fun conn_sw ->
436 let conn_info = Conpool.connection ~sw:conn_sw pool endpoint in
437 let is_h2 =
438 match conn_info.Conpool.tls_epoch with
439 | Some epoch -> epoch.Tls.Core.alpn_protocol = Some "h2"
440 | None -> false
441 in
442 if is_https then
443 update_protocol_hint ~protocol_hints_mutex ~protocol_hints ~endpoint_key
444 ~is_h2;
445 if is_h2 then begin
446 Log.debug (fun m -> m "Using HTTP/2 for %s (ALPN negotiated)" url);
447 h2_alpn_response ~sw:conn_sw ~flow:conn_info.Conpool.flow ~uri ~headers
448 ~body ~method_ ~auto_decompress
449 end
450 else
451 Http_client.request_100_continue_decompress ~expect_100 ~clock
452 ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress
453 conn_info.Conpool.flow)
454
455let proxy_http_request ~sw ~pool ~proxy_endpoint ~uri ~headers ~body ~method_
456 ~auto_decompress ~proxy_auth =
457 Conpool.with_connection pool proxy_endpoint (fun conn ->
458 Http_write.write_and_flush conn.Conpool.flow (fun w ->
459 Http_write.request_via_proxy w ~sw ~method_ ~uri ~headers ~body
460 ~proxy_auth);
461 let limits = Response_limits.default in
462 let buf_read = Http_read.of_flow ~max_size:65536 conn.Conpool.flow in
463 let _version, status, resp_headers, body_str =
464 Http_read.response ~limits ~method_ buf_read
465 in
466 let body_str =
467 match
468 (auto_decompress, Headers.find `Content_encoding resp_headers)
469 with
470 | true, Some encoding ->
471 Http_client.decompress_body ~limits ~content_encoding:encoding
472 body_str
473 | _ -> body_str
474 in
475 (status, resp_headers, body_str))
476
477let build_request_headers ~default_headers ~cookie_mutex ~cookie_jar ~clock
478 ~xsrf_cookie_name ~xsrf_header_name ~default_auth ~allow_insecure_auth
479 ~auto_decompress ~headers ~auth ~body ~url =
480 let headers =
481 match headers with
482 | Some h -> Headers.merge default_headers h
483 | None -> default_headers
484 in
485 let headers =
486 if not (Headers.mem `User_agent headers) then
487 Headers.set `User_agent Version.user_agent headers
488 else headers
489 in
490 let headers =
491 Eio.Mutex.use_ro cookie_mutex (fun () ->
492 apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name
493 ~url headers)
494 in
495 let auth = match auth with Some a -> Some a | None -> default_auth in
496 let headers =
497 match auth with
498 | Some a ->
499 Log.debug (fun m -> m "Applying authentication");
500 Auth.apply_secure ~allow_insecure_auth ~url a headers
501 | None -> headers
502 in
503 let headers =
504 match body with
505 | Some b -> (
506 match Body.content_type b with
507 | Some mime -> Headers.content_type mime headers
508 | None -> headers)
509 | None -> headers
510 in
511 let headers =
512 if auto_decompress && not (Headers.mem `Accept_encoding headers) then
513 Headers.set `Accept_encoding "gzip, deflate" headers
514 else headers
515 in
516 (auth, headers)
517
518let extract_url_components uri_to_fetch url_to_fetch =
519 let redirect_host =
520 match Uri.host uri_to_fetch with
521 | Some h -> h
522 | None ->
523 raise
524 (Error.err
525 (Error.Invalid_redirect
526 { url = url_to_fetch; reason = "URL must contain a host" }))
527 in
528 let redirect_port =
529 match (Uri.scheme uri_to_fetch, Uri.port uri_to_fetch) with
530 | Some "https", None -> 443
531 | Some "https", Some p -> p
532 | Some "http", None -> 80
533 | Some "http", Some p -> p
534 | _, Some p -> p
535 | _ -> 80
536 in
537 let redirect_is_https =
538 match Uri.scheme uri_to_fetch with Some "https" -> true | _ -> false
539 in
540 (redirect_host, redirect_port, redirect_is_https)
541
542let add_cookies_to_headers ~cookie_mutex ~cookie_jar ~clock ~headers_for_request
543 ~host ~path ~is_secure =
544 Eio.Mutex.use_ro cookie_mutex (fun () ->
545 let cookies =
546 Cookeio_jar.cookies cookie_jar ~clock ~domain:host ~path ~is_secure
547 in
548 match cookies with
549 | [] ->
550 Log.debug (fun m -> m "No cookies found for %s%s" host path);
551 headers_for_request
552 | cookies ->
553 let cookie_header = Cookeio.cookie_header cookies in
554 let cookie_summary =
555 cookies
556 |> List.map (fun c ->
557 Fmt.str "%s=<%d chars>" (Cookeio.name c)
558 (String.length (Cookeio.value c)))
559 |> String.concat "; "
560 in
561 Log.debug (fun m ->
562 m "Adding %d cookies for %s%s: [%s]" (List.length cookies) host
563 path cookie_summary);
564 Headers.set `Cookie cookie_header headers_for_request)
565
566(* Extract and store Set-Cookie headers from a response into the session cookie jar. *)
567let store_response_cookies (T t) ~resp_headers ~url_str =
568 let uri = Uri.of_string url_str in
569 let cookie_domain = Uri.host uri |> Option.value ~default:"" in
570 let cookie_path = Uri.path uri in
571 Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
572 match Headers.all `Set_cookie resp_headers with
573 | [] -> ()
574 | cookie_headers ->
575 Log.debug (fun m ->
576 m "Received %d Set-Cookie headers" (List.length cookie_headers));
577 List.iter
578 (fun cookie_str ->
579 let now =
580 fun () -> Ptime.of_float_s (Eio.Time.now t.clock) |> Option.get
581 in
582 match
583 Cookeio.of_set_cookie_header ~now ~domain:cookie_domain
584 ~path:cookie_path cookie_str
585 with
586 | Ok cookie ->
587 Log.debug (fun m ->
588 m "Storing cookie: %s" (Cookeio.name cookie));
589 Cookeio_jar.add_cookie t.cookie_jar cookie
590 | Error msg ->
591 let redacted =
592 match String.index_opt cookie_str '=' with
593 | Some i -> String.sub cookie_str 0 i ^ "=<redacted>"
594 | None -> "<malformed>"
595 in
596 Log.warn (fun m ->
597 m "Failed to parse cookie: %s (%s)" redacted msg))
598 cookie_headers)
599
600(* Dispatch a request using ALPN negotiation to detect H1/H2 protocol. *)
601let dispatch_alpn (T t) ~redirect_is_https ~redirect_pool ~redirect_endpoint
602 ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ () =
603 alpn_detect_request ~outer_sw:t.sw ~clock:t.clock ~pool:redirect_pool
604 ~endpoint:redirect_endpoint ~uri:uri_to_fetch ~headers ~body ~method_
605 ~auto_decompress:t.auto_decompress ~expect_100:t.expect_100_continue
606 ~is_https:redirect_is_https ~protocol_hints_mutex:t.protocol_hints_mutex
607 ~protocol_hints:t.protocol_hints ~endpoint_key
608 ~url:(Uri.to_string uri_to_fetch)
609
610let proxy_auth_header proxy =
611 match proxy.Proxy.auth with
612 | Some auth ->
613 let auth_headers = Auth.apply auth Headers.empty in
614 Headers.find `Authorization auth_headers
615 | None -> None
616
617(* Dispatch a single HTTP request to the appropriate transport based on proxy
618 settings, protocol hints, and whether the target is HTTPS. *)
619let dispatch_request (T t) ~use_proxy ~redirect_is_https ~redirect_pool
620 ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch
621 ~headers ~body ~method_ ~protocol_hint () =
622 match (use_proxy, redirect_is_https, t.proxy, protocol_hint) with
623 | false, true, _, Some H2 ->
624 (* Known HTTP/2 - use h2_pool with shared connections *)
625 Log.debug (fun m ->
626 m "Using HTTP/2 for %s (from protocol hint)"
627 (Uri.to_string uri_to_fetch));
628 h2_conn_response ~sw:t.sw ~h2_pool:t.h2_pool ~endpoint:redirect_endpoint
629 ~uri:uri_to_fetch ~headers ~body ~method_
630 ~auto_decompress:t.auto_decompress
631 | false, true, _, Some H1 ->
632 Log.debug (fun m ->
633 m "Using HTTP/1.1 for %s (from protocol hint)"
634 (Uri.to_string uri_to_fetch));
635 pooled_h1_request ~outer_sw:t.sw ~clock:t.clock ~pool:redirect_pool
636 ~endpoint:redirect_endpoint ~uri:uri_to_fetch ~headers ~body ~method_
637 ~auto_decompress:t.auto_decompress ~expect_100:t.expect_100_continue
638 | false, _, _, _ ->
639 dispatch_alpn (T t) ~redirect_is_https ~redirect_pool ~redirect_endpoint
640 ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ ()
641 | true, false, Some proxy, _ ->
642 (* HTTP via proxy - connect to proxy and use absolute-URI form *)
643 Log.debug (fun m ->
644 m "Routing HTTP request via proxy %s:%d" proxy.Proxy.host
645 proxy.Proxy.port);
646 let proxy_endpoint =
647 Conpool.Endpoint.v ~host:proxy.Proxy.host ~port:proxy.Proxy.port
648 in
649 (* Convert Auth.t to header value string *)
650 let proxy_auth = proxy_auth_header proxy in
651 proxy_http_request ~sw:t.sw ~pool:t.http_pool ~proxy_endpoint
652 ~uri:uri_to_fetch ~headers ~body ~method_
653 ~auto_decompress:t.auto_decompress ~proxy_auth
654 | true, true, Some proxy, _ ->
655 (* HTTPS via proxy - establish CONNECT tunnel then TLS *)
656 Log.debug (fun m ->
657 m "Routing HTTPS request via proxy %s:%d (CONNECT tunnel)"
658 proxy.Proxy.host proxy.Proxy.port);
659 (* Establish TLS tunnel through proxy *)
660 let tunnel_flow =
661 Proxy_tunnel.connect_with_tls ~sw:t.sw ~net:t.net ~clock:t.clock ~proxy
662 ~target_host:redirect_host ~target_port:redirect_port
663 ?tls_config:t.tls_config ()
664 in
665 (* Send request through tunnel using normal format (not absolute-URI) *)
666 Http_client.request_100_continue_decompress
667 ~expect_100:t.expect_100_continue ~clock:t.clock ~sw:t.sw ~method_
668 ~uri:uri_to_fetch ~headers ~body ~auto_decompress:t.auto_decompress
669 tunnel_flow
670 | true, _, None, _ ->
671 (* Should not happen due to use_proxy check *)
672 Conpool.with_connection redirect_pool redirect_endpoint (fun conn ->
673 Http_client.request_100_continue_decompress
674 ~expect_100:t.expect_100_continue ~clock:t.clock ~sw:t.sw ~method_
675 ~uri:uri_to_fetch ~headers ~body ~auto_decompress:t.auto_decompress
676 conn.Conpool.flow)
677
678let log_request_headers ~method_str ~uri ~headers =
679 Log.info (fun m -> m "");
680 Log.info (fun m -> m "=== Request to %s ===" (Uri.to_string uri));
681 Log.info (fun m -> m "> %s %s HTTP/1.1" method_str (Uri.to_string uri));
682 Log.info (fun m -> m "> Request Headers:");
683 Headers.to_list headers
684 |> List.iter (fun (k, v) ->
685 let v =
686 if Error.is_sensitive_header k then
687 Fmt.str "<redacted: %d chars>" (String.length v)
688 else v
689 in
690 Log.info (fun m -> m "> %s: %s" k v));
691 Log.info (fun m -> m "")
692
693let log_response_headers ~status ~resp_headers =
694 Log.info (fun m -> m "< HTTP/1.1 %d" status);
695 Log.info (fun m -> m "< Response Headers:");
696 Headers.to_list resp_headers
697 |> List.iter (fun (k, v) ->
698 let v =
699 if Error.is_sensitive_header k then
700 Fmt.str "<redacted: %d chars>" (String.length v)
701 else v
702 in
703 Log.info (fun m -> m "< %s: %s" k v));
704 Log.info (fun m -> m "")
705
706let execute_request_with_timeout (T t as wrapped_t) ~use_proxy
707 ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host
708 ~redirect_port ~endpoint_key ~uri_to_fetch ~headers ~body ~method_
709 ~protocol_hint ~timeout =
710 let timeout_val = Option.value timeout ~default:t.timeout in
711 match Timeout.total timeout_val with
712 | Some seconds ->
713 Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
714 Eio.Time.with_timeout_exn t.clock seconds
715 (dispatch_request wrapped_t ~use_proxy ~redirect_is_https ~redirect_pool
716 ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key
717 ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint)
718 | None ->
719 dispatch_request wrapped_t ~use_proxy ~redirect_is_https ~redirect_pool
720 ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key
721 ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint ()
722
723let resolve_absolute_location ~base_uri location =
724 let location_uri = Uri.of_string location in
725 match Uri.host location_uri with
726 | Some _ -> location
727 | None ->
728 let scheme = Option.value (Uri.scheme base_uri) ~default:"http" in
729 let resolved = Uri.resolve scheme base_uri location_uri in
730 Uri.to_string resolved
731
732let redirect_headers_for_origin ~original_uri ~redirect_uri headers =
733 if Redirect.same_origin original_uri redirect_uri then headers
734 else begin
735 Log.debug (fun m ->
736 m "Cross-origin redirect detected: stripping sensitive headers");
737 Redirect.strip_sensitive_headers headers
738 end
739
740let rec handle_redirect_or_return wrapped_t ~original_url ~original_uri
741 ~follow_redirects ~max_redirects ~timeout ~headers_for_request ~method_
742 ~body ~url_to_fetch ~uri_to_fetch ~redirects_left status resp_headers
743 response_body_str =
744 let (T t) = wrapped_t in
745 let follow = Option.value follow_redirects ~default:t.follow_redirects in
746 let max_redir = Option.value max_redirects ~default:t.max_redirects in
747 if follow && status >= 300 && status < 400 then begin
748 if redirects_left <= 0 then begin
749 Log.err (fun m ->
750 m "Too many redirects (%d) for %s" max_redir original_url);
751 raise
752 (Error.err
753 (Error.Too_many_redirects
754 { url = original_url; count = max_redir; max = max_redir }))
755 end;
756 match Headers.find `Location resp_headers with
757 | None ->
758 Log.debug (fun m -> m "Redirect response missing Location header");
759 (status, resp_headers, response_body_str, url_to_fetch)
760 | Some location ->
761 let _ = Redirect.validate_url location in
762 let absolute_location =
763 resolve_absolute_location ~base_uri:uri_to_fetch location
764 in
765 Log.info (fun m ->
766 m "Following redirect to %s (%d remaining)" absolute_location
767 redirects_left);
768 let redirect_uri = Uri.of_string absolute_location in
769 let headers_for_redirect =
770 redirect_headers_for_origin ~original_uri ~redirect_uri
771 headers_for_request
772 in
773 let redirect_method, redirect_body =
774 if status = 303 then begin
775 match method_ with
776 | `POST | `PUT | `DELETE | `PATCH ->
777 Log.debug (fun m ->
778 m "303 redirect: changing %s to GET and stripping body"
779 (Method.to_string method_));
780 (`GET, Body.empty)
781 | _ -> (method_, body)
782 end
783 else (method_, body)
784 in
785 with_redirects wrapped_t ~original_url ~follow_redirects ~max_redirects
786 ~timeout ~headers_for_request:headers_for_redirect
787 ~method_:redirect_method ~body:redirect_body absolute_location
788 (redirects_left - 1)
789 end
790 else (status, resp_headers, response_body_str, url_to_fetch)
791
792(* Execute request with redirect handling.
793 headers_for_request: headers for this request (may have auth stripped)
794 method_: HTTP method (may be changed by 303 redirect)
795 body: request body (may be stripped by 303 redirect) *)
796and with_redirects (T t as wrapped_t) ~original_url ~follow_redirects
797 ~max_redirects ~timeout ~headers_for_request ~method_ ~body url_to_fetch
798 redirects_left =
799 let method_str = Method.to_string method_ in
800 let uri_to_fetch = Uri.of_string url_to_fetch in
801 let original_uri = Uri.of_string original_url in
802 let redirect_host, redirect_port, redirect_is_https =
803 extract_url_components uri_to_fetch url_to_fetch
804 in
805 let redirect_endpoint =
806 Conpool.Endpoint.v ~host:redirect_host ~port:redirect_port
807 in
808 let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in
809 let headers_with_cookies =
810 add_cookies_to_headers ~cookie_mutex:t.cookie_mutex ~cookie_jar:t.cookie_jar
811 ~clock:t.clock ~headers_for_request ~host:redirect_host
812 ~path:(Uri.path uri_to_fetch) ~is_secure:redirect_is_https
813 in
814 log_request_headers ~method_str ~uri:uri_to_fetch
815 ~headers:headers_with_cookies;
816 let use_proxy =
817 match t.proxy with
818 | None -> false
819 | Some proxy -> not (Proxy.should_bypass proxy url_to_fetch)
820 in
821 let endpoint_key = Fmt.str "%s:%d" redirect_host redirect_port in
822 let protocol_hint =
823 Eio.Mutex.use_ro t.protocol_hints_mutex (fun () ->
824 Hashtbl.find_opt t.protocol_hints endpoint_key)
825 in
826 let status, resp_headers, response_body_str =
827 execute_request_with_timeout wrapped_t ~use_proxy ~redirect_is_https
828 ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port
829 ~endpoint_key ~uri_to_fetch ~headers:headers_with_cookies ~body ~method_
830 ~protocol_hint ~timeout
831 in
832 log_response_headers ~status ~resp_headers;
833 store_response_cookies wrapped_t ~resp_headers ~url_str:url_to_fetch;
834 handle_redirect_or_return wrapped_t ~original_url ~original_uri
835 ~follow_redirects ~max_redirects ~timeout ~headers_for_request ~method_
836 ~body ~url_to_fetch ~uri_to_fetch ~redirects_left status resp_headers
837 response_body_str
838
839let apply_signature_auth ~clock ~method_ ~uri ~headers auth =
840 match auth with
841 | Some a when Auth.is_signature a ->
842 Auth.apply_signature ~clock ~method_ ~uri ~headers a
843 | _ -> headers
844
845let persist_cookies_if_needed (T t) =
846 match (t.persist_cookies, t.xdg) with
847 | true, Some xdg_ctx ->
848 let data_dir = Xdge.data_dir xdg_ctx in
849 let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
850 Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
851 Cookeio_jar.save cookie_file t.cookie_jar;
852 Log.debug (fun m -> m "Saved cookies to %a" Eio.Path.pp cookie_file))
853 | _ -> ()
854
855(* Internal request function using connection pools *)
856let request_internal (T t as wrapped_t) ?headers ?body ?auth ?timeout
857 ?follow_redirects ?max_redirects ?(path_params = []) ~method_ url =
858 let start_time = Unix.gettimeofday () in
859 let url =
860 if path_params = [] then url else substitute_path_params url path_params
861 in
862 let url = resolve_url ?base_url:t.base_url url in
863 Log.info (fun m -> m "Making %s request to %s" (Method.to_string method_) url);
864 let auth, base_headers =
865 build_request_headers ~default_headers:t.default_headers
866 ~cookie_mutex:t.cookie_mutex ~cookie_jar:t.cookie_jar ~clock:t.clock
867 ~xsrf_cookie_name:t.xsrf_cookie_name ~xsrf_header_name:t.xsrf_header_name
868 ~default_auth:t.auth ~allow_insecure_auth:t.allow_insecure_auth
869 ~auto_decompress:t.auto_decompress ~headers ~auth ~body ~url
870 in
871 let request_body = Option.value ~default:Body.empty body in
872 let original_uri = Uri.of_string url in
873 let max_redir = Option.value max_redirects ~default:t.max_redirects in
874 let signed_headers =
875 apply_signature_auth ~clock:t.clock ~method_ ~uri:original_uri
876 ~headers:base_headers auth
877 in
878 let final_status, final_headers, final_body_str, final_url =
879 with_redirects wrapped_t ~original_url:url ~follow_redirects ~max_redirects
880 ~timeout ~headers_for_request:signed_headers ~method_ ~body:request_body
881 url max_redir
882 in
883 let elapsed = Unix.gettimeofday () -. start_time in
884 Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
885 let body_flow = Eio.Flow.string_source final_body_str in
886 let response =
887 Response.Private.make ~sw:t.sw ~status:final_status ~headers:final_headers
888 ~body:body_flow ~url:final_url ~elapsed
889 in
890 t.requests_made <- t.requests_made + 1;
891 t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
892 Log.info (fun m ->
893 m "Request completed with status %d" (Response.status_code response));
894 persist_cookies_if_needed wrapped_t;
895 response
896
897let build_digest_auth_header ~nonce_counter ~username ~password ~method_ ~uri
898 ~challenge ~auth_header_name base_headers =
899 let auth_value =
900 Auth.apply_digest ~nonce_counter ~username ~password
901 ~method_:(Method.to_string method_) ~uri ~challenge Headers.empty
902 in
903 match Headers.find `Authorization auth_value with
904 | Some v -> Headers.set auth_header_name v base_headers
905 | None -> base_headers
906
907(* Helper to handle Digest authentication challenges (401 and 407).
908 Per RFC 7235: 401 uses WWW-Authenticate/Authorization headers,
909 407 uses Proxy-Authenticate/Proxy-Authorization headers. *)
910let digest_header_names status =
911 let challenge_header : Header_name.t =
912 if status = 401 then `Www_authenticate else `Proxy_authenticate
913 in
914 let auth_header_name : Header_name.t =
915 if status = 401 then `Authorization else `Proxy_authorization
916 in
917 (challenge_header, auth_header_name)
918
919let handle_digest_auth (T t as wrapped_t) ~headers ~body ~auth ~timeout
920 ~follow_redirects ~max_redirects ~method_ ~url response =
921 let status = Response.status_code response in
922 let auth_to_use =
923 match auth with
924 | Some a -> a
925 | None -> Option.value t.auth ~default:Auth.none
926 in
927 let is_auth_challenge =
928 (status = 401 || status = 407) && Auth.is_digest auth_to_use
929 in
930 if is_auth_challenge then begin
931 match Auth.digest_credentials auth_to_use with
932 | Some (username, password) -> (
933 let challenge_header, auth_header_name = digest_header_names status in
934 match Response.header challenge_header response with
935 | Some www_auth -> (
936 match Auth.parse_www_authenticate www_auth with
937 | Some challenge ->
938 Log.info (fun m ->
939 m
940 "Received %s challenge (status %d), retrying with \
941 authentication"
942 (if status = 401 then "Digest" else "Proxy Digest")
943 status);
944 let uri_path =
945 let p = Uri.path (Uri.of_string url) in
946 if p = "" then "/" else p
947 in
948 let base_headers =
949 Option.value headers ~default:Headers.empty
950 in
951 let auth_headers =
952 build_digest_auth_header ~nonce_counter:t.nonce_counter
953 ~username ~password ~method_ ~uri:uri_path ~challenge
954 ~auth_header_name base_headers
955 in
956 request_internal wrapped_t ~headers:auth_headers ?body
957 ~auth:Auth.none ?timeout ?follow_redirects ?max_redirects
958 ~method_ url
959 | None ->
960 Log.warn (fun m ->
961 m "Could not parse Digest challenge from %s"
962 (Header_name.to_string challenge_header));
963 response)
964 | None ->
965 Log.warn (fun m ->
966 m "%d response has no %s header" status
967 (Header_name.to_string challenge_header));
968 response)
969 | None -> response
970 end
971 else response
972
973let compute_retry_delay ~retry_config ~status ~response ~attempt =
974 if retry_config.Retry.respect_retry_after && (status = 429 || status = 503)
975 then
976 match Response.header `Retry_after response with
977 | Some value ->
978 Retry.parse_retry_after value
979 |> Option.value
980 ~default:(Retry.calculate_backoff ~config:retry_config ~attempt)
981 | None -> Retry.calculate_backoff ~config:retry_config ~attempt
982 else Retry.calculate_backoff ~config:retry_config ~attempt
983
984let should_retry_exn = function
985 | Eio.Io (Error.E e, _) -> Error.is_retryable e
986 | Eio.Time.Timeout -> true
987 | _ -> false
988
989let retry_after_delay (T t) ~retry_config ~delay ~headers ~body ~auth ~timeout
990 ~follow_redirects ~max_redirects ~path_params ~method_ ~url
991 ~with_digest_handling ~attempt ~recurse =
992 Eio.Time.sleep t.clock delay;
993 t.retries_count <- t.retries_count + 1;
994 recurse ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects
995 ~path_params ~method_ ~url ~retry_config ~with_digest_handling (attempt + 1)
996
997let rec attempt_request (T t as wrapped_t) ~headers ~body ~auth ~timeout
998 ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~retry_config
999 ~with_digest_handling attempt =
1000 if attempt > 1 then
1001 Log.info (fun m ->
1002 m "Retry attempt %d/%d for %s %s" attempt
1003 (retry_config.Retry.max_retries + 1)
1004 (Method.to_string method_) url);
1005 let retry ~delay =
1006 retry_after_delay wrapped_t ~retry_config ~delay ~headers ~body ~auth
1007 ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url
1008 ~with_digest_handling ~attempt
1009 ~recurse:(attempt_request wrapped_t)
1010 in
1011 try
1012 let response =
1013 request_internal wrapped_t ?headers ?body ?auth ?timeout ?follow_redirects
1014 ?max_redirects ~path_params ~method_ url
1015 in
1016 let response = with_digest_handling response in
1017 let status = Response.status_code response in
1018 if
1019 attempt <= retry_config.Retry.max_retries
1020 && Retry.should_retry ~config:retry_config ~method_ ~status
1021 then begin
1022 let delay =
1023 compute_retry_delay ~retry_config ~status ~response ~attempt
1024 in
1025 Log.warn (fun m ->
1026 m
1027 "Request returned status %d (attempt %d/%d). Retrying in %.2f \
1028 seconds..."
1029 status attempt
1030 (retry_config.Retry.max_retries + 1)
1031 delay);
1032 retry ~delay
1033 end
1034 else response
1035 with
1036 | exn
1037 when attempt <= retry_config.Retry.max_retries && should_retry_exn exn
1038 ->
1039 let delay = Retry.calculate_backoff ~config:retry_config ~attempt in
1040 Log.warn (fun m ->
1041 m "Request failed (attempt %d/%d): %s. Retrying in %.2f seconds..."
1042 attempt
1043 (retry_config.Retry.max_retries + 1)
1044 (Printexc.to_string exn) delay);
1045 retry ~delay
1046
1047(* Public request function - executes synchronously with retry support *)
1048let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects
1049 ?max_redirects ?(path_params = []) ~method_ url =
1050 let with_digest_handling response =
1051 handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects
1052 ~max_redirects ~method_ ~url response
1053 in
1054 match t.retry with
1055 | None ->
1056 let response =
1057 request_internal wrapped_t ?headers ?body ?auth ?timeout
1058 ?follow_redirects ?max_redirects ~path_params ~method_ url
1059 in
1060 with_digest_handling response
1061 | Some retry_config ->
1062 attempt_request wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects
1063 ~max_redirects ~path_params ~method_ ~url ~retry_config
1064 ~with_digest_handling 1
1065
1066(* Convenience methods *)
1067let get t ?headers ?auth ?timeout ?params ?(path_params = []) url =
1068 let url =
1069 match params with
1070 | Some p ->
1071 let uri = Uri.of_string url in
1072 let uri =
1073 List.fold_left (fun u (k, v) -> Uri.add_query_param' u (k, v)) uri p
1074 in
1075 Uri.to_string uri
1076 | None -> url
1077 in
1078 request t ?headers ?auth ?timeout ~path_params ~method_:`GET url
1079
1080let post t ?headers ?body ?auth ?timeout ?(path_params = []) url =
1081 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`POST url
1082
1083let put t ?headers ?body ?auth ?timeout ?(path_params = []) url =
1084 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PUT url
1085
1086let patch t ?headers ?body ?auth ?timeout ?(path_params = []) url =
1087 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PATCH url
1088
1089let delete t ?headers ?auth ?timeout ?(path_params = []) url =
1090 request t ?headers ?auth ?timeout ~path_params ~method_:`DELETE url
1091
1092let head t ?headers ?auth ?timeout ?(path_params = []) url =
1093 request t ?headers ?auth ?timeout ~path_params ~method_:`HEAD url
1094
1095let options t ?headers ?auth ?timeout ?(path_params = []) url =
1096 request t ?headers ?auth ?timeout ~path_params ~method_:`OPTIONS url
1097
1098(* Cmdliner integration module *)
1099module Cmd = struct
1100 open Cmdliner
1101
1102 (** Source tracking for configuration values. Tracks where each configuration
1103 value came from for debugging and transparency. *)
1104 type source =
1105 | Default (** Value from hardcoded default *)
1106 | Env of string (** Value from environment variable (stores var name) *)
1107 | Cmdline (** Value from command-line argument *)
1108
1109 type 'a with_source = { value : 'a; source : source }
1110 (** Wrapper for values with source tracking *)
1111
1112 type proxy_config = {
1113 proxy_url : string with_source option;
1114 (** Proxy URL (from HTTP_PROXY/HTTPS_PROXY/etc) *)
1115 no_proxy : string with_source option; (** NO_PROXY patterns *)
1116 }
1117 (** Proxy configuration from command line and environment *)
1118
1119 type config = {
1120 xdg : Xdge.t * Xdge.Cmd.t;
1121 persist_cookies : bool with_source;
1122 verify_tls : bool with_source;
1123 timeout : float option with_source;
1124 max_retries : int with_source;
1125 retry_backoff : float with_source;
1126 follow_redirects : bool with_source;
1127 max_redirects : int with_source;
1128 user_agent : string option with_source;
1129 verbose_http : bool with_source;
1130 proxy : proxy_config;
1131 }
1132
1133 (** Helper to check environment variable and track source *)
1134 let check_env_bool ~app_name ~suffix ~default =
1135 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
1136 match Sys.getenv_opt env_var with
1137 | Some v
1138 when String.lowercase_ascii v = "1" || String.lowercase_ascii v = "true"
1139 ->
1140 { value = true; source = Env env_var }
1141 | Some v
1142 when String.lowercase_ascii v = "0" || String.lowercase_ascii v = "false"
1143 ->
1144 { value = false; source = Env env_var }
1145 | Some _ | None -> { value = default; source = Default }
1146
1147 let check_env_string ~app_name ~suffix =
1148 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
1149 match Sys.getenv_opt env_var with
1150 | Some v when v <> "" -> Some { value = v; source = Env env_var }
1151 | Some _ | None -> None
1152
1153 let check_env_float ~app_name ~suffix ~default =
1154 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
1155 match Sys.getenv_opt env_var with
1156 | Some v -> (
1157 try { value = float_of_string v; source = Env env_var }
1158 with Failure _ -> { value = default; source = Default })
1159 | None -> { value = default; source = Default }
1160
1161 let check_env_int ~app_name ~suffix ~default =
1162 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
1163 match Sys.getenv_opt env_var with
1164 | Some v -> (
1165 try { value = int_of_string v; source = Env env_var }
1166 with Failure _ -> { value = default; source = Default })
1167 | None -> { value = default; source = Default }
1168
1169 (** Parse proxy configuration from environment. Follows standard
1170 HTTP_PROXY/HTTPS_PROXY/ALL_PROXY/NO_PROXY conventions. *)
1171 let proxy_from_env () =
1172 let check_env var =
1173 match Sys.getenv_opt var with
1174 | Some v when v <> "" -> Some { value = v; source = Env var }
1175 | _ -> None
1176 in
1177 let proxy_url =
1178 List.find_map check_env
1179 [
1180 "HTTP_PROXY";
1181 "http_proxy";
1182 "HTTPS_PROXY";
1183 "https_proxy";
1184 "ALL_PROXY";
1185 "all_proxy";
1186 ]
1187 in
1188 let no_proxy = List.find_map check_env [ "NO_PROXY"; "no_proxy" ] in
1189 { proxy_url; no_proxy }
1190
1191 let v config env sw =
1192 let xdg, _xdg_cmd = config.xdg in
1193 let retry =
1194 if config.max_retries.value > 0 then
1195 Some
1196 (Retry.config ~max_retries:config.max_retries.value
1197 ~backoff_factor:config.retry_backoff.value ())
1198 else None
1199 in
1200
1201 let timeout =
1202 match config.timeout.value with
1203 | Some t -> Timeout.v ~total:t ()
1204 | None -> Timeout.default
1205 in
1206
1207 (* Build proxy config if URL is set *)
1208 let proxy =
1209 match config.proxy.proxy_url with
1210 | Some { value = url; _ } ->
1211 let no_proxy =
1212 match config.proxy.no_proxy with
1213 | Some { value = np; _ } ->
1214 np |> String.split_on_char ',' |> List.map String.trim
1215 |> List.filter (fun s -> s <> "")
1216 | None -> []
1217 in
1218 (* Parse proxy URL to extract components *)
1219 let uri = Uri.of_string url in
1220 let host = Uri.host uri |> Option.value ~default:"localhost" in
1221 let port = Uri.port uri |> Option.value ~default:8080 in
1222 let auth =
1223 match Uri.userinfo uri with
1224 | Some info -> (
1225 match String.index_opt info ':' with
1226 | Some idx ->
1227 let username = String.sub info 0 idx in
1228 let password =
1229 String.sub info (idx + 1) (String.length info - idx - 1)
1230 in
1231 Some (Auth.basic ~username ~password)
1232 | None -> Some (Auth.basic ~username:info ~password:""))
1233 | None -> None
1234 in
1235 Some (Proxy.http ~port ?auth ~no_proxy host)
1236 | None -> None
1237 in
1238
1239 let req =
1240 v ~sw ~xdg ~persist_cookies:config.persist_cookies.value
1241 ~verify_tls:config.verify_tls.value ~timeout ?retry
1242 ~follow_redirects:config.follow_redirects.value
1243 ~max_redirects:config.max_redirects.value ?proxy env
1244 in
1245
1246 (* Set user agent if provided *)
1247 let req =
1248 match config.user_agent.value with
1249 | Some ua -> set_default_header req "User-Agent" ua
1250 | None -> req
1251 in
1252
1253 req
1254
1255 (* Individual terms - parameterized by app_name
1256 These terms return with_source wrapped values to track provenance *)
1257
1258 let persist_cookies_term app_name =
1259 let doc = "Persist cookies to disk between sessions" in
1260 let env_name = String.uppercase_ascii app_name ^ "_PERSIST_COOKIES" in
1261 let env_info = Cmdliner.Cmd.Env.info env_name in
1262 let cmdline_arg =
1263 Arg.(value & flag & info [ "persist-cookies" ] ~env:env_info ~doc)
1264 in
1265 Term.(
1266 const (fun cmdline ->
1267 if cmdline then { value = true; source = Cmdline }
1268 else check_env_bool ~app_name ~suffix:"PERSIST_COOKIES" ~default:false)
1269 $ cmdline_arg)
1270
1271 let verify_tls_term app_name =
1272 let doc = "Skip TLS certificate verification (insecure)" in
1273 let env_name = String.uppercase_ascii app_name ^ "_NO_VERIFY_TLS" in
1274 let env_info = Cmdliner.Cmd.Env.info env_name in
1275 let cmdline_arg =
1276 Arg.(value & flag & info [ "no-verify-tls" ] ~env:env_info ~doc)
1277 in
1278 Term.(
1279 const (fun no_verify ->
1280 if no_verify then { value = false; source = Cmdline }
1281 else
1282 let env_val =
1283 check_env_bool ~app_name ~suffix:"NO_VERIFY_TLS" ~default:false
1284 in
1285 { value = not env_val.value; source = env_val.source })
1286 $ cmdline_arg)
1287
1288 let timeout_term app_name =
1289 let doc = "Request timeout in seconds" in
1290 let env_name = String.uppercase_ascii app_name ^ "_TIMEOUT" in
1291 let env_info = Cmdliner.Cmd.Env.info env_name in
1292 let cmdline_arg =
1293 Arg.(
1294 value
1295 & opt (some float) None
1296 & info [ "timeout" ] ~env:env_info ~docv:"SECONDS" ~doc)
1297 in
1298 Term.(
1299 const (fun cmdline ->
1300 match cmdline with
1301 | Some t -> { value = Some t; source = Cmdline }
1302 | None -> (
1303 match check_env_string ~app_name ~suffix:"TIMEOUT" with
1304 | Some { value = v; source } -> (
1305 try { value = Some (float_of_string v); source }
1306 with Failure _ -> { value = None; source = Default })
1307 | None -> { value = None; source = Default }))
1308 $ cmdline_arg)
1309
1310 let retries_term app_name =
1311 let doc = "Maximum number of request retries" in
1312 let env_name = String.uppercase_ascii app_name ^ "_MAX_RETRIES" in
1313 let env_info = Cmdliner.Cmd.Env.info env_name in
1314 let cmdline_arg =
1315 Arg.(
1316 value
1317 & opt (some int) None
1318 & info [ "max-retries" ] ~env:env_info ~docv:"N" ~doc)
1319 in
1320 Term.(
1321 const (fun cmdline ->
1322 match cmdline with
1323 | Some n -> { value = n; source = Cmdline }
1324 | None -> check_env_int ~app_name ~suffix:"MAX_RETRIES" ~default:3)
1325 $ cmdline_arg)
1326
1327 let retry_backoff_term app_name =
1328 let doc = "Retry backoff factor for exponential delay" in
1329 let env_name = String.uppercase_ascii app_name ^ "_RETRY_BACKOFF" in
1330 let env_info = Cmdliner.Cmd.Env.info env_name in
1331 let cmdline_arg =
1332 Arg.(
1333 value
1334 & opt (some float) None
1335 & info [ "retry-backoff" ] ~env:env_info ~docv:"FACTOR" ~doc)
1336 in
1337 Term.(
1338 const (fun cmdline ->
1339 match cmdline with
1340 | Some f -> { value = f; source = Cmdline }
1341 | None ->
1342 check_env_float ~app_name ~suffix:"RETRY_BACKOFF" ~default:0.3)
1343 $ cmdline_arg)
1344
1345 let follow_redirects_term app_name =
1346 let doc = "Don't follow HTTP redirects" in
1347 let env_name = String.uppercase_ascii app_name ^ "_NO_FOLLOW_REDIRECTS" in
1348 let env_info = Cmdliner.Cmd.Env.info env_name in
1349 let cmdline_arg =
1350 Arg.(value & flag & info [ "no-follow-redirects" ] ~env:env_info ~doc)
1351 in
1352 Term.(
1353 const (fun no_follow ->
1354 if no_follow then { value = false; source = Cmdline }
1355 else
1356 let env_val =
1357 check_env_bool ~app_name ~suffix:"NO_FOLLOW_REDIRECTS"
1358 ~default:false
1359 in
1360 { value = not env_val.value; source = env_val.source })
1361 $ cmdline_arg)
1362
1363 let max_redirects_term app_name =
1364 let doc = "Maximum number of redirects to follow" in
1365 let env_name = String.uppercase_ascii app_name ^ "_MAX_REDIRECTS" in
1366 let env_info = Cmdliner.Cmd.Env.info env_name in
1367 let cmdline_arg =
1368 Arg.(
1369 value
1370 & opt (some int) None
1371 & info [ "max-redirects" ] ~env:env_info ~docv:"N" ~doc)
1372 in
1373 Term.(
1374 const (fun cmdline ->
1375 match cmdline with
1376 | Some n -> { value = n; source = Cmdline }
1377 | None -> check_env_int ~app_name ~suffix:"MAX_REDIRECTS" ~default:10)
1378 $ cmdline_arg)
1379
1380 let user_agent_term app_name =
1381 let doc = "User-Agent header to send with requests" in
1382 let env_name = String.uppercase_ascii app_name ^ "_USER_AGENT" in
1383 let env_info = Cmdliner.Cmd.Env.info env_name in
1384 let cmdline_arg =
1385 Arg.(
1386 value
1387 & opt (some string) None
1388 & info [ "user-agent" ] ~env:env_info ~docv:"STRING" ~doc)
1389 in
1390 Term.(
1391 const (fun cmdline ->
1392 match cmdline with
1393 | Some ua -> { value = Some ua; source = Cmdline }
1394 | None -> (
1395 match check_env_string ~app_name ~suffix:"USER_AGENT" with
1396 | Some { value; source } -> { value = Some value; source }
1397 | None -> { value = None; source = Default }))
1398 $ cmdline_arg)
1399
1400 let verbose_http_term app_name =
1401 let doc = "Enable verbose HTTP-level logging (hexdumps, TLS details)" in
1402 let env_name = String.uppercase_ascii app_name ^ "_VERBOSE_HTTP" in
1403 let env_info = Cmdliner.Cmd.Env.info env_name in
1404 let cmdline_arg =
1405 Arg.(value & flag & info [ "verbose-http" ] ~env:env_info ~doc)
1406 in
1407 Term.(
1408 const (fun cmdline ->
1409 if cmdline then { value = true; source = Cmdline }
1410 else check_env_bool ~app_name ~suffix:"VERBOSE_HTTP" ~default:false)
1411 $ cmdline_arg)
1412
1413 let proxy_term _app_name =
1414 let doc = "HTTP/HTTPS proxy URL (e.g., http://proxy:8080)" in
1415 let cmdline_arg =
1416 Arg.(value & opt (some string) None & info [ "proxy" ] ~docv:"URL" ~doc)
1417 in
1418 let no_proxy_doc = "Comma-separated list of hosts to bypass proxy" in
1419 let no_proxy_arg =
1420 Arg.(
1421 value
1422 & opt (some string) None
1423 & info [ "no-proxy" ] ~docv:"HOSTS" ~doc:no_proxy_doc)
1424 in
1425 Term.(
1426 const (fun cmdline_proxy cmdline_no_proxy ->
1427 let proxy_url =
1428 match cmdline_proxy with
1429 | Some url -> Some { value = url; source = Cmdline }
1430 | None -> (proxy_from_env ()).proxy_url
1431 in
1432 let no_proxy =
1433 match cmdline_no_proxy with
1434 | Some np -> Some { value = np; source = Cmdline }
1435 | None -> (proxy_from_env ()).no_proxy
1436 in
1437 { proxy_url; no_proxy })
1438 $ cmdline_arg $ no_proxy_arg)
1439
1440 (* Combined terms *)
1441
1442 let config_term app_name fs =
1443 let xdg_term =
1444 Xdge.Cmd.term app_name fs ~dirs:[ `Config; `Data; `Cache ] ()
1445 in
1446 Term.(
1447 const
1448 (fun
1449 xdg
1450 persist
1451 verify
1452 timeout
1453 retries
1454 backoff
1455 follow
1456 max_redir
1457 ua
1458 verbose
1459 proxy
1460 ->
1461 {
1462 xdg;
1463 persist_cookies = persist;
1464 verify_tls = verify;
1465 timeout;
1466 max_retries = retries;
1467 retry_backoff = backoff;
1468 follow_redirects = follow;
1469 max_redirects = max_redir;
1470 user_agent = ua;
1471 verbose_http = verbose;
1472 proxy;
1473 })
1474 $ xdg_term
1475 $ persist_cookies_term app_name
1476 $ verify_tls_term app_name $ timeout_term app_name $ retries_term app_name
1477 $ retry_backoff_term app_name
1478 $ follow_redirects_term app_name
1479 $ max_redirects_term app_name
1480 $ user_agent_term app_name $ verbose_http_term app_name
1481 $ proxy_term app_name)
1482
1483 let requests_term app_name eio_env sw =
1484 let config_t = config_term app_name eio_env#fs in
1485 Term.(const (fun config -> v config eio_env sw) $ config_t)
1486
1487 let minimal_term app_name fs =
1488 let xdg_term = Xdge.Cmd.term app_name fs ~dirs:[ `Data; `Cache ] () in
1489 Term.(
1490 const (fun (xdg, _xdg_cmd) persist -> (xdg, persist.value))
1491 $ xdg_term
1492 $ persist_cookies_term app_name)
1493
1494 let env_docs app_name =
1495 let app_upper = String.uppercase_ascii app_name in
1496 Fmt.str
1497 "## ENVIRONMENT\n\n\
1498 The following environment variables affect %s:\n\n\
1499 ### XDG Directories\n\n\
1500 **%s_CONFIG_DIR**\n\
1501 : Override configuration directory location\n\n\
1502 **%s_DATA_DIR**\n\
1503 : Override data directory location (for cookies)\n\n\
1504 **%s_CACHE_DIR**\n\
1505 : Override cache directory location\n\n\
1506 **XDG_CONFIG_HOME**\n\
1507 : Base directory for user configuration files (default: ~/.config)\n\n\
1508 **XDG_DATA_HOME**\n\
1509 : Base directory for user data files (default: ~/.local/share)\n\n\
1510 **XDG_CACHE_HOME**\n\
1511 : Base directory for user cache files (default: ~/.cache)\n\n\
1512 ### HTTP Settings\n\n\
1513 **%s_PERSIST_COOKIES**\n\
1514 : Set to '1' to persist cookies by default\n\n\
1515 **%s_NO_VERIFY_TLS**\n\
1516 : Set to '1' to disable TLS verification (insecure)\n\n\
1517 **%s_TIMEOUT**\n\
1518 : Default request timeout in seconds\n\n\
1519 **%s_MAX_RETRIES**\n\
1520 : Maximum number of retries (default: 3)\n\n\
1521 **%s_RETRY_BACKOFF**\n\
1522 : Retry backoff factor (default: 0.3)\n\n\
1523 **%s_NO_FOLLOW_REDIRECTS**\n\
1524 : Set to '1' to disable redirect following\n\n\
1525 **%s_MAX_REDIRECTS**\n\
1526 : Maximum redirects to follow (default: 10)\n\n\
1527 **%s_USER_AGENT**\n\
1528 : User-Agent header to send with requests\n\n\
1529 **%s_VERBOSE_HTTP**\n\
1530 : Set to '1' to enable verbose HTTP-level logging\n\n\
1531 ### Proxy Configuration\n\n\
1532 **HTTP_PROXY** / **http_proxy**\n\
1533 : HTTP proxy URL (e.g., http://proxy:8080 or \
1534 http://user:pass@proxy:8080)\n\n\
1535 **HTTPS_PROXY** / **https_proxy**\n\
1536 : HTTPS proxy URL (used for HTTPS requests)\n\n\
1537 **ALL_PROXY** / **all_proxy**\n\
1538 : Fallback proxy URL for all protocols\n\n\
1539 **NO_PROXY** / **no_proxy**\n\
1540 : Comma-separated list of hosts to bypass proxy (e.g., \
1541 localhost,*.example.com)"
1542 app_name app_upper app_upper app_upper app_upper app_upper app_upper
1543 app_upper app_upper app_upper app_upper app_upper app_upper
1544
1545 (** Pretty-print source type *)
1546 let pp_source ppf = function
1547 | Default -> Fmt.pf ppf "default"
1548 | Env var -> Fmt.pf ppf "env(%s)" var
1549 | Cmdline -> Fmt.pf ppf "cmdline"
1550
1551 (** Pretty-print a value with its source *)
1552 let pp_with_source pp_val ppf ws =
1553 Fmt.pf ppf "%a [%a]" pp_val ws.value pp_source ws.source
1554
1555 let pp_config ?(show_sources = true) ppf config =
1556 let _xdg, xdg_cmd = config.xdg in
1557 let pp_bool = Fmt.bool in
1558 let pp_float = Fmt.float in
1559 let pp_int = Fmt.int in
1560 let pp_string_opt = Fmt.option Fmt.string in
1561 let pp_float_opt = Fmt.option Fmt.float in
1562
1563 let pp_val pp =
1564 if show_sources then pp_with_source pp else fun ppf ws -> pp ppf ws.value
1565 in
1566
1567 Fmt.pf ppf
1568 "@[<v>Configuration:@,\
1569 @[<v 2>XDG:@,\
1570 %a@]@,\
1571 persist_cookies: %a@,\
1572 verify_tls: %a@,\
1573 timeout: %a@,\
1574 max_retries: %a@,\
1575 retry_backoff: %a@,\
1576 follow_redirects: %a@,\
1577 max_redirects: %a@,\
1578 user_agent: %a@,\
1579 verbose_http: %a@,\
1580 @[<v 2>Proxy:@,\
1581 url: %a@,\
1582 no_proxy: %a@]@]"
1583 Xdge.Cmd.pp xdg_cmd (pp_val pp_bool) config.persist_cookies
1584 (pp_val pp_bool) config.verify_tls (pp_val pp_float_opt) config.timeout
1585 (pp_val pp_int) config.max_retries (pp_val pp_float) config.retry_backoff
1586 (pp_val pp_bool) config.follow_redirects (pp_val pp_int)
1587 config.max_redirects (pp_val pp_string_opt) config.user_agent
1588 (pp_val pp_bool) config.verbose_http
1589 (Fmt.option (pp_with_source Fmt.string))
1590 config.proxy.proxy_url
1591 (Fmt.option (pp_with_source Fmt.string))
1592 config.proxy.no_proxy
1593
1594 (* Logging configuration *)
1595 let setup_log_sources ?(verbose_http = false) level =
1596 (* Helper to set TLS tracing level by finding the source by name *)
1597 let set_tls_tracing_level lvl =
1598 match
1599 List.find_opt
1600 (fun s -> Logs.Src.name s = "tls.tracing")
1601 (Logs.Src.list ())
1602 with
1603 | Some tls_src -> Logs.Src.set_level tls_src (Some lvl)
1604 | None -> () (* TLS not loaded yet, ignore *)
1605 in
1606 match level with
1607 | Some Logs.Debug ->
1608 (* Enable debug logging for application-level requests modules *)
1609 Logs.Src.set_level src (Some Logs.Debug);
1610 Logs.Src.set_level Auth.src (Some Logs.Debug);
1611 Logs.Src.set_level Body.src (Some Logs.Debug);
1612 Logs.Src.set_level Response.src (Some Logs.Debug);
1613 Logs.Src.set_level Retry.src (Some Logs.Debug);
1614 Logs.Src.set_level Headers.src (Some Logs.Debug);
1615 Logs.Src.set_level Error.src (Some Logs.Debug);
1616 Logs.Src.set_level Method.src (Some Logs.Debug);
1617 Logs.Src.set_level Mime.src (Some Logs.Debug);
1618 Logs.Src.set_level Status.src (Some Logs.Debug);
1619 Logs.Src.set_level Timeout.src (Some Logs.Debug);
1620 (* Only enable HTTP-level debug if verbose_http is set *)
1621 if verbose_http then begin
1622 Logs.Src.set_level One.src (Some Logs.Debug);
1623 Logs.Src.set_level Http_client.src (Some Logs.Debug);
1624 Logs.Src.set_level Conpool.src (Some Logs.Debug);
1625 set_tls_tracing_level Logs.Debug
1626 end
1627 else begin
1628 Logs.Src.set_level One.src (Some Logs.Info);
1629 Logs.Src.set_level Http_client.src (Some Logs.Info);
1630 Logs.Src.set_level Conpool.src (Some Logs.Info);
1631 set_tls_tracing_level Logs.Warning
1632 end
1633 | Some Logs.Info ->
1634 (* Set info level for main modules *)
1635 Logs.Src.set_level src (Some Logs.Info);
1636 Logs.Src.set_level Response.src (Some Logs.Info);
1637 Logs.Src.set_level One.src (Some Logs.Info);
1638 set_tls_tracing_level Logs.Warning
1639 | _ ->
1640 (* Suppress TLS debug output by default *)
1641 set_tls_tracing_level Logs.Warning
1642end
1643
1644let pp fmt (T { base_url; auth; _ }) =
1645 Fmt.pf fmt "Requests.t(base_url=%s, auth=%a)"
1646 (Option.value ~default:"<none>" base_url)
1647 (Fmt.option Auth.pp) auth
1648
1649(** {1 Supporting Types} *)
1650
1651module Huri = Huri