jon.recoil.org
forked from
anil.recoil.org/monopam-myspace
My aggregated monorepo of OCaml code, automaintained
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** HTTP response parsing using Eio.Buf_read combinators
7
8 This module provides efficient HTTP/1.1 response parsing using Eio's
9 buffered read API with parser combinators for clean, composable parsing. *)
10
11let src = Logs.Src.create "requests.http_read" ~doc:"HTTP response parsing"
12module Log = (val Logs.src_log src : Logs.LOG)
13
14module Read = Eio.Buf_read
15
16(** Import limits from Response_limits module. *)
17type limits = Response_limits.t
18
19(** {1 Character Predicates} *)
20
21(** HTTP version characters: letters, digits, slash, dot *)
22let is_version_char = function
23 | 'A'..'Z' | 'a'..'z' | '0'..'9' | '/' | '.' -> true
24 | _ -> false
25
26(** HTTP status code digits *)
27let is_digit = function
28 | '0'..'9' -> true
29 | _ -> false
30
31(** RFC 9110 token characters for header names *)
32let is_token_char = function
33 | 'A'..'Z' | 'a'..'z' | '0'..'9' -> true
34 | '!' | '#' | '$' | '%' | '&' | '\'' | '*' | '+' | '-' | '.' -> true
35 | '^' | '_' | '`' | '|' | '~' -> true
36 | _ -> false
37
38(** Hex digits for chunk size *)
39let is_hex_digit = function
40 | '0'..'9' | 'a'..'f' | 'A'..'F' -> true
41 | _ -> false
42
43(** Optional whitespace *)
44let is_ows = function
45 | ' ' | '\t' -> true
46 | _ -> false
47
48(** {1 Security Validation}
49
50 Per RFC 9112 Section 2.2: bare CR MUST be rejected to prevent
51 HTTP request smuggling attacks. *)
52
53(** Maximum chunk size hex digits (16 hex digits = 64-bit max) *)
54let max_chunk_size_hex_digits = 16
55
56(** Validate that a string contains no bare CR characters.
57 A bare CR is a CR not followed by LF, which can be used for
58 HTTP request smuggling attacks.
59 @raise Error.t if bare CR is found. *)
60let validate_no_bare_cr ~context s =
61 let len = String.length s in
62 for i = 0 to len - 1 do
63 if s.[i] = '\r' then begin
64 if i + 1 >= len || s.[i + 1] <> '\n' then
65 raise (Error.invalid_requestf "Bare CR in %s (potential HTTP smuggling attack)" context)
66 end
67 done
68
69(** {1 Low-level Parsers} *)
70
71let sp = Read.char ' '
72
73let http_version r =
74 Read.take_while is_version_char r
75
76let status_code r =
77 let code_str = Read.take_while is_digit r in
78 if String.length code_str <> 3 then
79 raise (Error.invalid_requestf "Invalid status code: %s" code_str);
80 try int_of_string code_str
81 with _ ->
82 raise (Error.invalid_requestf "Invalid status code: %s" code_str)
83
84let reason_phrase r =
85 Read.line r
86
87(** {1 HTTP Version Type}
88
89 Per Recommendation #26: Expose HTTP version used for the response *)
90
91type http_version =
92 | HTTP_1_0
93 | HTTP_1_1
94
95let http_version_of_string = function
96 | "HTTP/1.0" -> HTTP_1_0
97 | "HTTP/1.1" -> HTTP_1_1
98 | v -> raise (Error.invalid_requestf "Invalid HTTP version: %s" v)
99
100let http_version_to_string = function
101 | HTTP_1_0 -> "HTTP/1.0"
102 | HTTP_1_1 -> "HTTP/1.1"
103
104(** {1 Status Line Parser} *)
105
106let status_line r =
107 let version_str = http_version r in
108 (* Parse and validate HTTP version *)
109 let version = http_version_of_string version_str in
110 sp r;
111 let code = status_code r in
112 sp r;
113 let reason = reason_phrase r in
114 (* RFC 9112 Section 2.2: Validate no bare CR in reason phrase *)
115 validate_no_bare_cr ~context:"reason phrase" reason;
116 Log.debug (fun m -> m "Parsed status line: %s %d" version_str code);
117 (version, code)
118
119(** {1 Header Parsing} *)
120
121(** Parse a single header line. Returns ("", "") for empty line (end of headers).
122 Handles obs-fold (RFC 9112 Section 5.2): continuation lines starting with
123 whitespace are merged into the previous header value with a single space.
124 Per RFC 9112 Section 2.2: validates that no bare CR characters are present. *)
125let header_line r =
126 let name = Read.take_while is_token_char r in
127 if name = "" then begin
128 (* Empty line - end of headers. Consume the CRLF. *)
129 let line = Read.line r in
130 if line <> "" then
131 raise (Error.err (Error.Invalid_request {
132 reason = "Expected empty line but got: " ^ line
133 }));
134 ("", "")
135 end else begin
136 Read.char ':' r;
137 Read.skip_while is_ows r;
138 let value = Read.line r in
139 (* RFC 9112 Section 2.2: Validate no bare CR in header value *)
140 validate_no_bare_cr ~context:"header value" value;
141 (* RFC 9112 Section 5.2: Handle obs-fold (obsolete line folding)
142 A recipient of an obs-fold MUST replace each obs-fold with one or more
143 SP octets prior to interpreting the field value. *)
144 let rec collect_obs_fold acc =
145 match Read.peek_char r with
146 | Some (' ' | '\t') ->
147 (* obs-fold: continuation line starts with whitespace *)
148 Log.debug (fun m -> m "Handling obs-fold continuation for header %s" name);
149 Read.skip_while is_ows r;
150 let continuation = Read.line r in
151 (* Validate continuation for bare CR *)
152 validate_no_bare_cr ~context:"header continuation" continuation;
153 (* Replace obs-fold with single space and continue *)
154 collect_obs_fold (acc ^ " " ^ String.trim continuation)
155 | _ -> acc
156 in
157 let full_value = collect_obs_fold value in
158 (String.lowercase_ascii name, String.trim full_value)
159 end
160
161(** Parse all headers with size and count limits *)
162let headers ~limits r =
163 let max_count = Response_limits.max_header_count limits in
164 let max_size = Response_limits.max_header_size limits in
165 let rec loop acc count =
166 (* Check header count limit *)
167 if count >= max_count then
168 raise (Error.err (Error.Headers_too_large {
169 limit = max_count;
170 actual = count + 1
171 }));
172
173 let (name, value) = header_line r in
174
175 if name = "" then begin
176 (* End of headers *)
177 Log.debug (fun m -> m "Parsed %d headers" count);
178 Headers.of_list (List.rev acc)
179 end else begin
180 (* Check header line size limit *)
181 let line_len = String.length name + String.length value + 2 in
182 if line_len > max_size then
183 raise (Error.err (Error.Headers_too_large {
184 limit = max_size;
185 actual = line_len
186 }));
187
188 loop ((name, value) :: acc) (count + 1)
189 end
190 in
191 loop [] 0
192
193(** {1 Body Parsing} *)
194
195(** Read body until connection close (close-delimited message).
196 Per RFC 9112 Section 6.3 item 8: When no Transfer-Encoding or Content-Length
197 is present, the body length is determined by reading until connection close. *)
198let close_delimited_body ~limits r =
199 let max_body = Response_limits.max_response_body_size limits in
200 Log.debug (fun m -> m "Reading close-delimited body (until EOF)");
201
202 let buf = Buffer.create 8192 in
203 let bytes_read = ref 0L in
204
205 let rec read_until_eof () =
206 (* Check size limit *)
207 if !bytes_read > max_body then
208 raise (Error.err (Error.Body_too_large {
209 limit = max_body;
210 actual = Some !bytes_read
211 }));
212
213 (* Try to read a chunk - at_end_of_input returns true when EOF reached *)
214 if Read.at_end_of_input r then
215 Buffer.contents buf
216 else begin
217 (* Read up to 8KB at a time *)
218 let chunk = Read.take_while (fun _ -> true) r in
219 let chunk_len = String.length chunk in
220 if chunk_len > 0 then begin
221 Buffer.add_string buf chunk;
222 bytes_read := Int64.add !bytes_read (Int64.of_int chunk_len);
223 read_until_eof ()
224 end else
225 (* No more data available *)
226 Buffer.contents buf
227 end
228 in
229 read_until_eof ()
230
231(** Read a fixed-length body with size limit checking *)
232let fixed_body ~limits ~length r =
233 let max_body = Response_limits.max_response_body_size limits in
234 (* Check size limit before allocating *)
235 if length > max_body then
236 raise (Error.err (Error.Body_too_large {
237 limit = max_body;
238 actual = Some length
239 }));
240
241 Log.debug (fun m -> m "Reading fixed-length body: %Ld bytes" length);
242
243 let len_int = Int64.to_int length in
244 let buf = Buffer.create len_int in
245 let bytes_read = ref 0L in
246
247 let rec read_n remaining =
248 if remaining > 0L then begin
249 let to_read = min 8192 (Int64.to_int remaining) in
250 let chunk = Read.take to_read r in
251 let chunk_len = String.length chunk in
252
253 if chunk_len = 0 then
254 (* Connection closed prematurely - Content-Length mismatch *)
255 raise (Error.err (Error.Content_length_mismatch {
256 expected = length;
257 actual = !bytes_read
258 }))
259 else begin
260 Buffer.add_string buf chunk;
261 bytes_read := Int64.add !bytes_read (Int64.of_int chunk_len);
262 read_n (Int64.sub remaining (Int64.of_int chunk_len))
263 end
264 end
265 in
266 read_n length;
267 Buffer.contents buf
268
269(** Parse chunk size line (hex size with optional extensions).
270 Per RFC 9112 Section 7.1: protect against chunk size overflow attacks. *)
271let chunk_size r =
272 let hex_str = Read.take_while is_hex_digit r in
273 if hex_str = "" then
274 raise (Error.err (Error.Invalid_request {
275 reason = "Empty chunk size"
276 }));
277 (* Protect against overflow: limit hex digits to prevent parsing huge numbers.
278 16 hex digits = 64-bit max, which is way more than any reasonable chunk. *)
279 if String.length hex_str > max_chunk_size_hex_digits then
280 raise (Error.invalid_requestf "Chunk size too large (%d hex digits, max %d)"
281 (String.length hex_str) max_chunk_size_hex_digits);
282 (* Skip any chunk extensions (after semicolon) - validate for bare CR *)
283 let extensions = Read.take_while (fun c -> c <> '\r' && c <> '\n') r in
284 validate_no_bare_cr ~context:"chunk extension" extensions;
285 let _ = Read.line r in (* Consume CRLF *)
286 try int_of_string ("0x" ^ hex_str)
287 with _ ->
288 raise (Error.invalid_requestf "Invalid chunk size: %s" hex_str)
289
290(** {1 Trailer Header Parsing}
291
292 Per RFC 9112 Section 7.1.2: Trailer section can contain headers after the
293 final chunk. Certain headers MUST NOT be in trailers (hop-by-hop, content-*, etc.). *)
294
295(** Headers that MUST NOT appear in trailers per RFC 9110 Section 6.5.1 *)
296let forbidden_trailer_headers = [
297 "transfer-encoding"; "content-length"; "host"; "content-encoding";
298 "content-type"; "content-range"; "trailer"
299]
300
301(** Parse trailer headers after final chunk.
302 Returns parsed headers. Forbidden trailer headers are logged and ignored. *)
303let parse_trailers ~limits r =
304 let max_count = Response_limits.max_header_count limits in
305 let max_size = Response_limits.max_header_size limits in
306 let rec loop acc count =
307 if count >= max_count then begin
308 Log.warn (fun m -> m "Trailer count limit reached (%d), skipping remaining" max_count);
309 Headers.of_list (List.rev acc)
310 end else begin
311 let line = Read.line r in
312 if line = "" then
313 (* End of trailers *)
314 Headers.of_list (List.rev acc)
315 else
316 (* Parse trailer line *)
317 match String.index_opt line ':' with
318 | None ->
319 Log.warn (fun m -> m "Invalid trailer line (no colon): %s" line);
320 loop acc count
321 | Some colon_idx ->
322 let name = String.sub line 0 colon_idx |> String.trim |> String.lowercase_ascii in
323 let value = String.sub line (colon_idx + 1) (String.length line - colon_idx - 1) |> String.trim in
324 (* Check header size *)
325 let line_len = String.length name + String.length value + 2 in
326 if line_len > max_size then begin
327 Log.warn (fun m -> m "Trailer header too large (%d > %d), skipping: %s" line_len max_size name);
328 loop acc count
329 end else if List.mem name forbidden_trailer_headers then begin
330 Log.warn (fun m -> m "Forbidden header in trailers, ignoring: %s" name);
331 loop acc count
332 end else
333 loop ((name, value) :: acc) (count + 1)
334 end
335 in
336 loop [] 0
337
338(** Skip trailer headers after final chunk (legacy compatibility) *)
339let skip_trailers r =
340 let rec loop () =
341 let line = Read.line r in
342 if line <> "" then loop ()
343 in
344 loop ()
345
346(** Read a chunked transfer-encoded body with size limit checking *)
347let chunked_body ~limits r =
348 Log.debug (fun m -> m "Reading chunked body");
349 let max_body = Response_limits.max_response_body_size limits in
350 let buf = Buffer.create 4096 in
351 let total_size = ref 0L in
352
353 let rec read_chunks () =
354 let size = chunk_size r in
355
356 if size = 0 then begin
357 (* Final chunk - skip trailers *)
358 skip_trailers r;
359 Log.debug (fun m -> m "Chunked body complete: %Ld bytes" !total_size);
360 Buffer.contents buf
361 end else begin
362 (* Check size limit before reading chunk *)
363 let new_total = Int64.add !total_size (Int64.of_int size) in
364 if new_total > max_body then
365 raise (Error.err (Error.Body_too_large {
366 limit = max_body;
367 actual = Some new_total
368 }));
369
370 let chunk = Read.take size r in
371 Buffer.add_string buf chunk;
372 total_size := new_total;
373 let _ = Read.line r in (* Consume trailing CRLF *)
374 read_chunks ()
375 end
376 in
377 read_chunks ()
378
379(** {1 Streaming Body Sources} *)
380
381(** A flow source that reads from a Buf_read with a fixed length limit *)
382module Fixed_body_source = struct
383 type t = {
384 buf_read : Read.t;
385 mutable remaining : int64;
386 }
387
388 let single_read t dst =
389 if t.remaining <= 0L then raise End_of_file;
390
391 let to_read = min (Cstruct.length dst) (Int64.to_int (min t.remaining 8192L)) in
392
393 (* Ensure data is available *)
394 Read.ensure t.buf_read to_read;
395 let src = Read.peek t.buf_read in
396 let actual = min to_read (Cstruct.length src) in
397
398 Cstruct.blit src 0 dst 0 actual;
399 Read.consume t.buf_read actual;
400 t.remaining <- Int64.sub t.remaining (Int64.of_int actual);
401 actual
402
403 let read_methods = []
404end
405
406let fixed_body_stream ~limits ~length buf_read =
407 let max_body = Response_limits.max_response_body_size limits in
408 (* Check size limit *)
409 if length > max_body then
410 raise (Error.err (Error.Body_too_large {
411 limit = max_body;
412 actual = Some length
413 }));
414
415 let t = { Fixed_body_source.buf_read; remaining = length } in
416 let ops = Eio.Flow.Pi.source (module Fixed_body_source) in
417 Eio.Resource.T (t, ops)
418
419(** A flow source that reads chunked transfer encoding from a Buf_read *)
420module Chunked_body_source = struct
421 type state =
422 | Reading_size
423 | Reading_chunk of int
424 | Reading_chunk_end
425 | Done
426
427 type t = {
428 buf_read : Read.t;
429 mutable state : state;
430 mutable total_read : int64;
431 max_body_size : int64;
432 }
433
434 let read_chunk_size t =
435 let hex_str = Read.take_while is_hex_digit t.buf_read in
436 if hex_str = "" then 0
437 else begin
438 (* Protect against overflow: limit hex digits *)
439 if String.length hex_str > max_chunk_size_hex_digits then
440 raise (Error.err (Error.Invalid_request {
441 reason = Printf.sprintf "Chunk size too large (%d hex digits)"
442 (String.length hex_str)
443 }));
444 (* Skip extensions and CRLF - validate for bare CR *)
445 let extensions = Read.take_while (fun c -> c <> '\r' && c <> '\n') t.buf_read in
446 validate_no_bare_cr ~context:"chunk extension" extensions;
447 let _ = Read.line t.buf_read in
448 try int_of_string ("0x" ^ hex_str)
449 with _ -> 0
450 end
451
452 let single_read t dst =
453 let rec aux () =
454 match t.state with
455 | Done -> raise End_of_file
456 | Reading_size ->
457 let size = read_chunk_size t in
458 if size = 0 then begin
459 (* Skip trailers *)
460 let rec skip () =
461 let line = Read.line t.buf_read in
462 if line <> "" then skip ()
463 in
464 skip ();
465 t.state <- Done;
466 raise End_of_file
467 end else begin
468 (* Check size limit *)
469 let new_total = Int64.add t.total_read (Int64.of_int size) in
470 if new_total > t.max_body_size then
471 raise (Error.err (Error.Body_too_large {
472 limit = t.max_body_size;
473 actual = Some new_total
474 }));
475 t.state <- Reading_chunk size;
476 aux ()
477 end
478 | Reading_chunk remaining ->
479 let to_read = min (Cstruct.length dst) remaining in
480 Read.ensure t.buf_read to_read;
481 let src = Read.peek t.buf_read in
482 let actual = min to_read (Cstruct.length src) in
483 Cstruct.blit src 0 dst 0 actual;
484 Read.consume t.buf_read actual;
485 t.total_read <- Int64.add t.total_read (Int64.of_int actual);
486 let new_remaining = remaining - actual in
487 if new_remaining = 0 then
488 t.state <- Reading_chunk_end
489 else
490 t.state <- Reading_chunk new_remaining;
491 actual
492 | Reading_chunk_end ->
493 let _ = Read.line t.buf_read in (* Consume trailing CRLF *)
494 t.state <- Reading_size;
495 aux ()
496 in
497 aux ()
498
499 let read_methods = []
500end
501
502let chunked_body_stream ~limits buf_read =
503 let t = {
504 Chunked_body_source.buf_read;
505 state = Reading_size;
506 total_read = 0L;
507 max_body_size = Response_limits.max_response_body_size limits;
508 } in
509 let ops = Eio.Flow.Pi.source (module Chunked_body_source) in
510 Eio.Resource.T (t, ops)
511
512(** A flow source that reads until connection close (close-delimited).
513 Per RFC 9112 Section 6.3 item 8: When no Transfer-Encoding or Content-Length
514 is present, the body length is determined by reading until connection close. *)
515module Close_delimited_source = struct
516 type t = {
517 buf_read : Read.t;
518 mutable total_read : int64;
519 max_body_size : int64;
520 mutable eof : bool;
521 }
522
523 let single_read t dst =
524 if t.eof then raise End_of_file;
525
526 (* Check size limit *)
527 if t.total_read > t.max_body_size then
528 raise (Error.err (Error.Body_too_large {
529 limit = t.max_body_size;
530 actual = Some t.total_read
531 }));
532
533 if Read.at_end_of_input t.buf_read then begin
534 t.eof <- true;
535 raise End_of_file
536 end;
537
538 let to_read = min (Cstruct.length dst) 8192 in
539 (* Try to ensure data is available, but don't fail on EOF *)
540 (try Read.ensure t.buf_read 1 with End_of_file ->
541 t.eof <- true;
542 raise End_of_file);
543
544 let src = Read.peek t.buf_read in
545 let available = Cstruct.length src in
546 if available = 0 then begin
547 t.eof <- true;
548 raise End_of_file
549 end;
550
551 let actual = min to_read available in
552 Cstruct.blit src 0 dst 0 actual;
553 Read.consume t.buf_read actual;
554 t.total_read <- Int64.add t.total_read (Int64.of_int actual);
555 actual
556
557 let read_methods = []
558end
559
560let close_delimited_body_stream ~limits buf_read =
561 let t = {
562 Close_delimited_source.buf_read;
563 total_read = 0L;
564 max_body_size = Response_limits.max_response_body_size limits;
565 eof = false;
566 } in
567 let ops = Eio.Flow.Pi.source (module Close_delimited_source) in
568 Eio.Resource.T (t, ops)
569
570(** {1 High-level Response Parsing} *)
571
572(** Check if response should have no body per
573 {{:https://datatracker.ietf.org/doc/html/rfc9110#section-6.4.1}RFC 9110 Section 6.4.1}:
574 {ul
575 {- Any response to a HEAD request}
576 {- 2xx (Successful) response to a CONNECT request (switches to tunnel mode)}
577 {- Any 1xx (Informational) response}
578 {- 204 (No Content) response}
579 {- 304 (Not Modified) response}} *)
580let response_has_no_body ~method_ ~status =
581 match method_, status with
582 | Some `HEAD, _ -> true
583 | Some `CONNECT, s when s >= 200 && s < 300 -> true
584 | _, s when s >= 100 && s < 200 -> true
585 | _, 204 | _, 304 -> true
586 | _ -> false
587
588(** {1 Transfer-Encoding Validation}
589
590 Per RFC 9112 Section 6.1: Transfer-Encoding is a list of transfer codings.
591 If "chunked" is present, it MUST be the final encoding. The encodings are
592 applied in order, so we must reject unknown encodings that appear before chunked.
593
594 Per RFC 9112 Section 6.1: A server MUST NOT send Transfer-Encoding in:
595 - A response to a HEAD request
596 - Any 1xx (Informational) response
597 - A 204 (No Content) response
598 - A 304 (Not Modified) response *)
599
600(** Validate that Transfer-Encoding is not present in responses that MUST NOT have it.
601 Per RFC 9112 Section 6.1: These responses must not include Transfer-Encoding.
602 If present, this is a protocol violation but we log and continue.
603 @return true if Transfer-Encoding is present (violation), false otherwise *)
604let validate_no_transfer_encoding ~method_ ~status transfer_encoding =
605 let should_not_have_te =
606 match method_, status with
607 | Some `HEAD, _ -> true (* HEAD responses must not have TE *)
608 | _, s when s >= 100 && s < 200 -> true (* 1xx responses *)
609 | _, 204 -> true (* 204 No Content *)
610 | _, 304 -> true (* 304 Not Modified *)
611 | _ -> false
612 in
613 match transfer_encoding, should_not_have_te with
614 | Some te, true ->
615 Log.warn (fun m -> m "RFC 9112 violation: Transfer-Encoding '%s' in %s response \
616 (status %d) - ignoring per spec" te
617 (match method_ with Some `HEAD -> "HEAD" | _ -> "bodiless")
618 status);
619 true
620 | _ -> false
621
622(** Parse Transfer-Encoding header into list of codings.
623 Returns list in order (first coding is outermost) *)
624let parse_transfer_encoding = function
625 | None -> []
626 | Some te ->
627 String.split_on_char ',' te
628 |> List.map (fun s -> String.trim (String.lowercase_ascii s))
629 |> List.filter (fun s -> s <> "")
630
631(** Validate Transfer-Encoding per RFC 9112 Section 6.1.
632 Returns [`Chunked] if chunked encoding should be used, [`None] if no body,
633 or raises an error for invalid encodings.
634 @raise Error.t if chunked is not final or unknown encodings precede chunked *)
635let validate_transfer_encoding encodings =
636 match encodings with
637 | [] -> `None
638 | codings ->
639 (* Find position of chunked if present *)
640 let chunked_idx =
641 List.mapi (fun i c -> (i, c)) codings
642 |> List.find_map (fun (i, c) -> if c = "chunked" then Some i else None)
643 in
644 match chunked_idx with
645 | None ->
646 (* No chunked encoding - check if we support any of these *)
647 Log.warn (fun m -> m "Transfer-Encoding without chunked: %s (not supported)"
648 (String.concat ", " codings));
649 `Unsupported codings
650 | Some idx ->
651 (* Per RFC 9112 Section 6.1: chunked MUST be the final transfer coding *)
652 if idx <> List.length codings - 1 then begin
653 Log.err (fun m -> m "Transfer-Encoding: chunked is not final (RFC 9112 violation)");
654 raise (Error.err (Error.Invalid_request {
655 reason = "Transfer-Encoding: chunked must be the final encoding"
656 }))
657 end;
658 (* Check encodings before chunked - we only support identity *)
659 let before_chunked = List.filteri (fun i _ -> i < idx) codings in
660 List.iter (fun enc ->
661 match enc with
662 | "identity" -> () (* identity is a no-op *)
663 | other ->
664 Log.warn (fun m -> m "Unsupported encoding '%s' before chunked (treating as identity)" other)
665 ) before_chunked;
666 `Chunked
667
668(** Helper to check if transfer-encoding indicates chunked *)
669let is_chunked_encoding transfer_encoding =
670 match validate_transfer_encoding (parse_transfer_encoding transfer_encoding) with
671 | `Chunked -> true
672 | `None | `Unsupported _ -> false
673
674(** Safely parse Content-Length header, returning None for invalid values.
675 Per RFC 9110 Section 8.6: Content-Length must be >= 0.
676 @raise Error.t if Content-Length is invalid or negative. *)
677let parse_content_length = function
678 | None -> None
679 | Some s ->
680 try
681 let len = Int64.of_string s in
682 (* Per RFC 9110 Section 8.6: Content-Length MUST be >= 0 *)
683 if len < 0L then begin
684 Log.warn (fun m -> m "Negative Content-Length rejected: %s" s);
685 raise (Error.invalid_requestf "Content-Length cannot be negative: %s" s)
686 end;
687 Some len
688 with Failure _ ->
689 Log.warn (fun m -> m "Invalid Content-Length header value: %s" s);
690 raise (Error.invalid_requestf "Invalid Content-Length header: %s" s)
691
692(** Parse complete response (status + headers + body) to string.
693 Per {{:https://datatracker.ietf.org/doc/html/rfc9112#section-6}RFC 9112 Section 6}}. *)
694let response ~limits ?method_ r =
695 let version, status = status_line r in
696 let hdrs = headers ~limits r in
697
698 (* Per RFC 9112 Section 6.1: Validate Transfer-Encoding not present in bodiless responses *)
699 let transfer_encoding = Headers.get `Transfer_encoding hdrs in
700 let _ = validate_no_transfer_encoding ~method_ ~status transfer_encoding in
701
702 (* Per RFC 9110 Section 6.4.1: Certain responses MUST NOT have a body *)
703 if response_has_no_body ~method_ ~status then (
704 Log.debug (fun m -> m "Response has no body (HEAD, CONNECT 2xx, 1xx, 204, or 304)");
705 (version, status, hdrs, "")
706 ) else
707 (* Determine how to read body based on headers.
708 Per RFC 9112 Section 6.3: Transfer-Encoding takes precedence over Content-Length *)
709 let content_length = parse_content_length (Headers.get `Content_length hdrs) in
710 let body = match is_chunked_encoding transfer_encoding, content_length with
711 | true, Some _ ->
712 (* Both headers present - potential HTTP request smuggling indicator *)
713 Log.warn (fun m -> m "Both Transfer-Encoding and Content-Length present - \
714 ignoring Content-Length per RFC 9112 (potential attack indicator)");
715 chunked_body ~limits r
716 | true, None ->
717 Log.debug (fun m -> m "Reading chunked response body");
718 chunked_body ~limits r
719 | false, Some len ->
720 Log.debug (fun m -> m "Reading fixed-length response body (%Ld bytes)" len);
721 fixed_body ~limits ~length:len r
722 | false, None ->
723 (match transfer_encoding with
724 | Some te ->
725 Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" te);
726 ""
727 | None ->
728 (* RFC 9112 Section 6.3 item 8: If no Transfer-Encoding or Content-Length,
729 the body length is determined by reading until connection close.
730 This is common for HTTP/1.0 responses. *)
731 Log.debug (fun m -> m "No length indicators, reading until connection close");
732 close_delimited_body ~limits r)
733 in
734 (version, status, hdrs, body)
735
736(** Response with streaming body *)
737type stream_response = {
738 http_version : http_version;
739 status : int;
740 headers : Headers.t;
741 body : [ `String of string
742 | `Stream of Eio.Flow.source_ty Eio.Resource.t
743 | `None ]
744}
745
746let response_stream ~limits ?method_ r =
747 let (version, status) = status_line r in
748 let hdrs = headers ~limits r in
749
750 (* Per RFC 9112 Section 6.1: Validate Transfer-Encoding not present in bodiless responses *)
751 let transfer_encoding = Headers.get `Transfer_encoding hdrs in
752 let _ = validate_no_transfer_encoding ~method_ ~status transfer_encoding in
753
754 (* Determine body type *)
755 let content_length = parse_content_length (Headers.get `Content_length hdrs) in
756
757 (* Per RFC 9112 Section 6.3: When both Transfer-Encoding and Content-Length
758 are present, Transfer-Encoding takes precedence. The presence of both
759 headers is a potential HTTP request smuggling attack indicator. *)
760 let body = match is_chunked_encoding transfer_encoding, content_length with
761 | true, Some _ ->
762 (* Both headers present - log warning per RFC 9112 Section 6.3 *)
763 Log.warn (fun m -> m "Both Transfer-Encoding and Content-Length present - \
764 ignoring Content-Length per RFC 9112 (potential attack indicator)");
765 `Stream (chunked_body_stream ~limits r)
766 | true, None ->
767 Log.debug (fun m -> m "Creating chunked body stream");
768 `Stream (chunked_body_stream ~limits r)
769 | false, Some len ->
770 Log.debug (fun m -> m "Creating fixed-length body stream (%Ld bytes)" len);
771 `Stream (fixed_body_stream ~limits ~length:len r)
772 | false, None ->
773 (match transfer_encoding with
774 | Some te ->
775 Log.warn (fun m -> m "Unsupported transfer-encoding: %s, assuming no body" te);
776 `None
777 | None ->
778 (* RFC 9112 Section 6.3 item 8: If no Transfer-Encoding or Content-Length,
779 the body length is determined by reading until connection close. *)
780 Log.debug (fun m -> m "Creating close-delimited body stream");
781 `Stream (close_delimited_body_stream ~limits r))
782 in
783
784 { http_version = version; status; headers = hdrs; body }
785
786(** {1 Convenience Functions} *)
787
788let of_flow ?initial_size ~max_size flow =
789 Read.of_flow ?initial_size ~max_size flow