jon.recoil.org
forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
anil.recoil.org
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"
9module Log = (val Logs.src_log src : Logs.LOG)
10
11module Method = Method
12module Mime = Mime
13module Headers = Headers
14module Http_date = Http_date
15module Auth = Auth
16module Proxy = Proxy
17module Proxy_tunnel = Proxy_tunnel
18module Timeout = Timeout
19module Body = Body
20module Response = Response
21module One = One
22module Http_client = Http_client
23module Status = Status
24module Error = Error
25module Retry = Retry
26module Cache_control = Cache_control
27module Response_limits = Response_limits
28module Expect_continue = Expect_continue
29module Version = Version
30module Link = Link
31module Timing = Timing
32module Header_name = Header_name
33module Header_parsing = Header_parsing
34module Websocket = Websocket
35
36(** Minimum TLS version configuration - re-exported from Tls_config. *)
37type tls_version = Tls_config.tls_version =
38 | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *)
39 | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *)
40
41(* Main API - Session functionality with connection pooling *)
42
43type t = T : {
44 sw : Eio.Switch.t;
45 clock : [> float Eio.Time.clock_ty] Eio.Resource.t;
46 net : [> [> `Generic] Eio.Net.ty] Eio.Resource.t;
47 http_pool : Conpool.t;
48 https_pool : Conpool.t;
49 cookie_jar : Cookeio_jar.t;
50 cookie_mutex : Eio.Mutex.t;
51 default_headers : Headers.t;
52 auth : Auth.t option;
53 timeout : Timeout.t;
54 follow_redirects : bool;
55 max_redirects : int;
56 verify_tls : bool;
57 tls_config : Tls.Config.client option;
58 retry : Retry.config option;
59 persist_cookies : bool;
60 xdg : Xdge.t option;
61 auto_decompress : bool;
62 expect_100_continue : Expect_continue.t; (** 100-continue configuration *)
63 base_url : string option; (** Per Recommendation #11: Base URL for relative paths *)
64 xsrf_cookie_name : string option; (** Per Recommendation #24: XSRF cookie name *)
65 xsrf_header_name : string; (** Per Recommendation #24: XSRF header name *)
66 proxy : Proxy.config option; (** HTTP/HTTPS proxy configuration *)
67 allow_insecure_auth : bool; (** Allow auth over HTTP for dev/testing *)
68 nonce_counter : Auth.Nonce_counter.t; (** Digest auth nonce count tracker *)
69
70 (* Statistics - mutable but NOTE: when sessions are derived via record update
71 syntax ({t with field = value}), these are copied not shared. Each derived
72 session has independent statistics. Use the same session object to track
73 cumulative stats. *)
74 mutable requests_made : int;
75 mutable total_time : float;
76 mutable retries_count : int;
77} -> t
78
79let create
80 ~sw
81 ?http_pool
82 ?https_pool
83 ?cookie_jar
84 ?(default_headers = Headers.empty)
85 ?auth
86 ?(timeout = Timeout.default)
87 ?(follow_redirects = true)
88 ?(max_redirects = 10)
89 ?(verify_tls = true)
90 ?tls_config
91 ?(min_tls_version = TLS_1_2)
92 ?(max_connections_per_host = 10)
93 ?(connection_idle_timeout = 60.0)
94 ?(connection_lifetime = 300.0)
95 ?retry
96 ?(persist_cookies = false)
97 ?xdg
98 ?(auto_decompress = true)
99 ?(expect_100_continue = `Threshold Expect_continue.default_threshold)
100 ?base_url
101 ?(xsrf_cookie_name = Some "XSRF-TOKEN") (* Per Recommendation #24 *)
102 ?(xsrf_header_name = "X-XSRF-TOKEN")
103 ?proxy
104 ?(allow_insecure_auth = false)
105 env =
106
107 Mirage_crypto_rng_unix.use_default (); (* avsm: is this bad to do twice? very common footgun to forget to initialise *)
108 let clock = env#clock in
109 let net = env#net in
110
111 let xdg = match xdg, persist_cookies with
112 | Some x, _ -> Some x
113 | None, true -> Some (Xdge.create env#fs "requests")
114 | None, false -> None
115 in
116
117 (* Create TLS config for HTTPS pool if needed
118 Per Recommendation #6: Enforce minimum TLS version *)
119 let tls_config = Tls_config.create_client_opt
120 ?existing_config:tls_config
121 ~verify_tls
122 ~min_tls_version
123 ~host:"session-init"
124 ()
125 in
126
127 (* Create connection pools if not provided *)
128 let pool_config = Conpool.Config.make
129 ~max_connections_per_endpoint:max_connections_per_host
130 ~max_idle_time:connection_idle_timeout
131 ~max_connection_lifetime:connection_lifetime
132 ()
133 in
134
135 (* HTTP pool - plain TCP connections *)
136 let http_pool = match http_pool with
137 | Some p -> p
138 | None ->
139 Conpool.create ~sw ~net ~clock ~config:pool_config ()
140 in
141
142 (* HTTPS pool - TLS-wrapped connections *)
143 let https_pool = match https_pool with
144 | Some p -> p
145 | None ->
146 Conpool.create ~sw ~net ~clock ?tls:tls_config ~config:pool_config ()
147 in
148
149 Log.info (fun m -> m "Created Requests session with connection pools (max_per_host=%d, TLS=%b)"
150 max_connections_per_host (Option.is_some tls_config));
151
152 let cookie_jar = match cookie_jar, persist_cookies, xdg with
153 | Some jar, _, _ -> jar
154 | None, true, Some xdg_ctx ->
155 let data_dir = Xdge.data_dir xdg_ctx in
156 let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
157 Cookeio_jar.load ~clock cookie_file
158 | None, _, _ ->
159 Cookeio_jar.create ()
160 in
161
162 (* Build expect_100_continue configuration from polymorphic variant *)
163 let expect_100_timeout = Timeout.expect_100_continue timeout |> Option.value ~default:1.0 in
164 let expect_100_config = Expect_continue.of_config ~timeout:expect_100_timeout expect_100_continue in
165
166 (* Normalize base_url: remove trailing slash for consistent path joining *)
167 let base_url = Option.map (fun url ->
168 if String.length url > 0 && url.[String.length url - 1] = '/' then
169 String.sub url 0 (String.length url - 1)
170 else url
171 ) base_url in
172
173 T {
174 sw;
175 clock;
176 net;
177 http_pool;
178 https_pool;
179 cookie_jar;
180 cookie_mutex = Eio.Mutex.create ();
181 default_headers;
182 auth;
183 timeout;
184 follow_redirects;
185 max_redirects;
186 verify_tls;
187 tls_config;
188 retry;
189 persist_cookies;
190 xdg;
191 auto_decompress;
192 expect_100_continue = expect_100_config;
193 base_url;
194 xsrf_cookie_name;
195 xsrf_header_name;
196 proxy;
197 allow_insecure_auth;
198 nonce_counter = Auth.Nonce_counter.create ();
199 requests_made = 0;
200 total_time = 0.0;
201 retries_count = 0;
202 }
203
204let set_default_header (T t) key value =
205 T { t with default_headers = Headers.set (Header_name.of_string key) value t.default_headers }
206
207let remove_default_header (T t) key =
208 T { t with default_headers = Headers.remove (Header_name.of_string key) t.default_headers }
209
210let set_auth (T t) auth =
211 Log.debug (fun m -> m "Setting authentication method");
212 T { t with auth = Some auth }
213
214let clear_auth (T t) =
215 Log.debug (fun m -> m "Clearing authentication");
216 T { t with auth = None }
217
218let set_timeout (T t) timeout =
219 Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout);
220 T { t with timeout }
221
222let set_retry (T t) config =
223 Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries);
224 T { t with retry = Some config }
225
226let cookies (T t) = t.cookie_jar
227let clear_cookies (T t) = Cookeio_jar.clear t.cookie_jar
228
229let set_proxy (T t) config =
230 Log.debug (fun m -> m "Setting proxy: %s:%d" config.Proxy.host config.Proxy.port);
231 T { t with proxy = Some config }
232
233let clear_proxy (T t) =
234 Log.debug (fun m -> m "Clearing proxy configuration");
235 T { t with proxy = None }
236
237let proxy (T t) = t.proxy
238
239(* Redirect handling - delegated to shared Redirect module *)
240
241(** {1 URL Resolution and Path Templating}
242
243 Per Recommendation #11: Base URL support with RFC 3986 resolution.
244 Per Recommendation #29: Path parameter templating. *)
245
246(** Check if a URL is relative (no scheme) *)
247let is_relative_url url =
248 let uri = Uri.of_string url in
249 Option.is_none (Uri.scheme uri)
250
251(** Resolve a URL against a base URL per RFC 3986 Section 5.
252 If the URL is already absolute, return it unchanged.
253 If base_url is None, return the original URL. *)
254let resolve_url ?base_url url =
255 match base_url with
256 | None -> url
257 | Some base ->
258 if is_relative_url url then begin
259 let base_uri = Uri.of_string base in
260 let rel_uri = Uri.of_string url in
261 let scheme = Uri.scheme base_uri |> Option.value ~default:"https" in
262 let resolved = Uri.resolve scheme base_uri rel_uri in
263 Log.debug (fun m -> m "Resolved relative URL %s against base %s -> %s"
264 url base (Uri.to_string resolved));
265 Uri.to_string resolved
266 end else
267 url (* Already absolute *)
268
269(** Substitute path parameters in a URL template.
270 Per Recommendation #29 and RFC 6570 (simplified).
271 Template: "/users/{id}/posts/{post_id}"
272 Params: [("id", "123"); ("post_id", "456")]
273 Result: "/users/123/posts/456"
274 Values are automatically URL-encoded. *)
275let substitute_path_params url params =
276 List.fold_left (fun url (key, value) ->
277 let pattern = "{" ^ key ^ "}" in
278 let encoded_value = Uri.pct_encode value in
279 let rec replace s =
280 match String.split_on_char '{' s with
281 | [] -> ""
282 | [single] -> single
283 | before :: rest ->
284 let rest_str = String.concat "{" rest in
285 if String.length rest_str >= String.length key + 1 &&
286 String.sub rest_str 0 (String.length key) = key &&
287 rest_str.[String.length key] = '}' then
288 before ^ encoded_value ^ String.sub rest_str (String.length key + 1)
289 (String.length rest_str - String.length key - 1)
290 else
291 before ^ "{" ^ replace rest_str
292 in
293 if String.length pattern > 0 then replace url else url
294 ) url params
295
296(** {1 XSRF Token Handling}
297
298 Per Recommendation #24: Automatically inject XSRF tokens from cookies. *)
299
300(** Extract XSRF token from cookies and add to headers if:
301 1. xsrf_cookie_name is configured
302 2. The cookie exists
303 3. The request is same-origin (security) *)
304let apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url headers =
305 match xsrf_cookie_name with
306 | None -> headers (* XSRF handling disabled *)
307 | Some cookie_name ->
308 let uri = Uri.of_string url in
309 let domain = Uri.host uri |> Option.value ~default:"" in
310 let path = Uri.path uri in
311 let is_secure = Uri.scheme uri = Some "https" in
312
313 (* Get cookies for this domain *)
314 let cookies = Cookeio_jar.get_cookies cookie_jar ~clock
315 ~domain ~path ~is_secure in
316
317 (* Find the XSRF token cookie *)
318 let xsrf_value = List.find_map (fun cookie ->
319 if Cookeio.name cookie = cookie_name then
320 Some (Cookeio.value cookie)
321 else
322 None
323 ) cookies in
324
325 match xsrf_value with
326 | Some token ->
327 Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name);
328 (* XSRF header name is configurable, use string variant *)
329 Headers.set_string xsrf_header_name token headers
330 | None -> headers
331
332(* Internal request function using connection pools *)
333let make_request_internal (T t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects
334 ?(path_params=[]) ~method_ url =
335 let start_time = Unix.gettimeofday () in
336 let method_str = Method.to_string method_ in
337
338 (* Per Recommendation #29: Substitute path parameters first *)
339 let url = if path_params = [] then url else substitute_path_params url path_params in
340
341 (* Per Recommendation #11: Resolve relative URLs against base_url *)
342 let url = resolve_url ?base_url:t.base_url url in
343
344 Log.info (fun m -> m "Making %s request to %s" method_str url);
345
346 (* Merge headers *)
347 let headers = match headers with
348 | Some h -> Headers.merge t.default_headers h
349 | None -> t.default_headers
350 in
351
352 (* Add default User-Agent if not already set - per RFC 9110 Section 10.1.5 *)
353 let headers =
354 if not (Headers.mem `User_agent headers) then
355 Headers.set `User_agent Version.user_agent headers
356 else
357 headers
358 in
359
360 (* Per Recommendation #24: Apply XSRF token from cookies *)
361 let headers = Eio.Mutex.use_ro t.cookie_mutex (fun () ->
362 apply_xsrf_token
363 ~cookie_jar:t.cookie_jar
364 ~clock:t.clock
365 ~xsrf_cookie_name:t.xsrf_cookie_name
366 ~xsrf_header_name:t.xsrf_header_name
367 ~url
368 headers
369 ) in
370
371 (* Use provided auth or default *)
372 let auth = match auth with
373 | Some a -> Some a
374 | None -> t.auth
375 in
376
377 (* Apply auth with HTTPS validation per RFC 7617/6750 *)
378 let headers = match auth with
379 | Some a ->
380 Log.debug (fun m -> m "Applying authentication");
381 Auth.apply_secure ~allow_insecure_auth:t.allow_insecure_auth ~url a headers
382 | None -> headers
383 in
384
385 (* Add content type from body *)
386 let base_headers = match body with
387 | Some b -> (match Body.content_type b with
388 | Some mime -> Headers.content_type mime headers
389 | None -> headers)
390 | None -> headers
391 in
392
393 (* Add Accept-Encoding header for auto-decompression if not already set *)
394 let base_headers =
395 if t.auto_decompress && not (Headers.mem `Accept_encoding base_headers) then
396 Headers.set `Accept_encoding "gzip, deflate" base_headers
397 else
398 base_headers
399 in
400
401 (* Get request body, defaulting to empty *)
402 let request_body = Option.value ~default:Body.empty body in
403
404 (* Helper to extract and store cookies from response headers *)
405 let extract_cookies_from_headers resp_headers url_str =
406 let uri = Uri.of_string url_str in
407 let cookie_domain = Uri.host uri |> Option.value ~default:"" in
408 let cookie_path = Uri.path uri in
409 Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
410 match Headers.get_all `Set_cookie resp_headers with
411 | [] -> ()
412 | cookie_headers ->
413 Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers));
414 List.iter (fun cookie_str ->
415 let now = fun () -> Ptime.of_float_s (Eio.Time.now t.clock) |> Option.get in
416 match Cookeio.of_set_cookie_header ~now ~domain:cookie_domain ~path:cookie_path cookie_str with
417 | Ok cookie ->
418 Log.debug (fun m -> m "Storing cookie: %s" (Cookeio.name cookie));
419 Cookeio_jar.add_cookie t.cookie_jar cookie
420 | Error msg ->
421 Log.warn (fun m -> m "Failed to parse cookie: %s (%s)" cookie_str msg)
422 ) cookie_headers
423 )
424 in
425
426 (* Track the original URL for cross-origin redirect detection *)
427 let original_uri = Uri.of_string url in
428
429 let response =
430
431 (* Execute request with redirect handling
432 headers_for_request: the headers to use for this specific request (may have auth stripped)
433 ~method_: the HTTP method for this request (may be changed by 303 redirect)
434 ~body: the request body (may be stripped by 303 redirect) *)
435 let rec make_with_redirects ~headers_for_request ~method_ ~body url_to_fetch redirects_left =
436 let uri_to_fetch = Uri.of_string url_to_fetch in
437
438 (* Parse the redirect URL to get correct host and port *)
439 let redirect_host = match Uri.host uri_to_fetch with
440 | Some h -> h
441 | None -> raise (Error.err (Error.Invalid_redirect { url = url_to_fetch; reason = "URL must contain a host" }))
442 in
443 let redirect_port = match Uri.scheme uri_to_fetch, Uri.port uri_to_fetch with
444 | Some "https", None -> 443
445 | Some "https", Some p -> p
446 | Some "http", None -> 80
447 | Some "http", Some p -> p
448 | _, Some p -> p
449 | _ -> 80
450 in
451
452 (* Create endpoint for this specific URL *)
453 let redirect_endpoint = Conpool.Endpoint.make ~host:redirect_host ~port:redirect_port in
454
455 (* Determine if we need TLS based on this URL's scheme *)
456 let redirect_is_https = match Uri.scheme uri_to_fetch with
457 | Some "https" -> true
458 | _ -> false
459 in
460
461 (* Choose the appropriate connection pool for this URL *)
462 let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in
463
464 (* Get cookies for this specific URL *)
465 let fetch_domain = redirect_host in
466 let fetch_path = Uri.path uri_to_fetch in
467 let fetch_is_secure = redirect_is_https in
468 let headers_with_cookies =
469 Eio.Mutex.use_ro t.cookie_mutex (fun () ->
470 let cookies = Cookeio_jar.get_cookies t.cookie_jar ~clock:t.clock
471 ~domain:fetch_domain ~path:fetch_path ~is_secure:fetch_is_secure in
472 match cookies with
473 | [] ->
474 Log.debug (fun m -> m "No cookies found for %s%s" fetch_domain fetch_path);
475 headers_for_request
476 | cookies ->
477 let cookie_header = Cookeio.make_cookie_header cookies in
478 Log.debug (fun m -> m "Adding %d cookies for %s%s: Cookie: %s"
479 (List.length cookies) fetch_domain fetch_path cookie_header);
480 Headers.set `Cookie cookie_header headers_for_request
481 )
482 in
483
484 (* Log the request being made at Info level *)
485 Log.info (fun m -> m "");
486 Log.info (fun m -> m "=== Request to %s ===" url_to_fetch);
487 Log.info (fun m -> m "> %s %s HTTP/1.1" method_str (Uri.to_string uri_to_fetch));
488 Log.info (fun m -> m "> Request Headers:");
489 Headers.to_list headers_with_cookies |> List.iter (fun (k, v) ->
490 Log.info (fun m -> m "> %s: %s" k v)
491 );
492 Log.info (fun m -> m "");
493
494 (* Determine if we should use proxy for this URL *)
495 let use_proxy = match t.proxy with
496 | None -> false
497 | Some proxy -> not (Proxy.should_bypass proxy url_to_fetch)
498 in
499
500 let make_request_fn () =
501 match use_proxy, redirect_is_https, t.proxy with
502 | false, _, _ ->
503 (* Direct connection - use connection pool *)
504 Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
505 Http_client.make_request_100_continue_decompress
506 ~expect_100:t.expect_100_continue
507 ~clock:t.clock
508 ~sw:t.sw
509 ~method_ ~uri:uri_to_fetch
510 ~headers:headers_with_cookies ~body
511 ~auto_decompress:t.auto_decompress flow
512 )
513
514 | true, false, Some proxy ->
515 (* HTTP via proxy - connect to proxy and use absolute-URI form *)
516 Log.debug (fun m -> m "Routing HTTP request via proxy %s:%d"
517 proxy.Proxy.host proxy.Proxy.port);
518 let proxy_endpoint = Conpool.Endpoint.make
519 ~host:proxy.Proxy.host ~port:proxy.Proxy.port in
520 Conpool.with_connection t.http_pool proxy_endpoint (fun flow ->
521 (* Write request using absolute-URI form *)
522 Http_write.write_and_flush flow (fun w ->
523 Http_write.request_via_proxy w ~sw:t.sw ~method_ ~uri:uri_to_fetch
524 ~headers:headers_with_cookies ~body
525 ~proxy_auth:proxy.Proxy.auth
526 );
527 (* Read response *)
528 let limits = Response_limits.default in
529 let buf_read = Http_read.of_flow ~max_size:65536 flow in
530 let _version, status, resp_headers, body_str =
531 Http_read.response ~limits ~method_ buf_read in
532 (* Handle decompression if enabled *)
533 let body_str = match t.auto_decompress, Headers.get `Content_encoding resp_headers with
534 | true, Some encoding ->
535 Http_client.decompress_body ~limits ~content_encoding:encoding body_str
536 | _ -> body_str
537 in
538 (status, resp_headers, body_str)
539 )
540
541 | true, true, Some proxy ->
542 (* HTTPS via proxy - establish CONNECT tunnel then TLS *)
543 Log.debug (fun m -> m "Routing HTTPS request via proxy %s:%d (CONNECT tunnel)"
544 proxy.Proxy.host proxy.Proxy.port);
545 (* Establish TLS tunnel through proxy *)
546 let tunnel_flow = Proxy_tunnel.connect_with_tls
547 ~sw:t.sw ~net:t.net ~clock:t.clock
548 ~proxy
549 ~target_host:redirect_host
550 ~target_port:redirect_port
551 ?tls_config:t.tls_config
552 ()
553 in
554 (* Send request through tunnel using normal format (not absolute-URI) *)
555 Http_client.make_request_100_continue_decompress
556 ~expect_100:t.expect_100_continue
557 ~clock:t.clock
558 ~sw:t.sw
559 ~method_ ~uri:uri_to_fetch
560 ~headers:headers_with_cookies ~body
561 ~auto_decompress:t.auto_decompress tunnel_flow
562
563 | true, _, None ->
564 (* Should not happen due to use_proxy check *)
565 Conpool.with_connection redirect_pool redirect_endpoint (fun flow ->
566 Http_client.make_request_100_continue_decompress
567 ~expect_100:t.expect_100_continue
568 ~clock:t.clock
569 ~sw:t.sw
570 ~method_ ~uri:uri_to_fetch
571 ~headers:headers_with_cookies ~body
572 ~auto_decompress:t.auto_decompress flow
573 )
574 in
575
576 (* Apply timeout if specified *)
577 let status, resp_headers, response_body_str =
578 let timeout_val = Option.value timeout ~default:t.timeout in
579 match Timeout.total timeout_val with
580 | Some seconds ->
581 Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds);
582 Eio.Time.with_timeout_exn t.clock seconds make_request_fn
583 | None -> make_request_fn ()
584 in
585
586 (* Log response headers at Info level *)
587 Log.info (fun m -> m "< HTTP/1.1 %d" status);
588 Log.info (fun m -> m "< Response Headers:");
589 Headers.to_list resp_headers |> List.iter (fun (k, v) ->
590 Log.info (fun m -> m "< %s: %s" k v)
591 );
592 Log.info (fun m -> m "");
593
594 (* Extract and store cookies from this response (including redirect responses) *)
595 extract_cookies_from_headers resp_headers url_to_fetch;
596
597 (* Handle redirects if enabled *)
598 let follow = Option.value follow_redirects ~default:t.follow_redirects in
599 let max_redir = Option.value max_redirects ~default:t.max_redirects in
600
601 if follow && (status >= 300 && status < 400) then begin
602 if redirects_left <= 0 then begin
603 Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir url);
604 raise (Error.err (Error.Too_many_redirects { url; count = max_redir; max = max_redir }))
605 end;
606
607 match Headers.get `Location resp_headers with
608 | None ->
609 Log.debug (fun m -> m "Redirect response missing Location header");
610 (status, resp_headers, response_body_str, url_to_fetch)
611 | Some location ->
612 (* Validate redirect URL scheme - Per Recommendation #5 *)
613 let _ = Redirect.validate_url location in
614
615 (* Resolve relative redirects against the current URL *)
616 let location_uri = Uri.of_string location in
617 let absolute_location =
618 match Uri.host location_uri with
619 | Some _ -> location (* Already absolute *)
620 | None ->
621 (* Relative redirect - resolve against current URL *)
622 let base_uri = uri_to_fetch in
623 let scheme = Option.value (Uri.scheme base_uri) ~default:"http" in
624 let resolved = Uri.resolve scheme base_uri location_uri in
625 Uri.to_string resolved
626 in
627 Log.info (fun m -> m "Following redirect to %s (%d remaining)" absolute_location redirects_left);
628 (* Strip sensitive headers on cross-origin redirects (security)
629 Per Recommendation #1: Strip auth headers to prevent credential leakage *)
630 let redirect_uri = Uri.of_string absolute_location in
631 let headers_for_redirect =
632 if Redirect.same_origin original_uri redirect_uri then
633 headers_for_request
634 else begin
635 Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers");
636 Redirect.strip_sensitive_headers headers_for_request
637 end
638 in
639 (* RFC 9110 Section 15.4.4: For 303 See Other, change method to GET
640 "A user agent can perform a retrieval request targeting that URI
641 (a GET or HEAD request if using HTTP)" *)
642 let redirect_method, redirect_body =
643 if status = 303 then begin
644 match method_ with
645 | `POST | `PUT | `DELETE | `PATCH ->
646 Log.debug (fun m -> m "303 redirect: changing %s to GET and stripping body"
647 (Method.to_string method_));
648 (`GET, Body.empty)
649 | _ -> (method_, body)
650 end else
651 (method_, body)
652 in
653 make_with_redirects ~headers_for_request:headers_for_redirect
654 ~method_:redirect_method ~body:redirect_body
655 absolute_location (redirects_left - 1)
656 end else
657 (status, resp_headers, response_body_str, url_to_fetch)
658 in
659
660 let max_redir = Option.value max_redirects ~default:t.max_redirects in
661 let final_status, final_headers, final_body_str, final_url =
662 make_with_redirects ~headers_for_request:base_headers
663 ~method_ ~body:request_body url max_redir
664 in
665
666 let elapsed = Unix.gettimeofday () -. start_time in
667 Log.info (fun m -> m "Request completed in %.3f seconds" elapsed);
668
669 (* Create a flow from the body string *)
670 let body_flow = Eio.Flow.string_source final_body_str in
671
672 Response.Private.make
673 ~sw:t.sw
674 ~status:final_status
675 ~headers:final_headers
676 ~body:body_flow
677 ~url:final_url
678 ~elapsed
679 in
680
681 (* Cookies are extracted and stored during the redirect loop for each response,
682 including the final response, so no additional extraction needed here *)
683
684 (* Update statistics *)
685 t.requests_made <- t.requests_made + 1;
686 t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
687 Log.info (fun m -> m "Request completed with status %d" (Response.status_code response));
688
689 (* Save cookies to disk if persistence is enabled *)
690 (match t.persist_cookies, t.xdg with
691 | true, Some xdg_ctx ->
692 let data_dir = Xdge.data_dir xdg_ctx in
693 let cookie_file = Eio.Path.(data_dir / "cookies.txt") in
694 Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () ->
695 Cookeio_jar.save cookie_file t.cookie_jar;
696 Log.debug (fun m -> m "Saved cookies to %a" Eio.Path.pp cookie_file)
697 )
698 | _ -> ());
699
700 response
701
702(* Helper to handle Digest authentication challenges (401 and 407).
703 Per RFC 7235: 401 uses WWW-Authenticate/Authorization headers,
704 407 uses Proxy-Authenticate/Proxy-Authorization headers. *)
705let handle_digest_auth (T t as wrapped_t) ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response =
706 let status = Response.status_code response in
707 let auth_to_use = match auth with Some a -> a | None -> Option.value t.auth ~default:Auth.none in
708 (* Handle both 401 Unauthorized and 407 Proxy Authentication Required *)
709 let is_auth_challenge = (status = 401 || status = 407) && Auth.is_digest auth_to_use in
710 if is_auth_challenge then begin
711 match Auth.get_digest_credentials auth_to_use with
712 | Some (username, password) ->
713 (* RFC 7235: 401 uses WWW-Authenticate, 407 uses Proxy-Authenticate *)
714 let challenge_header : Header_name.t = if status = 401 then `Www_authenticate else `Proxy_authenticate in
715 let auth_header_name : Header_name.t = if status = 401 then `Authorization else `Proxy_authorization in
716 (match Response.header challenge_header response with
717 | Some www_auth ->
718 (match Auth.parse_www_authenticate www_auth with
719 | Some challenge ->
720 Log.info (fun m -> m "Received %s challenge (status %d), retrying with authentication"
721 (if status = 401 then "Digest" else "Proxy Digest") status);
722 let uri = Uri.of_string url in
723 let uri_path = Uri.path uri in
724 let uri_path = if uri_path = "" then "/" else uri_path in
725 (* Apply digest auth to headers with nonce counter for replay protection *)
726 let base_headers = Option.value headers ~default:Headers.empty in
727 (* Build the Authorization/Proxy-Authorization value manually *)
728 let auth_value = Auth.apply_digest
729 ~nonce_counter:t.nonce_counter
730 ~username ~password
731 ~method_:(Method.to_string method_)
732 ~uri:uri_path
733 ~challenge
734 Headers.empty
735 in
736 (* Get the auth value and set it on the correct header name *)
737 let auth_headers = match Headers.get `Authorization auth_value with
738 | Some v -> Headers.set auth_header_name v base_headers
739 | None -> base_headers
740 in
741 (* Retry with Digest auth - use Auth.none to prevent double-application *)
742 make_request_internal wrapped_t ~headers:auth_headers ?body ~auth:Auth.none ?timeout
743 ?follow_redirects ?max_redirects ~method_ url
744 | None ->
745 Log.warn (fun m -> m "Could not parse Digest challenge from %s" (Header_name.to_string challenge_header));
746 response)
747 | None ->
748 Log.warn (fun m -> m "%d response has no %s header" status (Header_name.to_string challenge_header));
749 response)
750 | None -> response
751 end else
752 response
753
754(* Public request function - executes synchronously with retry support *)
755let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects
756 ?(path_params=[]) ~method_ url =
757 (* Helper to wrap response with Digest auth handling *)
758 let with_digest_handling response =
759 handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response
760 in
761 match t.retry with
762 | None ->
763 (* No retry configured, execute directly *)
764 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
765 ?follow_redirects ?max_redirects ~path_params ~method_ url in
766 with_digest_handling response
767 | Some retry_config ->
768 (* Wrap in retry logic *)
769 (* Check if an Eio.Io exception is retryable using the new error types *)
770 let should_retry_exn = function
771 | Eio.Io (Error.E e, _) -> Error.is_retryable e
772 | Eio.Time.Timeout -> true
773 | _ -> false
774 in
775
776 let rec attempt_with_status_retry attempt =
777 if attempt > 1 then
778 Log.info (fun m -> m "Retry attempt %d/%d for %s %s"
779 attempt (retry_config.Retry.max_retries + 1)
780 (Method.to_string method_) url);
781
782 try
783 let response = make_request_internal wrapped_t ?headers ?body ?auth ?timeout
784 ?follow_redirects ?max_redirects ~path_params ~method_ url in
785 (* Handle Digest auth challenge if applicable *)
786 let response = with_digest_handling response in
787 let status = Response.status_code response in
788
789 (* Check if this status code should be retried *)
790 if attempt <= retry_config.Retry.max_retries &&
791 Retry.should_retry ~config:retry_config ~method_ ~status
792 then begin
793 (* Per Recommendation #4: Use Retry-After header when available *)
794 let delay =
795 if retry_config.respect_retry_after && (status = 429 || status = 503) then
796 match Response.header `Retry_after response with
797 | Some value ->
798 Retry.parse_retry_after value
799 |> Option.value ~default:(Retry.calculate_backoff ~config:retry_config ~attempt)
800 | None -> Retry.calculate_backoff ~config:retry_config ~attempt
801 else
802 Retry.calculate_backoff ~config:retry_config ~attempt
803 in
804 Log.warn (fun m -> m "Request returned status %d (attempt %d/%d). Retrying in %.2f seconds..."
805 status attempt (retry_config.Retry.max_retries + 1) delay);
806 Eio.Time.sleep t.clock delay;
807 t.retries_count <- t.retries_count + 1;
808 attempt_with_status_retry (attempt + 1)
809 end else
810 response
811 with exn when attempt <= retry_config.Retry.max_retries && should_retry_exn exn ->
812 let delay = Retry.calculate_backoff ~config:retry_config ~attempt in
813 Log.warn (fun m -> m "Request failed (attempt %d/%d): %s. Retrying in %.2f seconds..."
814 attempt (retry_config.Retry.max_retries + 1) (Printexc.to_string exn) delay);
815 Eio.Time.sleep t.clock delay;
816 t.retries_count <- t.retries_count + 1;
817 attempt_with_status_retry (attempt + 1)
818 in
819 attempt_with_status_retry 1
820
821(* Convenience methods *)
822let get t ?headers ?auth ?timeout ?params ?(path_params=[]) url =
823 let url = match params with
824 | Some p ->
825 let uri = Uri.of_string url in
826 let uri = List.fold_left (fun u (k, v) -> Uri.add_query_param' u (k, v)) uri p in
827 Uri.to_string uri
828 | None -> url
829 in
830 request t ?headers ?auth ?timeout ~path_params ~method_:`GET url
831
832let post t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
833 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`POST url
834
835let put t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
836 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PUT url
837
838let patch t ?headers ?body ?auth ?timeout ?(path_params=[]) url =
839 request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PATCH url
840
841let delete t ?headers ?auth ?timeout ?(path_params=[]) url =
842 request t ?headers ?auth ?timeout ~path_params ~method_:`DELETE url
843
844let head t ?headers ?auth ?timeout ?(path_params=[]) url =
845 request t ?headers ?auth ?timeout ~path_params ~method_:`HEAD url
846
847let options t ?headers ?auth ?timeout ?(path_params=[]) url =
848 request t ?headers ?auth ?timeout ~path_params ~method_:`OPTIONS url
849
850(* Cmdliner integration module *)
851module Cmd = struct
852 open Cmdliner
853
854 (** Source tracking for configuration values.
855 Tracks where each configuration value came from for debugging
856 and transparency. *)
857 type source =
858 | Default (** Value from hardcoded default *)
859 | Env of string (** Value from environment variable (stores var name) *)
860 | Cmdline (** Value from command-line argument *)
861
862 (** Wrapper for values with source tracking *)
863 type 'a with_source = {
864 value : 'a;
865 source : source;
866 }
867
868 (** Proxy configuration from command line and environment *)
869 type proxy_config = {
870 proxy_url : string with_source option; (** Proxy URL (from HTTP_PROXY/HTTPS_PROXY/etc) *)
871 no_proxy : string with_source option; (** NO_PROXY patterns *)
872 }
873
874 type config = {
875 xdg : Xdge.t * Xdge.Cmd.t;
876 persist_cookies : bool with_source;
877 verify_tls : bool with_source;
878 timeout : float option with_source;
879 max_retries : int with_source;
880 retry_backoff : float with_source;
881 follow_redirects : bool with_source;
882 max_redirects : int with_source;
883 user_agent : string option with_source;
884 verbose_http : bool with_source;
885 proxy : proxy_config;
886 }
887
888 (** Helper to check environment variable and track source *)
889 let check_env_bool ~app_name ~suffix ~default =
890 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
891 match Sys.getenv_opt env_var with
892 | Some v when String.lowercase_ascii v = "1" || String.lowercase_ascii v = "true" ->
893 { value = true; source = Env env_var }
894 | Some v when String.lowercase_ascii v = "0" || String.lowercase_ascii v = "false" ->
895 { value = false; source = Env env_var }
896 | Some _ | None -> { value = default; source = Default }
897
898 let check_env_string ~app_name ~suffix =
899 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
900 match Sys.getenv_opt env_var with
901 | Some v when v <> "" -> Some { value = v; source = Env env_var }
902 | Some _ | None -> None
903
904 let check_env_float ~app_name ~suffix ~default =
905 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
906 match Sys.getenv_opt env_var with
907 | Some v ->
908 (try { value = float_of_string v; source = Env env_var }
909 with _ -> { value = default; source = Default })
910 | None -> { value = default; source = Default }
911
912 let check_env_int ~app_name ~suffix ~default =
913 let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in
914 match Sys.getenv_opt env_var with
915 | Some v ->
916 (try { value = int_of_string v; source = Env env_var }
917 with _ -> { value = default; source = Default })
918 | None -> { value = default; source = Default }
919
920 (** Parse proxy configuration from environment.
921 Follows standard HTTP_PROXY/HTTPS_PROXY/ALL_PROXY/NO_PROXY conventions. *)
922 let proxy_from_env () =
923 let proxy_url =
924 (* Check in order of preference *)
925 match Sys.getenv_opt "HTTP_PROXY" with
926 | Some v when v <> "" -> Some { value = v; source = Env "HTTP_PROXY" }
927 | _ ->
928 match Sys.getenv_opt "http_proxy" with
929 | Some v when v <> "" -> Some { value = v; source = Env "http_proxy" }
930 | _ ->
931 match Sys.getenv_opt "HTTPS_PROXY" with
932 | Some v when v <> "" -> Some { value = v; source = Env "HTTPS_PROXY" }
933 | _ ->
934 match Sys.getenv_opt "https_proxy" with
935 | Some v when v <> "" -> Some { value = v; source = Env "https_proxy" }
936 | _ ->
937 match Sys.getenv_opt "ALL_PROXY" with
938 | Some v when v <> "" -> Some { value = v; source = Env "ALL_PROXY" }
939 | _ ->
940 match Sys.getenv_opt "all_proxy" with
941 | Some v when v <> "" -> Some { value = v; source = Env "all_proxy" }
942 | _ -> None
943 in
944 let no_proxy =
945 match Sys.getenv_opt "NO_PROXY" with
946 | Some v when v <> "" -> Some { value = v; source = Env "NO_PROXY" }
947 | _ ->
948 match Sys.getenv_opt "no_proxy" with
949 | Some v when v <> "" -> Some { value = v; source = Env "no_proxy" }
950 | _ -> None
951 in
952 { proxy_url; no_proxy }
953
954 let create config env sw =
955 let xdg, _xdg_cmd = config.xdg in
956 let retry = if config.max_retries.value > 0 then
957 Some (Retry.create_config
958 ~max_retries:config.max_retries.value
959 ~backoff_factor:config.retry_backoff.value ())
960 else None in
961
962 let timeout = match config.timeout.value with
963 | Some t -> Timeout.create ~total:t ()
964 | None -> Timeout.default in
965
966 (* Build proxy config if URL is set *)
967 let proxy = match config.proxy.proxy_url with
968 | Some { value = url; _ } ->
969 let no_proxy = match config.proxy.no_proxy with
970 | Some { value = np; _ } ->
971 np |> String.split_on_char ','
972 |> List.map String.trim
973 |> List.filter (fun s -> s <> "")
974 | None -> []
975 in
976 (* Parse proxy URL to extract components *)
977 let uri = Uri.of_string url in
978 let host = Uri.host uri |> Option.value ~default:"localhost" in
979 let port = Uri.port uri |> Option.value ~default:8080 in
980 let auth = match Uri.userinfo uri with
981 | Some info ->
982 (match String.index_opt info ':' with
983 | Some idx ->
984 let username = String.sub info 0 idx in
985 let password = String.sub info (idx + 1) (String.length info - idx - 1) in
986 Some (Auth.basic ~username ~password)
987 | None -> Some (Auth.basic ~username:info ~password:""))
988 | None -> None
989 in
990 Some (Proxy.http ~port ?auth ~no_proxy host)
991 | None -> None
992 in
993
994 let req = create ~sw
995 ~xdg
996 ~persist_cookies:config.persist_cookies.value
997 ~verify_tls:config.verify_tls.value
998 ~timeout
999 ?retry
1000 ~follow_redirects:config.follow_redirects.value
1001 ~max_redirects:config.max_redirects.value
1002 ?proxy
1003 env in
1004
1005 (* Set user agent if provided *)
1006 let req = match config.user_agent.value with
1007 | Some ua -> set_default_header req "User-Agent" ua
1008 | None -> req
1009 in
1010
1011 req
1012
1013 (* Individual terms - parameterized by app_name
1014 These terms return with_source wrapped values to track provenance *)
1015
1016 let persist_cookies_term app_name =
1017 let doc = "Persist cookies to disk between sessions" in
1018 let env_name = String.uppercase_ascii app_name ^ "_PERSIST_COOKIES" in
1019 let env_info = Cmdliner.Cmd.Env.info env_name in
1020 let cmdline_arg = Arg.(value & flag & info ["persist-cookies"] ~env:env_info ~doc) in
1021 Term.(const (fun cmdline ->
1022 if cmdline then
1023 { value = true; source = Cmdline }
1024 else
1025 check_env_bool ~app_name ~suffix:"PERSIST_COOKIES" ~default:false
1026 ) $ cmdline_arg)
1027
1028 let verify_tls_term app_name =
1029 let doc = "Skip TLS certificate verification (insecure)" in
1030 let env_name = String.uppercase_ascii app_name ^ "_NO_VERIFY_TLS" in
1031 let env_info = Cmdliner.Cmd.Env.info env_name in
1032 let cmdline_arg = Arg.(value & flag & info ["no-verify-tls"] ~env:env_info ~doc) in
1033 Term.(const (fun no_verify ->
1034 if no_verify then
1035 { value = false; source = Cmdline }
1036 else
1037 let env_val = check_env_bool ~app_name ~suffix:"NO_VERIFY_TLS" ~default:false in
1038 { value = not env_val.value; source = env_val.source }
1039 ) $ cmdline_arg)
1040
1041 let timeout_term app_name =
1042 let doc = "Request timeout in seconds" in
1043 let env_name = String.uppercase_ascii app_name ^ "_TIMEOUT" in
1044 let env_info = Cmdliner.Cmd.Env.info env_name in
1045 let cmdline_arg = Arg.(value & opt (some float) None & info ["timeout"] ~env:env_info ~docv:"SECONDS" ~doc) in
1046 Term.(const (fun cmdline ->
1047 match cmdline with
1048 | Some t -> { value = Some t; source = Cmdline }
1049 | None ->
1050 match check_env_string ~app_name ~suffix:"TIMEOUT" with
1051 | Some { value = v; source } ->
1052 (try { value = Some (float_of_string v); source }
1053 with _ -> { value = None; source = Default })
1054 | None -> { value = None; source = Default }
1055 ) $ cmdline_arg)
1056
1057 let retries_term app_name =
1058 let doc = "Maximum number of request retries" in
1059 let env_name = String.uppercase_ascii app_name ^ "_MAX_RETRIES" in
1060 let env_info = Cmdliner.Cmd.Env.info env_name in
1061 let cmdline_arg = Arg.(value & opt (some int) None & info ["max-retries"] ~env:env_info ~docv:"N" ~doc) in
1062 Term.(const (fun cmdline ->
1063 match cmdline with
1064 | Some n -> { value = n; source = Cmdline }
1065 | None -> check_env_int ~app_name ~suffix:"MAX_RETRIES" ~default:3
1066 ) $ cmdline_arg)
1067
1068 let retry_backoff_term app_name =
1069 let doc = "Retry backoff factor for exponential delay" in
1070 let env_name = String.uppercase_ascii app_name ^ "_RETRY_BACKOFF" in
1071 let env_info = Cmdliner.Cmd.Env.info env_name in
1072 let cmdline_arg = Arg.(value & opt (some float) None & info ["retry-backoff"] ~env:env_info ~docv:"FACTOR" ~doc) in
1073 Term.(const (fun cmdline ->
1074 match cmdline with
1075 | Some f -> { value = f; source = Cmdline }
1076 | None -> check_env_float ~app_name ~suffix:"RETRY_BACKOFF" ~default:0.3
1077 ) $ cmdline_arg)
1078
1079 let follow_redirects_term app_name =
1080 let doc = "Don't follow HTTP redirects" in
1081 let env_name = String.uppercase_ascii app_name ^ "_NO_FOLLOW_REDIRECTS" in
1082 let env_info = Cmdliner.Cmd.Env.info env_name in
1083 let cmdline_arg = Arg.(value & flag & info ["no-follow-redirects"] ~env:env_info ~doc) in
1084 Term.(const (fun no_follow ->
1085 if no_follow then
1086 { value = false; source = Cmdline }
1087 else
1088 let env_val = check_env_bool ~app_name ~suffix:"NO_FOLLOW_REDIRECTS" ~default:false in
1089 { value = not env_val.value; source = env_val.source }
1090 ) $ cmdline_arg)
1091
1092 let max_redirects_term app_name =
1093 let doc = "Maximum number of redirects to follow" in
1094 let env_name = String.uppercase_ascii app_name ^ "_MAX_REDIRECTS" in
1095 let env_info = Cmdliner.Cmd.Env.info env_name in
1096 let cmdline_arg = Arg.(value & opt (some int) None & info ["max-redirects"] ~env:env_info ~docv:"N" ~doc) in
1097 Term.(const (fun cmdline ->
1098 match cmdline with
1099 | Some n -> { value = n; source = Cmdline }
1100 | None -> check_env_int ~app_name ~suffix:"MAX_REDIRECTS" ~default:10
1101 ) $ cmdline_arg)
1102
1103 let user_agent_term app_name =
1104 let doc = "User-Agent header to send with requests" in
1105 let env_name = String.uppercase_ascii app_name ^ "_USER_AGENT" in
1106 let env_info = Cmdliner.Cmd.Env.info env_name in
1107 let cmdline_arg = Arg.(value & opt (some string) None & info ["user-agent"] ~env:env_info ~docv:"STRING" ~doc) in
1108 Term.(const (fun cmdline ->
1109 match cmdline with
1110 | Some ua -> { value = Some ua; source = Cmdline }
1111 | None ->
1112 match check_env_string ~app_name ~suffix:"USER_AGENT" with
1113 | Some { value; source } -> { value = Some value; source }
1114 | None -> { value = None; source = Default }
1115 ) $ cmdline_arg)
1116
1117 let verbose_http_term app_name =
1118 let doc = "Enable verbose HTTP-level logging (hexdumps, TLS details)" in
1119 let env_name = String.uppercase_ascii app_name ^ "_VERBOSE_HTTP" in
1120 let env_info = Cmdliner.Cmd.Env.info env_name in
1121 let cmdline_arg = Arg.(value & flag & info ["verbose-http"] ~env:env_info ~doc) in
1122 Term.(const (fun cmdline ->
1123 if cmdline then
1124 { value = true; source = Cmdline }
1125 else
1126 check_env_bool ~app_name ~suffix:"VERBOSE_HTTP" ~default:false
1127 ) $ cmdline_arg)
1128
1129 let proxy_term _app_name =
1130 let doc = "HTTP/HTTPS proxy URL (e.g., http://proxy:8080)" in
1131 let cmdline_arg = Arg.(value & opt (some string) None & info ["proxy"] ~docv:"URL" ~doc) in
1132 let no_proxy_doc = "Comma-separated list of hosts to bypass proxy" in
1133 let no_proxy_arg = Arg.(value & opt (some string) None & info ["no-proxy"] ~docv:"HOSTS" ~doc:no_proxy_doc) in
1134 Term.(const (fun cmdline_proxy cmdline_no_proxy ->
1135 let proxy_url = match cmdline_proxy with
1136 | Some url -> Some { value = url; source = Cmdline }
1137 | None -> (proxy_from_env ()).proxy_url
1138 in
1139 let no_proxy = match cmdline_no_proxy with
1140 | Some np -> Some { value = np; source = Cmdline }
1141 | None -> (proxy_from_env ()).no_proxy
1142 in
1143 { proxy_url; no_proxy }
1144 ) $ cmdline_arg $ no_proxy_arg)
1145
1146 (* Combined terms *)
1147
1148 let config_term app_name fs =
1149 let xdg_term = Xdge.Cmd.term app_name fs
1150 ~dirs:[`Config; `Data; `Cache] () in
1151 Term.(const (fun xdg persist verify timeout retries backoff follow max_redir ua verbose proxy ->
1152 { xdg; persist_cookies = persist; verify_tls = verify;
1153 timeout; max_retries = retries; retry_backoff = backoff;
1154 follow_redirects = follow; max_redirects = max_redir;
1155 user_agent = ua; verbose_http = verbose; proxy })
1156 $ xdg_term
1157 $ persist_cookies_term app_name
1158 $ verify_tls_term app_name
1159 $ timeout_term app_name
1160 $ retries_term app_name
1161 $ retry_backoff_term app_name
1162 $ follow_redirects_term app_name
1163 $ max_redirects_term app_name
1164 $ user_agent_term app_name
1165 $ verbose_http_term app_name
1166 $ proxy_term app_name)
1167
1168 let requests_term app_name eio_env sw =
1169 let config_t = config_term app_name eio_env#fs in
1170 Term.(const (fun config -> create config eio_env sw) $ config_t)
1171
1172 let minimal_term app_name fs =
1173 let xdg_term = Xdge.Cmd.term app_name fs
1174 ~dirs:[`Data; `Cache] () in
1175 Term.(const (fun (xdg, _xdg_cmd) persist -> (xdg, persist.value))
1176 $ xdg_term
1177 $ persist_cookies_term app_name)
1178
1179 let env_docs app_name =
1180 let app_upper = String.uppercase_ascii app_name in
1181 Printf.sprintf
1182 "## ENVIRONMENT\n\n\
1183 The following environment variables affect %s:\n\n\
1184 ### XDG Directories\n\n\
1185 **%s_CONFIG_DIR**\n\
1186 : Override configuration directory location\n\n\
1187 **%s_DATA_DIR**\n\
1188 : Override data directory location (for cookies)\n\n\
1189 **%s_CACHE_DIR**\n\
1190 : Override cache directory location\n\n\
1191 **XDG_CONFIG_HOME**\n\
1192 : Base directory for user configuration files (default: ~/.config)\n\n\
1193 **XDG_DATA_HOME**\n\
1194 : Base directory for user data files (default: ~/.local/share)\n\n\
1195 **XDG_CACHE_HOME**\n\
1196 : Base directory for user cache files (default: ~/.cache)\n\n\
1197 ### HTTP Settings\n\n\
1198 **%s_PERSIST_COOKIES**\n\
1199 : Set to '1' to persist cookies by default\n\n\
1200 **%s_NO_VERIFY_TLS**\n\
1201 : Set to '1' to disable TLS verification (insecure)\n\n\
1202 **%s_TIMEOUT**\n\
1203 : Default request timeout in seconds\n\n\
1204 **%s_MAX_RETRIES**\n\
1205 : Maximum number of retries (default: 3)\n\n\
1206 **%s_RETRY_BACKOFF**\n\
1207 : Retry backoff factor (default: 0.3)\n\n\
1208 **%s_NO_FOLLOW_REDIRECTS**\n\
1209 : Set to '1' to disable redirect following\n\n\
1210 **%s_MAX_REDIRECTS**\n\
1211 : Maximum redirects to follow (default: 10)\n\n\
1212 **%s_USER_AGENT**\n\
1213 : User-Agent header to send with requests\n\n\
1214 **%s_VERBOSE_HTTP**\n\
1215 : Set to '1' to enable verbose HTTP-level logging\n\n\
1216 ### Proxy Configuration\n\n\
1217 **HTTP_PROXY** / **http_proxy**\n\
1218 : HTTP proxy URL (e.g., http://proxy:8080 or http://user:pass@proxy:8080)\n\n\
1219 **HTTPS_PROXY** / **https_proxy**\n\
1220 : HTTPS proxy URL (used for HTTPS requests)\n\n\
1221 **ALL_PROXY** / **all_proxy**\n\
1222 : Fallback proxy URL for all protocols\n\n\
1223 **NO_PROXY** / **no_proxy**\n\
1224 : Comma-separated list of hosts to bypass proxy (e.g., localhost,*.example.com)\
1225 "
1226 app_name app_upper app_upper app_upper
1227 app_upper app_upper app_upper app_upper
1228 app_upper app_upper app_upper app_upper app_upper
1229
1230 (** Pretty-print source type *)
1231 let pp_source ppf = function
1232 | Default -> Format.fprintf ppf "default"
1233 | Env var -> Format.fprintf ppf "env(%s)" var
1234 | Cmdline -> Format.fprintf ppf "cmdline"
1235
1236 (** Pretty-print a value with its source *)
1237 let pp_with_source pp_val ppf ws =
1238 Format.fprintf ppf "%a [%a]" pp_val ws.value pp_source ws.source
1239
1240 let pp_config ?(show_sources = true) ppf config =
1241 let _xdg, xdg_cmd = config.xdg in
1242 let pp_bool = Format.pp_print_bool in
1243 let pp_float = Format.pp_print_float in
1244 let pp_int = Format.pp_print_int in
1245 let pp_string_opt = Format.pp_print_option Format.pp_print_string in
1246 let pp_float_opt = Format.pp_print_option Format.pp_print_float in
1247
1248 let pp_val pp = if show_sources then pp_with_source pp else fun ppf ws -> pp ppf ws.value in
1249
1250 Format.fprintf ppf "@[<v>Configuration:@,\
1251 @[<v 2>XDG:@,%a@]@,\
1252 persist_cookies: %a@,\
1253 verify_tls: %a@,\
1254 timeout: %a@,\
1255 max_retries: %a@,\
1256 retry_backoff: %a@,\
1257 follow_redirects: %a@,\
1258 max_redirects: %a@,\
1259 user_agent: %a@,\
1260 verbose_http: %a@,\
1261 @[<v 2>Proxy:@,\
1262 url: %a@,\
1263 no_proxy: %a@]@]"
1264 Xdge.Cmd.pp xdg_cmd
1265 (pp_val pp_bool) config.persist_cookies
1266 (pp_val pp_bool) config.verify_tls
1267 (pp_val pp_float_opt) config.timeout
1268 (pp_val pp_int) config.max_retries
1269 (pp_val pp_float) config.retry_backoff
1270 (pp_val pp_bool) config.follow_redirects
1271 (pp_val pp_int) config.max_redirects
1272 (pp_val pp_string_opt) config.user_agent
1273 (pp_val pp_bool) config.verbose_http
1274 (Format.pp_print_option (pp_with_source Format.pp_print_string))
1275 config.proxy.proxy_url
1276 (Format.pp_print_option (pp_with_source Format.pp_print_string))
1277 config.proxy.no_proxy
1278
1279 (* Logging configuration *)
1280 let setup_log_sources ?(verbose_http = false) level =
1281 (* Helper to set TLS tracing level by finding the source by name *)
1282 let set_tls_tracing_level lvl =
1283 match List.find_opt (fun s -> Logs.Src.name s = "tls.tracing") (Logs.Src.list ()) with
1284 | Some tls_src -> Logs.Src.set_level tls_src (Some lvl)
1285 | None -> () (* TLS not loaded yet, ignore *)
1286 in
1287 match level with
1288 | Some Logs.Debug ->
1289 (* Enable debug logging for application-level requests modules *)
1290 Logs.Src.set_level src (Some Logs.Debug);
1291 Logs.Src.set_level Auth.src (Some Logs.Debug);
1292 Logs.Src.set_level Body.src (Some Logs.Debug);
1293 Logs.Src.set_level Response.src (Some Logs.Debug);
1294 Logs.Src.set_level Retry.src (Some Logs.Debug);
1295 Logs.Src.set_level Headers.src (Some Logs.Debug);
1296 Logs.Src.set_level Error.src (Some Logs.Debug);
1297 Logs.Src.set_level Method.src (Some Logs.Debug);
1298 Logs.Src.set_level Mime.src (Some Logs.Debug);
1299 Logs.Src.set_level Status.src (Some Logs.Debug);
1300 Logs.Src.set_level Timeout.src (Some Logs.Debug);
1301 (* Only enable HTTP-level debug if verbose_http is set *)
1302 if verbose_http then begin
1303 Logs.Src.set_level One.src (Some Logs.Debug);
1304 Logs.Src.set_level Http_client.src (Some Logs.Debug);
1305 Logs.Src.set_level Conpool.src (Some Logs.Debug);
1306 set_tls_tracing_level Logs.Debug
1307 end else begin
1308 Logs.Src.set_level One.src (Some Logs.Info);
1309 Logs.Src.set_level Http_client.src (Some Logs.Info);
1310 Logs.Src.set_level Conpool.src (Some Logs.Info);
1311 set_tls_tracing_level Logs.Warning
1312 end
1313 | Some Logs.Info ->
1314 (* Set info level for main modules *)
1315 Logs.Src.set_level src (Some Logs.Info);
1316 Logs.Src.set_level Response.src (Some Logs.Info);
1317 Logs.Src.set_level One.src (Some Logs.Info);
1318 set_tls_tracing_level Logs.Warning
1319 | _ ->
1320 (* Suppress TLS debug output by default *)
1321 set_tls_tracing_level Logs.Warning
1322end
1323