gazagnaire.org
HTTP/2 framing, HPACK and connection state, I/O-free
1(*---------------------------------------------------------------------------
2 Copyright (c) 2019 Antonio Nuno Monteiro. Copyright (c) 2025 Anil Madhavapeddy
3 <anil@recoil.org>.
4
5 All rights reserved.
6
7 Redistribution and use in source and binary forms, with or without
8 modification, are permitted provided that the following conditions are met:
9
10 1. Redistributions of source code must retain the above copyright notice, this
11 list of conditions and the following disclaimer.
12
13 2. Redistributions in binary form must reproduce the above copyright notice,
14 this list of conditions and the following disclaimer in the documentation
15 and/or other materials provided with the distribution.
16
17 3. Neither the name of the copyright holder nor the names of its contributors
18 may be used to endorse or promote products derived from this software without
19 specific prior written permission.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
22 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
24 DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
25 FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
27 SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
29 OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 SPDX-License-Identifier: BSD-3-Clause
32 ---------------------------------------------------------------------------*)
33
34(** HPACK Header Compression per RFC 7541.
35
36 This module implements header compression for HTTP/2, including:
37 - Static and dynamic table management
38 - Huffman encoding/decoding
39 - Integer encoding with variable-length prefix
40 - String literal encoding
41
42 Derived from ocaml-h2 with adaptation for Bytes-based operations. *)
43
44(* ============================================================ Types
45 ============================================================ *)
46
47type header = { name : string; value : string; sensitive : bool }
48type error = Decoding_error
49
50let pp_error ppf = function
51 | Decoding_error -> Fmt.string ppf "HPACK decoding error"
52
53open Result.Syntax
54
55(* ============================================================ Dynamic Table -
56 RFC 7541 Section 2.3.2
57 ============================================================ *)
58
59module Dynamic_table = struct
60 type t = {
61 mutable entries : (string * string * int) array;
62 mutable length : int;
63 mutable offset : int;
64 mutable capacity : int;
65 mutable size : int; (* HPACK size, not array size *)
66 mutable max_size : int;
67 }
68
69 let default_entry = ("", "", 32)
70
71 let v max_size =
72 (* [max_size] is the HPACK byte budget; each entry costs at least 32 bytes
73 (RFC 7541 4.1), so the table can never hold more than [max_size / 32]
74 entries. Start the backing array small and let it double on demand
75 ([increase_capacity] re-linearizes the ring): a table holding only a
76 handful of entries (the common case) costs ~128 bytes instead of a 2 KB
77 256-slot array, and one that fills to the [max_size / 32] cap reaches it
78 in a few doublings that together allocate less than that one oversized
79 array. [max 1] keeps the array non-empty so the [mod capacity] index math
80 stays safe when [max_size] is 0. *)
81 let capacity = max 1 (min 16 (max_size / 32)) in
82 {
83 entries = Array.make capacity default_entry;
84 length = 0;
85 offset = 0;
86 capacity;
87 size = 0;
88 max_size;
89 }
90
91 let[@inline] get_entry table i =
92 table.entries.((table.offset + i) mod table.capacity)
93
94 let[@inline] get table i =
95 let name, value, _ = get_entry table i in
96 (name, value)
97
98 let[@inline] entry_size name value =
99 String.length name + String.length value + 32
100
101 let evict_one table =
102 table.length <- table.length - 1;
103 let i = (table.offset + table.length) mod table.capacity in
104 let _, _, entry_size = table.entries.(i) in
105 table.entries.(i) <- default_entry;
106 table.size <- table.size - entry_size
107
108 let increase_capacity table =
109 let new_capacity = 2 * table.capacity in
110 let new_entries =
111 Array.init new_capacity (fun i ->
112 if i < table.length then get_entry table i else default_entry)
113 in
114 table.entries <- new_entries;
115 table.offset <- 0;
116 table.capacity <- new_capacity
117
118 let add table (name, value) =
119 let entry_size = entry_size name value in
120 while table.size > 0 && table.size + entry_size > table.max_size do
121 evict_one table
122 done;
123 if table.size + entry_size <= table.max_size then begin
124 if table.length = table.capacity then increase_capacity table;
125 table.length <- table.length + 1;
126 table.size <- table.size + entry_size;
127 let new_offset = (table.offset + table.capacity - 1) mod table.capacity in
128 table.entries.(new_offset) <- (name, value, entry_size);
129 table.offset <- new_offset
130 end
131
132 let[@inline] table_size table = table.length
133
134 let set_capacity table max_size =
135 table.max_size <- max_size;
136 while table.size > max_size do
137 evict_one table
138 done
139end
140
141(* ============================================================ Huffman
142 Encoding/Decoding - RFC 7541 Section 5.2
143 ============================================================ *)
144
145(* The code itself lives in the huffman package (Huffman.Hpack), shared with
146 QPACK; this wrapper keeps Hpack's error type. *)
147module Huffman = struct
148 let encoded_length = Huffman.Hpack.encoded_length
149 let encode = Huffman.Hpack.encode_into
150
151 let decode s =
152 Result.map_error (fun (`Msg _) -> Decoding_error) (Huffman.Hpack.decode s)
153end
154
155(* ============================================================ Integer Encoding
156 - RFC 7541 Section 5.1
157 ============================================================ *)
158
159let encode_int buf off prefix n i =
160 let max_prefix = (1 lsl n) - 1 in
161 if i < max_prefix then begin
162 Bytes.set_uint8 buf off (prefix lor i);
163 1
164 end
165 else begin
166 Bytes.set_uint8 buf off (prefix lor max_prefix);
167 let i = ref (i - max_prefix) in
168 let pos = ref (off + 1) in
169 while !i >= 128 do
170 Bytes.set_uint8 buf !pos (!i land 127 lor 128);
171 incr pos;
172 i := !i lsr 7
173 done;
174 Bytes.set_uint8 buf !pos !i;
175 !pos - off + 1
176 end
177
178(* RFC 7541 Section 5.1: continuation-byte loop for decode_int. Limit shift to
179 prevent integer overflow (max 28 bits = 4 continuation bytes). This is
180 sufficient for any valid HPACK index or table size. *)
181let rec decode_int_continuation buf i m pos =
182 if pos >= Bytes.length buf then Error Decoding_error
183 else if m > 28 then Error Decoding_error (* Overflow protection *)
184 else
185 let b = Bytes.get_uint8 buf pos in
186 let i = i + ((b land 127) lsl m) in
187 if i < 0 then Error Decoding_error (* Overflow occurred *)
188 else if b land 0b1000_0000 = 0b1000_0000 then
189 decode_int_continuation buf i (m + 7) (pos + 1)
190 else Ok (i, pos + 1)
191
192let decode_int buf off prefix n =
193 let max_prefix = (1 lsl n) - 1 in
194 let i = prefix land max_prefix in
195 if i < max_prefix then Ok (i, off) else decode_int_continuation buf i 0 off
196
197(* ============================================================ String Literal
198 Encoding - RFC 7541 Section 5.2
199 ============================================================ *)
200
201let encode_string buf off s =
202 let string_length = String.length s in
203 let huffman_length = Huffman.encoded_length s in
204 if huffman_length >= string_length then begin
205 (* Raw encoding *)
206 let len = encode_int buf off 0 7 string_length in
207 Bytes.blit_string s 0 buf (off + len) string_length;
208 len + string_length
209 end
210 else begin
211 (* Huffman encoding *)
212 let len = encode_int buf off 128 7 huffman_length in
213 let hlen = Huffman.encode buf (off + len) s in
214 len + hlen
215 end
216
217let decode_string buf off =
218 if off >= Bytes.length buf then Error Decoding_error
219 else
220 let h = Bytes.get_uint8 buf off in
221 let* string_length, pos = decode_int buf (off + 1) h 7 in
222 if pos + string_length > Bytes.length buf then Error Decoding_error
223 else
224 let string_data = Bytes.sub_string buf pos string_length in
225 let is_huffman = h land 0b1000_0000 <> 0 in
226 if is_huffman then
227 let* decoded = Huffman.decode string_data in
228 Ok (decoded, pos + string_length)
229 else Ok (string_data, pos + string_length)
230
231type field =
232 | Indexed
233 | Literal_inc
234 | Literal_no
235 | Literal_never
236 | Table_update
237 | Invalid
238
239let classify_hpack_byte b ~saw_first_header =
240 match (b lsr 4, b land 0b1110_0000, saw_first_header) with
241 | n, _, _ when n >= 8 -> Indexed
242 | n, _, _ when n >= 4 -> Literal_inc
243 | 0, _, _ -> Literal_no
244 | 1, _, _ -> Literal_never
245 | _, 0b0010_0000, false -> Table_update
246 | _ -> Invalid
247
248(* ============================================================ Decoder - RFC
249 7541 Section 6
250 ============================================================ *)
251
252let indexed_field table index =
253 let static_table_size = Hpack_tables.static_table_size in
254 let dynamic_table_size = Dynamic_table.table_size table in
255 if index = 0 || index > static_table_size + dynamic_table_size then
256 Error Decoding_error
257 else if index <= static_table_size then
258 Ok (Hpack_tables.static_entry (index - 1))
259 else Ok (Dynamic_table.get table (index - static_table_size - 1))
260
261let decode_header_field table buf off prefix prefix_length =
262 let* index, pos = decode_int buf (off + 1) prefix prefix_length in
263 let* name, pos =
264 if index = 0 then decode_string buf pos
265 else
266 let* name, _ = indexed_field table index in
267 Ok (name, pos)
268 in
269 let* value, pos = decode_string buf pos in
270 Ok ((name, value), pos)
271
272module Decoder = struct
273 type t = {
274 table : Dynamic_table.t;
275 max_capacity : int;
276 max_header_list_size : int;
277 }
278
279 let v ?(max_header_list_size = max_int) max_capacity =
280 { table = Dynamic_table.v max_capacity; max_capacity; max_header_list_size }
281
282 let set_capacity t capacity =
283 if capacity > t.max_capacity then Error Decoding_error
284 else begin
285 Dynamic_table.set_capacity t.table capacity;
286 Ok ()
287 end
288
289 (* Decode an indexed header field (RFC 7541 Section 6.1) *)
290 let decode_indexed table buf b off =
291 let* index, pos = decode_int buf (off + 1) b 7 in
292 let* name, value = indexed_field table index in
293 Ok ({ name; value; sensitive = false }, pos)
294
295 (* Decode a literal header field *)
296 let decode_literal table buf ~add_to_table ~sensitive b prefix_length off =
297 let* (name, value), pos =
298 decode_header_field table buf off b prefix_length
299 in
300 if add_to_table then Dynamic_table.add table (name, value);
301 Ok ({ name; value; sensitive }, pos)
302
303 let decode_table_update t buf b off =
304 let* capacity, pos = decode_int buf (off + 1) b 5 in
305 let* () = set_capacity t capacity in
306 Ok pos
307
308 let decode_step t buf acc b saw_first_header off =
309 let table = t.table in
310 match classify_hpack_byte b ~saw_first_header with
311 | Indexed ->
312 let* header, pos = decode_indexed table buf b off in
313 Ok (header :: acc, true, pos)
314 | Literal_inc ->
315 let* header, pos =
316 decode_literal table buf ~add_to_table:true ~sensitive:false b 6 off
317 in
318 Ok (header :: acc, true, pos)
319 | Literal_no ->
320 let* header, pos =
321 decode_literal table buf ~add_to_table:false ~sensitive:false b 4 off
322 in
323 Ok (header :: acc, true, pos)
324 | Literal_never ->
325 let* header, pos =
326 decode_literal table buf ~add_to_table:false ~sensitive:true b 4 off
327 in
328 Ok (header :: acc, true, pos)
329 | Table_update ->
330 let* pos = decode_table_update t buf b off in
331 Ok (acc, saw_first_header, pos)
332 | Invalid -> Error Decoding_error
333
334 let rec decode_loop t buf len acc size saw_first_header off =
335 if off >= len then Ok (List.rev acc)
336 else
337 let b = Bytes.get_uint8 buf off in
338 let* acc', new_saw, pos = decode_step t buf acc b saw_first_header off in
339 (* RFC 7541 sec 7.2 / RFC 9113 sec 6.5.2: bound the decoded header-list
340 size so a small block whose indexed fields expand without limit -- an
341 HPACK decompression bomb (CVE-2016-6581 class) -- is rejected in
342 bounded work rather than allocated unboundedly. The size is the
343 SETTINGS_MAX_HEADER_LIST_SIZE metric: each field costs its name and
344 value octets plus 32. A dynamic-table-size update adds no field (it
345 returns [acc] unchanged), so only a newly prepended field grows it. *)
346 let size =
347 match acc' with
348 | { name; value; _ } :: _ when acc' != acc ->
349 size + String.length name + String.length value + 32
350 | _ -> size
351 in
352 if size > t.max_header_list_size then Error Decoding_error
353 else decode_loop t buf len acc' size new_saw pos
354
355 let decode t buf = decode_loop t buf (Bytes.length buf) [] 0 false 0
356end
357
358(* ============================================================ Encoder - RFC
359 7541 Section 6
360 ============================================================ *)
361
362module Encoder = struct
363 module Header_fields_tbl = Hashtbl.Make (struct
364 type t = string
365
366 let equal = String.equal
367 let hash = Hashtbl.hash
368 end)
369
370 module Value_map = Map.Make (String)
371
372 type t = {
373 table : Dynamic_table.t;
374 lookup_table : int Value_map.t Header_fields_tbl.t;
375 mutable next_seq : int;
376 }
377
378 let v capacity =
379 {
380 table = Dynamic_table.v capacity;
381 (* [capacity] is the byte budget; the lookup table holds at most one entry
382 per dynamic-table name (<= capacity / 32), so seed the hashtable by that
383 count rather than the byte budget. It still grows on demand. *)
384 lookup_table = Header_fields_tbl.create (max 16 (capacity / 32));
385 next_seq = 0;
386 }
387
388 let set_capacity t new_capacity =
389 Dynamic_table.set_capacity t.table new_capacity
390
391 let add encoder (name, value) =
392 Dynamic_table.add encoder.table (name, value);
393 let map =
394 match Header_fields_tbl.find_opt encoder.lookup_table name with
395 | Some map -> Value_map.add value encoder.next_seq map
396 | None -> Value_map.singleton value encoder.next_seq
397 in
398 encoder.next_seq <- encoder.next_seq + 1;
399 Header_fields_tbl.replace encoder.lookup_table name map
400
401 (* Binary format constants *)
402 let never_indexed = (0b0001_0000, 4)
403 let without_indexing = (0b0000_0000, 4)
404 let incremental_indexing = (0b0100_0000, 6)
405 let indexed = (0b1000_0000, 7)
406
407 let[@inline] seq_to_index next_seq seq =
408 Hpack_tables.static_table_size + next_seq - seq
409
410 let is_without_indexing_set =
411 let module IntSet = Set.Make (Int) in
412 IntSet.of_list
413 Hpack_tables.Token_indices.
414 [
415 path;
416 age;
417 content_length;
418 etag;
419 if_modified_since;
420 if_none_match;
421 location;
422 set_cookie;
423 ]
424
425 let[@inline] is_without_indexing token =
426 let module IntSet = Set.Make (Int) in
427 token <> -1 && IntSet.mem token is_without_indexing_set
428
429 let[@inline] is_sensitive token value =
430 token <> -1
431 && Hpack_tables.Token_indices.(
432 token = authorization || (token = cookie && String.length value < 20))
433
434 (* Encode (name, value) as a token-based reference, optionally adding it to
435 the dynamic table. Used when the static table held the name but no matching
436 name/value pair was found. *)
437 let encode_via_token encoder skip_indexing token name value =
438 let index = token + 1 in
439 if skip_indexing then (without_indexing, index)
440 else begin
441 add encoder (name, value);
442 (incremental_indexing, index)
443 end
444
445 let try_static_match encoder skip_indexing token name value i =
446 let name', value' = Hpack_tables.static_entry i in
447 if String.equal name name' then
448 if String.equal value' value then `Indexed i else `Continue
449 else `Fallback (encode_via_token encoder skip_indexing token name value)
450
451 let find_encoding encoder skip_indexing token name value =
452 (* Search static table for matching name/value *)
453 let rec loop i =
454 if i >= Hpack_tables.static_table_size then
455 encode_via_token encoder skip_indexing token name value
456 else
457 match try_static_match encoder skip_indexing token name value i with
458 | `Indexed idx -> (indexed, idx + 1)
459 | `Continue -> loop (i + 1)
460 | `Fallback v -> v
461 in
462 loop token
463
464 (* The dynamic table holds the last [table_size] insertions, so a seq is live
465 iff it is within that window. Evicted seqs linger in the lookup table; an
466 index derived from one would point past the end of the peer's table, a
467 COMPRESSION_ERROR (RFC 7541 section 2.3.3). *)
468 let[@inline] is_live encoder seq =
469 encoder.next_seq - seq <= Dynamic_table.table_size encoder.table
470
471 (* Drop the evicted seqs of [name]'s map, returning what remains. *)
472 let prune_stale encoder name map =
473 let live = Value_map.filter (fun _ seq -> is_live encoder seq) map in
474 if Value_map.is_empty live then
475 Header_fields_tbl.remove encoder.lookup_table name
476 else if not (Value_map.equal Int.equal live map) then
477 Header_fields_tbl.replace encoder.lookup_table name live;
478 live
479
480 let dynamic_exact_index encoder name value =
481 match Header_fields_tbl.find_opt encoder.lookup_table name with
482 | None -> None
483 | Some map -> (
484 match Value_map.find_opt value map with
485 | Some seq when is_live encoder seq ->
486 Some (seq_to_index encoder.next_seq seq)
487 | Some _ ->
488 ignore (prune_stale encoder name map);
489 None
490 | None -> None)
491
492 let dynamic_name_index encoder name =
493 match Header_fields_tbl.find_opt encoder.lookup_table name with
494 | None -> None
495 | Some map -> (
496 let live = prune_stale encoder name map in
497 (* Prefer the most recent entry: it stays live the longest. *)
498 match Value_map.fold (fun _ seq acc -> max seq acc) live (-1) with
499 | -1 -> None
500 | seq -> Some (seq_to_index encoder.next_seq seq))
501
502 let encode_sensitive_field encoder token name =
503 let token_found = token <> -1 in
504 let index =
505 if token_found then token + 1
506 else Option.value ~default:0 (dynamic_name_index encoder name)
507 in
508 (never_indexed, index)
509
510 let encode_token_header encoder token name value =
511 match dynamic_exact_index encoder name value with
512 | Some index -> (indexed, index)
513 | None ->
514 let skip_indexing = is_without_indexing token in
515 find_encoding encoder skip_indexing token name value
516
517 let encode_custom_dynamic encoder name value index =
518 add encoder (name, value);
519 (incremental_indexing, index)
520
521 let encode_custom_header encoder name value =
522 match dynamic_exact_index encoder name value with
523 | Some index -> (indexed, index)
524 | None -> (
525 match dynamic_name_index encoder name with
526 | Some index -> encode_custom_dynamic encoder name value index
527 | None ->
528 add encoder (name, value);
529 (incremental_indexing, 0))
530
531 let encode encoder header =
532 let { name; value; sensitive } = header in
533 let token = Hpack_tables.lookup_token_index name in
534 if sensitive || is_sensitive token value then
535 encode_sensitive_field encoder token name
536 else if token <> -1 then encode_token_header encoder token name value
537 else encode_custom_header encoder name value
538
539 let[@inline] is_indexed prefix = prefix = 128
540
541 let encode_header encoder buf off header =
542 let { name; value; _ } = header in
543 let (prefix, prefix_length), index = encode encoder header in
544 let len = encode_int buf off prefix prefix_length index in
545 let off = off + len in
546 if is_indexed prefix then len
547 else begin
548 let name_len = if index = 0 then encode_string buf off name else 0 in
549 let off = off + name_len in
550 let value_len = encode_string buf off value in
551 len + name_len + value_len
552 end
553
554 let encode_headers encoder buf headers =
555 List.fold_left
556 (fun off header -> off + encode_header encoder buf off header)
557 0 headers
558end
559
560(* ============================================================ Constants
561 ============================================================ *)
562
563let default_table_size = 4096