An OCaml webserver, but the allocating version (vs httpz which doesnt)
anil.recoil.org
1(* request_parse.ml - HTTP request parsing logic *)
2
3open Base
4
5(* Connection header disposition *)
6type conn_value = Conn_default | Conn_close | Conn_keep_alive
7
8(* Header parsing state *)
9type header_state =
10 { count : int
11 ; content_len : int64
12 ; chunked : bool
13 ; conn : conn_value
14 ; has_cl : bool
15 ; has_te : bool
16 ; has_host : bool
17 ; expect_continue : bool
18 }
19
20let initial_header_state =
21 { count = 0
22 ; content_len = -1L
23 ; chunked = false
24 ; conn = Conn_default
25 ; has_cl = false
26 ; has_te = false
27 ; has_host = false
28 ; expect_continue = false
29 }
30
31(* Helper to create error result with empty request *)
32let error_result status =
33 ( status
34 , { Req.meth = Method.Get
35 ; target = Span.make ~off:0 ~len:0
36 ; version = Version.Http_1_1
37 ; body_off = 0
38 ; content_length = -1L
39 ; is_chunked = false
40 ; keep_alive = true
41 ; expect_continue = false
42 }
43 , ([] : Header.t list) )
44
45(* Build successful request from parsed components and state *)
46let build_request ~meth ~target ~version ~body_off st ~headers =
47 let keep_alive =
48 match st.conn with
49 | Conn_close -> false
50 | Conn_keep_alive -> true
51 | Conn_default -> Poly.( = ) version Version.Http_1_1
52 in
53 let req =
54 { Req.meth
55 ; target
56 ; version
57 ; body_off
58 ; content_length = st.content_len
59 ; is_chunked = st.chunked
60 ; keep_alive
61 ; expect_continue = st.expect_continue
62 }
63 in
64 (Buf_read.Complete, req, headers)
65
66(* Determine Connection header value *)
67let parse_connection_value buf value_span ~default =
68 if Span.equal_caseless buf value_span "close" then Conn_close
69 else if Span.equal_caseless buf value_span "keep-alive" then Conn_keep_alive
70 else default
71
72(* Parse headers using Parser combinators. Raises Err.Parse_error on failure.
73 Position is threaded explicitly for zero allocation. *)
74let rec parse_headers_loop pst ~pos ~acc st ~limits =
75 let open Buf_read in
76 if Parser.is_headers_end pst ~pos then (
77 let pos = Parser.end_headers pst ~pos in
78 (pos, st, acc)
79 )
80 else (
81 Err.when_ (st.count >= limits.max_header_count) Err.Headers_too_large;
82 let (name, name_span, value_span, pos) = Parser.parse_header pst ~pos in
83 Err.when_ (has_bare_cr pst.buf ~pos:(Span.off value_span) ~len:(Span.len value_span))
84 Err.Bare_cr_detected;
85 let next_count = st.count + 1 in
86 match name with
87 | Header_name.Content_length ->
88 Err.when_ st.has_te Err.Ambiguous_framing;
89 let (parsed_len, overflow) =
90 Span.parse_int64_limited pst.buf value_span ~max_value:limits.max_content_length
91 in
92 Err.when_ overflow Err.Content_length_overflow;
93 parse_headers_loop pst ~pos ~acc ~limits
94 { st with count = next_count; content_len = parsed_len; has_cl = true }
95 | Header_name.Transfer_encoding ->
96 Err.when_ st.has_cl Err.Ambiguous_framing;
97 let is_chunked = Span.equal_caseless pst.buf value_span "chunked" in
98 let is_identity = Span.equal_caseless pst.buf value_span "identity" in
99 Err.when_ (not (is_chunked || is_identity)) Err.Unsupported_transfer_encoding;
100 parse_headers_loop pst ~pos ~acc ~limits
101 { st with count = next_count; chunked = is_chunked; has_te = true }
102 | Header_name.Host ->
103 let hdr = { Header.name; name_span; value = value_span } in
104 parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
105 { st with count = next_count; has_host = true }
106 | Header_name.Connection ->
107 let new_conn = parse_connection_value pst.buf value_span ~default:st.conn in
108 parse_headers_loop pst ~pos ~acc ~limits
109 { st with count = next_count; conn = new_conn }
110 | Header_name.Expect ->
111 let is_continue = Span.equal_caseless pst.buf value_span "100-continue" in
112 parse_headers_loop pst ~pos ~acc ~limits
113 { st with count = next_count; expect_continue = is_continue || st.expect_continue }
114 | _ ->
115 let hdr = { Header.name; name_span; value = value_span } in
116 parse_headers_loop pst ~pos ~acc:(hdr :: acc) ~limits
117 { st with count = next_count }
118 )
119
120(* Parse HTTP request with configurable limits and full RFC 7230 validation.
121 Uses Parser combinators for cleaner, more maintainable parsing. *)
122let parse buf ~len ~limits =
123 let open Buf_read in
124 if len > buffer_size || len > limits.max_header_size then
125 error_result Headers_too_large
126 else
127 try
128 let pst = Parser.make buf ~len in
129 let (meth, target, version, pos) = Parser.request_line pst ~pos:0 in
130 let (body_off, st, headers) =
131 parse_headers_loop pst ~pos ~acc:[] initial_header_state ~limits
132 in
133 (* Only missing Host header needs end-of-parse check *)
134 match (version, st.has_host) with
135 | (Version.Http_1_1, false) -> error_result Missing_host_header
136 | _ -> build_request ~meth ~target ~version ~body_off st ~headers
137 with Err.Parse_error status ->
138 error_result status