anil.recoil.org
A batteries included HTTP/1.1 client in OCaml
1(*---------------------------------------------------------------------------
2 Copyright (c) 2019 Antonio Nuno Monteiro.
3 Copyright (c) 2025 Anil Madhavapeddy <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,
11 this 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
19 without 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
24 ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
25 LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
26 CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
27 SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
28 INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
29 CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
30 ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 POSSIBILITY OF SUCH DAMAGE.
32 SPDX-License-Identifier: BSD-3-Clause
33 ---------------------------------------------------------------------------*)
34
35(** HPACK Header Compression per RFC 7541.
36
37 This module implements header compression for HTTP/2, including:
38 - Static and dynamic table management
39 - Huffman encoding/decoding
40 - Integer encoding with variable-length prefix
41 - String literal encoding
42
43 Derived from ocaml-h2 with adaptation for Cstruct-based operations. *)
44
45(* ============================================================
46 Types
47 ============================================================ *)
48
49type header = {
50 name : string;
51 value : string;
52 sensitive : bool;
53}
54
55type error = Decoding_error
56
57let pp_error ppf = function
58 | Decoding_error -> Format.pp_print_string ppf "HPACK decoding error"
59
60(** Result bind operator for cleaner error handling in decoding. *)
61let ( let* ) = Result.bind
62
63(* ============================================================
64 Dynamic Table - RFC 7541 Section 2.3.2
65 ============================================================ *)
66
67module Dynamic_table = struct
68 type t = {
69 mutable entries : (string * string * int) array;
70 mutable length : int;
71 mutable offset : int;
72 mutable capacity : int;
73 mutable size : int; (* HPACK size, not array size *)
74 mutable max_size : int;
75 }
76
77 let default_entry = "", "", 32
78
79 let create max_size =
80 let capacity = max 256 max_size in
81 { entries = Array.make capacity default_entry
82 ; length = 0
83 ; offset = 0
84 ; capacity
85 ; size = 0
86 ; max_size
87 }
88
89 let[@inline] _get table i =
90 table.entries.((table.offset + i) mod table.capacity)
91
92 let[@inline] get table i =
93 let name, value, _ = _get table i in
94 name, value
95
96 let[@inline] entry_size name value =
97 String.length name + String.length value + 32
98
99 let evict_one table =
100 table.length <- table.length - 1;
101 let i = (table.offset + table.length) mod table.capacity in
102 let _, _, entry_size = table.entries.(i) in
103 table.entries.(i) <- default_entry;
104 table.size <- table.size - entry_size
105
106 let increase_capacity table =
107 let new_capacity = 2 * table.capacity in
108 let new_entries =
109 Array.init new_capacity (fun i ->
110 if i < table.length then _get table i else default_entry)
111 in
112 table.entries <- new_entries;
113 table.offset <- 0;
114 table.capacity <- new_capacity
115
116 let add table (name, value) =
117 let entry_size = entry_size name value in
118 while table.size > 0 && table.size + entry_size > table.max_size do
119 evict_one table
120 done;
121 if table.size + entry_size <= table.max_size then begin
122 if table.length = table.capacity then increase_capacity table;
123 table.length <- table.length + 1;
124 table.size <- table.size + entry_size;
125 let new_offset = (table.offset + table.capacity - 1) mod table.capacity in
126 table.entries.(new_offset) <- name, value, entry_size;
127 table.offset <- new_offset
128 end
129
130 let[@inline] table_size table = table.length
131
132 let set_capacity table max_size =
133 table.max_size <- max_size;
134 while table.size > max_size do
135 evict_one table
136 done
137end
138
139(* ============================================================
140 Huffman Encoding/Decoding - RFC 7541 Section 5.2
141 ============================================================ *)
142
143module Huffman = struct
144 let encoded_length s =
145 let len = String.length s in
146 let rec loop bits i =
147 if i < len then
148 let input = Char.code s.[i] in
149 let _, len_in_bits = H2_huffman_table.encode_table.(input) in
150 loop (bits + len_in_bits) (i + 1)
151 else
152 (bits + 7) / 8
153 in
154 loop 0 0
155
156 let encode buf off s =
157 let bits = ref 0 in
158 let bits_left = ref 40 in
159 let pos = ref off in
160 for i = 0 to String.length s - 1 do
161 let code, code_len = H2_huffman_table.encode_table.(Char.code s.[i]) in
162 bits_left := !bits_left - code_len;
163 bits := !bits lor (code lsl !bits_left);
164 while !bits_left <= 32 do
165 Cstruct.set_uint8 buf !pos (!bits lsr 32);
166 incr pos;
167 bits := !bits lsl 8;
168 bits_left := !bits_left + 8
169 done
170 done;
171 if !bits_left < 40 then begin
172 bits := !bits lor ((1 lsl !bits_left) - 1);
173 Cstruct.set_uint8 buf !pos (!bits lsr 32);
174 incr pos
175 end;
176 !pos - off
177
178 let decode s =
179 let len = String.length s in
180 let buffer = Buffer.create len in
181 let[@inline] add_output c =
182 if c <> '\000' then Buffer.add_char buffer c
183 in
184 let[@inline] exists_in_huffman_table token = token <> -1 in
185 let rec loop id accept i =
186 if i < len then begin
187 let input = Char.code s.[i] in
188 let index = (id lsl 4) + (input lsr 4) in
189 let id, _, output = H2_huffman_table.decode_table.(index) in
190 add_output output;
191 if exists_in_huffman_table id then begin
192 let index = (id lsl 4) + (input land 0x0f) in
193 let id, accept, output = H2_huffman_table.decode_table.(index) in
194 add_output output;
195 if exists_in_huffman_table id
196 then loop id accept (i + 1)
197 else Error Decoding_error
198 end else Error Decoding_error
199 end else if not accept then
200 Error Decoding_error
201 else
202 Ok (Buffer.contents buffer)
203 in
204 loop 0 true 0
205end
206
207(* ============================================================
208 Integer Encoding - RFC 7541 Section 5.1
209 ============================================================ *)
210
211let encode_int buf off prefix n i =
212 let max_prefix = (1 lsl n) - 1 in
213 if i < max_prefix then begin
214 Cstruct.set_uint8 buf off (prefix lor i);
215 1
216 end else begin
217 Cstruct.set_uint8 buf off (prefix lor max_prefix);
218 let i = ref (i - max_prefix) in
219 let pos = ref (off + 1) in
220 while !i >= 128 do
221 Cstruct.set_uint8 buf !pos (!i land 127 lor 128);
222 incr pos;
223 i := !i lsr 7
224 done;
225 Cstruct.set_uint8 buf !pos !i;
226 !pos - off + 1
227 end
228
229let decode_int buf off prefix n =
230 let max_prefix = (1 lsl n) - 1 in
231 let i = prefix land max_prefix in
232 if i < max_prefix then
233 Ok (i, off)
234 else
235 let rec loop i m pos =
236 if pos >= Cstruct.length buf then
237 Error Decoding_error
238 else
239 let b = Cstruct.get_uint8 buf pos in
240 let i = i + ((b land 127) lsl m) in
241 if b land 0b1000_0000 = 0b1000_0000
242 then loop i (m + 7) (pos + 1)
243 else Ok (i, pos + 1)
244 in
245 loop i 0 off
246
247(* ============================================================
248 String Literal Encoding - RFC 7541 Section 5.2
249 ============================================================ *)
250
251let encode_string buf off s =
252 let string_length = String.length s in
253 let huffman_length = Huffman.encoded_length s in
254 if huffman_length >= string_length then begin
255 (* Raw encoding *)
256 let len = encode_int buf off 0 7 string_length in
257 Cstruct.blit_from_string s 0 buf (off + len) string_length;
258 len + string_length
259 end else begin
260 (* Huffman encoding *)
261 let len = encode_int buf off 128 7 huffman_length in
262 let hlen = Huffman.encode buf (off + len) s in
263 len + hlen
264 end
265
266let decode_string buf off =
267 if off >= Cstruct.length buf then
268 Error Decoding_error
269 else
270 let h = Cstruct.get_uint8 buf off in
271 let* string_length, pos = decode_int buf (off + 1) h 7 in
272 if pos + string_length > Cstruct.length buf then
273 Error Decoding_error
274 else
275 let string_data = Cstruct.to_string ~off:pos ~len:string_length buf in
276 let is_huffman = h land 0b1000_0000 <> 0 in
277 if is_huffman then
278 let* decoded = Huffman.decode string_data in
279 Ok (decoded, pos + string_length)
280 else
281 Ok (string_data, pos + string_length)
282
283(* ============================================================
284 Decoder - RFC 7541 Section 6
285 ============================================================ *)
286
287module Decoder = struct
288 type t = {
289 table : Dynamic_table.t;
290 max_capacity : int;
291 }
292
293 let create max_capacity =
294 { table = Dynamic_table.create max_capacity; max_capacity }
295
296 let set_capacity t capacity =
297 if capacity > t.max_capacity then
298 Error Decoding_error
299 else begin
300 Dynamic_table.set_capacity t.table capacity;
301 Ok ()
302 end
303
304 let get_indexed_field table index =
305 let static_table_size = H2_hpack_tables.static_table_size in
306 let dynamic_table_size = Dynamic_table.table_size table in
307 if index = 0 || index > static_table_size + dynamic_table_size then
308 Error Decoding_error
309 else if index <= static_table_size then
310 Ok H2_hpack_tables.static_table.(index - 1)
311 else
312 Ok (Dynamic_table.get table (index - static_table_size - 1))
313
314 let decode_header_field table buf off prefix prefix_length =
315 let* index, pos = decode_int buf (off + 1) prefix prefix_length in
316 let* name, pos =
317 if index = 0 then
318 decode_string buf pos
319 else
320 let* name, _ = get_indexed_field table index in
321 Ok (name, pos)
322 in
323 let* value, pos = decode_string buf pos in
324 Ok ((name, value), pos)
325
326 let decode t buf =
327 let table = t.table in
328 let len = Cstruct.length buf in
329
330 (* Helper to decode an indexed header field (RFC 7541 Section 6.1) *)
331 let decode_indexed b off =
332 let* index, pos = decode_int buf (off + 1) b 7 in
333 let* name, value = get_indexed_field table index in
334 Ok ({ name; value; sensitive = false }, pos)
335 in
336
337 (* Helper to decode a literal header field *)
338 let decode_literal ~add_to_table ~sensitive b prefix_length off =
339 let* (name, value), pos = decode_header_field table buf off b prefix_length in
340 if add_to_table then Dynamic_table.add table (name, value);
341 Ok ({ name; value; sensitive }, pos)
342 in
343
344 let rec loop acc saw_first_header off =
345 if off >= len then
346 Ok (List.rev acc)
347 else
348 let b = Cstruct.get_uint8 buf off in
349 if b land 0b1000_0000 <> 0 then begin
350 (* Indexed Header Field - RFC 7541 Section 6.1 *)
351 let* header, pos = decode_indexed b off in
352 loop (header :: acc) true pos
353 end
354 else if b land 0b1100_0000 = 0b0100_0000 then begin
355 (* Literal Header Field with Incremental Indexing - RFC 7541 Section 6.2.1 *)
356 let* header, pos = decode_literal ~add_to_table:true ~sensitive:false b 6 off in
357 loop (header :: acc) true pos
358 end
359 else if b land 0b1111_0000 = 0 then begin
360 (* Literal Header Field without Indexing - RFC 7541 Section 6.2.2 *)
361 let* header, pos = decode_literal ~add_to_table:false ~sensitive:false b 4 off in
362 loop (header :: acc) true pos
363 end
364 else if b land 0b1111_0000 = 0b0001_0000 then begin
365 (* Literal Header Field Never Indexed - RFC 7541 Section 6.2.3 *)
366 let* header, pos = decode_literal ~add_to_table:false ~sensitive:true b 4 off in
367 loop (header :: acc) true pos
368 end
369 else if b land 0b1110_0000 = 0b0010_0000 then begin
370 (* Dynamic Table Size Update - RFC 7541 Section 6.3 *)
371 if saw_first_header then
372 Error Decoding_error
373 else
374 let* capacity, pos = decode_int buf (off + 1) b 5 in
375 let* () = set_capacity t capacity in
376 loop acc saw_first_header pos
377 end
378 else
379 Error Decoding_error
380 in
381 loop [] false 0
382end
383
384(* ============================================================
385 Encoder - RFC 7541 Section 6
386 ============================================================ *)
387
388module Encoder = struct
389 module HeaderFieldsTbl = Hashtbl.Make(struct
390 type t = string
391 let equal = String.equal
392 let hash = Hashtbl.hash
393 end)
394
395 module ValueMap = Map.Make(String)
396
397 type t = {
398 table : Dynamic_table.t;
399 lookup_table : int ValueMap.t HeaderFieldsTbl.t;
400 mutable next_seq : int;
401 }
402
403 let create capacity =
404 { table = Dynamic_table.create capacity
405 ; lookup_table = HeaderFieldsTbl.create capacity
406 ; next_seq = 0
407 }
408
409 let set_capacity t new_capacity =
410 Dynamic_table.set_capacity t.table new_capacity
411
412 let add encoder (name, value) =
413 Dynamic_table.add encoder.table (name, value);
414 let map =
415 match HeaderFieldsTbl.find_opt encoder.lookup_table name with
416 | Some map -> ValueMap.add value encoder.next_seq map
417 | None -> ValueMap.singleton value encoder.next_seq
418 in
419 encoder.next_seq <- encoder.next_seq + 1;
420 HeaderFieldsTbl.replace encoder.lookup_table name map
421
422 (* Binary format constants *)
423 let never_indexed = 0b0001_0000, 4
424 let without_indexing = 0b0000_0000, 4
425 let incremental_indexing = 0b0100_0000, 6
426 let indexed = 0b1000_0000, 7
427
428 let[@inline] seq_to_index next_seq seq =
429 H2_hpack_tables.static_table_size + next_seq - seq
430
431 let is_without_indexing_set =
432 let module IntSet = Set.Make(Int) in
433 IntSet.of_list H2_hpack_tables.TokenIndices.[
434 path; age; content_length; etag; if_modified_since;
435 if_none_match; location; set_cookie
436 ]
437
438 let[@inline] is_without_indexing token =
439 let module IntSet = Set.Make(Int) in
440 token <> -1 && IntSet.mem token is_without_indexing_set
441
442 let[@inline] is_sensitive token value =
443 token <> -1 &&
444 H2_hpack_tables.TokenIndices.(
445 token = authorization || (token = cookie && String.length value < 20))
446
447 let find_encoding encoder skip_indexing token name value =
448 (* Search static table for matching name/value *)
449 let rec loop i =
450 if i >= H2_hpack_tables.static_table_size then begin
451 (* Name matched but value didn't *)
452 let index = token + 1 in
453 if skip_indexing then
454 without_indexing, index
455 else begin
456 add encoder (name, value);
457 incremental_indexing, index
458 end
459 end else
460 let name', value' = H2_hpack_tables.static_table.(i) in
461 if name = name' then
462 if value' = value then
463 indexed, i + 1
464 else
465 loop (i + 1)
466 else begin
467 let index = token + 1 in
468 if skip_indexing then
469 without_indexing, index
470 else begin
471 add encoder (name, value);
472 incremental_indexing, index
473 end
474 end
475 in
476 loop token
477
478 let encode encoder header =
479 let { name; value; sensitive } = header in
480 let token = H2_hpack_tables.lookup_token_index name in
481 let token_found = token <> -1 in
482 if sensitive || is_sensitive token value then begin
483 let index =
484 if token_found then
485 token + 1
486 else
487 match HeaderFieldsTbl.find_opt encoder.lookup_table name with
488 | Some map ->
489 let _, any_entry = ValueMap.choose map in
490 seq_to_index encoder.next_seq any_entry
491 | None -> 0
492 in
493 never_indexed, index
494 end
495 else if token_found then begin
496 match HeaderFieldsTbl.find_opt encoder.lookup_table name with
497 | Some map ->
498 (match ValueMap.find_opt value map with
499 | Some seq -> indexed, seq_to_index encoder.next_seq seq
500 | None ->
501 let skip_indexing = is_without_indexing token in
502 find_encoding encoder skip_indexing token name value)
503 | None ->
504 let skip_indexing = is_without_indexing token in
505 find_encoding encoder skip_indexing token name value
506 end
507 else begin
508 match HeaderFieldsTbl.find_opt encoder.lookup_table name with
509 | Some map ->
510 (match ValueMap.find_opt value map with
511 | Some seq -> indexed, seq_to_index encoder.next_seq seq
512 | None ->
513 let index = seq_to_index encoder.next_seq (snd (ValueMap.choose map)) in
514 if is_without_indexing token then
515 without_indexing, index
516 else begin
517 add encoder (name, value);
518 incremental_indexing, index
519 end)
520 | None ->
521 if is_without_indexing token then
522 without_indexing, 0
523 else begin
524 add encoder (name, value);
525 incremental_indexing, 0
526 end
527 end
528
529 let[@inline] is_indexed prefix = prefix = 128
530
531 let encode_header encoder buf off header =
532 let { name; value; _ } = header in
533 let (prefix, prefix_length), index = encode encoder header in
534 let len = encode_int buf off prefix prefix_length index in
535 let off = off + len in
536 if is_indexed prefix then
537 len
538 else begin
539 let name_len =
540 if index = 0 then
541 encode_string buf off name
542 else
543 0
544 in
545 let off = off + name_len in
546 let value_len = encode_string buf off value in
547 len + name_len + value_len
548 end
549
550 let encode_headers encoder buf headers =
551 List.fold_left (fun off header ->
552 off + encode_header encoder buf off header
553 ) 0 headers
554end
555
556(* ============================================================
557 Constants
558 ============================================================ *)
559
560let default_table_size = 4096