+7 -10

bin/ocurl.ml

··· 228 228 ~follow_redirects ~max_redirects ~allow_insecure_auth ?timeout:timeout_obj env in 229 229 230 230 (* Set authentication if provided *) 231 231 - let req = match auth with 232 232 - | Some auth_str -> 233 233 - (match parse_auth auth_str with 234 234 - | Some (user, pass) -> 235 235 - Requests.set_auth req 236 236 - (Requests.Auth.basic ~username:user ~password:pass) 237 237 - | None -> 238 238 - Logs.warn (fun m -> m "Invalid auth format, ignoring"); 239 239 - req) 240 240 - | None -> req 231 231 + let req = match Option.bind auth parse_auth with 232 232 + | Some (user, pass) -> 233 233 + Requests.set_auth req (Requests.Auth.basic ~username:user ~password:pass) 234 234 + | None -> 235 235 + (if Option.is_some auth then 236 236 + Logs.warn (fun m -> m "Invalid auth format, ignoring")); 237 237 + req 241 238 in 242 239 243 240 (* Build headers from command line *)

+15 -37

lib/http_client.ml

··· 166 166 167 167 (** {1 Request Execution} *) 168 168 169 169 + (** Apply auto-decompression to response if enabled *) 170 170 + let maybe_decompress ~limits ~auto_decompress (status, resp_headers, body_str) = 171 171 + match auto_decompress, Headers.get "content-encoding" resp_headers with 172 172 + | true, Some encoding -> 173 173 + let body_str = decompress_body ~limits ~content_encoding:encoding body_str in 174 174 + let resp_headers = Headers.remove "content-encoding" resp_headers in 175 175 + (status, resp_headers, body_str) 176 176 + | _ -> 177 177 + (status, resp_headers, body_str) 178 178 + 169 179 (** Make HTTP request over a pooled connection using Buf_write/Buf_read *) 170 180 let make_request ?(limits=default_limits) ~sw ~method_ ~uri ~headers ~body flow = 171 181 Log.debug (fun m -> m "Making %s request to %s" (Method.to_string method_) (Uri.to_string uri)); ··· 182 192 183 193 (** Make HTTP request with optional auto-decompression *) 184 194 let make_request_decompress ?(limits=default_limits) ~sw ~method_ ~uri ~headers ~body ~auto_decompress flow = 185 185 - let (status, resp_headers, body_str) = make_request ~limits ~sw ~method_ ~uri ~headers ~body flow in 186 186 - if auto_decompress then 187 187 - let body_str = match Headers.get "content-encoding" resp_headers with 188 188 - | Some encoding -> decompress_body ~limits ~content_encoding:encoding body_str 189 189 - | None -> body_str 190 190 - in 191 191 - (* Remove Content-Encoding header after decompression since body is now uncompressed *) 192 192 - let resp_headers = match Headers.get "content-encoding" resp_headers with 193 193 - | Some _ -> Headers.remove "content-encoding" resp_headers 194 194 - | None -> resp_headers 195 195 - in 196 196 - (status, resp_headers, body_str) 197 197 - else 198 198 - (status, resp_headers, body_str) 195 195 + make_request ~limits ~sw ~method_ ~uri ~headers ~body flow 196 196 + |> maybe_decompress ~limits ~auto_decompress 199 197 200 198 (** {1 HTTP 100-Continue Protocol Implementation} 201 199 ··· 369 367 let make_request_100_continue_decompress 370 368 ?(limits=default_limits) 371 369 ?(expect_100=default_expect_100_config) 372 372 - ~clock 373 373 - ~sw 374 374 - ~method_ 375 375 - ~uri 376 376 - ~headers 377 377 - ~body 378 378 - ~auto_decompress 379 379 - flow = 380 380 - let (status, resp_headers, body_str) = 381 381 - make_request_100_continue ~limits ~expect_100 ~clock ~sw ~method_ ~uri ~headers ~body flow 382 382 - in 383 383 - if auto_decompress then 384 384 - let body_str = match Headers.get "content-encoding" resp_headers with 385 385 - | Some encoding -> decompress_body ~limits ~content_encoding:encoding body_str 386 386 - | None -> body_str 387 387 - in 388 388 - let resp_headers = match Headers.get "content-encoding" resp_headers with 389 389 - | Some _ -> Headers.remove "content-encoding" resp_headers 390 390 - | None -> resp_headers 391 391 - in 392 392 - (status, resp_headers, body_str) 393 393 - else 394 394 - (status, resp_headers, body_str) 370 370 + ~clock ~sw ~method_ ~uri ~headers ~body ~auto_decompress flow = 371 371 + make_request_100_continue ~limits ~expect_100 ~clock ~sw ~method_ ~uri ~headers ~body flow 372 372 + |> maybe_decompress ~limits ~auto_decompress

+40 -33

lib/http_read.ml

··· 376 376 377 377 (** {1 High-level Response Parsing} *) 378 378 379 379 - (** Check if response should have no body per RFC 9110. 380 380 - Per RFC 9110 Section 6.4.1: 381 381 - - Any response to a HEAD request 382 382 - - Any 1xx (Informational) response 383 383 - - 204 (No Content) response 384 384 - - 304 (Not Modified) response *) 379 379 + (** Check if response should have no body per 380 380 + {{:https://datatracker.ietf.org/doc/html/rfc9110#section-6.4.1}RFC 9110 Section 6.4.1}: 381 381 + {ul 382 382 + {- Any response to a HEAD request} 383 383 + {- 2xx (Successful) response to a CONNECT request (switches to tunnel mode)} 384 384 + {- Any 1xx (Informational) response} 385 385 + {- 204 (No Content) response} 386 386 + {- 304 (Not Modified) response}} *) 385 387 let response_has_no_body ~method_ ~status = 386 386 - (method_ = Some `HEAD) || 387 387 - (status >= 100 && status < 200) || 388 388 - status = 204 || 389 389 - status = 304 388 388 + match method_, status with 389 389 + | Some `HEAD, _ -> true 390 390 + | Some `CONNECT, s when s >= 200 && s < 300 -> true 391 391 + | _, s when s >= 100 && s < 200 -> true 392 392 + | _, 204 | _, 304 -> true 393 393 + | _ -> false 390 394 391 391 - (** Parse complete response (status + headers + body) to string *) 395 395 + (** Helper to normalize and check transfer-encoding *) 396 396 + let is_chunked_encoding = function 397 397 + | None -> false 398 398 + | Some te -> String.lowercase_ascii te |> String.trim = "chunked" 399 399 + 400 400 + (** Parse complete response (status + headers + body) to string. 401 401 + Per {{:https://datatracker.ietf.org/doc/html/rfc9112#section-6}RFC 9112 Section 6}}. *) 392 402 let response ~limits ?method_ r = 393 393 - let (version, status) = status_line r in 403 403 + let version, status = status_line r in 394 404 let hdrs = headers ~limits r in 395 405 396 406 (* Per RFC 9110 Section 6.4.1: Certain responses MUST NOT have a body *) 397 397 - if response_has_no_body ~method_ ~status then begin 398 398 - Log.debug (fun m -> m "Response has no body (HEAD, 1xx, 204, or 304)"); 407 407 + if response_has_no_body ~method_ ~status then ( 408 408 + Log.debug (fun m -> m "Response has no body (HEAD, CONNECT 2xx, 1xx, 204, or 304)"); 399 409 (version, status, hdrs, "") 400 400 - end else begin 401 401 - (* Determine how to read body *) 410 410 + ) else 411 411 + (* Determine how to read body based on headers. 412 412 + Per RFC 9112 Section 6.3: Transfer-Encoding takes precedence over Content-Length *) 402 413 let transfer_encoding = Headers.get "transfer-encoding" hdrs in 403 414 let content_length = Headers.get "content-length" hdrs |> Option.map Int64.of_string in 404 404 - 405 405 - (* Per RFC 9112 Section 6.3: When both Transfer-Encoding and Content-Length 406 406 - are present, Transfer-Encoding takes precedence. The presence of both 407 407 - headers is a potential HTTP request smuggling attack indicator. *) 408 408 - let body = match transfer_encoding, content_length with 409 409 - | Some te, Some _ when String.lowercase_ascii te |> String.trim = "chunked" -> 410 410 - (* Both headers present - log warning per RFC 9112 Section 6.3 *) 415 415 + let body = match is_chunked_encoding transfer_encoding, content_length with 416 416 + | true, Some _ -> 417 417 + (* Both headers present - potential HTTP request smuggling indicator *) 411 418 Log.warn (fun m -> m "Both Transfer-Encoding and Content-Length present - \ 412 419 ignoring Content-Length per RFC 9112 (potential attack indicator)"); 413 420 chunked_body ~limits r 414 414 - | Some te, None when String.lowercase_ascii te |> String.trim = "chunked" -> 421 421 + | true, None -> 415 422 Log.debug (fun m -> m "Reading chunked response body"); 416 423 chunked_body ~limits r 417 417 - | _, Some len -> 424 424 + | false, Some len -> 418 425 Log.debug (fun m -> m "Reading fixed-length response body (%Ld bytes)" len); 419 426 fixed_body ~limits ~length:len r 420 420 - | Some other_te, None -> 421 421 - Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" other_te); 422 422 - "" 423 423 - | None, None -> 424 424 - Log.debug (fun m -> m "No body indicated"); 425 425 - "" 427 427 + | false, None -> 428 428 + (match transfer_encoding with 429 429 + | Some te -> 430 430 + Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" te); 431 431 + "" 432 432 + | None -> 433 433 + Log.debug (fun m -> m "No body indicated"); 434 434 + "") 426 435 in 427 427 - 428 436 (version, status, hdrs, body) 429 429 - end 430 437 431 438 (** Response with streaming body *) 432 439 type stream_response = {

+7 -3

lib/http_read.mli

··· 97 97 98 98 Returns [(http_version, status, headers, body)]. 99 99 100 100 - @param method_ The HTTP method of the request. When [`HEAD], the body 101 101 - is always empty regardless of Content-Length header (per RFC 9110 102 102 - Section 9.3.2). Similarly for 1xx, 204, and 304 responses. 100 100 + @param method_ The HTTP method of the request. Per 101 101 + {{:https://datatracker.ietf.org/doc/html/rfc9110#section-6.4.1}RFC 9110 Section 6.4.1}, 102 102 + certain responses have no body: 103 103 + {ul 104 104 + {- [`HEAD] - body is always empty regardless of Content-Length} 105 105 + {- [`CONNECT] with 2xx - switches to tunnel mode, no body} 106 106 + {- 1xx, 204, 304 - no content responses}} 103 107 104 108 This reads the entire body into memory. For large responses, 105 109 use {!response_stream} instead. *)

+5 -10

lib/one.ml

··· 265 265 (* Read response *) 266 266 let limits = Response_limits.default in 267 267 let buf_read = Http_read.of_flow ~max_size:65536 flow in 268 268 - let (_version, status, resp_headers, body_str) = 268 268 + let _version, status, resp_headers, body_str = 269 269 Http_read.response ~limits ~method_ buf_read in 270 270 (* Handle decompression if enabled *) 271 271 - let body_str = 272 272 - if auto_decompress then 273 273 - match Headers.get "content-encoding" resp_headers with 274 274 - | Some encoding -> 275 275 - Http_client.decompress_body 276 276 - ~limits:Response_limits.default 277 277 - ~content_encoding:encoding body_str 278 278 - | None -> body_str 279 279 - else body_str 271 271 + let body_str = match auto_decompress, Headers.get "content-encoding" resp_headers with 272 272 + | true, Some encoding -> 273 273 + Http_client.decompress_body ~limits ~content_encoding:encoding body_str 274 274 + | _ -> body_str 280 275 in 281 276 (status, resp_headers, body_str) 282 277

+5 -10

lib/requests.ml

··· 604 604 (* Read response *) 605 605 let limits = Response_limits.default in 606 606 let buf_read = Http_read.of_flow ~max_size:65536 flow in 607 607 - let (_version, status, resp_headers, body_str) = 607 607 + let _version, status, resp_headers, body_str = 608 608 Http_read.response ~limits ~method_ buf_read in 609 609 (* Handle decompression if enabled *) 610 610 - let body_str = 611 611 - if t.auto_decompress then 612 612 - match Headers.get "content-encoding" resp_headers with 613 613 - | Some encoding -> 614 614 - Http_client.decompress_body 615 615 - ~limits:Response_limits.default 616 616 - ~content_encoding:encoding body_str 617 617 - | None -> body_str 618 618 - else body_str 610 610 + let body_str = match t.auto_decompress, Headers.get "content-encoding" resp_headers with 611 611 + | true, Some encoding -> 612 612 + Http_client.decompress_body ~limits ~content_encoding:encoding body_str 613 613 + | _ -> body_str 619 614 in 620 615 (status, resp_headers, body_str) 621 616 )