Use new hpack library

Author: 314eter

lib/client_connection.ml

@@ -402,7 +402,7 @@ let handle_headers_block
     t.receiving_headers_for_stream <- None;
     let parse_state' = AB.feed parse_state' `Eof in
     match parse_state' with
-    | Done (_, Ok headers) ->
+    | Done (_, headers) ->
       if not is_trailers then
         (* `handle_headers` will take care of transitioning the stream state *)
         let end_stream = partial_headers.end_stream in
@@ -425,7 +425,7 @@ let handle_headers_block
     (* From RFC7540§4.3:
      *   A decoding error in a header block MUST be treated as a connection
      *   error (Section 5.4.1) of type COMPRESSION_ERROR. *)
-    | Done (_, Error _) | Partial _ ->
+    | Partial _ ->
       report_connection_error t Error.CompressionError
     | Fail (_, _, message) ->
       report_connection_error
@@ -451,7 +451,7 @@ let create_partial_headers t flags headers_block =
   { Stream.parse_state =
       AB.parse
         ~initial_buffer_size
-        (Hpack.Decoder.decode_headers t.hpack_decoder)
+        (Hpack.Decoder.headers t.hpack_decoder)
   ; end_stream = Flags.test_end_stream flags
   }
 
@@ -493,7 +493,7 @@ let process_trailer_headers t respd active_response frame_header headers_block =
   else
     let partial_headers =
       { Stream.parse_state =
-          AB.parse (Hpack.Decoder.decode_headers t.hpack_decoder)
+          AB.parse (Hpack.Decoder.headers t.hpack_decoder)
           (* obviously true at this point. *)
       ; end_stream
       }
@@ -846,7 +846,8 @@ let process_settings_frame t { Frame.frame_header; _ } settings =
              *   size of the header compression table used to decode header
              *   blocks, in octets. *)
             t.settings.header_table_size <- x;
-            Hpack.Encoder.set_capacity t.hpack_encoder x
+            let table_size = min t.config.encoder_table_size x in
+            Hpack.Encoder.change_table_size t.hpack_encoder table_size
           | EnablePush, x ->
             (* We've already verified that this setting is either 0 or 1 in the
              * call to `Settings.check_settings_list` above. *)
@@ -1164,6 +1165,7 @@ let create ?(config = Config.default) ?push_handler ~error_handler =
         (* If the caller is not going to process PUSH_PROMISE frames, just
          * disable it. *)
         config.enable_server_push && push_handler != default_push_handler
+    ; header_table_size = config.decoder_table_size
     }
   in
   let rec connection_preface_handler recv_frame settings_list =
@@ -1243,8 +1245,8 @@ let create ?(config = Config.default) ?push_handler ~error_handler =
           (* From RFC7540§4.3:
            *   Header compression is stateful. One compression context and one
            *   decompression context are used for the entire connection. *)
-      ; hpack_encoder = Hpack.Encoder.(create settings.header_table_size)
-      ; hpack_decoder = Hpack.Decoder.(create settings.header_table_size)
+      ; hpack_encoder = Hpack.Encoder.create ~max_size:(min Settings.default_settings.header_table_size config.encoder_table_size) ()
+      ; hpack_decoder = Hpack.Decoder.create ~max_size_limit:config.decoder_table_size ()
       }
   in
   let t = Lazy.force t in

lib/config.ml

@@ -39,6 +39,8 @@ type t =
   ; enable_server_push : bool
   ; max_concurrent_streams : int
   ; initial_window_size : int
+  ; encoder_table_size : int
+  ; decoder_table_size : int
   }
 
 let default =
@@ -71,4 +73,6 @@ let default =
        *   Indicates the sender's initial window size (in octets) for
        *   stream-level flow control. *)
   ; initial_window_size = Settings.WindowSize.default_initial_window_size
+  ; encoder_table_size = 0x1000
+  ; decoder_table_size = 0x1000
   }

lib/h2.mli

@@ -268,10 +268,10 @@ module Headers : sig
   (** [to_rev_list t] is the association list of header fields contained in [t]
       in {i reverse} transmission order. *)
 
-  val add : t -> ?sensitive:bool -> name -> value -> t
-  (** [add t ?sensitive name value] is a collection of header fields that is
+  val add : t -> ?never_index:bool -> name -> value -> t
+  (** [add t ?never_index name value] is a collection of header fields that is
       the same as [t] except with [(name, value)] added at the end of the
-      trasmission order. Additionally, [sensitive] specifies whether this
+      trasmission order. Additionally, [never_index] specifies whether this
       header field should not be compressed by HPACK and instead encoded as a
       never-indexed literal (see
       {{:https://tools.ietf.org/html/rfc7541#section-7.1.3} RFC7541§7.1.3} for
@@ -281,10 +281,10 @@ module Headers : sig
 
       - [get (add t name value) name = Some value] *)
 
-  val add_unless_exists : t -> ?sensitive:bool -> name -> value -> t
-  (** [add_unless_exists t ?sensitive name value] is a collection of header
+  val add_unless_exists : t -> ?never_index:bool -> name -> value -> t
+  (** [add_unless_exists t ?never_index name value] is a collection of header
       fields that is the same as [t] if [t] already inclues [name], and
-      otherwise is equivalent to [add t ?sensitive name value]. *)
+      otherwise is equivalent to [add t ?never_index name value]. *)
 
   val add_list : t -> (name * value) list -> t
   (** [add_list t assoc] is a collection of header fields that is the same as
@@ -312,8 +312,8 @@ add_multi t ["name1", ["x", "y"]; "name2", ["p", "q"]] = add_list
       equal to [name]. If [t] contains multiple header fields whose name is
       [name], they will all be removed. *)
 
-  val replace : t -> ?sensitive:bool -> name -> value -> t
-  (** [replace t ?sensitive name value] is a collection of header fields that
+  val replace : t -> ?never_index:bool -> name -> value -> t
+  (** [replace t ?never_index name value] is a collection of header fields that
       is the same as [t] except with all header fields with a name equal to
       [name] removed and replaced with a single header field whose name is
       [name] and whose value is [value]. This new header field will appear in
@@ -588,6 +588,8 @@ module Config : sig
     ; initial_window_size : int
           (** [initial_window_size] specifies the initial window size for flow
               control tokens. Defaults to [65535] *)
+    ; encoder_table_size : int  (** Defaults to [4096] *)
+    ; decoder_table_size : int  (** Defaults to [4096] *)
     }
 
   val default : t

lib/headers.ml

@@ -36,18 +36,18 @@ type name = string
 
 type value = string
 
-type header = Hpack.header =
+type header = Hpack.Header.t = private
   { name : name
   ; value : value
-  ; sensitive : bool
+  ; never_index : bool
   }
 
 type t = header list
 
 let empty : t = []
 
 let of_rev_list hs =
-  List.map (fun (name, value) -> { name; value; sensitive = false }) hs
+  List.map (fun (name, value) -> Hpack.Header.make name value) hs
 
 let of_list t = of_rev_list (List.rev t)
 
@@ -108,7 +108,7 @@ let rec mem t name =
     false
 
 (* TODO: do we need to keep a list of never indexed fields? *)
-let add t ?(sensitive = false) name value = { name; value; sensitive } :: t
+let add t ?(never_index = false) name value = Hpack.Header.make ~never_index name value :: t
 
 let add_list t ls = of_rev_list ls @ t (* XXX(seliopou): do better here *)
 
@@ -120,17 +120,17 @@ let add_multi =
     | [] ->
       loop_outer t lss
     | v :: vs' ->
-      loop_inner ({ name = n; value = v; sensitive = false } :: t) n vs' lss
+      loop_inner (Hpack.Header.make n v :: t) n vs' lss
   in
   loop_outer
 
-let add_unless_exists t ?(sensitive = false) name value =
+let add_unless_exists t ?(never_index = false) name value =
   if mem t name then
     t
   else
-    { name; value; sensitive } :: t
+    Hpack.Header.make ~never_index name value :: t
 
-let replace t ?(sensitive = false) name value =
+let replace t ?(never_index = false) name value =
   let rec loop t n nv seen =
     match t with
     | [] ->
@@ -144,7 +144,7 @@ let replace t ?(sensitive = false) name value =
       else
         nv' :: loop t n nv false
   in
-  try loop t name { name; value; sensitive } false with Local -> t
+  try loop t name (Hpack.Header.make ~never_index name value) false with Local -> t
 
 let remove t name =
   let rec loop s n seen =

lib/serialize.ml

@@ -481,21 +481,18 @@ module Writer = struct
     Hpack.Encoder.encode_header
       hpack_encoder
       faraday
-      { Headers.name = ":method"
-      ; value = Httpaf.Method.to_string meth
-      ; sensitive = false
-      };
+      (Hpack.Header.make ":method" (Httpaf.Method.to_string meth));
     if meth <> `CONNECT then (
       (* From RFC7540§8.3:
        *   The :scheme and :path pseudo-header fields MUST be omitted. *)
       Hpack.Encoder.encode_header
         hpack_encoder
         faraday
-        { Headers.name = ":path"; value = target; sensitive = false };
+        (Hpack.Header.make ":path" target);
       Hpack.Encoder.encode_header
         hpack_encoder
         faraday
-        { Headers.name = ":scheme"; value = scheme; sensitive = false });
+        (Hpack.Header.make ":scheme" scheme));
     encode_headers hpack_encoder faraday headers;
     chunk_header_block_fragments t frame_info ~write_frame faraday
 
@@ -518,10 +515,7 @@ module Writer = struct
     Hpack.Encoder.encode_header
       hpack_encoder
       faraday
-      { Headers.name = ":status"
-      ; value = Status.to_string status
-      ; sensitive = false
-      };
+      (Hpack.Header.make ":status" (Status.to_string status));
     encode_headers hpack_encoder faraday headers;
     let has_priority = match priority with Some _ -> true | None -> false in
     chunk_header_block_fragments

lib/server_connection.ml

@@ -328,7 +328,7 @@ let handle_headers_block
     t.receiving_headers_for_stream <- None;
     let parse_state' = AB.feed parse_state' `Eof in
     match parse_state' with
-    | Done (_, Ok headers) ->
+    | Done (_, headers) ->
       if not is_trailers then (
         (* Note:
          *   the highest stream identifier that the server has seen is set here
@@ -364,7 +364,7 @@ let handle_headers_block
     (* From RFC7540§4.3:
      *   A decoding error in a header block MUST be treated as a connection
      *   error (Section 5.4.1) of type COMPRESSION_ERROR. *)
-    | Done (_, Error _) | Partial _ ->
+    | Partial _ ->
       report_connection_error t Error.CompressionError
     | Fail (_, _, message) ->
       report_connection_error
@@ -436,7 +436,7 @@ let open_stream t frame_header ?priority headers_block =
       { Stream.parse_state =
           AB.parse
             ~initial_buffer_size
-            (Hpack.Decoder.decode_headers t.hpack_decoder)
+            (Hpack.Decoder.headers t.hpack_decoder)
       ; end_stream = Flags.test_end_stream flags
       }
     in
@@ -472,7 +472,7 @@ let process_trailer_headers t reqd active_stream frame_header headers_block =
   else
     let partial_headers =
       { Stream.parse_state =
-          AB.parse (Hpack.Decoder.decode_headers t.hpack_decoder)
+          AB.parse (Hpack.Decoder.headers t.hpack_decoder)
           (* obviously true at this point. *)
       ; end_stream
       }
@@ -832,7 +832,8 @@ let process_settings_frame t { Frame.frame_header; _ } settings =
              *   size of the header compression table used to decode header
              *   blocks, in octets. *)
             t.settings.header_table_size <- x;
-            Hpack.Encoder.set_capacity t.hpack_encoder x
+            let table_size = min t.config.encoder_table_size x in
+            Hpack.Encoder.change_table_size t.hpack_encoder table_size
           | EnablePush, x ->
             (* We've already verified that this setting is either 0 or 1 in the
              * call to `Settings.check_settings_list` above. *)
@@ -1093,6 +1094,7 @@ let create
     ; max_concurrent_streams = config.max_concurrent_streams
     ; initial_window_size = config.initial_window_size
     ; enable_push = config.enable_server_push
+    ; header_table_size = config.decoder_table_size
     }
   in
   let writer = Writer.create settings.max_frame_size in
@@ -1200,8 +1202,8 @@ let create
       ; did_send_go_away = false
       ; unacked_settings = 0
       ; wakeup_writer = ref default_wakeup_writer
-      ; hpack_encoder = Hpack.Encoder.(create settings.header_table_size)
-      ; hpack_decoder = Hpack.Decoder.(create settings.header_table_size)
+      ; hpack_encoder = Hpack.Encoder.create ~max_size:(min Settings.default_settings.header_table_size config.encoder_table_size) ()
+      ; hpack_decoder = Hpack.Decoder.create ~max_size_limit:config.decoder_table_size ()
       }
   in
   Lazy.force t

lib/settings.ml

@@ -211,4 +211,10 @@ let settings_for_the_connection settings =
     else
       settings_list
   in
+  let settings_list =
+    if settings.header_table_size <> default_settings.header_table_size then
+      (HeaderTableSize, settings.header_table_size) :: settings_list
+    else
+      settings_list
+  in
   settings_list

lib/stream.ml

@@ -34,7 +34,7 @@ module AB = Angstrom.Buffered
 module Writer = Serialize.Writer
 
 type partial_headers =
-  { mutable parse_state : (Headers.t, Hpack.error) result AB.state
+  { mutable parse_state : Headers.header list AB.state
   ; end_stream : bool
   }
 

lib_test/test_h2_client.ml

@@ -192,7 +192,7 @@ module Client_connection_tests = struct
 
   (* Well-formed HEADERS + CONTINUATION frames. *)
   let header_and_continuation_frames =
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     let headers =
       { Frame.frame_header =
           { payload_length = 0
@@ -303,7 +303,7 @@ module Client_connection_tests = struct
       true
       (Flags.test_end_stream frame.frame_header.flags);
     report_write_result t (`Ok lenv);
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response t hpack_encoder (Response.create `OK);
     Alcotest.(check bool) "Response handler called" true !handler_called
 
@@ -350,7 +350,7 @@ module Client_connection_tests = struct
       true
       (Flags.test_end_stream frame.frame_header.flags);
     report_write_result t (`Ok lenv);
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response
       t
       hpack_encoder
@@ -405,7 +405,7 @@ module Client_connection_tests = struct
       true
       (Flags.test_end_stream frame.frame_header.flags);
     report_write_result t (`Ok lenv);
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response
       t
       hpack_encoder
@@ -561,7 +561,7 @@ module Client_connection_tests = struct
       true
       (Flags.test_end_stream frame.frame_header.flags);
     report_write_result t (`Ok lenv);
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response
       t
       hpack_encoder
@@ -635,7 +635,7 @@ module Client_connection_tests = struct
       true
       (Flags.test_end_stream frame.frame_header.flags);
     report_write_result t (`Ok lenv);
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response
       t
       hpack_encoder
@@ -763,7 +763,7 @@ module Client_connection_tests = struct
        body"
       true
       (not (Stream.is_open stream));
-    let hpack_encoder = Hpack.Encoder.create 4096 in
+    let hpack_encoder = Hpack.Encoder.create () in
     write_response t hpack_encoder (Response.create `OK);
     Alcotest.(check bool) "Response handler called" true !handler_called;
     Alcotest.(check bool)