(*--------------------------------------------------------------------------- Copyright (c) 2025 Anil Madhavapeddy . All rights reserved. SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) (** OCaml HTTP client library with streaming support *) let src = Logs.Src.create "requests" ~doc:"HTTP Client Library" module Log = (val Logs.src_log src : Logs.LOG) module Method = Method module Mime = Mime module Headers = Headers module Http_date = Http_date module Http_version = Http_version module Auth = Auth module Proxy = Proxy module Proxy_tunnel = Proxy_tunnel module Timeout = Timeout module Body = Body module Response = Response module One = One module Http_client = Http_client module Status = Status module Error = Error module Retry = Retry module Cache_control = Cache_control module Response_limits = Response_limits module Expect_continue = Expect_continue module Version = Version module Link = Link module Timing = Timing module Header_name = Header_name module Header_parsing = Header_parsing module Websocket = Websocket module Signature = Signature (** Minimum TLS version configuration - re-exported from Tls_config. *) type tls_version = Tls_config.tls_version = | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *) | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *) (* Main API - Session functionality with connection pooling *) (** Protocol hint for endpoints - remembers ALPN negotiation results. *) type protocol_hint = H1 | H2 type t = | T : { sw : Eio.Switch.t; clock : [> float Eio.Time.clock_ty ] Eio.Resource.t; net : [> [> `Generic ] Eio.Net.ty ] Eio.Resource.t; http_pool : unit Conpool.t; (** HTTP/1.x pool - exclusive access, no protocol state *) https_pool : unit Conpool.t; (** HTTPS pool - exclusive access, no protocol state *) h2_pool : H2_conpool_handler.h2_state Conpool.t; (** HTTP/2 pool - shared access with H2 client state *) protocol_hints : (string, protocol_hint) Hashtbl.t; (** Maps "host:port" to protocol hint from ALPN *) protocol_hints_mutex : Eio.Mutex.t; cookie_jar : Cookeio_jar.t; cookie_mutex : Eio.Mutex.t; default_headers : Headers.t; auth : Auth.t option; timeout : Timeout.t; follow_redirects : bool; max_redirects : int; verify_tls : bool; tls_config : Tls.Config.client option; retry : Retry.config option; persist_cookies : bool; xdg : Xdge.t option; auto_decompress : bool; expect_100_continue : Expect_continue.t; (** 100-continue configuration *) base_url : string option; (** Per Recommendation #11: Base URL for relative paths *) xsrf_cookie_name : string option; (** Per Recommendation #24: XSRF cookie name *) xsrf_header_name : string; (** Per Recommendation #24: XSRF header name *) proxy : Proxy.config option; (** HTTP/HTTPS proxy configuration *) allow_insecure_auth : bool; (** Allow auth over HTTP for dev/testing *) nonce_counter : Auth.Nonce_counter.t; (** Digest auth nonce count tracker *) (* Statistics - mutable but NOTE: when sessions are derived via record update syntax ({t with field = value}), these are copied not shared. Each derived session has independent statistics. Use the same session object to track cumulative stats. *) mutable requests_made : int; mutable total_time : float; mutable retries_count : int; } -> t let connection_pools ~sw ~net ~clock ?http_pool ?https_pool ~tls_config ~max_connections_per_host ~connection_idle_timeout ~connection_lifetime () = let pool_config = Conpool.Config.v ~max_connections_per_endpoint:max_connections_per_host ~max_idle_time:connection_idle_timeout ~max_connection_lifetime:connection_lifetime () in let http_pool = match http_pool with | Some p -> p | None -> Conpool.basic ~sw ~net ~clock ~config:pool_config () in let https_pool = match https_pool with | Some p -> p | None -> Conpool.basic ~sw ~net ~clock ?tls:tls_config ~config:pool_config () in let h2_pool = Conpool.v ~sw ~net ~clock ?tls:tls_config ~config:pool_config ~protocol:H2_conpool_handler.h2_protocol () in (http_pool, https_pool, h2_pool) let resolve_cookie_jar ~cookie_jar ~persist_cookies ~xdg ~clock = match (cookie_jar, persist_cookies, xdg) with | Some jar, _, _ -> jar | None, true, Some xdg_ctx -> let data_dir = Xdge.data_dir xdg_ctx in let cookie_file = Eio.Path.(data_dir / "cookies.txt") in Cookeio_jar.load ~clock cookie_file | None, _, _ -> Cookeio_jar.v () let normalize_base_url base_url = Option.map (fun url -> if String.length url > 0 && url.[String.length url - 1] = '/' then String.sub url 0 (String.length url - 1) else url) base_url let resolve_xdg ~xdg ~persist_cookies env_fs = match (xdg, persist_cookies) with | Some x, _ -> Some x | None, true -> Some (Xdge.v env_fs "requests") | None, false -> None let build_expect_100_config ~expect_100_continue ~timeout = let expect_100_timeout = Timeout.expect_100_continue timeout |> Option.value ~default:1.0 in Expect_continue.of_config ~timeout:expect_100_timeout expect_100_continue let session ~sw ~clock ~net ~http_pool ~https_pool ~h2_pool ~protocol_hints ~cookie_jar ~default_headers ~auth ~timeout ~follow_redirects ~max_redirects ~verify_tls ~tls_config ~retry ~persist_cookies ~xdg ~auto_decompress ~expect_100_config ~base_url ~xsrf_cookie_name ~xsrf_header_name ~proxy ~allow_insecure_auth = T { sw; clock; net; http_pool; https_pool; h2_pool; protocol_hints; protocol_hints_mutex = Eio.Mutex.create (); cookie_jar; cookie_mutex = Eio.Mutex.create (); default_headers; auth; timeout; follow_redirects; max_redirects; verify_tls; tls_config; retry; persist_cookies; xdg; auto_decompress; expect_100_continue = expect_100_config; base_url; xsrf_cookie_name; xsrf_header_name; proxy; allow_insecure_auth; nonce_counter = Auth.Nonce_counter.create (); requests_made = 0; total_time = 0.0; retries_count = 0; } let v ~sw ?http_pool ?https_pool ?cookie_jar ?(default_headers = Headers.empty) ?auth ?(timeout = Timeout.default) ?(follow_redirects = true) ?(max_redirects = 10) ?(verify_tls = true) ?tls_config ?(min_tls_version = TLS_1_2) ?(max_connections_per_host = 10) ?(connection_idle_timeout = 60.0) ?(connection_lifetime = 300.0) ?retry ?(persist_cookies = false) ?xdg ?(auto_decompress = true) ?(expect_100_continue = `Threshold Expect_continue.default_threshold) ?base_url ?(xsrf_cookie_name = Some "XSRF-TOKEN") (* Per Recommendation #24 *) ?(xsrf_header_name = "X-XSRF-TOKEN") ?proxy ?(allow_insecure_auth = false) env = Crypto_rng_unix.use_default (); (* avsm: is this bad to do twice? very common footgun to forget to initialise *) let clock = env#clock in let net = env#net in let xdg = resolve_xdg ~xdg ~persist_cookies env#fs in (* Create TLS config for HTTPS pool if needed Per Recommendation #6: Enforce minimum TLS version *) let tls_config = Tls_config.client_opt ?existing_config:tls_config ~verify_tls ~min_tls_version ~host:"session-init" () in let http_pool, https_pool, h2_pool = connection_pools ~sw ~net ~clock ?http_pool ?https_pool ~tls_config ~max_connections_per_host ~connection_idle_timeout ~connection_lifetime () in let protocol_hints = Hashtbl.create 32 in Log.info (fun m -> m "Created Requests session with connection pools (max_per_host=%d, \ TLS=%b)" max_connections_per_host (Option.is_some tls_config)); let cookie_jar = resolve_cookie_jar ~cookie_jar ~persist_cookies ~xdg ~clock in let expect_100_config = build_expect_100_config ~expect_100_continue ~timeout in let base_url = normalize_base_url base_url in session ~sw ~clock ~net ~http_pool ~https_pool ~h2_pool ~protocol_hints ~cookie_jar ~default_headers ~auth ~timeout ~follow_redirects ~max_redirects ~verify_tls ~tls_config ~retry ~persist_cookies ~xdg ~auto_decompress ~expect_100_config ~base_url ~xsrf_cookie_name ~xsrf_header_name ~proxy ~allow_insecure_auth let set_default_header (T t) key value = T { t with default_headers = Headers.set (Header_name.of_string key) value t.default_headers; } let remove_default_header (T t) key = T { t with default_headers = Headers.remove (Header_name.of_string key) t.default_headers; } let set_auth (T t) auth = Log.debug (fun m -> m "Setting authentication method"); T { t with auth = Some auth } let clear_auth (T t) = Log.debug (fun m -> m "Clearing authentication"); T { t with auth = None } let set_timeout (T t) timeout = Log.debug (fun m -> m "Setting timeout: %a" Timeout.pp timeout); T { t with timeout } let set_retry (T t) config = Log.debug (fun m -> m "Setting retry config: max_retries=%d" config.Retry.max_retries); T { t with retry = Some config } let cookies (T t) = t.cookie_jar let clear_cookies (T t) = Cookeio_jar.clear t.cookie_jar let set_proxy (T t) config = Log.debug (fun m -> m "Setting proxy: %s:%d" config.Proxy.host config.Proxy.port); T { t with proxy = Some config } let clear_proxy (T t) = Log.debug (fun m -> m "Clearing proxy configuration"); T { t with proxy = None } let proxy (T t) = t.proxy (* Redirect handling - delegated to shared Redirect module *) (** {1 URL Resolution and Path Templating} Per Recommendation #11: Base URL support with RFC 3986 resolution. Per Recommendation #29: Path parameter templating. *) (** Check if a URL is relative (no scheme) *) let is_relative_url url = let uri = Uri.of_string url in Option.is_none (Uri.scheme uri) (** Resolve a URL against a base URL per RFC 3986 Section 5. If the URL is already absolute, return it unchanged. If base_url is None, return the original URL. *) let resolve_url ?base_url url = match base_url with | None -> url | Some base -> if is_relative_url url then begin let base_uri = Uri.of_string base in let rel_uri = Uri.of_string url in let scheme = Uri.scheme base_uri |> Option.value ~default:"https" in let resolved = Uri.resolve scheme base_uri rel_uri in Log.debug (fun m -> m "Resolved relative URL %s against base %s -> %s" url base (Uri.to_string resolved)); Uri.to_string resolved end else url (* Already absolute *) (** Substitute path parameters in a URL template. Per Recommendation #29 and RFC 6570 (simplified). Template: ["/users/\{id\}/posts/\{post_id\}"] Params: [[("id", "123"); ("post_id", "456")]] Result: ["/users/123/posts/456"] Values are automatically URL-encoded. *) let substitute_path_params url params = List.fold_left (fun url (key, value) -> let pattern = "{" ^ key ^ "}" in let encoded_value = Uri.pct_encode value in let rec replace s = match String.split_on_char '{' s with | [] -> "" | [ single ] -> single | before :: rest -> let rest_str = String.concat "{" rest in if String.length rest_str >= String.length key + 1 && String.sub rest_str 0 (String.length key) = key && rest_str.[String.length key] = '}' then before ^ encoded_value ^ String.sub rest_str (String.length key + 1) (String.length rest_str - String.length key - 1) else before ^ "{" ^ replace rest_str in if String.length pattern > 0 then replace url else url) url params (** {1 XSRF Token Handling} Per Recommendation #24: Automatically inject XSRF tokens from cookies. *) (** Extract XSRF token from cookies and add to headers if: 1. xsrf_cookie_name is configured 2. The cookie exists 3. The request is same-origin (security) *) let apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url headers = match xsrf_cookie_name with | None -> headers (* XSRF handling disabled *) | Some cookie_name -> ( let uri = Uri.of_string url in let domain = Uri.host uri |> Option.value ~default:"" in let path = Uri.path uri in let is_secure = Uri.scheme uri = Some "https" in (* Get cookies for this domain *) let cookies = Cookeio_jar.cookies cookie_jar ~clock ~domain ~path ~is_secure in (* Find the XSRF token cookie *) let xsrf_value = List.find_map (fun cookie -> if Cookeio.name cookie = cookie_name then Some (Cookeio.value cookie) else None) cookies in match xsrf_value with | Some token -> Log.debug (fun m -> m "Adding XSRF token header: %s" xsrf_header_name); (* XSRF header name is configurable, use string variant *) Headers.set_string xsrf_header_name token headers | None -> headers) let h2_conn_response ~sw ~h2_pool ~endpoint ~uri ~headers ~body ~method_ ~auto_decompress = Eio.Switch.run (fun conn_sw -> let h2_conn = Conpool.connection ~sw:conn_sw h2_pool endpoint in match H2_conpool_handler.request ~state:h2_conn.Conpool.state ~uri ~headers ~body ~method_ ~auto_decompress () with | Ok resp -> (resp.H2_adapter.status, resp.H2_adapter.headers, resp.H2_adapter.body) | Error msg -> raise (Error.err (Error.Invalid_request { reason = "HTTP/2 error: " ^ msg }))) let h2_alpn_response ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress = match H2_adapter.request ~sw ~flow ~uri ~headers ~body ~method_ ~auto_decompress () with | Ok resp -> (resp.H2_adapter.status, resp.H2_adapter.headers, resp.H2_adapter.body) | Error msg -> raise (Error.err (Error.Invalid_request { reason = "HTTP/2 error: " ^ msg })) let pooled_h1_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body ~method_ ~auto_decompress ~expect_100 = Eio.Switch.run (fun conn_sw -> let conn_info = Conpool.connection ~sw:conn_sw pool endpoint in Http_client.request_100_continue_decompress ~expect_100 ~clock ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress conn_info.Conpool.flow) let pooled_with_h1_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body ~method_ ~auto_decompress ~expect_100 = Conpool.with_connection pool endpoint (fun conn -> Http_client.request_100_continue_decompress ~expect_100 ~clock ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress conn.Conpool.flow) let update_protocol_hint ~protocol_hints_mutex ~protocol_hints ~endpoint_key ~is_h2 = let hint = if is_h2 then H2 else H1 in Eio.Mutex.use_rw ~protect:true protocol_hints_mutex (fun () -> Hashtbl.replace protocol_hints endpoint_key hint); Log.debug (fun m -> m "Learned protocol for %s: %s" endpoint_key (if is_h2 then "H2" else "H1")) let alpn_detect_request ~outer_sw ~clock ~pool ~endpoint ~uri ~headers ~body ~method_ ~auto_decompress ~expect_100 ~is_https ~protocol_hints_mutex ~protocol_hints ~endpoint_key ~url = Eio.Switch.run (fun conn_sw -> let conn_info = Conpool.connection ~sw:conn_sw pool endpoint in let is_h2 = match conn_info.Conpool.tls_epoch with | Some epoch -> epoch.Tls.Core.alpn_protocol = Some "h2" | None -> false in if is_https then update_protocol_hint ~protocol_hints_mutex ~protocol_hints ~endpoint_key ~is_h2; if is_h2 then begin Log.debug (fun m -> m "Using HTTP/2 for %s (ALPN negotiated)" url); h2_alpn_response ~sw:conn_sw ~flow:conn_info.Conpool.flow ~uri ~headers ~body ~method_ ~auto_decompress end else Http_client.request_100_continue_decompress ~expect_100 ~clock ~sw:outer_sw ~method_ ~uri ~headers ~body ~auto_decompress conn_info.Conpool.flow) let proxy_http_request ~sw ~pool ~proxy_endpoint ~uri ~headers ~body ~method_ ~auto_decompress ~proxy_auth = Conpool.with_connection pool proxy_endpoint (fun conn -> Http_write.write_and_flush conn.Conpool.flow (fun w -> Http_write.request_via_proxy w ~sw ~method_ ~uri ~headers ~body ~proxy_auth); let limits = Response_limits.default in let buf_read = Http_read.of_flow ~max_size:65536 conn.Conpool.flow in let _version, status, resp_headers, body_str = Http_read.response ~limits ~method_ buf_read in let body_str = match (auto_decompress, Headers.find `Content_encoding resp_headers) with | true, Some encoding -> Http_client.decompress_body ~limits ~content_encoding:encoding body_str | _ -> body_str in (status, resp_headers, body_str)) let build_request_headers ~default_headers ~cookie_mutex ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~default_auth ~allow_insecure_auth ~auto_decompress ~headers ~auth ~body ~url = let headers = match headers with | Some h -> Headers.merge default_headers h | None -> default_headers in let headers = if not (Headers.mem `User_agent headers) then Headers.set `User_agent Version.user_agent headers else headers in let headers = Eio.Mutex.use_ro cookie_mutex (fun () -> apply_xsrf_token ~cookie_jar ~clock ~xsrf_cookie_name ~xsrf_header_name ~url headers) in let auth = match auth with Some a -> Some a | None -> default_auth in let headers = match auth with | Some a -> Log.debug (fun m -> m "Applying authentication"); Auth.apply_secure ~allow_insecure_auth ~url a headers | None -> headers in let headers = match body with | Some b -> ( match Body.content_type b with | Some mime -> Headers.content_type mime headers | None -> headers) | None -> headers in let headers = if auto_decompress && not (Headers.mem `Accept_encoding headers) then Headers.set `Accept_encoding "gzip, deflate" headers else headers in (auth, headers) let extract_url_components uri_to_fetch url_to_fetch = let redirect_host = match Uri.host uri_to_fetch with | Some h -> h | None -> raise (Error.err (Error.Invalid_redirect { url = url_to_fetch; reason = "URL must contain a host" })) in let redirect_port = match (Uri.scheme uri_to_fetch, Uri.port uri_to_fetch) with | Some "https", None -> 443 | Some "https", Some p -> p | Some "http", None -> 80 | Some "http", Some p -> p | _, Some p -> p | _ -> 80 in let redirect_is_https = match Uri.scheme uri_to_fetch with Some "https" -> true | _ -> false in (redirect_host, redirect_port, redirect_is_https) let add_cookies_to_headers ~cookie_mutex ~cookie_jar ~clock ~headers_for_request ~host ~path ~is_secure = Eio.Mutex.use_ro cookie_mutex (fun () -> let cookies = Cookeio_jar.cookies cookie_jar ~clock ~domain:host ~path ~is_secure in match cookies with | [] -> Log.debug (fun m -> m "No cookies found for %s%s" host path); headers_for_request | cookies -> let cookie_header = Cookeio.cookie_header cookies in let cookie_summary = cookies |> List.map (fun c -> Fmt.str "%s=<%d chars>" (Cookeio.name c) (String.length (Cookeio.value c))) |> String.concat "; " in Log.debug (fun m -> m "Adding %d cookies for %s%s: [%s]" (List.length cookies) host path cookie_summary); Headers.set `Cookie cookie_header headers_for_request) (* Extract and store Set-Cookie headers from a response into the session cookie jar. *) let store_response_cookies (T t) ~resp_headers ~url_str = let uri = Uri.of_string url_str in let cookie_domain = Uri.host uri |> Option.value ~default:"" in let cookie_path = Uri.path uri in Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () -> match Headers.all `Set_cookie resp_headers with | [] -> () | cookie_headers -> Log.debug (fun m -> m "Received %d Set-Cookie headers" (List.length cookie_headers)); List.iter (fun cookie_str -> let now = fun () -> Ptime.of_float_s (Eio.Time.now t.clock) |> Option.get in match Cookeio.of_set_cookie_header ~now ~domain:cookie_domain ~path:cookie_path cookie_str with | Ok cookie -> Log.debug (fun m -> m "Storing cookie: %s" (Cookeio.name cookie)); Cookeio_jar.add_cookie t.cookie_jar cookie | Error msg -> let redacted = match String.index_opt cookie_str '=' with | Some i -> String.sub cookie_str 0 i ^ "=" | None -> "" in Log.warn (fun m -> m "Failed to parse cookie: %s (%s)" redacted msg)) cookie_headers) (* Dispatch a request using ALPN negotiation to detect H1/H2 protocol. *) let dispatch_alpn (T t) ~redirect_is_https ~redirect_pool ~redirect_endpoint ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ () = alpn_detect_request ~outer_sw:t.sw ~clock:t.clock ~pool:redirect_pool ~endpoint:redirect_endpoint ~uri:uri_to_fetch ~headers ~body ~method_ ~auto_decompress:t.auto_decompress ~expect_100:t.expect_100_continue ~is_https:redirect_is_https ~protocol_hints_mutex:t.protocol_hints_mutex ~protocol_hints:t.protocol_hints ~endpoint_key ~url:(Uri.to_string uri_to_fetch) let proxy_auth_header proxy = match proxy.Proxy.auth with | Some auth -> let auth_headers = Auth.apply auth Headers.empty in Headers.find `Authorization auth_headers | None -> None (* Dispatch a single HTTP request to the appropriate transport based on proxy settings, protocol hints, and whether the target is HTTPS. *) let dispatch_request (T t) ~use_proxy ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint () = match (use_proxy, redirect_is_https, t.proxy, protocol_hint) with | false, true, _, Some H2 -> (* Known HTTP/2 - use h2_pool with shared connections *) Log.debug (fun m -> m "Using HTTP/2 for %s (from protocol hint)" (Uri.to_string uri_to_fetch)); h2_conn_response ~sw:t.sw ~h2_pool:t.h2_pool ~endpoint:redirect_endpoint ~uri:uri_to_fetch ~headers ~body ~method_ ~auto_decompress:t.auto_decompress | false, true, _, Some H1 -> Log.debug (fun m -> m "Using HTTP/1.1 for %s (from protocol hint)" (Uri.to_string uri_to_fetch)); pooled_h1_request ~outer_sw:t.sw ~clock:t.clock ~pool:redirect_pool ~endpoint:redirect_endpoint ~uri:uri_to_fetch ~headers ~body ~method_ ~auto_decompress:t.auto_decompress ~expect_100:t.expect_100_continue | false, _, _, _ -> dispatch_alpn (T t) ~redirect_is_https ~redirect_pool ~redirect_endpoint ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ () | true, false, Some proxy, _ -> (* HTTP via proxy - connect to proxy and use absolute-URI form *) Log.debug (fun m -> m "Routing HTTP request via proxy %s:%d" proxy.Proxy.host proxy.Proxy.port); let proxy_endpoint = Conpool.Endpoint.v ~host:proxy.Proxy.host ~port:proxy.Proxy.port in (* Convert Auth.t to header value string *) let proxy_auth = proxy_auth_header proxy in proxy_http_request ~sw:t.sw ~pool:t.http_pool ~proxy_endpoint ~uri:uri_to_fetch ~headers ~body ~method_ ~auto_decompress:t.auto_decompress ~proxy_auth | true, true, Some proxy, _ -> (* HTTPS via proxy - establish CONNECT tunnel then TLS *) Log.debug (fun m -> m "Routing HTTPS request via proxy %s:%d (CONNECT tunnel)" proxy.Proxy.host proxy.Proxy.port); (* Establish TLS tunnel through proxy *) let tunnel_flow = Proxy_tunnel.connect_with_tls ~sw:t.sw ~net:t.net ~clock:t.clock ~proxy ~target_host:redirect_host ~target_port:redirect_port ?tls_config:t.tls_config () in (* Send request through tunnel using normal format (not absolute-URI) *) Http_client.request_100_continue_decompress ~expect_100:t.expect_100_continue ~clock:t.clock ~sw:t.sw ~method_ ~uri:uri_to_fetch ~headers ~body ~auto_decompress:t.auto_decompress tunnel_flow | true, _, None, _ -> (* Should not happen due to use_proxy check *) Conpool.with_connection redirect_pool redirect_endpoint (fun conn -> Http_client.request_100_continue_decompress ~expect_100:t.expect_100_continue ~clock:t.clock ~sw:t.sw ~method_ ~uri:uri_to_fetch ~headers ~body ~auto_decompress:t.auto_decompress conn.Conpool.flow) let log_request_headers ~method_str ~uri ~headers = Log.info (fun m -> m ""); Log.info (fun m -> m "=== Request to %s ===" (Uri.to_string uri)); Log.info (fun m -> m "> %s %s HTTP/1.1" method_str (Uri.to_string uri)); Log.info (fun m -> m "> Request Headers:"); Headers.to_list headers |> List.iter (fun (k, v) -> let v = if Error.is_sensitive_header k then Fmt.str "" (String.length v) else v in Log.info (fun m -> m "> %s: %s" k v)); Log.info (fun m -> m "") let log_response_headers ~status ~resp_headers = Log.info (fun m -> m "< HTTP/1.1 %d" status); Log.info (fun m -> m "< Response Headers:"); Headers.to_list resp_headers |> List.iter (fun (k, v) -> let v = if Error.is_sensitive_header k then Fmt.str "" (String.length v) else v in Log.info (fun m -> m "< %s: %s" k v)); Log.info (fun m -> m "") let execute_request_with_timeout (T t as wrapped_t) ~use_proxy ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint ~timeout = let timeout_val = Option.value timeout ~default:t.timeout in match Timeout.total timeout_val with | Some seconds -> Log.debug (fun m -> m "Setting timeout: %.2f seconds" seconds); Eio.Time.with_timeout_exn t.clock seconds (dispatch_request wrapped_t ~use_proxy ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint) | None -> dispatch_request wrapped_t ~use_proxy ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch ~headers ~body ~method_ ~protocol_hint () let resolve_absolute_location ~base_uri location = let location_uri = Uri.of_string location in match Uri.host location_uri with | Some _ -> location | None -> let scheme = Option.value (Uri.scheme base_uri) ~default:"http" in let resolved = Uri.resolve scheme base_uri location_uri in Uri.to_string resolved let redirect_headers_for_origin ~original_uri ~redirect_uri headers = if Redirect.same_origin original_uri redirect_uri then headers else begin Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers"); Redirect.strip_sensitive_headers headers end let rec handle_redirect_or_return wrapped_t ~original_url ~original_uri ~follow_redirects ~max_redirects ~timeout ~headers_for_request ~method_ ~body ~url_to_fetch ~uri_to_fetch ~redirects_left status resp_headers response_body_str = let (T t) = wrapped_t in let follow = Option.value follow_redirects ~default:t.follow_redirects in let max_redir = Option.value max_redirects ~default:t.max_redirects in if follow && status >= 300 && status < 400 then begin if redirects_left <= 0 then begin Log.err (fun m -> m "Too many redirects (%d) for %s" max_redir original_url); raise (Error.err (Error.Too_many_redirects { url = original_url; count = max_redir; max = max_redir })) end; match Headers.find `Location resp_headers with | None -> Log.debug (fun m -> m "Redirect response missing Location header"); (status, resp_headers, response_body_str, url_to_fetch) | Some location -> let _ = Redirect.validate_url location in let absolute_location = resolve_absolute_location ~base_uri:uri_to_fetch location in Log.info (fun m -> m "Following redirect to %s (%d remaining)" absolute_location redirects_left); let redirect_uri = Uri.of_string absolute_location in let headers_for_redirect = redirect_headers_for_origin ~original_uri ~redirect_uri headers_for_request in let redirect_method, redirect_body = if status = 303 then begin match method_ with | `POST | `PUT | `DELETE | `PATCH -> Log.debug (fun m -> m "303 redirect: changing %s to GET and stripping body" (Method.to_string method_)); (`GET, Body.empty) | _ -> (method_, body) end else (method_, body) in with_redirects wrapped_t ~original_url ~follow_redirects ~max_redirects ~timeout ~headers_for_request:headers_for_redirect ~method_:redirect_method ~body:redirect_body absolute_location (redirects_left - 1) end else (status, resp_headers, response_body_str, url_to_fetch) (* Execute request with redirect handling. headers_for_request: headers for this request (may have auth stripped) method_: HTTP method (may be changed by 303 redirect) body: request body (may be stripped by 303 redirect) *) and with_redirects (T t as wrapped_t) ~original_url ~follow_redirects ~max_redirects ~timeout ~headers_for_request ~method_ ~body url_to_fetch redirects_left = let method_str = Method.to_string method_ in let uri_to_fetch = Uri.of_string url_to_fetch in let original_uri = Uri.of_string original_url in let redirect_host, redirect_port, redirect_is_https = extract_url_components uri_to_fetch url_to_fetch in let redirect_endpoint = Conpool.Endpoint.v ~host:redirect_host ~port:redirect_port in let redirect_pool = if redirect_is_https then t.https_pool else t.http_pool in let headers_with_cookies = add_cookies_to_headers ~cookie_mutex:t.cookie_mutex ~cookie_jar:t.cookie_jar ~clock:t.clock ~headers_for_request ~host:redirect_host ~path:(Uri.path uri_to_fetch) ~is_secure:redirect_is_https in log_request_headers ~method_str ~uri:uri_to_fetch ~headers:headers_with_cookies; let use_proxy = match t.proxy with | None -> false | Some proxy -> not (Proxy.should_bypass proxy url_to_fetch) in let endpoint_key = Fmt.str "%s:%d" redirect_host redirect_port in let protocol_hint = Eio.Mutex.use_ro t.protocol_hints_mutex (fun () -> Hashtbl.find_opt t.protocol_hints endpoint_key) in let status, resp_headers, response_body_str = execute_request_with_timeout wrapped_t ~use_proxy ~redirect_is_https ~redirect_pool ~redirect_endpoint ~redirect_host ~redirect_port ~endpoint_key ~uri_to_fetch ~headers:headers_with_cookies ~body ~method_ ~protocol_hint ~timeout in log_response_headers ~status ~resp_headers; store_response_cookies wrapped_t ~resp_headers ~url_str:url_to_fetch; handle_redirect_or_return wrapped_t ~original_url ~original_uri ~follow_redirects ~max_redirects ~timeout ~headers_for_request ~method_ ~body ~url_to_fetch ~uri_to_fetch ~redirects_left status resp_headers response_body_str let apply_signature_auth ~clock ~method_ ~uri ~headers auth = match auth with | Some a when Auth.is_signature a -> Auth.apply_signature ~clock ~method_ ~uri ~headers a | _ -> headers let persist_cookies_if_needed (T t) = match (t.persist_cookies, t.xdg) with | true, Some xdg_ctx -> let data_dir = Xdge.data_dir xdg_ctx in let cookie_file = Eio.Path.(data_dir / "cookies.txt") in Eio.Mutex.use_rw ~protect:true t.cookie_mutex (fun () -> Cookeio_jar.save cookie_file t.cookie_jar; Log.debug (fun m -> m "Saved cookies to %a" Eio.Path.pp cookie_file)) | _ -> () (* Internal request function using connection pools *) let request_internal (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ?(path_params = []) ~method_ url = let start_time = Unix.gettimeofday () in let url = if path_params = [] then url else substitute_path_params url path_params in let url = resolve_url ?base_url:t.base_url url in Log.info (fun m -> m "Making %s request to %s" (Method.to_string method_) url); let auth, base_headers = build_request_headers ~default_headers:t.default_headers ~cookie_mutex:t.cookie_mutex ~cookie_jar:t.cookie_jar ~clock:t.clock ~xsrf_cookie_name:t.xsrf_cookie_name ~xsrf_header_name:t.xsrf_header_name ~default_auth:t.auth ~allow_insecure_auth:t.allow_insecure_auth ~auto_decompress:t.auto_decompress ~headers ~auth ~body ~url in let request_body = Option.value ~default:Body.empty body in let original_uri = Uri.of_string url in let max_redir = Option.value max_redirects ~default:t.max_redirects in let signed_headers = apply_signature_auth ~clock:t.clock ~method_ ~uri:original_uri ~headers:base_headers auth in let final_status, final_headers, final_body_str, final_url = with_redirects wrapped_t ~original_url:url ~follow_redirects ~max_redirects ~timeout ~headers_for_request:signed_headers ~method_ ~body:request_body url max_redir in let elapsed = Unix.gettimeofday () -. start_time in Log.info (fun m -> m "Request completed in %.3f seconds" elapsed); let body_flow = Eio.Flow.string_source final_body_str in let response = Response.Private.make ~sw:t.sw ~status:final_status ~headers:final_headers ~body:body_flow ~url:final_url ~elapsed in t.requests_made <- t.requests_made + 1; t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time); Log.info (fun m -> m "Request completed with status %d" (Response.status_code response)); persist_cookies_if_needed wrapped_t; response let build_digest_auth_header ~nonce_counter ~username ~password ~method_ ~uri ~challenge ~auth_header_name base_headers = let auth_value = Auth.apply_digest ~nonce_counter ~username ~password ~method_:(Method.to_string method_) ~uri ~challenge Headers.empty in match Headers.find `Authorization auth_value with | Some v -> Headers.set auth_header_name v base_headers | None -> base_headers (* Helper to handle Digest authentication challenges (401 and 407). Per RFC 7235: 401 uses WWW-Authenticate/Authorization headers, 407 uses Proxy-Authenticate/Proxy-Authorization headers. *) let digest_header_names status = let challenge_header : Header_name.t = if status = 401 then `Www_authenticate else `Proxy_authenticate in let auth_header_name : Header_name.t = if status = 401 then `Authorization else `Proxy_authorization in (challenge_header, auth_header_name) let handle_digest_auth (T t as wrapped_t) ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response = let status = Response.status_code response in let auth_to_use = match auth with | Some a -> a | None -> Option.value t.auth ~default:Auth.none in let is_auth_challenge = (status = 401 || status = 407) && Auth.is_digest auth_to_use in if is_auth_challenge then begin match Auth.digest_credentials auth_to_use with | Some (username, password) -> ( let challenge_header, auth_header_name = digest_header_names status in match Response.header challenge_header response with | Some www_auth -> ( match Auth.parse_www_authenticate www_auth with | Some challenge -> Log.info (fun m -> m "Received %s challenge (status %d), retrying with \ authentication" (if status = 401 then "Digest" else "Proxy Digest") status); let uri_path = let p = Uri.path (Uri.of_string url) in if p = "" then "/" else p in let base_headers = Option.value headers ~default:Headers.empty in let auth_headers = build_digest_auth_header ~nonce_counter:t.nonce_counter ~username ~password ~method_ ~uri:uri_path ~challenge ~auth_header_name base_headers in request_internal wrapped_t ~headers:auth_headers ?body ~auth:Auth.none ?timeout ?follow_redirects ?max_redirects ~method_ url | None -> Log.warn (fun m -> m "Could not parse Digest challenge from %s" (Header_name.to_string challenge_header)); response) | None -> Log.warn (fun m -> m "%d response has no %s header" status (Header_name.to_string challenge_header)); response) | None -> response end else response let compute_retry_delay ~retry_config ~status ~response ~attempt = if retry_config.Retry.respect_retry_after && (status = 429 || status = 503) then match Response.header `Retry_after response with | Some value -> Retry.parse_retry_after value |> Option.value ~default:(Retry.calculate_backoff ~config:retry_config ~attempt) | None -> Retry.calculate_backoff ~config:retry_config ~attempt else Retry.calculate_backoff ~config:retry_config ~attempt let should_retry_exn = function | Eio.Io (Error.E e, _) -> Error.is_retryable e | Eio.Time.Timeout -> true | _ -> false let retry_after_delay (T t) ~retry_config ~delay ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~with_digest_handling ~attempt ~recurse = Eio.Time.sleep t.clock delay; t.retries_count <- t.retries_count + 1; recurse ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~retry_config ~with_digest_handling (attempt + 1) let rec attempt_request (T t as wrapped_t) ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~retry_config ~with_digest_handling attempt = if attempt > 1 then Log.info (fun m -> m "Retry attempt %d/%d for %s %s" attempt (retry_config.Retry.max_retries + 1) (Method.to_string method_) url); let retry ~delay = retry_after_delay wrapped_t ~retry_config ~delay ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~with_digest_handling ~attempt ~recurse:(attempt_request wrapped_t) in try let response = request_internal wrapped_t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~path_params ~method_ url in let response = with_digest_handling response in let status = Response.status_code response in if attempt <= retry_config.Retry.max_retries && Retry.should_retry ~config:retry_config ~method_ ~status then begin let delay = compute_retry_delay ~retry_config ~status ~response ~attempt in Log.warn (fun m -> m "Request returned status %d (attempt %d/%d). Retrying in %.2f \ seconds..." status attempt (retry_config.Retry.max_retries + 1) delay); retry ~delay end else response with | exn when attempt <= retry_config.Retry.max_retries && should_retry_exn exn -> let delay = Retry.calculate_backoff ~config:retry_config ~attempt in Log.warn (fun m -> m "Request failed (attempt %d/%d): %s. Retrying in %.2f seconds..." attempt (retry_config.Retry.max_retries + 1) (Printexc.to_string exn) delay); retry ~delay (* Public request function - executes synchronously with retry support *) let request (T t as wrapped_t) ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ?(path_params = []) ~method_ url = let with_digest_handling response = handle_digest_auth wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~method_ ~url response in match t.retry with | None -> let response = request_internal wrapped_t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~path_params ~method_ url in with_digest_handling response | Some retry_config -> attempt_request wrapped_t ~headers ~body ~auth ~timeout ~follow_redirects ~max_redirects ~path_params ~method_ ~url ~retry_config ~with_digest_handling 1 (* Convenience methods *) let get t ?headers ?auth ?timeout ?params ?(path_params = []) url = let url = match params with | Some p -> let uri = Uri.of_string url in let uri = List.fold_left (fun u (k, v) -> Uri.add_query_param' u (k, v)) uri p in Uri.to_string uri | None -> url in request t ?headers ?auth ?timeout ~path_params ~method_:`GET url let post t ?headers ?body ?auth ?timeout ?(path_params = []) url = request t ?headers ?body ?auth ?timeout ~path_params ~method_:`POST url let put t ?headers ?body ?auth ?timeout ?(path_params = []) url = request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PUT url let patch t ?headers ?body ?auth ?timeout ?(path_params = []) url = request t ?headers ?body ?auth ?timeout ~path_params ~method_:`PATCH url let delete t ?headers ?auth ?timeout ?(path_params = []) url = request t ?headers ?auth ?timeout ~path_params ~method_:`DELETE url let head t ?headers ?auth ?timeout ?(path_params = []) url = request t ?headers ?auth ?timeout ~path_params ~method_:`HEAD url let options t ?headers ?auth ?timeout ?(path_params = []) url = request t ?headers ?auth ?timeout ~path_params ~method_:`OPTIONS url (* Cmdliner integration module *) module Cmd = struct open Cmdliner (** Source tracking for configuration values. Tracks where each configuration value came from for debugging and transparency. *) type source = | Default (** Value from hardcoded default *) | Env of string (** Value from environment variable (stores var name) *) | Cmdline (** Value from command-line argument *) type 'a with_source = { value : 'a; source : source } (** Wrapper for values with source tracking *) type proxy_config = { proxy_url : string with_source option; (** Proxy URL (from HTTP_PROXY/HTTPS_PROXY/etc) *) no_proxy : string with_source option; (** NO_PROXY patterns *) } (** Proxy configuration from command line and environment *) type config = { xdg : Xdge.t * Xdge.Cmd.t; persist_cookies : bool with_source; verify_tls : bool with_source; timeout : float option with_source; max_retries : int with_source; retry_backoff : float with_source; follow_redirects : bool with_source; max_redirects : int with_source; user_agent : string option with_source; verbose_http : bool with_source; proxy : proxy_config; } (** Helper to check environment variable and track source *) let check_env_bool ~app_name ~suffix ~default = let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in match Sys.getenv_opt env_var with | Some v when String.lowercase_ascii v = "1" || String.lowercase_ascii v = "true" -> { value = true; source = Env env_var } | Some v when String.lowercase_ascii v = "0" || String.lowercase_ascii v = "false" -> { value = false; source = Env env_var } | Some _ | None -> { value = default; source = Default } let check_env_string ~app_name ~suffix = let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in match Sys.getenv_opt env_var with | Some v when v <> "" -> Some { value = v; source = Env env_var } | Some _ | None -> None let check_env_float ~app_name ~suffix ~default = let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in match Sys.getenv_opt env_var with | Some v -> ( try { value = float_of_string v; source = Env env_var } with Failure _ -> { value = default; source = Default }) | None -> { value = default; source = Default } let check_env_int ~app_name ~suffix ~default = let env_var = String.uppercase_ascii app_name ^ "_" ^ suffix in match Sys.getenv_opt env_var with | Some v -> ( try { value = int_of_string v; source = Env env_var } with Failure _ -> { value = default; source = Default }) | None -> { value = default; source = Default } (** Parse proxy configuration from environment. Follows standard HTTP_PROXY/HTTPS_PROXY/ALL_PROXY/NO_PROXY conventions. *) let proxy_from_env () = let check_env var = match Sys.getenv_opt var with | Some v when v <> "" -> Some { value = v; source = Env var } | _ -> None in let proxy_url = List.find_map check_env [ "HTTP_PROXY"; "http_proxy"; "HTTPS_PROXY"; "https_proxy"; "ALL_PROXY"; "all_proxy"; ] in let no_proxy = List.find_map check_env [ "NO_PROXY"; "no_proxy" ] in { proxy_url; no_proxy } let v config env sw = let xdg, _xdg_cmd = config.xdg in let retry = if config.max_retries.value > 0 then Some (Retry.config ~max_retries:config.max_retries.value ~backoff_factor:config.retry_backoff.value ()) else None in let timeout = match config.timeout.value with | Some t -> Timeout.v ~total:t () | None -> Timeout.default in (* Build proxy config if URL is set *) let proxy = match config.proxy.proxy_url with | Some { value = url; _ } -> let no_proxy = match config.proxy.no_proxy with | Some { value = np; _ } -> np |> String.split_on_char ',' |> List.map String.trim |> List.filter (fun s -> s <> "") | None -> [] in (* Parse proxy URL to extract components *) let uri = Uri.of_string url in let host = Uri.host uri |> Option.value ~default:"localhost" in let port = Uri.port uri |> Option.value ~default:8080 in let auth = match Uri.userinfo uri with | Some info -> ( match String.index_opt info ':' with | Some idx -> let username = String.sub info 0 idx in let password = String.sub info (idx + 1) (String.length info - idx - 1) in Some (Auth.basic ~username ~password) | None -> Some (Auth.basic ~username:info ~password:"")) | None -> None in Some (Proxy.http ~port ?auth ~no_proxy host) | None -> None in let req = v ~sw ~xdg ~persist_cookies:config.persist_cookies.value ~verify_tls:config.verify_tls.value ~timeout ?retry ~follow_redirects:config.follow_redirects.value ~max_redirects:config.max_redirects.value ?proxy env in (* Set user agent if provided *) let req = match config.user_agent.value with | Some ua -> set_default_header req "User-Agent" ua | None -> req in req (* Individual terms - parameterized by app_name These terms return with_source wrapped values to track provenance *) let persist_cookies_term app_name = let doc = "Persist cookies to disk between sessions" in let env_name = String.uppercase_ascii app_name ^ "_PERSIST_COOKIES" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.(value & flag & info [ "persist-cookies" ] ~env:env_info ~doc) in Term.( const (fun cmdline -> if cmdline then { value = true; source = Cmdline } else check_env_bool ~app_name ~suffix:"PERSIST_COOKIES" ~default:false) $ cmdline_arg) let verify_tls_term app_name = let doc = "Skip TLS certificate verification (insecure)" in let env_name = String.uppercase_ascii app_name ^ "_NO_VERIFY_TLS" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.(value & flag & info [ "no-verify-tls" ] ~env:env_info ~doc) in Term.( const (fun no_verify -> if no_verify then { value = false; source = Cmdline } else let env_val = check_env_bool ~app_name ~suffix:"NO_VERIFY_TLS" ~default:false in { value = not env_val.value; source = env_val.source }) $ cmdline_arg) let timeout_term app_name = let doc = "Request timeout in seconds" in let env_name = String.uppercase_ascii app_name ^ "_TIMEOUT" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.( value & opt (some float) None & info [ "timeout" ] ~env:env_info ~docv:"SECONDS" ~doc) in Term.( const (fun cmdline -> match cmdline with | Some t -> { value = Some t; source = Cmdline } | None -> ( match check_env_string ~app_name ~suffix:"TIMEOUT" with | Some { value = v; source } -> ( try { value = Some (float_of_string v); source } with Failure _ -> { value = None; source = Default }) | None -> { value = None; source = Default })) $ cmdline_arg) let retries_term app_name = let doc = "Maximum number of request retries" in let env_name = String.uppercase_ascii app_name ^ "_MAX_RETRIES" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.( value & opt (some int) None & info [ "max-retries" ] ~env:env_info ~docv:"N" ~doc) in Term.( const (fun cmdline -> match cmdline with | Some n -> { value = n; source = Cmdline } | None -> check_env_int ~app_name ~suffix:"MAX_RETRIES" ~default:3) $ cmdline_arg) let retry_backoff_term app_name = let doc = "Retry backoff factor for exponential delay" in let env_name = String.uppercase_ascii app_name ^ "_RETRY_BACKOFF" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.( value & opt (some float) None & info [ "retry-backoff" ] ~env:env_info ~docv:"FACTOR" ~doc) in Term.( const (fun cmdline -> match cmdline with | Some f -> { value = f; source = Cmdline } | None -> check_env_float ~app_name ~suffix:"RETRY_BACKOFF" ~default:0.3) $ cmdline_arg) let follow_redirects_term app_name = let doc = "Don't follow HTTP redirects" in let env_name = String.uppercase_ascii app_name ^ "_NO_FOLLOW_REDIRECTS" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.(value & flag & info [ "no-follow-redirects" ] ~env:env_info ~doc) in Term.( const (fun no_follow -> if no_follow then { value = false; source = Cmdline } else let env_val = check_env_bool ~app_name ~suffix:"NO_FOLLOW_REDIRECTS" ~default:false in { value = not env_val.value; source = env_val.source }) $ cmdline_arg) let max_redirects_term app_name = let doc = "Maximum number of redirects to follow" in let env_name = String.uppercase_ascii app_name ^ "_MAX_REDIRECTS" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.( value & opt (some int) None & info [ "max-redirects" ] ~env:env_info ~docv:"N" ~doc) in Term.( const (fun cmdline -> match cmdline with | Some n -> { value = n; source = Cmdline } | None -> check_env_int ~app_name ~suffix:"MAX_REDIRECTS" ~default:10) $ cmdline_arg) let user_agent_term app_name = let doc = "User-Agent header to send with requests" in let env_name = String.uppercase_ascii app_name ^ "_USER_AGENT" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.( value & opt (some string) None & info [ "user-agent" ] ~env:env_info ~docv:"STRING" ~doc) in Term.( const (fun cmdline -> match cmdline with | Some ua -> { value = Some ua; source = Cmdline } | None -> ( match check_env_string ~app_name ~suffix:"USER_AGENT" with | Some { value; source } -> { value = Some value; source } | None -> { value = None; source = Default })) $ cmdline_arg) let verbose_http_term app_name = let doc = "Enable verbose HTTP-level logging (hexdumps, TLS details)" in let env_name = String.uppercase_ascii app_name ^ "_VERBOSE_HTTP" in let env_info = Cmdliner.Cmd.Env.info env_name in let cmdline_arg = Arg.(value & flag & info [ "verbose-http" ] ~env:env_info ~doc) in Term.( const (fun cmdline -> if cmdline then { value = true; source = Cmdline } else check_env_bool ~app_name ~suffix:"VERBOSE_HTTP" ~default:false) $ cmdline_arg) let proxy_term _app_name = let doc = "HTTP/HTTPS proxy URL (e.g., http://proxy:8080)" in let cmdline_arg = Arg.(value & opt (some string) None & info [ "proxy" ] ~docv:"URL" ~doc) in let no_proxy_doc = "Comma-separated list of hosts to bypass proxy" in let no_proxy_arg = Arg.( value & opt (some string) None & info [ "no-proxy" ] ~docv:"HOSTS" ~doc:no_proxy_doc) in Term.( const (fun cmdline_proxy cmdline_no_proxy -> let proxy_url = match cmdline_proxy with | Some url -> Some { value = url; source = Cmdline } | None -> (proxy_from_env ()).proxy_url in let no_proxy = match cmdline_no_proxy with | Some np -> Some { value = np; source = Cmdline } | None -> (proxy_from_env ()).no_proxy in { proxy_url; no_proxy }) $ cmdline_arg $ no_proxy_arg) (* Combined terms *) let config_term app_name fs = let xdg_term = Xdge.Cmd.term app_name fs ~dirs:[ `Config; `Data; `Cache ] () in Term.( const (fun xdg persist verify timeout retries backoff follow max_redir ua verbose proxy -> { xdg; persist_cookies = persist; verify_tls = verify; timeout; max_retries = retries; retry_backoff = backoff; follow_redirects = follow; max_redirects = max_redir; user_agent = ua; verbose_http = verbose; proxy; }) $ xdg_term $ persist_cookies_term app_name $ verify_tls_term app_name $ timeout_term app_name $ retries_term app_name $ retry_backoff_term app_name $ follow_redirects_term app_name $ max_redirects_term app_name $ user_agent_term app_name $ verbose_http_term app_name $ proxy_term app_name) let requests_term app_name eio_env sw = let config_t = config_term app_name eio_env#fs in Term.(const (fun config -> v config eio_env sw) $ config_t) let minimal_term app_name fs = let xdg_term = Xdge.Cmd.term app_name fs ~dirs:[ `Data; `Cache ] () in Term.( const (fun (xdg, _xdg_cmd) persist -> (xdg, persist.value)) $ xdg_term $ persist_cookies_term app_name) let env_docs app_name = let app_upper = String.uppercase_ascii app_name in Fmt.str "## ENVIRONMENT\n\n\ The following environment variables affect %s:\n\n\ ### XDG Directories\n\n\ **%s_CONFIG_DIR**\n\ : Override configuration directory location\n\n\ **%s_DATA_DIR**\n\ : Override data directory location (for cookies)\n\n\ **%s_CACHE_DIR**\n\ : Override cache directory location\n\n\ **XDG_CONFIG_HOME**\n\ : Base directory for user configuration files (default: ~/.config)\n\n\ **XDG_DATA_HOME**\n\ : Base directory for user data files (default: ~/.local/share)\n\n\ **XDG_CACHE_HOME**\n\ : Base directory for user cache files (default: ~/.cache)\n\n\ ### HTTP Settings\n\n\ **%s_PERSIST_COOKIES**\n\ : Set to '1' to persist cookies by default\n\n\ **%s_NO_VERIFY_TLS**\n\ : Set to '1' to disable TLS verification (insecure)\n\n\ **%s_TIMEOUT**\n\ : Default request timeout in seconds\n\n\ **%s_MAX_RETRIES**\n\ : Maximum number of retries (default: 3)\n\n\ **%s_RETRY_BACKOFF**\n\ : Retry backoff factor (default: 0.3)\n\n\ **%s_NO_FOLLOW_REDIRECTS**\n\ : Set to '1' to disable redirect following\n\n\ **%s_MAX_REDIRECTS**\n\ : Maximum redirects to follow (default: 10)\n\n\ **%s_USER_AGENT**\n\ : User-Agent header to send with requests\n\n\ **%s_VERBOSE_HTTP**\n\ : Set to '1' to enable verbose HTTP-level logging\n\n\ ### Proxy Configuration\n\n\ **HTTP_PROXY** / **http_proxy**\n\ : HTTP proxy URL (e.g., http://proxy:8080 or \ http://user:pass@proxy:8080)\n\n\ **HTTPS_PROXY** / **https_proxy**\n\ : HTTPS proxy URL (used for HTTPS requests)\n\n\ **ALL_PROXY** / **all_proxy**\n\ : Fallback proxy URL for all protocols\n\n\ **NO_PROXY** / **no_proxy**\n\ : Comma-separated list of hosts to bypass proxy (e.g., \ localhost,*.example.com)" app_name app_upper app_upper app_upper app_upper app_upper app_upper app_upper app_upper app_upper app_upper app_upper app_upper (** Pretty-print source type *) let pp_source ppf = function | Default -> Fmt.pf ppf "default" | Env var -> Fmt.pf ppf "env(%s)" var | Cmdline -> Fmt.pf ppf "cmdline" (** Pretty-print a value with its source *) let pp_with_source pp_val ppf ws = Fmt.pf ppf "%a [%a]" pp_val ws.value pp_source ws.source let pp_config ?(show_sources = true) ppf config = let _xdg, xdg_cmd = config.xdg in let pp_bool = Fmt.bool in let pp_float = Fmt.float in let pp_int = Fmt.int in let pp_string_opt = Fmt.option Fmt.string in let pp_float_opt = Fmt.option Fmt.float in let pp_val pp = if show_sources then pp_with_source pp else fun ppf ws -> pp ppf ws.value in Fmt.pf ppf "@[Configuration:@,\ @[XDG:@,\ %a@]@,\ persist_cookies: %a@,\ verify_tls: %a@,\ timeout: %a@,\ max_retries: %a@,\ retry_backoff: %a@,\ follow_redirects: %a@,\ max_redirects: %a@,\ user_agent: %a@,\ verbose_http: %a@,\ @[Proxy:@,\ url: %a@,\ no_proxy: %a@]@]" Xdge.Cmd.pp xdg_cmd (pp_val pp_bool) config.persist_cookies (pp_val pp_bool) config.verify_tls (pp_val pp_float_opt) config.timeout (pp_val pp_int) config.max_retries (pp_val pp_float) config.retry_backoff (pp_val pp_bool) config.follow_redirects (pp_val pp_int) config.max_redirects (pp_val pp_string_opt) config.user_agent (pp_val pp_bool) config.verbose_http (Fmt.option (pp_with_source Fmt.string)) config.proxy.proxy_url (Fmt.option (pp_with_source Fmt.string)) config.proxy.no_proxy (* Logging configuration *) let setup_log_sources ?(verbose_http = false) level = (* Helper to set TLS tracing level by finding the source by name *) let set_tls_tracing_level lvl = match List.find_opt (fun s -> Logs.Src.name s = "tls.tracing") (Logs.Src.list ()) with | Some tls_src -> Logs.Src.set_level tls_src (Some lvl) | None -> () (* TLS not loaded yet, ignore *) in match level with | Some Logs.Debug -> (* Enable debug logging for application-level requests modules *) Logs.Src.set_level src (Some Logs.Debug); Logs.Src.set_level Auth.src (Some Logs.Debug); Logs.Src.set_level Body.src (Some Logs.Debug); Logs.Src.set_level Response.src (Some Logs.Debug); Logs.Src.set_level Retry.src (Some Logs.Debug); Logs.Src.set_level Headers.src (Some Logs.Debug); Logs.Src.set_level Error.src (Some Logs.Debug); Logs.Src.set_level Method.src (Some Logs.Debug); Logs.Src.set_level Mime.src (Some Logs.Debug); Logs.Src.set_level Status.src (Some Logs.Debug); Logs.Src.set_level Timeout.src (Some Logs.Debug); (* Only enable HTTP-level debug if verbose_http is set *) if verbose_http then begin Logs.Src.set_level One.src (Some Logs.Debug); Logs.Src.set_level Http_client.src (Some Logs.Debug); Logs.Src.set_level Conpool.src (Some Logs.Debug); set_tls_tracing_level Logs.Debug end else begin Logs.Src.set_level One.src (Some Logs.Info); Logs.Src.set_level Http_client.src (Some Logs.Info); Logs.Src.set_level Conpool.src (Some Logs.Info); set_tls_tracing_level Logs.Warning end | Some Logs.Info -> (* Set info level for main modules *) Logs.Src.set_level src (Some Logs.Info); Logs.Src.set_level Response.src (Some Logs.Info); Logs.Src.set_level One.src (Some Logs.Info); set_tls_tracing_level Logs.Warning | _ -> (* Suppress TLS debug output by default *) set_tls_tracing_level Logs.Warning end let pp fmt (T { base_url; auth; _ }) = Fmt.pf fmt "Requests.t(base_url=%s, auth=%a)" (Option.value ~default:"" base_url) (Fmt.option Auth.pp) auth (** {1 Supporting Types} *) module Huri = Huri