unikernel/duniverse/ocaml-h2/lib/settings.ml

@@ -0,0 +1,291 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019-2020 António Nuno Monteiro
+ *
+ *  All rights reserved.
+ *
+ *  Redistribution and use in source and binary forms, with or without
+ *  modification, are permitted provided that the following conditions are met:
+ *
+ *  1. Redistributions of source code must retain the above copyright notice,
+ *  this list of conditions and the following disclaimer.
+ *
+ *  2. Redistributions in binary form must reproduce the above copyright
+ *  notice, this list of conditions and the following disclaimer in the
+ *  documentation and/or other materials provided with the distribution.
+ *
+ *  3. Neither the name of the copyright holder nor the names of its
+ *  contributors may be used to endorse or promote products derived from this
+ *  software without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ *  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ *  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ *  ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
+ *  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ *  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ *  SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ *  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ *  CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ *  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ *  POSSIBILITY OF SUCH DAMAGE.
+ *---------------------------------------------------------------------------*)
+
+module WindowSize = struct
+  type t = int32
+
+  (* From RFC7540§6.9.2:
+   *   When an HTTP/2 connection is first established, new streams are created
+   *   with an initial flow-control window size of 65,535 octets. *)
+  let default_initial_window_size = 65535l
+
+  (* From RFC7540§6.9:
+   *   The legal range for the increment to the flow-control window is 1 to
+   *   2^31-1 (2,147,483,647) octets. *)
+  let max_window_size = Int32.max_int
+
+  (* Ideally `n` here would be an unsigned 32-bit integer, but OCaml doesn't
+   * support them. We avoid introducing a new dependency on an unsigned integer
+   * library by letting it overflow at parse time and checking if bit 31 is set
+   * here, since * `Window.max_window_size` is never allowed to be above
+   * 2^31-1 (see `max_window_size` above).
+   * See http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/f1c483068cc62075c916f7ad7d640ce0.fr.html
+   * for more info. *)
+  let is_window_overflow n = Util.test_bit_int32 n 31
+end
+
+type setting =
+  | HeaderTableSize of int
+  | EnablePush of int
+  | MaxConcurrentStreams of int32
+  | InitialWindowSize of int32
+  | MaxFrameSize (* this means payload size *) of int
+  | MaxHeaderListSize of int
+
+type settings_list = setting list
+
+(* From RFC7540§6.5.1:
+ *   The payload of a SETTINGS frame consists of zero or more parameters,
+ *   each consisting of an unsigned 16-bit setting identifier and an
+ *   unsigned 32-bit value. *)
+let octets_per_setting = 6
+
+let serialize_key = function
+  | HeaderTableSize _ -> 0x1
+  | EnablePush _ -> 0x2
+  | MaxConcurrentStreams _ -> 0x3
+  | InitialWindowSize _ -> 0x4
+  | MaxFrameSize _ -> 0x5
+  | MaxHeaderListSize _ -> 0x6
+
+let check_value ~is_client = function
+  | EnablePush v ->
+    if v <> 0 && v <> 1
+    then
+      (* From RFC7540§6.5.2
+       *   The initial value is 1, which indicates that server push is
+       *   permitted. Any value other than 0 or 1 MUST be treated as a
+       *   connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+      Error
+        Error.(
+          ConnectionError (ProtocolError, "SETTINGS_ENABLE_PUSH must be 0 or 1"))
+    else if is_client && v = 1
+    then
+      (* From RFC7540§8.2:
+       *   Clients MUST reject any attempt to change the
+       *   SETTINGS_ENABLE_PUSH setting to a value other than 0 by
+       *   treating the message as a connection error (Section 5.4.1) of
+       *   type PROTOCOL_ERROR. *)
+      Error
+        Error.(
+          ConnectionError
+            (ProtocolError, "Server must not try to enable SETTINGS_ENABLE_PUSH"))
+    else Ok ()
+  | InitialWindowSize v when WindowSize.is_window_overflow v ->
+    (* From RFC7540§6.5.2
+     *   Values above the maximum flow-control window size of 2^31-1 MUST be
+     *   treated as a connection error (Section 5.4.1) of type
+     *   FLOW_CONTROL_ERROR. *)
+    Error
+      Error.(
+        ConnectionError
+          ( FlowControlError
+          , Format.sprintf
+              "Window size must be less than or equal to %ld"
+              WindowSize.max_window_size ))
+  | MaxFrameSize v when v < 16384 || v > 16777215 ->
+    (* From RFC7540§6.5.2
+     *   The initial value is 214 (16,384) octets. The value advertised by an
+     *   endpoint MUST be between this initial value and the maximum allowed
+     *   frame size (224-1 or 16,777,215 octets), inclusive. Values outside
+     *   this range MUST be treated as a connection error (Section 5.4.1) of
+     *   type PROTOCOL_ERROR. *)
+    Error
+      Error.(
+        ConnectionError
+          (ProtocolError, "Max frame size must be in the 16384 - 16777215 range"))
+  | _ -> Ok ()
+
+(* Check incoming settings and report an error if any. *)
+let check_settings_list ?(is_client = false) settings =
+  let rec loop = function
+    | [] -> Ok ()
+    | x :: xs ->
+      (match check_value ~is_client x with
+      | Ok () -> loop xs
+      | Error _ as err -> err)
+  in
+  loop settings
+
+type t =
+  { header_table_size : int
+  ; enable_push : bool
+  ; max_concurrent_streams : int32
+  ; (* Indicates the amount tokens the peer allows an H2 endpoint to send. *)
+    initial_window_size : WindowSize.t
+  ; max_frame_size : int
+  ; max_header_list_size : int option
+  }
+
+(* From RFC7540§11.3 *)
+let default =
+  { header_table_size = 0x1000
+  ; enable_push =
+      true
+      (* From RFC7540§6.5.2:
+       *   SETTINGS_MAX_CONCURRENT_STREAMS (0x3): [...] Initially, there is no
+       *   limit to this value. *)
+  ; max_concurrent_streams = Int32.max_int
+  ; initial_window_size = WindowSize.default_initial_window_size
+  ; max_frame_size = 0x4000
+  ; max_header_list_size = None
+  }
+
+let settings_for_the_connection settings =
+  let settings_list =
+    if settings.max_frame_size <> default.max_frame_size
+    then [ MaxFrameSize settings.max_frame_size ]
+    else []
+  in
+  let settings_list =
+    if settings.max_concurrent_streams <> default.max_concurrent_streams
+    then MaxConcurrentStreams settings.max_concurrent_streams :: settings_list
+    else settings_list
+  in
+  let settings_list =
+    if settings.initial_window_size <> default.initial_window_size
+    then
+      (* FIXME: don't convert *)
+      InitialWindowSize settings.initial_window_size :: settings_list
+    else settings_list
+  in
+  let settings_list =
+    if settings.enable_push <> default.enable_push
+    then EnablePush (if settings.enable_push then 1 else 0) :: settings_list
+    else settings_list
+  in
+  settings_list
+
+let parse_settings_payload num_settings =
+  let open Angstrom in
+  let rec parse_inner acc remaining =
+    (* From RFC7540§6.5.3:
+     *   The values in the SETTINGS frame MUST be processed in the order
+     *   they appear, with no other frame processing between values. *)
+    if remaining <= 0
+    then return (List.rev acc)
+    else
+      lift2
+        (fun k (v : int32) ->
+           match k with
+           | 0x1 -> HeaderTableSize (Int32.to_int v) :: acc
+           | 0x2 -> EnablePush (Int32.to_int v) :: acc
+           | 0x3 -> MaxConcurrentStreams v :: acc
+           | 0x4 -> InitialWindowSize v :: acc
+           | 0x5 -> MaxFrameSize (Int32.to_int v) :: acc
+           | 0x6 -> MaxHeaderListSize (Int32.to_int v) :: acc
+           | _ ->
+             (* Note: This ignores unknown settings.
+              *
+              * From RFC7540§6.5.3:
+              *   Unsupported parameters MUST be ignored.
+              *)
+             acc)
+        BE.any_uint16
+        BE.any_int32
+      >>= fun acc' -> parse_inner acc' (remaining - 1)
+  in
+  parse_inner [] num_settings
+
+let write_settings_payload t settings_list =
+  let open Faraday in
+  List.iter
+    (fun setting ->
+       (* From RFC7540§6.5.1:
+        *   The payload of a SETTINGS frame consists of zero or more parameters,
+        *   each consisting of an unsigned 16-bit setting identifier and an
+        *   unsigned 32-bit value. *)
+       BE.write_uint16 t (serialize_key setting);
+       match setting with
+       | MaxConcurrentStreams value | InitialWindowSize value ->
+         BE.write_uint32 t value
+       | HeaderTableSize value
+       | EnablePush value
+       | MaxFrameSize value
+       | MaxHeaderListSize value ->
+         BE.write_uint32 t (Int32.of_int value))
+    settings_list
+
+let of_settings_list settings =
+  List.fold_left
+    (fun (acc : t) item ->
+       match item with
+       | HeaderTableSize x -> { acc with header_table_size = x }
+       | EnablePush x -> { acc with enable_push = x = 1 }
+       | MaxConcurrentStreams x -> { acc with max_concurrent_streams = x }
+       | InitialWindowSize new_val -> { acc with initial_window_size = new_val }
+       | MaxFrameSize x -> { acc with max_frame_size = x }
+       | MaxHeaderListSize x -> { acc with max_header_list_size = Some x })
+    default
+    settings
+
+let of_base64 encoded =
+  match Base64.decode ~alphabet:Base64.uri_safe_alphabet encoded with
+  | Ok settings_payload ->
+    let settings_payload_length =
+      String.length settings_payload / octets_per_setting
+    in
+    (match
+       Angstrom.parse_string
+         ~consume:All
+         (parse_settings_payload settings_payload_length)
+         settings_payload
+     with
+    | Ok settings -> Ok (of_settings_list settings)
+    | Error _ as e -> e)
+  | Error (`Msg msg) -> Error msg
+
+let to_base64 t =
+  let settings = settings_for_the_connection t in
+  let faraday = Faraday.create (List.length settings * 6) in
+  write_settings_payload faraday settings;
+  let settings_hex = Faraday.serialize_to_string faraday in
+  match Base64.encode ~alphabet:Base64.uri_safe_alphabet settings_hex with
+  | Ok r -> Ok r
+  | Error (`Msg msg) -> Error msg
+
+let pp_hum formatter t =
+  let pp_elem formatter setting =
+    let key, value =
+      match setting with
+      | HeaderTableSize v -> "HEADER_TABLE_SIZE", Int64.of_int v
+      | EnablePush v -> "ENABLE_PUSH", Int64.of_int v
+      | MaxConcurrentStreams v -> "MAX_CONCURRENT_STREAMS", Int64.of_int32 v
+      | InitialWindowSize v -> "INITIAL_WINDOW_SIZE", Int64.of_int32 v
+      | MaxFrameSize v -> "MAX_FRAME_SIZE", Int64.of_int v
+      | MaxHeaderListSize v -> "MAX_HEADER_LIST_SIZE", Int64.of_int v
+    in
+    Format.fprintf formatter "@[(%S %Ld)@]" key value
+  in
+  Format.fprintf formatter "@[(";
+  Format.pp_print_list pp_elem formatter (settings_for_the_connection t);
+  Format.fprintf formatter ")@]"