+18 -57

lib/http_client.ml

··· 27 27 28 28 (** {1 Decompression Support} *) 29 29 30 30 - (** Decompress gzip-encoded data. Returns [Some decompressed] on success, [None] on failure. *) 31 31 - let decompress_gzip data = 32 32 - Log.debug (fun m -> m "Decompressing gzip data (%d bytes)" (String.length data)); 30 30 + (** Generic decompression helper that handles common setup and result handling. 31 31 + The [uncompress] function receives refill/flush callbacks and input/output buffers. *) 32 32 + let decompress_with ~name ~uncompress data = 33 33 + Log.debug (fun m -> m "Decompressing %s data (%d bytes)" name (String.length data)); 33 34 let i = De.bigstring_create De.io_buffer_size in 34 35 let o = De.bigstring_create De.io_buffer_size in 35 36 let r = Buffer.create (String.length data * 2) in ··· 41 42 len 42 43 in 43 44 let flush buf len = 44 44 - let str = Bigstringaf.substring buf ~off:0 ~len in 45 45 - Buffer.add_string r str 45 45 + Buffer.add_string r (Bigstringaf.substring buf ~off:0 ~len) 46 46 in 47 47 - match Gz.Higher.uncompress ~refill ~flush i o with 47 47 + match uncompress ~refill ~flush i o with 48 48 | Ok _ -> 49 49 let result = Buffer.contents r in 50 50 - Log.debug (fun m -> m "Gzip decompression succeeded: %d -> %d bytes" 51 51 - (String.length data) (String.length result)); 50 50 + Log.debug (fun m -> m "%s decompression succeeded: %d -> %d bytes" 51 51 + name (String.length data) (String.length result)); 52 52 Some result 53 53 | Error (`Msg e) -> 54 54 - Log.warn (fun m -> m "Gzip decompression failed: %s" e); 54 54 + Log.warn (fun m -> m "%s decompression failed: %s" name e); 55 55 None 56 56 57 57 + (** Decompress gzip-encoded data. Returns [Some decompressed] on success, [None] on failure. *) 58 58 + let decompress_gzip data = 59 59 + decompress_with ~name:"gzip" data 60 60 + ~uncompress:(fun ~refill ~flush i o -> Gz.Higher.uncompress ~refill ~flush i o) 61 61 + 57 62 (** Decompress deflate-encoded data (raw DEFLATE, RFC 1951). Returns [Some decompressed] on success, [None] on failure. *) 58 63 let decompress_deflate data = 59 59 - Log.debug (fun m -> m "Decompressing deflate data (%d bytes)" (String.length data)); 60 60 - let i = De.bigstring_create De.io_buffer_size in 61 61 - let o = De.bigstring_create De.io_buffer_size in 62 64 let w = De.make_window ~bits:15 in 63 63 - let r = Buffer.create (String.length data * 2) in 64 64 - let p = ref 0 in 65 65 - let refill buf = 66 66 - let len = min (String.length data - !p) De.io_buffer_size in 67 67 - Bigstringaf.blit_from_string data ~src_off:!p buf ~dst_off:0 ~len; 68 68 - p := !p + len; 69 69 - len 70 70 - in 71 71 - let flush buf len = 72 72 - let str = Bigstringaf.substring buf ~off:0 ~len in 73 73 - Buffer.add_string r str 74 74 - in 75 75 - match De.Higher.uncompress ~w ~refill ~flush i o with 76 76 - | Ok () -> 77 77 - let result = Buffer.contents r in 78 78 - Log.debug (fun m -> m "Deflate decompression succeeded: %d -> %d bytes" 79 79 - (String.length data) (String.length result)); 80 80 - Some result 81 81 - | Error (`Msg e) -> 82 82 - Log.warn (fun m -> m "Deflate decompression failed: %s" e); 83 83 - None 65 65 + decompress_with ~name:"deflate" data 66 66 + ~uncompress:(fun ~refill ~flush i o -> De.Higher.uncompress ~w ~refill ~flush i o) 84 67 85 68 (** Decompress zlib-encoded data (DEFLATE with zlib header, RFC 1950). Returns [Some decompressed] on success, [None] on failure. *) 86 69 let decompress_zlib data = 87 87 - Log.debug (fun m -> m "Decompressing zlib data (%d bytes)" (String.length data)); 88 88 - let i = De.bigstring_create De.io_buffer_size in 89 89 - let o = De.bigstring_create De.io_buffer_size in 90 70 let allocate bits = De.make_window ~bits in 91 91 - let r = Buffer.create (String.length data * 2) in 92 92 - let p = ref 0 in 93 93 - let refill buf = 94 94 - let len = min (String.length data - !p) De.io_buffer_size in 95 95 - Bigstringaf.blit_from_string data ~src_off:!p buf ~dst_off:0 ~len; 96 96 - p := !p + len; 97 97 - len 98 98 - in 99 99 - let flush buf len = 100 100 - let str = Bigstringaf.substring buf ~off:0 ~len in 101 101 - Buffer.add_string r str 102 102 - in 103 103 - match Zl.Higher.uncompress ~allocate ~refill ~flush i o with 104 104 - | Ok _ -> 105 105 - let result = Buffer.contents r in 106 106 - Log.debug (fun m -> m "Zlib decompression succeeded: %d -> %d bytes" 107 107 - (String.length data) (String.length result)); 108 108 - Some result 109 109 - | Error (`Msg e) -> 110 110 - Log.warn (fun m -> m "Zlib decompression failed: %s" e); 111 111 - None 71 71 + decompress_with ~name:"zlib" data 72 72 + ~uncompress:(fun ~refill ~flush i o -> Zl.Higher.uncompress ~allocate ~refill ~flush i o) 112 73 113 74 (** {1 Decompression Bomb Prevention} 114 75

+9 -87

lib/one.ml

··· 6 6 let src = Logs.Src.create "requests.one" ~doc:"One-shot HTTP Requests" 7 7 module Log = (val Logs.src_log src : Logs.LOG) 8 8 9 9 - (* Helper to check if two URIs have the same origin for security purposes. 10 10 - Used to determine if sensitive headers (Authorization, Cookie) should be 11 11 - stripped during redirects. Following Python requests behavior: 12 12 - - Same host and same scheme = same origin 13 13 - - http -> https upgrade on same host = allowed (more secure) 14 14 - TODO: Support .netrc for re-acquiring auth credentials on new hosts *) 15 15 - let same_origin uri1 uri2 = 16 16 - let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in 17 17 - let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in 18 18 - let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in 19 19 - let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in 20 20 - match host1, host2 with 21 21 - | Some h1, Some h2 when String.equal h1 h2 -> 22 22 - (* Same host - allow same scheme or http->https upgrade *) 23 23 - String.equal scheme1 scheme2 || 24 24 - (scheme1 = "http" && scheme2 = "https") 25 25 - | _ -> false 26 26 - 27 27 - (* Strip sensitive headers for cross-origin redirects to prevent credential leakage 28 28 - Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *) 29 29 - let strip_sensitive_headers headers = 30 30 - headers 31 31 - |> Headers.remove "Authorization" 32 32 - |> Headers.remove "Cookie" 33 33 - |> Headers.remove "Proxy-Authorization" 34 34 - |> Headers.remove "WWW-Authenticate" 35 35 - 36 36 - (* Validate redirect URL scheme to prevent SSRF attacks 37 37 - Per Recommendation #5: Only allow http:// and https:// schemes *) 38 38 - let allowed_redirect_schemes = ["http"; "https"] 39 39 - 40 40 - let validate_redirect_url location = 41 41 - let uri = Uri.of_string location in 42 42 - match Uri.scheme uri with 43 43 - | Some scheme when List.mem (String.lowercase_ascii scheme) allowed_redirect_schemes -> 44 44 - uri 45 45 - | Some scheme -> 46 46 - raise (Error.err (Error.Invalid_redirect { 47 47 - url = location; 48 48 - reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme 49 49 - })) 50 50 - | None -> 51 51 - uri (* Relative URLs are OK - they will be resolved against current URL *) 9 9 + (* Redirect handling - delegated to shared Redirect module *) 52 10 53 11 (* Helper to create TCP connection to host:port *) 54 12 let connect_tcp ~sw ~net ~host ~port = ··· 63 21 Log.err (fun m -> m "Failed to resolve hostname: %s" host); 64 22 raise (Error.err (Error.Dns_resolution_failed { hostname = host })) 65 23 66 66 - (** Minimum TLS version configuration. 67 67 - Per Recommendation #6: Allow enforcing minimum TLS version. *) 68 68 - type tls_version = 24 24 + (** Minimum TLS version configuration - re-exported from Tls_config. *) 25 25 + type tls_version = Tls_config.tls_version = 69 26 | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *) 70 27 | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *) 71 28 72 72 - let tls_version_to_tls = function 73 73 - | TLS_1_2 -> `TLS_1_2 74 74 - | TLS_1_3 -> `TLS_1_3 75 75 - 76 29 (* Helper to wrap connection with TLS if needed *) 77 30 let wrap_tls flow ~host ~verify_tls ~tls_config ~min_tls_version = 78 31 Log.debug (fun m -> m "Wrapping connection with TLS for %s (verify=%b)" host verify_tls); 79 32 80 33 (* Get or create TLS config with minimum version enforcement *) 81 81 - let min_version = tls_version_to_tls min_tls_version in 82 82 - let tls_cfg = match tls_config, verify_tls with 83 83 - | Some cfg, _ -> cfg 84 84 - | None, true -> 85 85 - (* Use CA certificates for verification with minimum TLS version *) 86 86 - let authenticator = match Ca_certs.authenticator () with 87 87 - | Ok auth -> auth 88 88 - | Error (`Msg msg) -> 89 89 - Log.err (fun m -> m "Failed to load CA certificates: %s" msg); 90 90 - raise (Error.err (Error.Tls_handshake_failed { 91 91 - host; 92 92 - reason = "CA certificates error: " ^ msg 93 93 - })) 94 94 - in 95 95 - (match Tls.Config.client ~authenticator ~version:(min_version, `TLS_1_3) () with 96 96 - | Ok cfg -> cfg 97 97 - | Error (`Msg msg) -> 98 98 - Log.err (fun m -> m "Failed to create TLS config: %s" msg); 99 99 - raise (Error.err (Error.Tls_handshake_failed { 100 100 - host; 101 101 - reason = "TLS config error: " ^ msg 102 102 - }))) 103 103 - | None, false -> 104 104 - (* No verification but still enforce minimum TLS version *) 105 105 - match Tls.Config.client 106 106 - ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) 107 107 - ~version:(min_version, `TLS_1_3) 108 108 - () with 109 109 - | Ok cfg -> cfg 110 110 - | Error (`Msg msg) -> 111 111 - raise (Error.err (Error.Tls_handshake_failed { 112 112 - host; 113 113 - reason = "TLS config error: " ^ msg 114 114 - })) 34 34 + let tls_cfg = match tls_config with 35 35 + | Some cfg -> cfg 36 36 + | None -> Tls_config.create_client ~verify_tls ~min_tls_version ~host () 115 37 in 116 38 117 39 (* Get domain name for SNI *) ··· 325 247 (status, resp_headers, response_body_str, url_to_fetch) 326 248 | Some location -> 327 249 (* Validate redirect URL scheme - Per Recommendation #5 *) 328 328 - let _ = validate_redirect_url location in 250 250 + let _ = Redirect.validate_url location in 329 251 330 252 Log.info (fun m -> m "Following redirect to %s (%d remaining)" location redirects_left); 331 253 (* Strip sensitive headers on cross-origin redirects (security) 332 254 Per Recommendation #1: Strip auth headers to prevent credential leakage *) 333 255 let redirect_uri = Uri.of_string location in 334 256 let headers_for_redirect = 335 335 - if same_origin original_uri redirect_uri then 257 257 + if Redirect.same_origin original_uri redirect_uri then 336 258 headers_for_request 337 259 else begin 338 260 Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers"); 339 339 - strip_sensitive_headers headers_for_request 261 261 + Redirect.strip_sensitive_headers headers_for_request 340 262 end 341 263 in 342 264 make_with_redirects ~headers_for_request:headers_for_redirect location (redirects_left - 1)

+29 -42

lib/proxy.ml

··· 36 36 Log.debug (fun m -> m "Creating SOCKS5 proxy config: %s:%d" host port); 37 37 { host; port; proxy_type = SOCKS5; auth; no_proxy } 38 38 39 39 - (** {1 Configuration Utilities} *) 39 39 + (** {1 Pattern Matching for NO_PROXY} *) 40 40 41 41 - let should_bypass config url = 42 42 - let uri = Uri.of_string url in 43 43 - let target_host = Uri.host uri |> Option.value ~default:"" in 44 44 - let target_host_lower = String.lowercase_ascii target_host in 45 45 - 46 46 - let matches_pattern pattern = 47 47 - let pattern_lower = String.lowercase_ascii (String.trim pattern) in 48 48 - if String.length pattern_lower = 0 then 49 49 - false 50 50 - else if pattern_lower.[0] = '*' then 41 41 + (** Check if a hostname matches a no_proxy pattern. 42 42 + Supports: 43 43 + - Exact match: "example.com" 44 44 + - Wildcard prefix: "*.example.com" matches foo.example.com 45 45 + - Dot prefix: ".example.com" matches example.com and foo.example.com *) 46 46 + let host_matches_pattern ~host pattern = 47 47 + let host_lower = String.lowercase_ascii host in 48 48 + let pattern_lower = String.lowercase_ascii (String.trim pattern) in 49 49 + match String.length pattern_lower with 50 50 + | 0 -> false 51 51 + | _ when pattern_lower.[0] = '*' -> 51 52 (* Wildcard pattern: *.example.com matches foo.example.com *) 52 53 let suffix = String.sub pattern_lower 1 (String.length pattern_lower - 1) in 53 53 - String.length target_host_lower >= String.length suffix && 54 54 - String.sub target_host_lower 55 55 - (String.length target_host_lower - String.length suffix) 54 54 + String.length host_lower >= String.length suffix && 55 55 + String.sub host_lower 56 56 + (String.length host_lower - String.length suffix) 56 57 (String.length suffix) = suffix 57 57 - else if pattern_lower.[0] = '.' then 58 58 + | _ when pattern_lower.[0] = '.' -> 58 59 (* .example.com matches example.com and foo.example.com *) 59 59 - target_host_lower = String.sub pattern_lower 1 (String.length pattern_lower - 1) || 60 60 - (String.length target_host_lower > String.length pattern_lower && 61 61 - String.sub target_host_lower 62 62 - (String.length target_host_lower - String.length pattern_lower) 60 60 + host_lower = String.sub pattern_lower 1 (String.length pattern_lower - 1) || 61 61 + (String.length host_lower > String.length pattern_lower && 62 62 + String.sub host_lower 63 63 + (String.length host_lower - String.length pattern_lower) 63 64 (String.length pattern_lower) = pattern_lower) 64 64 - else 65 65 + | _ -> 65 66 (* Exact match *) 66 66 - target_host_lower = pattern_lower 67 67 - in 67 67 + host_lower = pattern_lower 68 68 69 69 - let bypassed = List.exists matches_pattern config.no_proxy in 69 69 + (** {1 Configuration Utilities} *) 70 70 + 71 71 + let should_bypass config url = 72 72 + let uri = Uri.of_string url in 73 73 + let target_host = Uri.host uri |> Option.value ~default:"" in 74 74 + let bypassed = List.exists (host_matches_pattern ~host:target_host) config.no_proxy in 70 75 if bypassed then 71 76 Log.debug (fun m -> m "URL %s bypasses proxy (matches no_proxy pattern)" 72 77 (Error.sanitize_url url)); ··· 143 148 (* Check if URL should bypass proxy *) 144 149 let target_host = Uri.host uri |> Option.value ~default:"" in 145 150 let should_bypass_url = 146 146 - let target_host_lower = String.lowercase_ascii target_host in 147 147 - List.exists (fun pattern -> 148 148 - let pattern_lower = String.lowercase_ascii (String.trim pattern) in 149 149 - if String.length pattern_lower = 0 then false 150 150 - else if pattern_lower.[0] = '*' then 151 151 - let suffix = String.sub pattern_lower 1 (String.length pattern_lower - 1) in 152 152 - String.length target_host_lower >= String.length suffix && 153 153 - String.sub target_host_lower 154 154 - (String.length target_host_lower - String.length suffix) 155 155 - (String.length suffix) = suffix 156 156 - else if pattern_lower.[0] = '.' then 157 157 - target_host_lower = String.sub pattern_lower 1 (String.length pattern_lower - 1) || 158 158 - (String.length target_host_lower > String.length pattern_lower && 159 159 - String.sub target_host_lower 160 160 - (String.length target_host_lower - String.length pattern_lower) 161 161 - (String.length pattern_lower) = pattern_lower) 162 162 - else 163 163 - target_host_lower = pattern_lower 164 164 - ) no_proxy 151 151 + List.exists (host_matches_pattern ~host:target_host) no_proxy 165 152 in 166 153 167 154 if should_bypass_url then begin

+65

lib/redirect.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Redirect handling and cross-origin security utilities 7 7 + 8 8 + This module provides shared functions for handling HTTP redirects safely, 9 9 + including cross-origin detection and sensitive header stripping. *) 10 10 + 11 11 + let src = Logs.Src.create "requests.redirect" ~doc:"HTTP Redirect Handling" 12 12 + module Log = (val Logs.src_log src : Logs.LOG) 13 13 + 14 14 + (** {1 Cross-Origin Detection} *) 15 15 + 16 16 + (** Check if two URIs have the same origin for security purposes. 17 17 + Used to determine if sensitive headers (Authorization, Cookie) should be 18 18 + stripped during redirects. Following Python requests behavior: 19 19 + - Same host and same scheme = same origin 20 20 + - http -> https upgrade on same host = allowed (more secure) 21 21 + TODO: Support .netrc for re-acquiring auth credentials on new hosts *) 22 22 + let same_origin uri1 uri2 = 23 23 + let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in 24 24 + let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in 25 25 + let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in 26 26 + let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in 27 27 + match host1, host2 with 28 28 + | Some h1, Some h2 when String.equal h1 h2 -> 29 29 + (* Same host - allow same scheme or http->https upgrade *) 30 30 + String.equal scheme1 scheme2 || 31 31 + (scheme1 = "http" && scheme2 = "https") 32 32 + | _ -> false 33 33 + 34 34 + (** {1 Sensitive Header Protection} *) 35 35 + 36 36 + (** Strip sensitive headers for cross-origin redirects to prevent credential leakage. 37 37 + Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *) 38 38 + let strip_sensitive_headers headers = 39 39 + headers 40 40 + |> Headers.remove "Authorization" 41 41 + |> Headers.remove "Cookie" 42 42 + |> Headers.remove "Proxy-Authorization" 43 43 + |> Headers.remove "WWW-Authenticate" 44 44 + 45 45 + (** {1 Redirect URL Validation} *) 46 46 + 47 47 + (** Allowed redirect URL schemes to prevent SSRF attacks. 48 48 + Per Recommendation #5: Only allow http:// and https:// schemes *) 49 49 + let allowed_schemes = ["http"; "https"] 50 50 + 51 51 + (** Validate redirect URL scheme to prevent SSRF attacks. 52 52 + Per Recommendation #5: Only allow http:// and https:// schemes. 53 53 + @raise Error.Invalid_redirect if scheme is not allowed *) 54 54 + let validate_url location = 55 55 + let uri = Uri.of_string location in 56 56 + match Uri.scheme uri with 57 57 + | Some scheme when List.mem (String.lowercase_ascii scheme) allowed_schemes -> 58 58 + uri 59 59 + | Some scheme -> 60 60 + raise (Error.err (Error.Invalid_redirect { 61 61 + url = location; 62 62 + reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme 63 63 + })) 64 64 + | None -> 65 65 + uri (* Relative URLs are OK - they will be resolved against current URL *)

+38

lib/redirect.mli

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Redirect handling and cross-origin security utilities 7 7 + 8 8 + This module provides shared functions for handling HTTP redirects safely, 9 9 + including cross-origin detection and sensitive header stripping. *) 10 10 + 11 11 + val src : Logs.src 12 12 + (** Logs source for this module *) 13 13 + 14 14 + (** {1 Cross-Origin Detection} *) 15 15 + 16 16 + val same_origin : Uri.t -> Uri.t -> bool 17 17 + (** [same_origin uri1 uri2] returns [true] if both URIs have the same origin. 18 18 + Same origin means same host with same scheme, or http->https upgrade. 19 19 + Used to determine if sensitive headers should be preserved during redirects. *) 20 20 + 21 21 + (** {1 Sensitive Header Protection} *) 22 22 + 23 23 + val strip_sensitive_headers : Headers.t -> Headers.t 24 24 + (** [strip_sensitive_headers headers] removes sensitive headers that should not 25 25 + be sent to cross-origin destinations: 26 26 + - Authorization 27 27 + - Cookie 28 28 + - Proxy-Authorization 29 29 + - WWW-Authenticate *) 30 30 + 31 31 + (** {1 Redirect URL Validation} *) 32 32 + 33 33 + val allowed_schemes : string list 34 34 + (** List of allowed URL schemes for redirects: ["http"; "https"] *) 35 35 + 36 36 + val validate_url : string -> Uri.t 37 37 + (** [validate_url location] validates that the redirect URL uses an allowed scheme. 38 38 + @raise Error.Invalid_redirect if scheme is not http or https *)

+12 -88

lib/requests.ml

··· 30 30 module Link = Link 31 31 module Timing = Timing 32 32 33 33 - (** Minimum TLS version configuration. 34 34 - Per Recommendation #6: Allow enforcing minimum TLS version. *) 35 35 - type tls_version = 33 33 + (** Minimum TLS version configuration - re-exported from Tls_config. *) 34 34 + type tls_version = Tls_config.tls_version = 36 35 | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *) 37 36 | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *) 38 38 - 39 39 - let tls_version_to_tls = function 40 40 - | TLS_1_2 -> `TLS_1_2 41 41 - | TLS_1_3 -> `TLS_1_3 42 37 43 38 (* Main API - Session functionality with connection pooling *) 44 39 ··· 118 113 119 114 (* Create TLS config for HTTPS pool if needed 120 115 Per Recommendation #6: Enforce minimum TLS version *) 121 121 - let min_version = tls_version_to_tls min_tls_version in 122 122 - let tls_config = match tls_config, verify_tls with 123 123 - | Some cfg, _ -> Some cfg 124 124 - | None, true -> 125 125 - (* Use CA certificates for verification with minimum TLS version *) 126 126 - let authenticator = match Ca_certs.authenticator () with 127 127 - | Ok auth -> auth 128 128 - | Error (`Msg msg) -> 129 129 - Log.err (fun m -> m "Failed to load CA certificates: %s" msg); 130 130 - raise (Error.err (Error.Tls_handshake_failed { 131 131 - host = "session-init"; 132 132 - reason = "CA certificates error: " ^ msg 133 133 - })) 134 134 - in 135 135 - (match Tls.Config.client ~authenticator ~version:(min_version, `TLS_1_3) () with 136 136 - | Ok cfg -> Some cfg 137 137 - | Error (`Msg msg) -> 138 138 - Log.err (fun m -> m "Failed to create TLS config: %s" msg); 139 139 - raise (Error.err (Error.Tls_handshake_failed { 140 140 - host = "session-init"; 141 141 - reason = "TLS config error: " ^ msg 142 142 - }))) 143 143 - | None, false -> 144 144 - (* No verification but still enforce minimum TLS version *) 145 145 - (match Tls.Config.client 146 146 - ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) 147 147 - ~version:(min_version, `TLS_1_3) 148 148 - () with 149 149 - | Ok cfg -> Some cfg 150 150 - | Error (`Msg msg) -> 151 151 - Log.err (fun m -> m "Failed to create TLS config: %s" msg); 152 152 - raise (Error.err (Error.Tls_handshake_failed { 153 153 - host = "session-init"; 154 154 - reason = "TLS config error: " ^ msg 155 155 - }))) 116 116 + let tls_config = Tls_config.create_client_opt 117 117 + ?existing_config:tls_config 118 118 + ~verify_tls 119 119 + ~min_tls_version 120 120 + ~host:"session-init" 121 121 + () 156 122 in 157 123 158 124 (* Create connection pools if not provided *) ··· 270 236 271 237 let proxy (T t) = t.proxy 272 238 273 273 - (* Helper to check if two URIs have the same origin for security purposes. 274 274 - Used to determine if sensitive headers (Authorization, Cookie) should be 275 275 - stripped during redirects. Following Python requests behavior: 276 276 - - Same host and same scheme = same origin 277 277 - - http -> https upgrade on same host = allowed (more secure) 278 278 - TODO: Support .netrc for re-acquiring auth credentials on new hosts *) 279 279 - let same_origin uri1 uri2 = 280 280 - let host1 = Uri.host uri1 |> Option.map String.lowercase_ascii in 281 281 - let host2 = Uri.host uri2 |> Option.map String.lowercase_ascii in 282 282 - let scheme1 = Uri.scheme uri1 |> Option.value ~default:"http" in 283 283 - let scheme2 = Uri.scheme uri2 |> Option.value ~default:"http" in 284 284 - match host1, host2 with 285 285 - | Some h1, Some h2 when String.equal h1 h2 -> 286 286 - (* Same host - allow same scheme or http->https upgrade *) 287 287 - String.equal scheme1 scheme2 || 288 288 - (scheme1 = "http" && scheme2 = "https") 289 289 - | _ -> false 290 290 - 291 291 - (* Strip sensitive headers for cross-origin redirects to prevent credential leakage 292 292 - Per Recommendation #1: Also strip Cookie, Proxy-Authorization, WWW-Authenticate *) 293 293 - let strip_sensitive_headers headers = 294 294 - headers 295 295 - |> Headers.remove "Authorization" 296 296 - |> Headers.remove "Cookie" 297 297 - |> Headers.remove "Proxy-Authorization" 298 298 - |> Headers.remove "WWW-Authenticate" 299 299 - 300 300 - (* Validate redirect URL scheme to prevent SSRF attacks 301 301 - Per Recommendation #5: Only allow http:// and https:// schemes *) 302 302 - let allowed_redirect_schemes = ["http"; "https"] 303 303 - 304 304 - let validate_redirect_url location = 305 305 - let uri = Uri.of_string location in 306 306 - match Uri.scheme uri with 307 307 - | Some scheme when List.mem (String.lowercase_ascii scheme) allowed_redirect_schemes -> 308 308 - uri 309 309 - | Some scheme -> 310 310 - raise (Error.err (Error.Invalid_redirect { 311 311 - url = location; 312 312 - reason = Printf.sprintf "Disallowed redirect scheme: %s" scheme 313 313 - })) 314 314 - | None -> 315 315 - uri (* Relative URLs are OK - they will be resolved against current URL *) 239 239 + (* Redirect handling - delegated to shared Redirect module *) 316 240 317 241 (** {1 URL Resolution and Path Templating} 318 242 ··· 683 607 (status, resp_headers, response_body_str, url_to_fetch) 684 608 | Some location -> 685 609 (* Validate redirect URL scheme - Per Recommendation #5 *) 686 686 - let _ = validate_redirect_url location in 610 610 + let _ = Redirect.validate_url location in 687 611 688 612 (* Resolve relative redirects against the current URL *) 689 613 let location_uri = Uri.of_string location in ··· 702 626 Per Recommendation #1: Strip auth headers to prevent credential leakage *) 703 627 let redirect_uri = Uri.of_string absolute_location in 704 628 let headers_for_redirect = 705 705 - if same_origin original_uri redirect_uri then 629 629 + if Redirect.same_origin original_uri redirect_uri then 706 630 headers_for_request 707 631 else begin 708 632 Log.debug (fun m -> m "Cross-origin redirect detected: stripping sensitive headers"); 709 709 - strip_sensitive_headers headers_for_request 633 633 + Redirect.strip_sensitive_headers headers_for_request 710 634 end 711 635 in 712 636 make_with_redirects ~headers_for_request:headers_for_redirect absolute_location (redirects_left - 1)

+8 -18

lib/timeout.ml

··· 40 40 let expect_100_continue t = t.expect_100_continue 41 41 42 42 let pp ppf t = 43 43 - let items = [] in 44 44 - let items = match t.connect with 45 45 - | Some c -> (Printf.sprintf "connect:%.1fs" c) :: items 46 46 - | None -> items 47 47 - in 48 48 - let items = match t.read with 49 49 - | Some r -> (Printf.sprintf "read:%.1fs" r) :: items 50 50 - | None -> items 51 51 - in 52 52 - let items = match t.total with 53 53 - | Some tot -> (Printf.sprintf "total:%.1fs" tot) :: items 54 54 - | None -> items 55 55 - in 56 56 - let items = match t.expect_100_continue with 57 57 - | Some e -> (Printf.sprintf "expect:%.1fs" e) :: items 58 58 - | None -> items 59 59 - in 43 43 + let fmt_opt name = Option.map (Printf.sprintf "%s:%.1fs" name) in 44 44 + let items = List.filter_map Fun.id [ 45 45 + fmt_opt "connect" t.connect; 46 46 + fmt_opt "read" t.read; 47 47 + fmt_opt "total" t.total; 48 48 + fmt_opt "expect" t.expect_100_continue; 49 49 + ] in 60 50 match items with 61 51 | [] -> Format.fprintf ppf "no timeouts" 62 62 - | _ -> Format.fprintf ppf "%s" (String.concat ", " (List.rev items)) 52 52 + | _ -> Format.fprintf ppf "%s" (String.concat ", " items)

+80

lib/tls_config.ml

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** TLS configuration utilities 7 7 + 8 8 + This module provides shared TLS configuration creation to ensure consistent 9 9 + behavior across session-based and one-shot request modes. *) 10 10 + 11 11 + let src = Logs.Src.create "requests.tls_config" ~doc:"TLS Configuration" 12 12 + module Log = (val Logs.src_log src : Logs.LOG) 13 13 + 14 14 + (** {1 TLS Version Types} *) 15 15 + 16 16 + (** Minimum TLS version configuration. 17 17 + Per Recommendation #6: Allow enforcing minimum TLS version. *) 18 18 + type tls_version = 19 19 + | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *) 20 20 + | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *) 21 21 + 22 22 + let tls_version_to_tls = function 23 23 + | TLS_1_2 -> `TLS_1_2 24 24 + | TLS_1_3 -> `TLS_1_3 25 25 + 26 26 + (** {1 Configuration Creation} *) 27 27 + 28 28 + (** Create a TLS client configuration. 29 29 + 30 30 + @param verify_tls If true, use system CA certificates for verification 31 31 + @param min_tls_version Minimum TLS version to accept (default TLS_1_2) 32 32 + @param host Hostname for error messages 33 33 + @return TLS client configuration 34 34 + @raise Error.Tls_handshake_failed if configuration cannot be created *) 35 35 + let create_client ?(verify_tls = true) ?(min_tls_version = TLS_1_2) ~host () = 36 36 + let min_version = tls_version_to_tls min_tls_version in 37 37 + match verify_tls with 38 38 + | true -> 39 39 + (* Use CA certificates for verification with minimum TLS version *) 40 40 + let authenticator = match Ca_certs.authenticator () with 41 41 + | Ok auth -> auth 42 42 + | Error (`Msg msg) -> 43 43 + Log.err (fun m -> m "Failed to load CA certificates: %s" msg); 44 44 + raise (Error.err (Error.Tls_handshake_failed { 45 45 + host; 46 46 + reason = "CA certificates error: " ^ msg 47 47 + })) 48 48 + in 49 49 + (match Tls.Config.client ~authenticator ~version:(min_version, `TLS_1_3) () with 50 50 + | Ok cfg -> cfg 51 51 + | Error (`Msg msg) -> 52 52 + Log.err (fun m -> m "Failed to create TLS config: %s" msg); 53 53 + raise (Error.err (Error.Tls_handshake_failed { 54 54 + host; 55 55 + reason = "TLS config error: " ^ msg 56 56 + }))) 57 57 + | false -> 58 58 + (* No verification but still enforce minimum TLS version *) 59 59 + match Tls.Config.client 60 60 + ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) 61 61 + ~version:(min_version, `TLS_1_3) 62 62 + () with 63 63 + | Ok cfg -> cfg 64 64 + | Error (`Msg msg) -> 65 65 + Log.err (fun m -> m "Failed to create TLS config: %s" msg); 66 66 + raise (Error.err (Error.Tls_handshake_failed { 67 67 + host; 68 68 + reason = "TLS config error: " ^ msg 69 69 + })) 70 70 + 71 71 + (** Create a TLS client configuration, returning an option. 72 72 + 73 73 + @param verify_tls If true, use system CA certificates for verification 74 74 + @param min_tls_version Minimum TLS version to accept (default TLS_1_2) 75 75 + @param host Hostname for error messages 76 76 + @return Some TLS client configuration, or raises on error *) 77 77 + let create_client_opt ?existing_config ~verify_tls ~min_tls_version ~host () = 78 78 + match existing_config with 79 79 + | Some cfg -> Some cfg 80 80 + | None -> Some (create_client ~verify_tls ~min_tls_version ~host ())

+55

lib/tls_config.mli

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** TLS configuration utilities 7 7 + 8 8 + This module provides shared TLS configuration creation to ensure consistent 9 9 + behavior across session-based and one-shot request modes. *) 10 10 + 11 11 + val src : Logs.src 12 12 + (** Logs source for this module *) 13 13 + 14 14 + (** {1 TLS Version Types} *) 15 15 + 16 16 + (** Minimum TLS version configuration. 17 17 + Per Recommendation #6: Allow enforcing minimum TLS version. *) 18 18 + type tls_version = 19 19 + | TLS_1_2 (** TLS 1.2 minimum (default, widely compatible) *) 20 20 + | TLS_1_3 (** TLS 1.3 minimum (most secure, may not work with older servers) *) 21 21 + 22 22 + val tls_version_to_tls : tls_version -> Tls.Core.tls_version 23 23 + (** Convert our TLS version type to the underlying library's type *) 24 24 + 25 25 + (** {1 Configuration Creation} *) 26 26 + 27 27 + val create_client : 28 28 + ?verify_tls:bool -> 29 29 + ?min_tls_version:tls_version -> 30 30 + host:string -> 31 31 + unit -> 32 32 + Tls.Config.client 33 33 + (** [create_client ~host ()] creates a TLS client configuration. 34 34 + 35 35 + @param verify_tls If true (default), use system CA certificates for verification 36 36 + @param min_tls_version Minimum TLS version to accept (default TLS_1_2) 37 37 + @param host Hostname for error messages 38 38 + @return TLS client configuration 39 39 + @raise Error.Tls_handshake_failed if configuration cannot be created *) 40 40 + 41 41 + val create_client_opt : 42 42 + ?existing_config:Tls.Config.client -> 43 43 + verify_tls:bool -> 44 44 + min_tls_version:tls_version -> 45 45 + host:string -> 46 46 + unit -> 47 47 + Tls.Config.client option 48 48 + (** [create_client_opt ~verify_tls ~min_tls_version ~host ()] creates a TLS 49 49 + client configuration, or returns the existing one if provided. 50 50 + 51 51 + @param existing_config If provided, return this instead of creating new 52 52 + @param verify_tls If true, use system CA certificates for verification 53 53 + @param min_tls_version Minimum TLS version to accept 54 54 + @param host Hostname for error messages 55 55 + @return Some TLS client configuration *)