+54 -11

lib/auth.ml

··· 172 172 Log.warn (fun m -> m "Digest challenge missing required fields (realm/nonce)"); 173 173 Option.none 174 174 175 175 - (** Hash function based on algorithm *) 175 175 + (** Hash function based on algorithm. 176 176 + Supports MD5 (default), SHA-256, and SHA-512 per RFC 7616. 177 177 + @raise Error.Authentication_failed if an unsupported algorithm is requested *) 176 178 let hash_string ~algorithm s = 177 179 match String.uppercase_ascii algorithm with 178 178 - | "SHA-256" | "SHA256" -> 180 180 + | "MD5" | "MD5-SESS" -> 181 181 + Digestif.MD5.(to_hex (digest_string s)) 182 182 + | "SHA-256" | "SHA256" | "SHA-256-SESS" -> 179 183 Digestif.SHA256.(to_hex (digest_string s)) 180 180 - | "SHA-512-256" -> 181 181 - (* SHA-512/256 - use SHA-512 and truncate *) 182 182 - let full = Digestif.SHA512.(to_hex (digest_string s)) in 183 183 - String.sub full 0 64 (* First 256 bits = 64 hex chars *) 184 184 - | _ -> (* Default to MD5 *) 184 184 + | "SHA-512" | "SHA512" -> 185 185 + Digestif.SHA512.(to_hex (digest_string s)) 186 186 + | "SHA-512-256" | "SHA512-256" -> 187 187 + (* SHA-512/256 requires specific initialization vectors that differ from 188 188 + standard SHA-512. Truncating SHA-512 output is cryptographically incorrect. 189 189 + This algorithm is rarely used; recommend SHA-256 instead. *) 190 190 + Log.err (fun m -> m "SHA-512-256 algorithm not supported (requires special IVs)"); 191 191 + raise (Error.err (Error.Authentication_failed { 192 192 + url = ""; 193 193 + reason = "Digest algorithm SHA-512-256 is not supported. Server should offer SHA-256 or MD5." 194 194 + })) 195 195 + | other -> 196 196 + Log.warn (fun m -> m "Unknown digest algorithm '%s', defaulting to MD5" other); 185 197 Digestif.MD5.(to_hex (digest_string s)) 186 198 187 199 (** Generate a random client nonce *) ··· 244 256 in 245 257 "Digest " ^ String.concat ", " parts 246 258 247 247 - (** Apply Digest authentication given a challenge *) 248 248 - let apply_digest ~username ~password ~method_ ~uri ~challenge headers = 249 249 - let nc = "00000001" in (* Nonce count - for simplicity we use 1 *) 259 259 + (** {1 Nonce Count Tracking} 260 260 + 261 261 + Per RFC 7616, the nonce count (nc) must be incremented for each request 262 262 + using the same server nonce to prevent replay attacks. *) 263 263 + 264 264 + module Nonce_counter = struct 265 265 + (** Mutable nonce count tracker, keyed by server nonce *) 266 266 + type t = (string, int) Hashtbl.t 267 267 + 268 268 + let create () : t = Hashtbl.create 16 269 269 + 270 270 + (** Get and increment the nonce count for a given server nonce. 271 271 + Returns the count formatted as 8 hex digits (e.g., "00000001"). *) 272 272 + let next (t : t) ~nonce = 273 273 + let count = match Hashtbl.find_opt t nonce with 274 274 + | Some c -> c + 1 275 275 + | None -> 1 276 276 + in 277 277 + Hashtbl.replace t nonce count; 278 278 + Printf.sprintf "%08x" count 279 279 + 280 280 + (** Clear all tracked nonces (e.g., on session reset) *) 281 281 + let clear (t : t) = Hashtbl.clear t 282 282 + end 283 283 + 284 284 + (** Apply Digest authentication given a challenge. 285 285 + @param nonce_counter Optional nonce counter for replay protection. 286 286 + If provided, the nonce count is tracked and incremented per-nonce. 287 287 + If not provided, defaults to "00000001" (single-request mode). *) 288 288 + let apply_digest ?nonce_counter ~username ~password ~method_ ~uri ~challenge headers = 289 289 + let nc = match nonce_counter with 290 290 + | Some counter -> Nonce_counter.next counter ~nonce:challenge.nonce 291 291 + | None -> "00000001" 292 292 + in 250 293 let cnonce = generate_cnonce () in 251 294 let response = compute_digest_response 252 295 ~username ~password ~method_ ~uri ~challenge ~nc ~cnonce in 253 296 let auth_header = build_digest_header 254 297 ~username ~uri ~challenge ~nc ~cnonce ~response in 255 255 - Log.debug (fun m -> m "Applied Digest authentication for user %s" username); 298 298 + Log.debug (fun m -> m "Applied Digest authentication for user %s (nc=%s)" username nc); 256 299 Headers.set "Authorization" auth_header headers 257 300 258 301 (** Check if auth type is Digest *)

+31 -3

lib/auth.mli

··· 40 40 a 401 response with a WWW-Authenticate: Digest header, the library will 41 41 parse the challenge and retry the request with proper digest credentials. 42 42 43 43 - Supports MD5, SHA-256, and SHA-512-256 algorithms as well as qop=auth. *) 43 43 + Supports MD5, SHA-256, and SHA-512 algorithms as well as qop=auth. 44 44 + Note: SHA-512-256 is not supported as it requires special initialization 45 45 + vectors not available in standard libraries. *) 44 46 45 47 val custom : (Headers.t -> Headers.t) -> t 46 48 (** Custom authentication handler *) ··· 87 89 and returns the Digest challenge if present. Returns [None] if the header 88 90 is not a Digest challenge or cannot be parsed. *) 89 91 92 92 + (** {2 Nonce Count Tracking} 93 93 + 94 94 + Per RFC 7616, the nonce count (nc) must be incremented for each request 95 95 + using the same server nonce to prevent replay attacks. *) 96 96 + 97 97 + module Nonce_counter : sig 98 98 + type t 99 99 + (** Mutable nonce count tracker, keyed by server nonce *) 100 100 + 101 101 + val create : unit -> t 102 102 + (** Create a new nonce counter *) 103 103 + 104 104 + val next : t -> nonce:string -> string 105 105 + (** [next t ~nonce] gets and increments the count for the given server nonce. 106 106 + Returns the count formatted as 8 hex digits (e.g., "00000001"). *) 107 107 + 108 108 + val clear : t -> unit 109 109 + (** Clear all tracked nonces (e.g., on session reset) *) 110 110 + end 111 111 + 90 112 val apply_digest : 113 113 + ?nonce_counter:Nonce_counter.t -> 91 114 username:string -> 92 115 password:string -> 93 116 method_:string -> ··· 95 118 challenge:digest_challenge -> 96 119 Headers.t -> 97 120 Headers.t 98 98 - (** [apply_digest ~username ~password ~method_ ~uri ~challenge headers] 121 121 + (** [apply_digest ?nonce_counter ~username ~password ~method_ ~uri ~challenge headers] 99 122 applies Digest authentication to [headers] using the given credentials 100 100 - and server challenge. *) 123 123 + and server challenge. 124 124 + 125 125 + @param nonce_counter Optional nonce counter for replay protection. 126 126 + When provided, the nonce count is tracked and incremented per-nonce 127 127 + across multiple requests in a session. When not provided, defaults 128 128 + to "00000001" (suitable for single-request/one-shot mode). *) 101 129 102 130 val is_digest : t -> bool 103 131 (** [is_digest auth] returns [true] if [auth] is Digest authentication. *)

+26

lib/error.ml

··· 272 272 273 273 let to_string e = 274 274 Format.asprintf "%a" pp_error e 275 275 + 276 276 + (** {1 Convenience Constructors} 277 277 + 278 278 + These functions provide a more concise way to raise common errors 279 279 + compared to the verbose [raise (err (Error_type { field = value; ... }))] pattern. *) 280 280 + 281 281 + let invalid_request ~reason = 282 282 + err (Invalid_request { reason }) 283 283 + 284 284 + let invalid_redirect ~url ~reason = 285 285 + err (Invalid_redirect { url; reason }) 286 286 + 287 287 + let invalid_url ~url ~reason = 288 288 + err (Invalid_url { url; reason }) 289 289 + 290 290 + let timeout ~operation ?duration () = 291 291 + err (Timeout { operation; duration }) 292 292 + 293 293 + let body_too_large ~limit ?actual () = 294 294 + err (Body_too_large { limit; actual }) 295 295 + 296 296 + let headers_too_large ~limit ~actual = 297 297 + err (Headers_too_large { limit; actual }) 298 298 + 299 299 + let proxy_error ~host ~reason = 300 300 + err (Proxy_error { host; reason })

+35

lib/error.mli

··· 164 164 165 165 (** Convert error to human-readable string *) 166 166 val to_string : error -> string 167 167 + 168 168 + (** {1 Convenience Constructors} 169 169 + 170 170 + These functions provide a more concise way to create error exceptions 171 171 + compared to the verbose [err (Error_type { field = value; ... })] pattern. 172 172 + 173 173 + Example: 174 174 + {[ 175 175 + (* Instead of: *) 176 176 + raise (err (Invalid_request { reason = "missing host" })) 177 177 + 178 178 + (* Use: *) 179 179 + raise (invalid_request ~reason:"missing host") 180 180 + ]} *) 181 181 + 182 182 + val invalid_request : reason:string -> exn 183 183 + (** Create an [Invalid_request] exception *) 184 184 + 185 185 + val invalid_redirect : url:string -> reason:string -> exn 186 186 + (** Create an [Invalid_redirect] exception *) 187 187 + 188 188 + val invalid_url : url:string -> reason:string -> exn 189 189 + (** Create an [Invalid_url] exception *) 190 190 + 191 191 + val timeout : operation:string -> ?duration:float -> unit -> exn 192 192 + (** Create a [Timeout] exception *) 193 193 + 194 194 + val body_too_large : limit:int64 -> ?actual:int64 -> unit -> exn 195 195 + (** Create a [Body_too_large] exception *) 196 196 + 197 197 + val headers_too_large : limit:int -> actual:int -> exn 198 198 + (** Create a [Headers_too_large] exception *) 199 199 + 200 200 + val proxy_error : host:string -> reason:string -> exn 201 201 + (** Create a [Proxy_error] exception *)

+13 -20

lib/http_client.ml

··· 127 127 128 128 (** {1 Request Execution} *) 129 129 130 130 + (** Write request body to flow, handling empty, chunked, and fixed-length bodies *) 131 131 + let write_body_to_flow ~sw flow body = 132 132 + Http_write.write_and_flush flow (fun w -> 133 133 + if Body.Private.is_empty body then 134 134 + () 135 135 + else if Body.Private.is_chunked body then 136 136 + Body.Private.write_chunked ~sw w body 137 137 + else 138 138 + Body.Private.write ~sw w body 139 139 + ) 140 140 + 130 141 (** Apply auto-decompression to response if enabled *) 131 142 let maybe_decompress ~limits ~auto_decompress (status, resp_headers, body_str) = 132 143 match auto_decompress, Headers.get "content-encoding" resp_headers with ··· 282 293 | Continue -> 283 294 (* Server said continue - send body and read final response *) 284 295 Log.debug (fun m -> m "Sending body after 100 Continue"); 285 285 - 286 286 - (* Write body *) 287 287 - Http_write.write_and_flush flow (fun w -> 288 288 - if Body.Private.is_empty body then 289 289 - () 290 290 - else if Body.Private.is_chunked body then 291 291 - Body.Private.write_chunked ~sw w body 292 292 - else 293 293 - Body.Private.write ~sw w body 294 294 - ); 296 296 + write_body_to_flow ~sw flow body; 295 297 296 298 (* Read final response *) 297 299 let buf_read = Http_read.of_flow flow ~max_size:max_int in ··· 307 309 | Timeout -> 308 310 (* Timeout expired - send body anyway per RFC 9110 *) 309 311 Log.debug (fun m -> m "Sending body after timeout"); 310 310 - 311 311 - (* Write body *) 312 312 - Http_write.write_and_flush flow (fun w -> 313 313 - if Body.Private.is_empty body then 314 314 - () 315 315 - else if Body.Private.is_chunked body then 316 316 - Body.Private.write_chunked ~sw w body 317 317 - else 318 318 - Body.Private.write ~sw w body 319 319 - ); 312 312 + write_body_to_flow ~sw flow body; 320 313 321 314 (* Read response *) 322 315 let buf_read = Http_read.of_flow flow ~max_size:max_int in

+25 -12

lib/http_read.ml

··· 397 397 | None -> false 398 398 | Some te -> String.lowercase_ascii te |> String.trim = "chunked" 399 399 400 400 + (** Safely parse Content-Length header, returning None for invalid values *) 401 401 + let parse_content_length = function 402 402 + | None -> None 403 403 + | Some s -> 404 404 + try Some (Int64.of_string s) 405 405 + with Failure _ -> 406 406 + Log.warn (fun m -> m "Invalid Content-Length header value: %s" s); 407 407 + raise (Error.err (Error.Invalid_request { 408 408 + reason = "Invalid Content-Length header: " ^ s 409 409 + })) 410 410 + 400 411 (** Parse complete response (status + headers + body) to string. 401 412 Per {{:https://datatracker.ietf.org/doc/html/rfc9112#section-6}RFC 9112 Section 6}}. *) 402 413 let response ~limits ?method_ r = ··· 411 422 (* Determine how to read body based on headers. 412 423 Per RFC 9112 Section 6.3: Transfer-Encoding takes precedence over Content-Length *) 413 424 let transfer_encoding = Headers.get "transfer-encoding" hdrs in 414 414 - let content_length = Headers.get "content-length" hdrs |> Option.map Int64.of_string in 425 425 + let content_length = parse_content_length (Headers.get "content-length" hdrs) in 415 426 let body = match is_chunked_encoding transfer_encoding, content_length with 416 427 | true, Some _ -> 417 428 (* Both headers present - potential HTTP request smuggling indicator *) ··· 451 462 452 463 (* Determine body type *) 453 464 let transfer_encoding = Headers.get "transfer-encoding" hdrs in 454 454 - let content_length = Headers.get "content-length" hdrs |> Option.map Int64.of_string in 465 465 + let content_length = parse_content_length (Headers.get "content-length" hdrs) in 455 466 456 467 (* Per RFC 9112 Section 6.3: When both Transfer-Encoding and Content-Length 457 468 are present, Transfer-Encoding takes precedence. The presence of both 458 469 headers is a potential HTTP request smuggling attack indicator. *) 459 459 - let body = match transfer_encoding, content_length with 460 460 - | Some te, Some _ when String.lowercase_ascii te |> String.trim = "chunked" -> 470 470 + let body = match is_chunked_encoding transfer_encoding, content_length with 471 471 + | true, Some _ -> 461 472 (* Both headers present - log warning per RFC 9112 Section 6.3 *) 462 473 Log.warn (fun m -> m "Both Transfer-Encoding and Content-Length present - \ 463 474 ignoring Content-Length per RFC 9112 (potential attack indicator)"); 464 475 `Stream (chunked_body_stream ~limits r) 465 465 - | Some te, None when String.lowercase_ascii te |> String.trim = "chunked" -> 476 476 + | true, None -> 466 477 Log.debug (fun m -> m "Creating chunked body stream"); 467 478 `Stream (chunked_body_stream ~limits r) 468 468 - | _, Some len -> 479 479 + | false, Some len -> 469 480 Log.debug (fun m -> m "Creating fixed-length body stream (%Ld bytes)" len); 470 481 `Stream (fixed_body_stream ~limits ~length:len r) 471 471 - | Some other_te, None -> 472 472 - Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" other_te); 473 473 - `None 474 474 - | None, None -> 475 475 - Log.debug (fun m -> m "No body indicated"); 476 476 - `None 482 482 + | false, None -> 483 483 + (match transfer_encoding with 484 484 + | Some te -> 485 485 + Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" te); 486 486 + `None 487 487 + | None -> 488 488 + Log.debug (fun m -> m "No body indicated"); 489 489 + `None) 477 490 in 478 491 479 492 { http_version = version; status; headers = hdrs; body }

+13

lib/proxy.ml

··· 79 79 80 80 let host_port config = (config.host, config.port) 81 81 82 82 + (** Validate that the proxy type is supported. 83 83 + Currently only HTTP proxies are implemented. 84 84 + @raise Error.Proxy_error if SOCKS5 is requested *) 85 85 + let validate_supported config = 86 86 + match config.proxy_type with 87 87 + | HTTP -> () 88 88 + | SOCKS5 -> 89 89 + Log.err (fun m -> m "SOCKS5 proxy requested but not implemented"); 90 90 + raise (Error.err (Error.Proxy_error { 91 91 + host = config.host; 92 92 + reason = "SOCKS5 proxy is not yet implemented" 93 93 + })) 94 94 + 82 95 (** {1 Environment Variable Support} *) 83 96 84 97 let get_env key =

+4

lib/proxy.mli

··· 89 89 val host_port : config -> string * int 90 90 (** [host_port config] returns the proxy host and port as a tuple. *) 91 91 92 92 + val validate_supported : config -> unit 93 93 + (** [validate_supported config] checks that the proxy type is currently supported. 94 94 + @raise Error.Proxy_error if SOCKS5 is requested (not yet implemented) *) 95 95 + 92 96 (** {1 Environment Variable Support} *) 93 97 94 98 val from_env : unit -> config option

+4 -1

lib/requests.ml

··· 62 62 xsrf_header_name : string; (** Per Recommendation #24: XSRF header name *) 63 63 proxy : Proxy.config option; (** HTTP/HTTPS proxy configuration *) 64 64 allow_insecure_auth : bool; (** Allow auth over HTTP for dev/testing *) 65 65 + nonce_counter : Auth.Nonce_counter.t; (** Digest auth nonce count tracker *) 65 66 66 67 (* Statistics - mutable but NOTE: when sessions are derived via record update 67 68 syntax ({t with field = value}), these are copied not shared. Each derived ··· 196 197 xsrf_header_name; 197 198 proxy; 198 199 allow_insecure_auth; 200 200 + nonce_counter = Auth.Nonce_counter.create (); 199 201 requests_made = 0; 200 202 total_time = 0.0; 201 203 retries_count = 0; ··· 694 696 let uri = Uri.of_string url in 695 697 let uri_path = Uri.path uri in 696 698 let uri_path = if uri_path = "" then "/" else uri_path in 697 697 - (* Apply digest auth to headers *) 699 699 + (* Apply digest auth to headers with nonce counter for replay protection *) 698 700 let base_headers = Option.value headers ~default:Headers.empty in 699 701 let auth_headers = Auth.apply_digest 702 702 + ~nonce_counter:t.nonce_counter 700 703 ~username ~password 701 704 ~method_:(Method.to_string method_) 702 705 ~uri:uri_path