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

@@ -0,0 +1,190 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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 Reader = struct
+  type t =
+    { faraday : Faraday.t
+    ; mutable read_scheduled : bool
+    ; mutable on_eof : unit -> unit
+    ; mutable on_read : Bigstringaf.t -> off:int -> len:int -> unit
+    ; done_reading : int -> unit
+    }
+
+  let default_done_reading = Sys.opaque_identity (fun _ -> ())
+  let default_on_eof = Sys.opaque_identity (fun () -> ())
+  let default_on_read = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ())
+
+  let create buffer ~done_reading =
+    { faraday = Faraday.of_bigstring buffer
+    ; read_scheduled = false
+    ; on_eof = default_on_eof
+    ; on_read = default_on_read
+    ; done_reading
+    }
+
+  let create_empty () =
+    let t = create Bigstringaf.empty ~done_reading:default_done_reading in
+    Faraday.close t.faraday;
+    t
+
+  let empty = create_empty ()
+  let is_closed t = Faraday.is_closed t.faraday
+  let unsafe_faraday t = t.faraday
+
+  let rec do_execute_read t on_eof on_read =
+    match Faraday.operation t.faraday with
+    | `Yield -> ()
+    | `Close ->
+      t.read_scheduled <- false;
+      t.on_eof <- default_on_eof;
+      t.on_read <- default_on_read;
+      on_eof ()
+    | `Writev [] -> assert false
+    | `Writev (iovec :: _) ->
+      t.read_scheduled <- false;
+      t.on_eof <- default_on_eof;
+      t.on_read <- default_on_read;
+      let { Httpun_types.IOVec.buffer; off; len } = iovec in
+      Faraday.shift t.faraday len;
+      on_read buffer ~off ~len;
+      (* Application is done reading, we can give flow control tokens back to
+         the peer. *)
+      t.done_reading len;
+      execute_read t
+
+  and execute_read t =
+    if t.read_scheduled then do_execute_read t t.on_eof t.on_read
+
+  let schedule_read t ~on_eof ~on_read =
+    if t.read_scheduled
+    then failwith "Body.schedule_read: reader already scheduled";
+    if not (is_closed t)
+    then (
+      t.read_scheduled <- true;
+      t.on_eof <- on_eof;
+      t.on_read <- on_read);
+    do_execute_read t on_eof on_read
+
+  let close t =
+    Faraday.close t.faraday;
+    execute_read t
+
+  let has_pending_output t = Faraday.has_pending_output t.faraday
+end
+
+module Writer = struct
+  module Writer = Serialize.Writer
+
+  type t =
+    { faraday : Faraday.t
+    ; mutable buffered_bytes : int
+    ; writer : Serialize.Writer.t
+    }
+
+  let create buffer ~writer =
+    { faraday = Faraday.of_bigstring buffer; buffered_bytes = 0; writer }
+
+  let create_empty ~writer =
+    let t = create Bigstringaf.empty ~writer in
+    Faraday.close t.faraday;
+    t
+
+  let ready_to_write t = Serialize.Writer.wakeup t.writer
+
+  let write_char t c =
+    if not (Faraday.is_closed t.faraday) then Faraday.write_char t.faraday c;
+    ready_to_write t
+
+  let write_string t ?off ?len s =
+    if not (Faraday.is_closed t.faraday)
+    then Faraday.write_string ?off ?len t.faraday s;
+    ready_to_write t
+
+  let write_bigstring t ?off ?len b =
+    if not (Faraday.is_closed t.faraday)
+    then Faraday.write_bigstring ?off ?len t.faraday b;
+    ready_to_write t
+
+  let schedule_bigstring t ?off ?len (b : Bigstringaf.t) =
+    if not (Faraday.is_closed t.faraday)
+    then Faraday.schedule_bigstring ?off ?len t.faraday b;
+    ready_to_write t
+
+  let flush t kontinue =
+    if Serialize.Writer.is_closed t.writer
+    then kontinue `Closed
+    else (
+      Faraday.flush_with_reason t.faraday (function
+        | Drain -> kontinue `Closed
+        | Nothing_pending | Shift -> kontinue `Written);
+      ready_to_write t)
+
+  let is_closed t = Faraday.is_closed t.faraday
+  let has_pending_output t = Faraday.has_pending_output t.faraday
+
+  let close_and_drain t =
+    Faraday.close t.faraday;
+    (* Resolve all pending flushes *)
+    ignore (Faraday.drain t.faraday : int)
+
+  let close t =
+    Serialize.Writer.unyield t.writer;
+    Faraday.close t.faraday;
+    ready_to_write t
+
+  let unsafe_faraday t = t.faraday
+
+  let transfer_to_writer t writer ~max_frame_size ~max_bytes stream_id =
+    let faraday = t.faraday in
+    if Serialize.Writer.is_closed t.writer
+    then (
+      close_and_drain t;
+      0)
+    else
+      match Faraday.operation faraday with
+      | `Yield | `Close -> 0
+      | `Writev iovecs ->
+        let iovecs = Httpun_types.IOVec.shiftv iovecs t.buffered_bytes in
+        let lengthv = Httpun_types.IOVec.lengthv iovecs in
+        let writev_len = if max_bytes < lengthv then max_bytes else lengthv in
+        t.buffered_bytes <- t.buffered_bytes + writev_len;
+        let frame_info = Writer.make_frame_info ~max_frame_size stream_id in
+        Writer.schedule_iovecs writer frame_info ~len:writev_len iovecs;
+        Writer.flush t.writer (function
+          | `Closed -> close_and_drain t
+          | `Written ->
+            Faraday.shift faraday writev_len;
+            t.buffered_bytes <- t.buffered_bytes - writev_len);
+        writev_len
+end

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

@@ -0,0 +1,91 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+(* TODO: add a config option for `Reqd` to flush max bytes at a time? *)
+type t =
+  { read_buffer_size : int
+  ; request_body_buffer_size : int
+  ; response_body_buffer_size : int
+  ; enable_server_push : bool
+  ; max_concurrent_streams : int32
+  ; initial_window_size : int32
+  }
+
+let default =
+  { (* This is effectively MAX_FRAME_SIZE, because the parser commits the frame
+     * header to prevent backtracking, therefore the entire payload can fit the
+     * read buffer. The default is 16384, and can't be lower than that.
+     *
+     * Note: h2 does not check that MAX_FRAME_SIZE is lower than 16384
+     * octets. In the case that a lower value than permitted is set, peers will
+     * reject the setting and close the connection with a PROTOCOL_ERROR.
+     *
+     * From RFC7540§6.5.2:
+     *   SETTINGS_MAX_FRAME_SIZE (0x5): Indicates the size of the largest frame
+     *   payload that the sender is willing to receive, in octets.
+     *   The initial value is 2^14 (16,384) octets. The value advertised by an
+     *   endpoint MUST be between this initial value and the maximum allowed
+     *   frame size (2^24-1 or 16,777,215 octets), inclusive. *)
+    read_buffer_size = Settings.default.max_frame_size
+  ; (* Buffer size for request bodies *) request_body_buffer_size = 0x1000
+  ; (* Buffer size for response bodies *) response_body_buffer_size = 0x1000
+  ; enable_server_push = true
+  ; (* From RFC7540§6.5.2:
+     *   Indicates the maximum number of concurrent streams that the sender
+     *   will allow. This limit is directional: it applies to the number of
+     *   streams that the sender permits the receiver to create. *)
+    max_concurrent_streams = Settings.default.max_concurrent_streams
+  ; (* Indicates the initial window size when receiving data from remote
+     * streams. In other words, represents the amount of octets that the H2
+     * endpoint is willing to receive from the peer. Cannot be lower than
+     * 65535 (the default as per the spec). The default in H2 is 2^27, or
+     * 128 MiB. *)
+    (* TODO(anmonteiro): validate the default somewhere. *)
+    initial_window_size = Int32.shift_left 1l 27
+  }
+
+let to_settings
+    { read_buffer_size
+    ; max_concurrent_streams
+    ; initial_window_size
+    ; enable_server_push
+    ; _
+    }
+  =
+  { Settings.default with
+    max_frame_size = read_buffer_size
+  ; max_concurrent_streams
+  ; initial_window_size
+  ; enable_push = enable_server_push
+  }

unikernel/duniverse/ocaml-h2/lib/dune

@@ -0,0 +1,4 @@
+(library
+ (name h2)
+ (public_name h2)
+ (libraries angstrom base64 faraday bigstringaf httpun-types psq hpack))

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

@@ -0,0 +1,43 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+(* From RFC7540§5.4:
+ *   HTTP/2 framing permits two classes of error:
+ *
+ *   - An error condition that renders the entire connection unusable is a
+ *     connection error.
+ *   - An error in an individual stream is a stream error. *)
+type t =
+  | ConnectionError of Error_code.t * string
+  | StreamError of Stream_identifier.t * Error_code.t
+
+let message = function ConnectionError (_, msg) -> msg | StreamError _ -> ""

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

@@ -0,0 +1,152 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+type t =
+  (* From RFC7540§7:
+   *   NO_ERROR (0x0): The associated condition is not a result of an
+   *   error. *)
+  | NoError
+  (* From RFC7540§7:
+   *   PROTOCOL_ERROR (0x1): The endpoint detected an unspecific protocol
+   *   error. This error is for use when a more specific error code is not
+   *   available. *)
+  | ProtocolError
+  (* From RFC7540§7:
+   *   INTERNAL_ERROR (0x2): The endpoint encountered an unexpected internal
+   *   error. *)
+  | InternalError
+  (* From RFC7540§7:
+   *   FLOW_CONTROL_ERROR (0x3): The endpoint detected that its peer violated
+   *   the flow-control protocol. *)
+  | FlowControlError
+  (* From RFC7540§7:
+   *   SETTINGS_TIMEOUT (0x4): The endpoint sent a SETTINGS frame but did not
+   *   receive a response in a timely manner. *)
+  | SettingsTimeout
+  (* From RFC7540§7:
+   *   STREAM_CLOSED (0x5): The endpoint received a frame after a stream was
+   *   half-closed. *)
+  | StreamClosed
+  (* From RFC7540§7:
+   *   FRAME_SIZE_ERROR (0x6): The endpoint received a frame with an invalid
+   *   size. *)
+  | FrameSizeError
+  (* From RFC7540§7:
+   *   REFUSED_STREAM (0x7): The endpoint refused the stream prior to
+   *   performing any application processing (see Section 8.1.4 for
+   *   details). *)
+  | RefusedStream
+  (* From RFC7540§7:
+   *   CANCEL (0x8): Used by the endpoint to indicate that the stream is no
+   *   longer needed. *)
+  | Cancel
+  (* From RFC7540§7:
+   *   COMPRESSION_ERROR (0x9): The endpoint is unable to maintain the header
+   *   compression context for the connection. *)
+  | CompressionError
+  (* From RFC7540§7:
+   *   CONNECT_ERROR (0xa): The connection established in response to a
+   *   CONNECT request (Section 8.3) was reset or abnormally closed. *)
+  | ConnectError
+  (* From RFC7540§7:
+   *   ENHANCE_YOUR_CALM (0xb): The endpoint detected that its peer is
+   *   exhibiting a behavior that might be generating excessive load. *)
+  | EnhanceYourCalm
+  (* From RFC7540§7:
+   *   INADEQUATE_SECURITY (0xc): The underlying transport has properties
+   *   that do not meet minimum security requirements (see Section 9.2). *)
+  | InadequateSecurity
+  (* From RFC7540§7:
+   *   HTTP_1_1_REQUIRED (0xd): The endpoint requires that HTTP/1.1 be used
+   *   instead of HTTP/2. *)
+  | HTTP_1_1_Required
+  (* From RFC7540§7:
+   *   Unknown or unsupported error codes MUST NOT trigger any special
+   *   behavior. These MAY be treated by an implementation as being
+   *   equivalent to INTERNAL_ERROR. *)
+  | UnknownError_code of int32
+
+(* From RFC7540§7:
+ *   Error codes are 32-bit fields that are used in RST_STREAM and GOAWAY
+ *   frames to convey the reasons for the stream or connection error. *)
+let serialize = function
+  | NoError -> 0x0l
+  | ProtocolError -> 0x1l
+  | InternalError -> 0x2l
+  | FlowControlError -> 0x3l
+  | SettingsTimeout -> 0x4l
+  | StreamClosed -> 0x5l
+  | FrameSizeError -> 0x6l
+  | RefusedStream -> 0x7l
+  | Cancel -> 0x8l
+  | CompressionError -> 0x9l
+  | ConnectError -> 0xal
+  | EnhanceYourCalm -> 0xbl
+  | InadequateSecurity -> 0xcl
+  | HTTP_1_1_Required -> 0xdl
+  | UnknownError_code id -> id
+
+let parse = function
+  | 0x0l -> NoError
+  | 0x1l -> ProtocolError
+  | 0x2l -> InternalError
+  | 0x3l -> FlowControlError
+  | 0x4l -> SettingsTimeout
+  | 0x5l -> StreamClosed
+  | 0x6l -> FrameSizeError
+  | 0x7l -> RefusedStream
+  | 0x8l -> Cancel
+  | 0x9l -> CompressionError
+  | 0xal -> ConnectError
+  | 0xbl -> EnhanceYourCalm
+  | 0xcl -> InadequateSecurity
+  | 0xdl -> HTTP_1_1_Required
+  | id -> UnknownError_code id
+
+let to_string = function
+  | NoError -> "NO_ERROR (0x0)"
+  | ProtocolError -> "PROTOCOL_ERROR (0x1)"
+  | InternalError -> "INTERNAL_ERROR (0x2)"
+  | FlowControlError -> "FLOW_CONTROL_ERROR (0x3)"
+  | SettingsTimeout -> "SETTINGS_TIMEOUT (0x4)"
+  | StreamClosed -> "STREAM_CLOSED (0x5)"
+  | FrameSizeError -> "FRAME_SIZE_ERROR (0x6)"
+  | RefusedStream -> "REFUSED_STREAM (0x7)"
+  | Cancel -> "CANCEL (0x8)"
+  | CompressionError -> "COMPRESSION_ERROR (0x9)"
+  | ConnectError -> "CONNECT_ERROR (0xa)"
+  | EnhanceYourCalm -> "ENHANCE_YOUR_CALM (0xb)"
+  | InadequateSecurity -> "INADEQUATE_SECURITY (0xc)"
+  | HTTP_1_1_Required -> "HTTP_1_1_REQUIRED (0xd)"
+  | UnknownError_code id -> Format.asprintf "UNKNOWN_ERROR (0x%lx)" id
+
+let pp_hum formatter t = Format.fprintf formatter "%s" (to_string t)

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

@@ -0,0 +1,72 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+open Util
+
+type t = int
+
+(* From RFC7540§6.2:
+ *   Flags that have no defined semantics for a particular frame type MUST be
+ *   ignored and MUST be left unset (0x0) when sending. *)
+let default_flags = 0x0
+
+(* From RFC7540§6.2:
+ *   END_STREAM (0x1): When set, bit 0 indicates that the header block (Section
+ *   4.3) is the last that the endpoint will send for the identified stream. *)
+let test_end_stream x = test_bit x 0
+let set_end_stream x = set_bit x 0
+let clear_end_stream x = clear_bit x 0
+
+(* From RFC7540§6.7:
+ *   ACK (0x1): When set, bit 0 indicates that this PING frame is a PING
+ *   response. *)
+let test_ack x = test_bit x 0
+let set_ack x = set_bit x 0
+
+(* From RFC7540§6.2:
+ *   END_HEADERS (0x4): When set, bit 2 indicates that this frame contains an
+ *   entire header block (Section 4.3) and is not followed by any CONTINUATION
+ *   frames. *)
+let test_end_header x = test_bit x 2
+let set_end_header x = set_bit x 2
+
+(* From RFC7540§6.2:
+ *   PADDED (0x8): When set, bit 3 indicates that the Pad Length field and any
+ *   padding that it describes are present. *)
+let test_padded x = test_bit x 3
+let set_padded x = set_bit x 3
+
+(* From RFC7540§6.2:
+ *   PRIORITY (0x20): When set, bit 5 indicates that the Exclusive Flag (E),
+ *   Stream Dependency, and Weight fields are present; see Section 5.3. *)
+let test_priority x = test_bit x 5
+let set_priority x = set_bit x 5

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

@@ -0,0 +1,218 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+let connection_preface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n"
+
+module FrameType = struct
+  type t =
+    (* From RFC7540§6.1:
+     *   DATA frames (type=0x0) convey arbitrary, variable-length sequences
+     *   of octets associated with a stream. *)
+    | Data
+    (* From RFC7540§6.2:
+     *   The HEADERS frame (type=0x1) is used to open a stream (Section 5.1),
+     *   and additionally carries a header block fragment. *)
+    | Headers
+    (* From RFC7540§6.3:
+     *   The PRIORITY frame (type=0x2) specifies the sender-advised priority
+     *   of a stream (Section 5.3). *)
+    | Priority
+    (* From RFC7540§6.4:
+     *   The RST_STREAM frame (type=0x3) allows for immediate termination of
+     *   a stream. *)
+    | RSTStream
+    (* From RFC7540§6.5:
+     *   The SETTINGS frame (type=0x4) conveys configuration parameters that
+     *   affect how endpoints communicate, such as preferences and
+     *   constraints on peer behavior. *)
+    | Settings
+    (* From RFC7540§6.6:
+     *   The PUSH_PROMISE frame (type=0x5) is used to notify the peer
+     *   endpoint in advance of streams the sender intends to initiate. *)
+    | PushPromise
+    (* From RFC7540§6.7:
+     *   The PING frame (type=0x6) is a mechanism for measuring a minimal
+     *   round-trip time from the sender, as well as determining whether an
+     *   idle connection is still functional. *)
+    | Ping
+    (* From RFC7540§6.8:
+     *   The GOAWAY frame (type=0x7) is used to initiate shutdown of a
+     *   connection or to signal serious error conditions. *)
+    | GoAway
+    (* From RFC7540§6.9:
+     *   The WINDOW_UPDATE frame (type=0x8) is used to implement flow
+     *   control; [...]. *)
+    | WindowUpdate
+    (* From RFC7540§6.10:
+     *   The CONTINUATION frame (type=0x9) is used to continue a sequence of
+     *   header block fragments (Section 4.3). *)
+    | Continuation
+    (* From RFC7540§5.1:
+     *   Frames of unknown types are ignored. *)
+    | Unknown of int
+
+  let serialize = function
+    | Data -> 0
+    | Headers -> 1
+    | Priority -> 2
+    | RSTStream -> 3
+    | Settings -> 4
+    | PushPromise -> 5
+    | Ping -> 6
+    | GoAway -> 7
+    | WindowUpdate -> 8
+    | Continuation -> 9
+    | Unknown x -> x
+
+  let parse = function
+    | 0 -> Data
+    | 1 -> Headers
+    | 2 -> Priority
+    | 3 -> RSTStream
+    | 4 -> Settings
+    | 5 -> PushPromise
+    | 6 -> Ping
+    | 7 -> GoAway
+    | 8 -> WindowUpdate
+    | 9 -> Continuation
+    | x -> Unknown x
+end
+
+(* From RFC7540§4.1:
+ *   The fields of the frame header are defined as:
+ *
+ *     Length: The length of the frame payload expressed as an unsigned 24-bit
+ *             integer. [...]
+ *
+ *     Type: The 8-bit type of the frame. [...]
+ *
+ *     Flags: An 8-bit field reserved for boolean flags specific to the frame
+ *            type. [...]
+ *
+ *     Stream Identifier: A stream identifier (see Section 5.1.1) expressed as
+ *                        an unsigned 31-bit integer. [...] *)
+type frame_header =
+  { payload_length : int
+  ; flags : Flags.t
+  ; stream_id : Stream_identifier.t
+  ; frame_type : FrameType.t
+  }
+
+(* From RFC7540§4.1:
+ *   The structure and content of the frame payload is dependent entirely on
+ *   the frame type. *)
+type frame_payload =
+  (* From RFC7540§6.1:
+   *   The DATA frame contains the following fields:
+   *
+   *   [...]
+   *
+   *   Data: Application data. The amount of data is the remainder of the
+   *         frame payload after subtracting the length of the other fields
+   *         that are present. *)
+  | Data of Bigstringaf.t
+  (* From RFC7540§6.2:
+   *   The HEADERS frame payload has the following fields:
+   *
+   *    E: A single-bit flag indicating that the stream dependency is
+   *       exclusive (see Section 5.3). [...]
+   *
+   *    Stream Dependency: A 31-bit stream identifier for the stream that
+   *                       this stream depends on (see Section 5.3). [...]
+   *
+   *    Weight: An unsigned 8-bit integer representing a priority weight for
+   *            the stream (see Section 5.3). [...] This field is only
+   *            present if the PRIORITY flag is set.
+   *
+   *    Header Block Fragment: A header block fragment (Section 4.3). *)
+  | Headers of Priority.t * Bigstringaf.t
+  (* From RFC7540§6.3:
+   *   The payload of a PRIORITY frame contains the following fields:
+   *
+   *   E: A single-bit flag indicating that the stream dependency is
+   *      exclusive (see Section 5.3).
+   *
+   *   Stream Dependency: A 31-bit stream identifier for the stream that this
+   *                      stream depends on (see Section 5.3).
+   *
+   *   Weight: An unsigned 8-bit integer representing a priority weight for
+   *           the stream (see Section 5.3). [...] *)
+  | Priority of Priority.t
+  (* From RFC7540§6.4:
+   *   The RST_STREAM frame contains a single unsigned, 32-bit integer
+   *   identifying the error code (Section 7). [...] *)
+  | RSTStream of Error_code.t
+  (* From RFC7540§6.5:
+   *   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. *)
+  | Settings of Settings.settings_list
+  (* From RFC7540§6.6:
+   *   The PUSH_PROMISE frame includes the unsigned 31-bit identifier of the
+   *   stream the endpoint plans to create along with a set of headers that
+   *   provide additional context for the stream. *)
+  | PushPromise of Stream_identifier.t * Bigstringaf.t
+  (* From RFC7540§6.7:
+   *   In addition to the frame header, PING frames MUST contain 8 octets of
+   *   opaque data in the payload. A sender can include any value it chooses
+   *   and use those octets in any fashion. *)
+  | Ping of Bigstringaf.t
+  (* From RFC7540§6.8:
+   *   The last stream identifier in the GOAWAY frame contains the
+   *   highest-numbered stream identifier for which the sender of the GOAWAY
+   *   frame might have taken some action on or might yet take action on.
+   *
+   *   [...] The GOAWAY frame also contains a 32-bit error code (Section 7)
+   *   that contains the reason for closing the connection.
+   *
+   *   [...] Endpoints MAY append opaque data to the payload of any GOAWAY
+   *   frame. *)
+  | GoAway of Stream_identifier.t * Error_code.t * Bigstringaf.t
+  (* From RFC7540§6.9:
+   *   The payload of a WINDOW_UPDATE frame is one reserved bit plus an
+   *   unsigned 31-bit integer indicating the number of octets that the
+   *   sender can transmit in addition to the existing flow-control
+   *   window. *)
+  | WindowUpdate of Settings.WindowSize.t
+  (* From RFC7540§6.10:
+   *   The CONTINUATION frame payload contains a header block fragment
+   *   (Section 4.3). *)
+  | Continuation of Bigstringaf.t
+  | Unknown of int * Bigstringaf.t
+
+(* From RFC7540§4.1:
+ *   All frames begin with a fixed 9-octet header followed by a variable-length
+ *   payload. *)
+type t =
+  { frame_header : frame_header
+  ; frame_payload : frame_payload
+  }

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

@@ -0,0 +1,47 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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 Headers = Headers
+module IOVec = Httpun_types.IOVec
+module Method = Httpun_types.Method
+module Reqd = Reqd
+module Request = Request
+module Response = Response
+module Status = Status
+module Body = Body
+module Error_code = Error_code
+module Config = Config
+module Server_connection = Server_connection
+module Client_connection = Client_connection
+module Settings = Settings

unikernel/duniverse/ocaml-h2/lib/h2.mli

@@ -0,0 +1,956 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+(** H2 is a high-performance, memory-efficient, and scalable HTTP/2
+    implementation for OCaml. It is based on the concepts introduced http/af,
+    and therefore uses the Angstrom and Faraday libraries to implement the
+    parsing and serialization layers of the HTTP/2 standard. It preserves the
+    same API as httpun wherever possible.
+
+    Not unlike httpun, the user should be familiar with HTTP, and the basic
+    principles of memory management and vectorized IO in order to use this
+    library. *)
+
+(** {2 Basic HTTP Types} *)
+
+module Method : module type of Httpun_types.Method
+(** Request Method
+
+    The request method token is the primary source of request semantics; it
+    indicates the purpose for which the client has made this request and what is
+    expected by the client as a successful result.
+
+    See {{:https://tools.ietf.org/html/rfc7231#section-4} RFC7231§4} for more
+    details.
+
+    This module is a proxy to [Httpun_types.Method] and is included in h2 for
+    convenience. *)
+
+(** Response Status Codes
+
+    The status-code element is a three-digit integer code giving the result of
+    the attempt to understand and satisfy the request.
+
+    See {{:https://tools.ietf.org/html/rfc7231#section-6} RFC7231§6} for more
+    details.
+
+    This module is a strict superset of [Httpun_types.Status]. Even though the
+    HTTP/2 specification removes support for the [Switching_protocols] status
+    code, h2 keeps it for the sake of higher level interaction between OCaml
+    libraries that support both HTTP/1 and HTTP/2.
+
+    See {{:https://tools.ietf.org/html/rfc7540#section-8.1.1} RFC7540§8.1.1} for
+    more details. *)
+module Status : sig
+  include
+    module type of Httpun_types.Status
+    with type client_error := Httpun_types.Status.client_error
+     and type standard := Httpun_types.Status.standard
+     and type t := Httpun_types.Status.t
+
+  type client_error =
+    [ Httpun_types.Status.client_error
+    | `Misdirected_request
+    ]
+  (** The 4xx (Client Error) class of status code indicates that the client
+      seems to have erred.
+
+      See {{:https://tools.ietf.org/html/rfc7231#section-6.5} RFC7231§6.5} for
+      more details.
+
+      In addition to httpun, this type also includes the 421 (Misdirected
+      Request) tag. See
+      {{:https://tools.ietf.org/html/rfc7540#section-9.1.2} RFC7540§9.1.2} for
+      more details. *)
+
+  type standard =
+    [ Httpun_types.Status.standard
+    | client_error
+    ]
+  (** The status codes defined in the HTTP/1.1 RFCs, excluding the
+      [Switching Protocols] status and including the [Misdirected Request] as
+      per the HTTP/2 RFC.
+
+      See {{:https://tools.ietf.org/html/rfc7540#section-8.1.1} RFC7540§8.1.1}
+      and {{:https://tools.ietf.org/html/rfc7540#section-9.1.2} RFC7540§9.1.2}
+      for more details. *)
+
+  type t =
+    [ standard
+    | `Code of int
+    ]
+  (** The standard codes along with support for custom codes. *)
+
+  val default_reason_phrase : standard -> string
+  (** [default_reason_phrase standard] is the example reason phrase provided by
+      RFC7231 for the [standard] status code. The RFC allows servers to use
+      reason phrases besides these in responses. *)
+
+  val to_code : t -> int
+  (** [to_code t] is the integer representation of [t]. *)
+
+  val of_code : int -> t
+  (** [of_code i] is the [t] representation of [i]. [of_code] raises [Failure]
+      if [i] is not a positive three-digit number. *)
+
+  val unsafe_of_code : int -> t
+  (** [unsafe_of_code i] is equivalent to [of_code i], except it accepts any
+      positive code, regardless of the number of digits it has. On negative
+      codes, it will still raise [Failure]. *)
+
+  val is_informational : t -> bool
+  (** [is_informational t] is [true] iff [t] belongs to the Informational class
+      of status codes. *)
+
+  val is_successful : t -> bool
+  (** [is_successful t] is [true] iff [t] belongs to the Successful class of
+      status codes. *)
+
+  val is_redirection : t -> bool
+  (** [is_redirection t] is [true] iff [t] belongs to the Redirection class of
+      status codes. *)
+
+  val is_client_error : t -> bool
+  (** [is_client_error t] is [true] iff [t] belongs to the Client Error class of
+      status codes. *)
+
+  val is_server_error : t -> bool
+  (** [is_server_error t] is [true] iff [t] belongs to the Server Error class of
+      status codes. *)
+
+  val is_error : t -> bool
+  (** [is_server_error t] is [true] iff [t] belongs to the Client Error or
+      Server Error class of status codes. *)
+
+  val to_string : t -> string
+  val of_string : string -> t
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+(** Header Fields
+
+    Each header field consists of a lowercase {b field name} and a
+    {b field value}. Per the HTTP/2 specification, header field names {b must}
+    be converted to lowercase prior to their encoding in HTTP/2 (see
+    {{:https://tools.ietf.org/html/rfc7540#section-8.1.2} RFC7540§8.1.2} for
+    more details). h2 does {b not} convert field names to lowercase; it is
+    therefore the responsibility of the caller of the functions contained in
+    this module to use lowercase names for header fields.
+
+    The order in which header fields {i with differing field names} are received
+    is not significant, except for pseudo-header fields, which {b must} appear
+    in header blocks before regular fields (see
+    {{:https://tools.ietf.org/html/rfc7540#section-8.1.2.1} RFC7540§8.1.2.1} for
+    more details).
+
+    A sender MUST NOT generate multiple header fields with the same field name
+    in a message unless either the entire field value for that header field is
+    defined as a comma-separated list or the header field is a well-known
+    exception, e.g., [Set-Cookie].
+
+    A recipient MAY combine multiple header fields with the same field name into
+    one "field-name: field-value" pair, without changing the semantics of the
+    message, by appending each subsequent field value to the combined field
+    value in order, separated by a comma.
+    {i The order in which header fields with the same field name are received is
+       therefore significant to the interpretation of the combined field value};
+    a proxy MUST NOT change the order of these field values when forwarding a
+    message.
+
+    {i Note.} Unless otherwise specified, all operations preserve header field
+    order and all reference to equality on names is assumed to be
+    case-insensitive.
+
+    See {{:https://tools.ietf.org/html/rfc7230#section-3.2} RFC7230§3.2} for
+    more details. *)
+module Headers : sig
+  type t
+  (** The type of a group of header fields. *)
+
+  type name = string
+  (** The type of a lowercase header name. *)
+
+  type value = string
+  (** The type of a header value. *)
+
+  (** {3 Constructor} *)
+
+  val empty : t
+  (** [empty] is the empty collection of header fields. *)
+
+  val of_list : (name * value) list -> t
+  (** [of_list assoc] is a collection of header fields defined by the
+      association list [assoc]. [of_list] assumes the order of header fields in
+      [assoc] is the intended transmission order. The following equations should
+      hold:
+
+      - [to_list (of_list lst) = lst]
+      - [get (of_list [("k", "v1"); ("k", "v2")]) "k" = Some "v2"]. *)
+
+  val of_rev_list : (name * value) list -> t
+  (** [of_list assoc] is a collection of header fields defined by the
+      association list [assoc]. [of_list] assumes the order of header fields in
+      [assoc] is the {i reverse} of the intended trasmission order. The
+      following equations should hold:
+
+      - [to_list (of_rev_list lst) = List.rev lst]
+      - [get (of_rev_list [("k", "v1"); ("k", "v2")]) "k" = Some "v1"]. *)
+
+  val to_list : t -> (name * value) list
+  (** [to_list t] is the association list of header fields contained in [t] in
+      transmission order. *)
+
+  val to_rev_list : t -> (name * value) list
+  (** [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 the
+      same as [t] except with [(name, value)] added at the end of the
+      trasmission order. Additionally, [sensitive] 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
+      more details).
+
+      The following equations should hold:
+
+      - [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
+      fields that is the same as [t] if [t] already inclues [name], and
+      otherwise is equivalent to [add t ?sensitive 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
+      [t] except with all the header fields in [assoc] added to the end of the
+      transmission order, in reverse order. *)
+
+  val add_multi : t -> (name * value list) list -> t
+  (** [add_multi t assoc] is the same as
+
+      {[
+        add_list
+          t
+          (List.concat_map assoc ~f:(fun (name, values) ->
+             List.map values ~f:(fun value -> name, value)))
+      ]}
+
+      but is implemented more efficiently. For example,
+
+      {[
+        add_multi t [ "name1", [ "x", "y" ]; "name2", [ "p", "q" ] ]
+        = add_list [ "name1", "x"; "name1", "y"; "name2", "p"; "name2", "q" ]
+      ]} *)
+
+  val remove : t -> name -> t
+  (** [remove t name] is a collection of header fields that contains all the
+      header fields of [t] except those that have a header-field name that are
+      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 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 the
+      transmission order where the first occurrence of a header field with a
+      name matching [name] was found.
+
+      If no header field with a name equal to [name] is present in [t], then the
+      result is simply [t], unchanged. *)
+
+  (** {3 Destructors} *)
+
+  val mem : t -> name -> bool
+  (** [mem t name] is [true] iff [t] includes a header field with a name that is
+      equal to [name]. *)
+
+  val get : t -> name -> value option
+  (** [get t name] returns the last header from [t] with name [name], or [None]
+      if no such header is present. *)
+
+  val get_exn : t -> name -> value
+  (** [get t name] returns the last header from [t] with name [name], or raises
+      [Not_found] if no such header is present. *)
+
+  val get_multi : t -> name -> value list
+  (** [get_multi t name] is the list of header values in [t] whose names are
+      equal to [name]. The returned list is in transmission order. *)
+
+  (** {3 Iteration} *)
+
+  val iter : f:(name -> value -> unit) -> t -> unit
+  val fold : f:(name -> value -> 'a -> 'a) -> init:'a -> t -> 'a
+
+  (** {3 Utilities} *)
+
+  val to_string : t -> string
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+(** {2 Message Body} *)
+
+module Body : sig
+  module Reader : sig
+    type t
+
+    val schedule_read :
+       t
+      -> on_eof:(unit -> unit)
+      -> on_read:(Bigstringaf.t -> off:int -> len:int -> unit)
+      -> unit
+    (** [schedule_read t ~on_eof ~on_read] will setup [on_read] and [on_eof] as
+        callbacks for when bytes are available in [t] for the application to
+        consume, or when the input channel has been closed and no further bytes
+        will be received by the application.
+
+        Once either of these callbacks have been called, they become inactive.
+        The application is responsible for scheduling subsequent reads, either
+        within the [on_read] callback or by some other mechanism. *)
+
+    val close : t -> unit
+    (** [close t] closes [t], indicating that any subsequent input received
+        should be discarded. *)
+
+    val is_closed : t -> bool
+    (** [is_closed t] is [true] if {!close} has been called on [t] and [false]
+        otherwise. A closed [t] may still have pending output. *)
+  end
+
+  module Writer : sig
+    type t
+
+    val write_char : t -> char -> unit
+    (** [write_char w char] copies [char] into an internal buffer. If possible,
+        this write will be combined with previous and/or subsequent writes
+        before transmission. *)
+
+    val write_string : t -> ?off:int -> ?len:int -> string -> unit
+    (** [write_string w ?off ?len str] copies [str] into an internal buffer. If
+        possible, this write will be combined with previous and/or subsequent
+        writes before transmission. *)
+
+    val write_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit
+    (** [write_bigstring w ?off ?len bs] copies [bs] into an internal buffer. If
+        possible, this write will be combined with previous and/or subsequent
+        writes before transmission. *)
+
+    val schedule_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit
+    (** [schedule_bigstring w ?off ?len bs] schedules [bs] to be transmitted at
+        the next opportunity without performing a copy. [bs] should not be
+        modified until a subsequent call to {!flush} has successfully completed. *)
+
+    val flush : t -> ([ `Written | `Closed ] -> unit) -> unit
+    (** [flush t f] makes all bytes in [t] available for writing to the awaiting
+        output channel. Once those bytes have reached that output channel, [f]
+        will be called.
+
+        The type of the output channel is runtime-dependent, as are guarantees
+        about whether those packets have been queued for delivery or have
+        actually been received by the intended recipient. *)
+
+    val close : t -> unit
+    (** [close t] closes [t], causing subsequent write calls to raise. If [t] is
+        writable, this will cause any pending output to become available to the
+        output channel. *)
+
+    val is_closed : t -> bool
+    (** [is_closed t] is [true] if {!close} has been called on [t] and [false]
+        otherwise. A closed [t] may still have pending output. *)
+  end
+end
+
+(** {2 Message Types} *)
+
+(** Request
+
+    A client-initiated HTTP message. *)
+module Request : sig
+  type t =
+    { meth : Method.t
+    ; target : string
+    ; scheme : string
+    ; headers : Headers.t
+    }
+
+  val create :
+     ?headers:Headers.t (** default is {!Headers.empty} *)
+    -> scheme:string
+    -> Method.t
+    -> string
+    -> t
+  (** [create ?headers ~scheme meth target] creates an HTTP request with the
+      given parameters. In HTTP/2, the [:scheme] pseudo-header field is required
+      and includes the scheme portion of the target URI. The [headers] parameter
+      is optional, however clients will want to include the [:authority]
+      pseudo-header field in most cases. The [:authority] pseudo-header field
+      includes the authority portion of the target URI, and should be used
+      instead of the [Host] header field in HTTP/2.
+
+      See
+      {{:https://tools.ietf.org/html/rfc7540#section-8.1.2.3} RFC7540§8.1.2.4}
+      for more details. *)
+
+  val body_length :
+     t
+    -> [ `Error of [ `Bad_request ] | `Fixed of int64 | `Unknown ]
+  (** [body_length t] is the length of the message body accompanying [t].
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
+      for more details. *)
+
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+(** Response
+
+    A server-generated message to a {!Request.t}. *)
+module Response : sig
+  type t =
+    { status : Status.t
+    ; headers : Headers.t
+    }
+
+  val create :
+     ?headers:Headers.t (** default is {!Headers.empty} *)
+    -> Status.t
+    -> t
+  (** [create ?headers status] creates an HTTP response with the given
+      parameters. Unlike the [Response] type in httpun, h2 does not define a way
+      for responses to carry reason phrases or protocol version.
+
+      See
+      {{:https://tools.ietf.org/html/rfc7540#section-8.1.2.4} RFC7540§8.1.2.4}
+      for more details. *)
+
+  val body_length :
+     request_method:Method.standard
+    -> t
+    -> [ `Error of [ `Bad_request ] | `Fixed of int64 | `Unknown ]
+  (** [body_length ~request_method t] is the length of the message body
+      accompanying [t] assuming it is a response to a request whose method was
+      [request_method].
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
+      for more details. *)
+
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+module IOVec : module type of Httpun_types.IOVec
+(** IOVec *)
+
+(** {2 Request Descriptor} *)
+module Reqd : sig
+  type error =
+    [ `Bad_request
+    | `Internal_server_error
+    | `Exn of exn
+    ]
+
+  type t
+
+  val request : t -> Request.t
+  val request_body : t -> Body.Reader.t
+  val response : t -> Response.t option
+  val response_exn : t -> Response.t
+
+  (** {3 Responding}
+
+      The following functions will initiate a response for the corresponding
+      request in [t]. When the response is fully transmitted to the wire, the
+      stream completes.
+
+      From {{:https://tools.ietf.org/html/rfc7540#section-8.1} RFC7540§8.1}: An
+      HTTP request/response exchange fully consumes a single stream. *)
+
+  val respond_with_string : t -> Response.t -> string -> unit
+  val respond_with_bigstring : t -> Response.t -> Bigstringaf.t -> unit
+
+  val respond_with_streaming :
+     t
+    -> ?flush_headers_immediately:bool
+    -> Response.t
+    -> Body.Writer.t
+
+  val schedule_trailers : t -> Headers.t -> unit
+  (** [schedule_trailers reqd trailers] schedules a list of trailers to be sent
+      before the stream is closed, concluding the HTTP message. Should only be
+      used after {!respond_with_streaming}. Raises [Failure] if trailers have
+      already been scheduled. See
+      {{:https://tools.ietf.org/html/rfc7540#section-8.1} RFC7540§8.1} for more
+      information *)
+
+  (** {3 Pushing}
+
+      HTTP/2 allows a server to pre-emptively send (or "push") responses (along
+      with corresponding "promised" requests) to a client in association with a
+      previous client-initiated request. This can be useful when the server
+      knows the client will need to have those responses available in order to
+      fully process the response to the original request.
+
+      {4 {b An additional note regarding server push:}}
+
+      In HTTP/2, PUSH_PROMISE frames must only be sent in the open or
+      half-closed ("remote") stream states. In practice, this means that calling
+      {!Reqd.push} must happen before the entire response body for the
+      associated client-initiated request has been written to the wire. As such,
+      it is dangerous to start a server pushed response in association with
+      either {!Reqd.respond_with_string} or {!Reqd.respond_with_bigstring}, as
+      the entire body for the response that they produce is sent to the output
+      channel immediately, causing the corresponding stream to enter the closed
+      state.
+
+      See {{:https://tools.ietf.org/html/rfc7540#section-8.2} RFC7540§8.2} for
+      more details. *)
+
+  val push :
+     t
+    -> Request.t
+    -> ( t
+         , [ `Push_disabled | `Stream_cant_push | `Stream_ids_exhausted ] )
+         result
+  (** [push reqd request] creates a new ("pushed") request descriptor that
+      allows responding to the "promised" [request]. As per the HTTP/2
+      specification, [request] must be cacheable, safe, and must not include a
+      request body (see
+      {{:https://tools.ietf.org/html/rfc7540.html#section-8.2} RFC7540§8.2} for
+      more details). {b Note}: h2 will not validate [request] against these
+      assumptions.
+
+      This function returns [Error `Push_disabled] when the value of
+      [SETTINGS_ENABLE_PUSH] is set to [0] (see
+      {{:https://tools.ietf.org/html/rfc7540.html#section-6.5.2} RFC7540§8.2}
+      for more details), [Error `Stream_cant_push] when trying to initiate a
+      push stream from a stream that has been obtained from pushing, or
+      [Error `Stream_ids_exhausted] when the connection has exhausted the range
+      of identifiers available for pushed streams and cannot push on that
+      connection anymore. *)
+
+  (** {3 Exception Handling} *)
+
+  val error_code : t -> error option
+  val report_exn : t -> exn -> unit
+  val try_with : t -> (unit -> unit) -> (unit, exn) result
+end
+
+(** {2 Errors} *)
+module Error_code : sig
+  type t =
+    (* From RFC7540§7:
+     *   NO_ERROR (0x0): The associated condition is not a result of an
+     *   error. *)
+    | NoError
+    (* From RFC7540§7:
+     *   PROTOCOL_ERROR (0x1): The endpoint detected an unspecific protocol
+     *   error. This error is for use when a more specific error code is not
+     *   available. *)
+    | ProtocolError
+    (* From RFC7540§7:
+     *   INTERNAL_ERROR (0x2): The endpoint encountered an unexpected internal
+     *   error. *)
+    | InternalError
+    (* From RFC7540§7:
+     *   FLOW_CONTROL_ERROR (0x3): The endpoint detected that its peer violated
+     *   the flow-control protocol. *)
+    | FlowControlError
+    (* From RFC7540§7:
+     *   SETTINGS_TIMEOUT (0x4): The endpoint sent a SETTINGS frame but did not
+     *   receive a response in a timely manner. *)
+    | SettingsTimeout
+    (* From RFC7540§7:
+     *   STREAM_CLOSED (0x5): The endpoint received a frame after a stream was
+     *   half-closed. *)
+    | StreamClosed
+    (* From RFC7540§7:
+     *   FRAME_SIZE_ERROR (0x6): The endpoint received a frame with an invalid
+     *   size. *)
+    | FrameSizeError
+    (* From RFC7540§7:
+     *   REFUSED_STREAM (0x7): The endpoint refused the stream prior to
+     *   performing any application processing (see Section 8.1.4 for
+     *   details). *)
+    | RefusedStream
+    (* From RFC7540§7:
+     *   CANCEL (0x8): Used by the endpoint to indicate that the stream is no
+     *   longer needed. *)
+    | Cancel
+    (* From RFC7540§7:
+     *   COMPRESSION_ERROR (0x9): The endpoint is unable to maintain the header
+     *   compression context for the connection. *)
+    | CompressionError
+    (* From RFC7540§7:
+     *   CONNECT_ERROR (0xa): The connection established in response to a
+     *   CONNECT request (Section 8.3) was reset or abnormally closed. *)
+    | ConnectError
+    (* From RFC7540§7:
+     *   ENHANCE_YOUR_CALM (0xb): The endpoint detected that its peer is
+     *   exhibiting a behavior that might be generating excessive load. *)
+    | EnhanceYourCalm
+    (* From RFC7540§7:
+     *   INADEQUATE_SECURITY (0xc): The underlying transport has properties
+     *   that do not meet minimum security requirements (see Section 9.2). *)
+    | InadequateSecurity
+    (* From RFC7540§7:
+     *   HTTP_1_1_REQUIRED (0xd): The endpoint requires that HTTP/1.1 be used
+     *   instead of HTTP/2. *)
+    | HTTP_1_1_Required
+    (* From RFC7540§7:
+     *   Unknown or unsupported error codes MUST NOT trigger any special
+     *   behavior. These MAY be treated by an implementation as being
+     *   equivalent to INTERNAL_ERROR. *)
+    | UnknownError_code of int32
+
+  val to_string : t -> string
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+(* TODO: needs docs *)
+module Settings : sig
+  type t =
+    { header_table_size : int
+    ; enable_push : bool
+    ; max_concurrent_streams : int32
+    ; initial_window_size : int32
+    ; max_frame_size : int
+    ; max_header_list_size : int option
+    }
+
+  val default : t
+
+  val of_base64 : string -> (t, string) result
+  (** {{:https://tools.ietf.org/html/rfc7540#section-3.2.1} RFC7540§3.2.1} *)
+
+  val to_base64 : t -> (string, string) result
+  (** {{:https://tools.ietf.org/html/rfc7540#section-3.2.1} RFC7540§3.2.1} *)
+
+  val pp_hum : Format.formatter -> t -> unit
+end
+
+(** {2 HTTP/2 Configuration} *)
+module Config : sig
+  type t =
+    { read_buffer_size : int
+    (** [read_buffer_size] specifies the size of the largest frame payload that
+        the sender is willing to receive, in octets. Defaults to [16384] *)
+    ; request_body_buffer_size : int  (** Defaults to [4096] *)
+    ; response_body_buffer_size : int  (** Defaults to [4096] *)
+    ; enable_server_push : bool  (** Defaults to [true] *)
+    ; max_concurrent_streams : int32
+    (** [max_concurrent_streams] specifies the maximum number of streams that
+        the sender will allow the peer to initiate. Defaults to [2^31 - 1] *)
+    ; initial_window_size : int32
+    (** [initial_window_size] specifies the initial window size for flow control
+        tokens. Defaults to [65535] *)
+    }
+
+  val default : t
+  (** [default] is a configuration record with all parameters set to their
+      default values. *)
+
+  val to_settings : t -> Settings.t
+end
+
+(** {2 Server Connection} *)
+
+module Server_connection : sig
+  type t
+
+  type error =
+    [ `Bad_request
+    | `Internal_server_error
+    | `Exn of exn
+    ]
+
+  type request_handler = Reqd.t -> unit
+
+  type error_handler =
+    ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
+
+  val create :
+     ?config:Config.t
+    -> ?error_handler:error_handler
+    -> request_handler
+    -> t
+  (** [create ?config ?error_handler ~request_handler] creates a connection
+      handler that will service individual requests with [request_handler]. *)
+
+  val create_h2c :
+     ?config:Config.t
+    -> ?error_handler:error_handler
+    -> headers:Httpun_types.Headers.t
+    -> target:string
+    -> meth:Httpun_types.Method.t
+    -> ?request_body:Bigstringaf.t IOVec.t list
+    -> request_handler
+    -> (t, string) result
+  (** [create ?config ?error_handler ~http_request ~request_handler] creates a
+      connection handler that will take over the communication channel from a
+      HTTP/1.1 connection, and service individual HTTP/2.0 requests with
+      [request_handler]. Upon successful creation, it returns the connection,
+      otherwise an error message is returned with an explanation of the failure
+      that caused the connection setup to not succeed.
+
+      This function is intended to be used in HTTP/1.1 upgrade handlers to set
+      up a new [h2c] (HTTP/2.0 over TCP) connection without prior knowledge.
+
+      See {{:https://tools.ietf.org/html/rfc7540#section-3.2} RFC7540§3.2} for
+      more details. *)
+
+  val next_read_operation : t -> [> `Read | `Close ]
+  (** [next_read_operation t] returns a value describing the next operation that
+      the caller should conduct on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      value and additional input is available for the connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      and an EOF has been received from the communication channel. The
+      connection will attempt to consume any buffered input and then shutdown
+      the HTTP parser for the connection. *)
+
+  val next_write_operation :
+     t
+    -> [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {!report_write_result} should be called after a
+      call to {!next_write_operation} that returns a [`Write buffer] value.
+
+      - [`Ok n] indicates that the caller successfully wrote [n] bytes of output
+        from the buffer that the caller was provided by {!next_write_operation}.
+      - [`Closed] indicates that the output destination will no longer accept
+        bytes from the write processor. *)
+
+  val yield_writer : t -> (unit -> unit) -> unit
+  (** [yield_writer t continue] registers with the connection to call [continue]
+      when writing should resume. {!yield_writer} should be called after
+      {!next_write_operation} returns a [`Yield] value. *)
+
+  val yield_reader : t -> (unit -> unit) -> unit
+  (** [yield_reader t continue] immediately calls [continue]. This function *
+      shouldn't generally be called and it's only here to simplify adhering * to
+      the Gluten [RUNTIME] module type. *)
+
+  val report_exn : t -> exn -> unit
+  (** [report_exn t exn] reports that an error [exn] has been caught and that it
+      has been attributed to [t]. Calling this function will switch [t] into an
+      error state. Depending on the state [t] is transitioning from, it may call
+      its error handler before terminating the connection. *)
+
+  val is_closed : t -> bool
+  (** [is_closed t] is [true] if both the read and write processors have been
+      shutdown. When this is the case {!next_read_operation} will return
+      [`Close _] and {!next_write_operation} will do the same will return a
+      [`Write _] until all buffered output has been flushed, at which point it
+      will return [`Close]. *)
+
+  (* val error_code : t -> error option *)
+  (** [error_code t] returns the [error_code] that caused the connection to
+      close, if one exists. *)
+
+  (**/**)
+
+  val shutdown : t -> unit
+
+  (**/**)
+end
+
+(** {2 Client Connection} *)
+
+module Client_connection : sig
+  type t
+
+  type error =
+    [ `Malformed_response of string
+    | `Invalid_response_body_length of Response.t
+    | `Protocol_error of Error_code.t * string
+    | `Exn of exn
+    ]
+
+  type trailers_handler = Headers.t -> unit
+  type response_handler = Response.t -> Body.Reader.t -> unit
+  type error_handler = error -> unit
+
+  val create :
+     ?config:Config.t
+    -> ?push_handler:(Request.t -> (response_handler, unit) result)
+    -> error_handler:error_handler
+    -> unit
+    -> t
+  (** [create ?config ?push_handler ~error_handler] creates a connection that
+      can be used to interact with servers over the HTTP/2 protocol.
+
+      [error_handler] will be called for {e connection-level} errors. HTTP/2 is
+      multiplexed over a single TCP connection and distinguishes
+      connection-level errors from stream-level errors. See See
+      {{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
+      details.
+
+      If present, [push_handler] will be called upon the receipt of PUSH_PROMISE
+      frames with the request promised by the server. This function should
+      return [Ok response_handler] if the client wishes to accept the pushed
+      request. In this case, [response_handler] will be called once the server
+      respondes to the pushed request. Returning [Error ()] will signal to h2
+      that the client is choosing to reject the request that the server is
+      pushing, and its stream will be closed, as per the following excerpt from
+      the HTTP/2 specification:
+
+      From RFC7540§6.6: Recipients of PUSH_PROMISE frames can choose to reject
+      promised streams by returning a RST_STREAM referencing the promised stream
+      identifier back to the sender of the PUSH_PROMISE. *)
+
+  val create_h2c :
+     ?config:Config.t
+    -> ?push_handler:(Request.t -> (response_handler, unit) result)
+    -> headers:Httpun_types.Headers.t
+    -> target:string
+    -> meth:Httpun_types.Method.t
+    -> error_handler:error_handler
+    -> response_handler * error_handler
+    -> (t, string) result
+
+  val request :
+     t
+    -> ?flush_headers_immediately:bool
+    -> ?trailers_handler:trailers_handler
+    -> Request.t
+    -> error_handler:error_handler
+    -> response_handler:response_handler
+    -> Body.Writer.t
+  (** [request connection ?trailers_handler req ~error_handler
+      ~response_handler]
+      opens a new HTTP/2 stream with [req] and returns a request body that can
+      be written to. Once a response arrives, [response_handler] will be called
+      with its headers and body. [error_handler] will be called for
+      {e stream-level} errors. If there are any trailers they will be parsed and
+      passed to [trailers_handler].
+
+      HTTP/2 is multiplexed over a single TCP connection and distinguishes
+      connection-level errors from stream-level errors. See
+      {{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
+      details. *)
+
+  val ping :
+     t
+    -> ?payload:Bigstringaf.t
+    -> ?off:int
+    -> ((unit, [ `EOF ]) result -> unit)
+    -> unit
+  (** [ping connection ?payload ?off f] sends an HTTP/2 PING frame and registers
+      [f] to be called when the server has sent an acknowledgement for it. A
+      custom [payload] (and offset into that payload) for the PING frame may
+      also be provided. If not, a payload with all bytes set to zero will be
+      used. Note that a PING frame's payload {b must} be 8 octets in length.
+
+      In HTTP/2, the PING frame is a mechanism for measuring a minimal
+      round-trip time from the sender, as well as determining whether an idle
+      connection is still functional. See
+      {{:https://tools.ietf.org/html/rfc7540#section-5.4} RFC7540§5.4} for more
+      details. *)
+
+  val shutdown : t -> unit
+  (** [shutdown connection] initiates the graceful shutdown of [connection], and
+      sends an HTTP/2 GOAWAY frame with NO_ERROR on the output channel (See
+      {{:https://tools.ietf.org/html/rfc7540#section-6.8} RFC7540§6.8} for more
+      details). *)
+
+  val next_read_operation : t -> [> `Read | `Close ]
+  (** [next_read_operation t] returns a value describing the next operation that
+      the caller should conduct on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      value and additional input is available for the connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the connection.
+      {!read} should be called after {!next_read_operation} returns a [`Read]
+      and an EOF has been received from the communication channel. The
+      connection will attempt to consume any buffered input and then shutdown
+      the HTTP parser for the connection. *)
+
+  val next_write_operation :
+     t
+    -> [ `Write of Bigstringaf.t IOVec.t list | `Yield | `Close of int ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {!report_write_result} should be called after a
+      call to {!next_write_operation} that returns a [`Write buffer] value.
+
+      - [`Ok n] indicates that the caller successfully wrote [n] bytes of output
+        from the buffer that the caller was provided by {!next_write_operation}.
+      - [`Closed] indicates that the output destination will no longer accept
+        bytes from the write processor. *)
+
+  val yield_writer : t -> (unit -> unit) -> unit
+  (** [yield_writer t continue] registers with the connection to call [continue]
+      when writing should resume. {!yield_writer} should be called after
+      {!next_write_operation} returns a [`Yield] value. *)
+
+  val yield_reader : t -> (unit -> unit) -> unit
+  (** [yield_reader t continue] immediately calls [continue]. This function *
+      shouldn't generally be called and it's only here to simplify adhering * to
+      the Gluten [RUNTIME] module type. *)
+
+  val report_exn : t -> exn -> unit
+  (** [report_exn t exn] reports that an error [exn] has been caught and that it
+      has been attributed to [t]. Calling this function will switch [t] into an
+      error state. Depending on the state [t] is transitioning from, it may call
+      its (connection-level) error handler before terminating the connection. *)
+
+  val is_closed : t -> bool
+  (** [is_closed t] is [true] if both the read and write processors have been
+      shutdown. When this is the case {!next_read_operation} will return
+      [`Close _] and {!next_write_operation} will do the same will return a
+      [`Write _] until all buffered output has been flushed, at which point it
+      will return [`Close]. *)
+end

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

@@ -0,0 +1,363 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+type name = string
+type value = string
+
+type header = Hpack.header =
+  { name : name
+  ; value : value
+  ; sensitive : bool
+  }
+
+type t = header list
+
+let empty : t = []
+
+let of_rev_list hs =
+  List.map (fun (name, value) -> { name; value; sensitive = false }) hs
+
+let of_list t = of_rev_list (List.rev t)
+let to_rev_list t = List.map (fun { name; value; _ } -> name, value) t
+let to_list t = List.rev (to_rev_list t)
+let to_hpack_list t = List.rev t
+
+exception Local
+
+module CI = struct
+  let char_is_upper c = c >= 0x41 && c <= 0x5a
+  let lower c = if char_is_upper c then c + 32 else c
+
+  let equal x y =
+    let len = String.length x in
+    len = String.length y
+    &&
+    match
+      for i = 0 to len - 1 do
+        let c1 = Char.code (String.unsafe_get x i) in
+        let c2 = Char.code (String.unsafe_get y i) in
+        if c1 = c2 then () else if lower c1 <> lower c2 then raise Local
+      done
+    with
+    | () -> true
+    | exception Local -> false
+
+  let is_lowercase x =
+    let len = String.length x in
+    match
+      for i = 0 to len - 1 do
+        let c1 = Char.code (String.unsafe_get x i) in
+        if char_is_upper c1 then raise Local else ()
+      done
+    with
+    | () -> true
+    | exception Local -> false
+end
+
+let rec mem t name =
+  match t with
+  | { name = name'; _ } :: t' -> CI.equal name name' || 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_list t ls = of_rev_list ls @ t (* XXX(seliopou): do better here *)
+
+let add_multi =
+  let rec loop_outer t lss =
+    match lss with [] -> t | (n, vs) :: lss' -> loop_inner t n vs lss'
+  and loop_inner t n vs lss =
+    match vs with
+    | [] -> loop_outer t lss
+    | v :: vs' ->
+      loop_inner ({ name = n; value = v; sensitive = false } :: t) n vs' lss
+  in
+  loop_outer
+
+let add_unless_exists t ?(sensitive = false) name value =
+  if mem t name then t else { name; value; sensitive } :: t
+
+let replace t ?(sensitive = false) name value =
+  let rec loop t n nv seen =
+    match t with
+    | [] -> if not seen then raise Local else []
+    | ({ name = n'; _ } as nv') :: t ->
+      if CI.equal n n'
+      then if seen then loop t n nv true else nv :: loop t n nv true
+      else nv' :: loop t n nv seen
+  in
+  try loop t name { name; value; sensitive } false with Local -> t
+
+let remove t name =
+  let rec loop s n seen =
+    match s with
+    | [] -> if not seen then raise Local else []
+    | ({ name = n'; _ } as nv') :: s' ->
+      if CI.equal n n' then loop s' n true else nv' :: loop s' n seen
+  in
+  try loop t name false with Local -> t
+
+let get t name =
+  let rec loop t n =
+    match t with
+    | [] -> None
+    | { name = n'; value; _ } :: t' ->
+      if CI.equal n n' then Some value else loop t' n
+  in
+  loop t name
+
+let get_exn t name =
+  let rec loop t =
+    match t with
+    | [] -> raise Not_found
+    | { name = n; value; _ } :: t' -> if CI.equal name n then value else loop t'
+  in
+  loop t
+
+let get_pseudo t name = get t (":" ^ name)
+let get_pseudo_exn t name = get_exn t (":" ^ name)
+
+let get_multi t name =
+  let rec loop t acc =
+    match t with
+    | [] -> acc
+    | { name = n; value; _ } :: t' ->
+      if CI.equal name n then loop t' (value :: acc) else loop t' acc
+  in
+  loop t []
+
+let get_multi_pseudo t name = get_multi t (":" ^ name)
+
+module Pseudo = struct
+  let reserved_request = [ ":method"; ":scheme"; ":authority"; ":path" ]
+  let reserved_response = [ ":status" ]
+
+  (* 0x3A is the char code for `:` *)
+  let is_pseudo name = Char.code (String.unsafe_get name 0) = 0x3A
+end
+
+let iter ~f t = List.iter (fun { name; value; _ } -> f name value) t
+
+let fold ~f ~init t =
+  List.fold_left (fun acc { name; value; _ } -> f name value acc) init t
+
+let exists ~f t = List.exists (fun { name; value; _ } -> f name value) t
+
+let valid_headers ?(is_request = true) t =
+  match get t "connection", get t "TE" with
+  | Some _, _ ->
+    (* From RFC7540§8.1.2.2:
+     *   HTTP/2 does not use the Connection header field to indicate
+     *   connection-specific header fields; in this protocol,
+     *   connection-specific metadata is conveyed by other means. An endpoint
+     *   MUST NOT generate an HTTP/2 message containing connection-specific
+     *   header fields; any message containing connection-specific header
+     *   fields MUST be treated as malformed (Section 8.1.2.6). *)
+    false
+  | _, Some value when value <> "trailers" ->
+    (* From RFC7540§8.1.2.2:
+     *   The only exception to this is the TE header field, which MAY be
+     *   present in an HTTP/2 request; when it is, it MUST NOT contain any
+     *   value other than "trailers". *)
+    false
+  | _ ->
+    let pseudo_ended = ref false in
+    let invalid =
+      exists
+        ~f:(fun name _ ->
+          let is_pseudo = Pseudo.is_pseudo name in
+          let pseudo_did_end = !pseudo_ended in
+          if (not is_pseudo) && not pseudo_did_end then pseudo_ended := true;
+          (* From RFC7540§8.1.2:
+           *   [...] header field names MUST be converted to lowercase
+           *   prior to their encoding in HTTP/2. A request or response
+           *   containing uppercase header field names MUST be treated as
+           *   malformed (Section 8.1.2.6). *)
+          (not CI.(is_lowercase name))
+          (* From RFC7540§8.1.2.1:
+           *   Pseudo-header fields are only valid in the context in
+           *   which they are defined. [...] pseudo-header fields defined
+           *   for responses MUST NOT appear in requests. [...] Endpoints
+           *   MUST treat a request or response that contains undefined
+           *   or invalid pseudo-header fields as malformed (Section
+           *   8.1.2.6). *)
+          || (is_pseudo
+             && not
+                  (List.mem
+                     name
+                     (if is_request
+                      then Pseudo.reserved_request
+                      else Pseudo.reserved_response)))
+          || (* From RFC7540§8.1.2.1:
+              * All pseudo-header fields MUST appear in the header block before
+              * regular header fields. Any request or response that contains a
+              * pseudo-header field that appears in a header block after a
+              * regular header field MUST be treated as malformed (Section
+              * 8.1.2.6). *)
+          (is_pseudo && pseudo_did_end))
+        (to_hpack_list t)
+    in
+    not invalid
+
+let valid_request_headers t = valid_headers t
+let valid_response_headers t = valid_headers ~is_request:false t
+
+let method_path_and_scheme_or_malformed t =
+  match
+    ( get_multi_pseudo t "method"
+    , get_multi_pseudo t "scheme"
+    , get_multi_pseudo t "path" )
+  with
+  | _, [ ("http" | "https") ], [ path ] when String.length path = 0 ->
+    (* From RFC7540§8.1.2.6:
+     *   This pseudo-header field MUST NOT be empty for http or https URIs;
+     *   http or https URIs that do not contain a path component MUST include a
+     *   value of '/'. *)
+    `Malformed
+  (* From RFC7540§8.1.2.3:
+   *   All HTTP/2 requests MUST include exactly one valid value for the
+   *   :method, :scheme, and :path pseudo-header fields, unless it is a
+   *   CONNECT request (Section 8.3). *)
+  | [ ("CONNECT" as meth) ], [], [] ->
+    (* From RFC7540§8.3:
+     *   The HTTP header field mapping works as defined in Section 8.1.2.3
+     *   ("Request Pseudo-Header Fields"), with a few differences.
+     *   Specifically:
+     *
+     *     - The :method pseudo-header field is set to CONNECT.
+     *     - The :scheme and :path pseudo-header fields MUST be omitted.
+     *     - The :authority pseudo-header field contains the host and port to
+     *       connect to (equivalent to the authority-form of the request-target
+     *       of CONNECT requests (see [RFC7230], Section 5.3)).
+     *
+     *   A CONNECT request that does not conform to these restrictions is
+     *   malformed (Section 8.1.2.6). *)
+    if mem t ":authority" then `Valid (meth, "", "") else `Malformed
+  | [ "CONNECT" ], _, _ -> `Malformed
+  | [ meth ], [ scheme ], [ path ] ->
+    if valid_request_headers t then `Valid (meth, path, scheme) else `Malformed
+  | _ -> `Malformed
+
+let trailers_valid t =
+  let invalid =
+    exists
+      ~f:(fun name _ ->
+        (* From RFC7540§8.1.2:
+         *   [...] header field names MUST be converted to lowercase prior to
+         *   their encoding in HTTP/2. A request or response containing
+         *   uppercase header field names MUST be treated as malformed
+         *   (Section 8.1.2.6). *)
+        (not (CI.is_lowercase name))
+        || (* From RFC7540§8.1.2.1:
+            * Pseudo-header fields MUST NOT appear in trailers. Endpoints MUST
+            * treat a request or response that contains undefined or invalid
+            * pseudo-header fields as malformed (Section 8.1.2.6). *)
+        Pseudo.is_pseudo name)
+      t
+  in
+  not invalid
+
+let is_valid_h2c_connection connection =
+  let values = String.split_on_char ',' connection in
+  let values = List.map String.trim values in
+  (* From RFC7540§3.2.1:
+   *   [...] Since the upgrade is only intended to apply to the immediate
+   *   connection, a client sending the HTTP2-Settings header field MUST also
+   *   send HTTP2-Settings as a connection option in the Connection header
+   *   field to prevent it from being forwarded (see Section 6.1 of [RFC7230]).
+   *)
+  match
+    ( List.find_opt (fun x -> CI.equal x "upgrade") values
+    , List.find_opt (fun x -> CI.equal x "http2-settings") values )
+  with
+  | Some _, Some _ -> true
+  | _ -> false
+
+let of_http1 ~headers ~meth ~target =
+  let module Headers = Httpun_types.Headers in
+  match Headers.get headers "host" with
+  | Some host ->
+    (* From RFC7540§8.1.2.3:
+     *   Clients that generate HTTP/2 requests directly SHOULD use the
+     *   :authority pseudo-header field instead of the Host header field. *)
+    let headers =
+      Headers.fold
+        ~f:(fun name value acc ->
+          if CI.equal name "host" || CI.equal name "connection"
+          then
+            (* From RFC7540§8.1.2.2:
+             *   HTTP/2 does not use the Connection header field to indicate
+             *   connection-specific header fields; in this protocol,
+             *   connection-specific metadata is conveyed by other means. An
+             *   endpoint MUST NOT generate an HTTP/2 message containing
+             *   connection-specific header fields; any message containing
+             *   connection-specific header fields MUST be treated as malformed
+             *   (Section 8.1.2.6). *)
+            acc
+          else
+            let name =
+              (* From RFC7540§8.1.2:
+               *   header field names MUST be converted to lowercase prior to
+               *   their encoding in HTTP/2. *)
+              if CI.is_lowercase name then name else String.lowercase_ascii name
+            in
+            (name, value) :: acc)
+        ~init:
+          [ ":authority", host
+          ; ":method", Httpun_types.Method.to_string meth
+          ; ":path", target
+          ; ":scheme", "https"
+          ]
+        headers
+    in
+    Ok (of_rev_list headers)
+  | None -> Error "Missing `Host` header field"
+
+let to_string t =
+  let b = Buffer.create 128 in
+  List.iter
+    (fun (name, value) ->
+       Buffer.add_string b name;
+       Buffer.add_string b ": ";
+       Buffer.add_string b value;
+       Buffer.add_string b "\r\n")
+    (to_list t);
+  Buffer.add_string b "\r\n";
+  Buffer.contents b
+
+let pp_hum fmt t =
+  let pp_elem fmt (name, value) = Format.fprintf fmt "@[(%S %S)@]" name value in
+  Format.fprintf fmt "@[(";
+  Format.pp_print_list pp_elem fmt (to_list t);
+  Format.fprintf fmt ")@]"

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

@@ -0,0 +1,53 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+(* This module contains functionality that applies to both requests and
+ * responses, which are collectively referred to in the HTTP 1.1 specifications
+ * as 'messages'. *)
+
+let content_length_of_string s =
+  match Int64.of_string s with
+  | len when Int64.compare len 0L >= 0 -> `Fixed len
+  | _ | (exception _) -> `Error `Bad_request
+
+let body_length headers =
+  match Headers.get_multi headers "content-length" with
+  | [] -> `Unknown
+  | [ x ] -> content_length_of_string x
+  | hd :: tl ->
+    (* if there are multiple content-length headers we require them all to be
+     * exactly equal. *)
+    if List.for_all (String.equal hd) tl
+    then content_length_of_string hd
+    else `Unknown

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

@@ -0,0 +1,49 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2020 Inhabited Type LLC.
+ *  Copyright (c) 2020 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+type t = unit -> unit
+
+let none = Sys.opaque_identity (fun () -> ())
+
+let some f =
+  if f == none
+  then
+    failwith
+      "Optional_thunk: this function is not representable as a some value";
+  f
+
+let is_none t = t == none
+let is_some t = not (is_none t)
+let call_if_some t = t ()
+let unchecked_value t = t

unikernel/duniverse/ocaml-h2/lib/optional_thunk.mli

@@ -0,0 +1,42 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2020 Inhabited Type LLC.
+ *  Copyright (c) 2020 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+type t
+
+val none : t
+val some : (unit -> unit) -> t
+val is_none : t -> bool
+val is_some : t -> bool
+val call_if_some : t -> unit
+val unchecked_value : t -> unit -> unit

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

@@ -0,0 +1,711 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+open Angstrom
+
+(* We use the tail-recursive variant of `skip_many` from
+ * https://github.com/inhabitedtype/angstrom/pull/219 to avoid memory leaks in
+ * long-running connections. The original `skip_many` can build up a list of
+ * error handlers that may never be released. *)
+let skip_many p =
+  fix (fun m ->
+    p >>| (fun _ -> true) <|> return false >>= function
+    | true -> m
+    | false -> return ())
+
+let default_frame_header =
+  { Frame.payload_length = 0
+  ; flags = Flags.default_flags
+  ; stream_id = -1l
+  ; frame_type = Unknown (-1)
+  }
+
+type parse_context =
+  { mutable frame_header : Frame.frame_header
+  ; mutable remaining_bytes_to_skip : int
+  ; mutable did_report_stream_error : bool
+  ; (* TODO: This should change as new settings frames arrive, but we don't yet
+     * resize the read buffer. *)
+    max_frame_size : int
+  }
+
+let connection_error error_code msg =
+  Error Error.(ConnectionError (error_code, msg))
+
+let stream_error error_code stream_id =
+  Error Error.(StreamError (stream_id, error_code))
+
+let parse_uint24 o1 o2 o3 = (o1 lsl 16) lor (o2 lsl 8) lor o3
+
+let frame_length =
+  (* From RFC7540§4.1:
+   *   Length: The length of the frame payload expressed as an unsigned 24-bit
+   *   integer. *)
+  lift3 parse_uint24 any_uint8 any_uint8 any_uint8
+
+let frame_type =
+  (* From RFC7540§4.1:
+   *   Type: The 8-bit type of the frame. The frame type determines the format
+   *   and semantics of the frame. Implementations MUST ignore and discard any
+   *   frame that has a type that is unknown. *)
+  lift Frame.FrameType.parse any_uint8
+
+let flags =
+  (* From RFC7540§4.1:
+   *   Flags: An 8-bit field reserved for boolean flags specific to the frame
+   *   type. *)
+  any_uint8
+
+let parse_stream_identifier n =
+  (* From RFC7540§4.1:
+   *   Stream Identifier: A stream identifier (see Section 5.1.1) expressed as
+   *   an unsigned 31-bit integer. The value 0x0 is reserved for frames that
+   *   are associated with the connection as a whole as opposed to an
+   *   individual stream. *)
+  Int32.(logand n (sub (shift_left 1l 31) 1l))
+
+let stream_identifier = lift parse_stream_identifier BE.any_int32
+
+let parse_frame_header =
+  lift4
+    (fun payload_length frame_type flags stream_id ->
+       { Frame.flags; payload_length; stream_id; frame_type })
+    frame_length
+    frame_type
+    flags
+    stream_identifier
+  <?> "frame_header"
+  (* The parser commits after parsing the frame header so that the entire
+   * underlying buffer can be used to store the payload length. This matters
+   * because the size of the buffer that gets allocated is the maximum frame
+   * payload negotiated by the HTTP/2 settings synchronization. The 9 octets
+   * that make up the frame header are, therefore, very important in order for
+   * h2 not to return a FRAME_SIZE_ERROR. *)
+  <* commit
+
+let parse_padded_payload { Frame.payload_length; flags; _ } parser =
+  if Flags.test_padded flags
+  then
+    any_uint8 >>= fun pad_length ->
+    (* From RFC7540§6.1:
+     *   Pad Length: An 8-bit field containing the length of the frame
+     *   padding in units of octets.
+     *
+     *   Data: Application data. The amount of data is the remainder of the
+     *   frame payload after subtracting the length of the other fields that
+     *   are present.
+     *
+     *   Padding: Padding octets that contain no application semantic
+     *   value. *)
+    if pad_length >= payload_length
+    then
+      (* From RFC7540§6.1:
+       *   If the length of the padding is the length of the frame payload or
+       *   greater, the recipient MUST treat this as a connection error
+       *   (Section 5.4.1) of type PROTOCOL_ERROR. *)
+      advance (payload_length - 1) >>| fun () ->
+      connection_error ProtocolError "Padding size exceeds payload size"
+    else
+      (* Subtract the octet that contains the length of padding, and the
+       * padding octets. *)
+      let relevant_length = payload_length - 1 - pad_length in
+      parser relevant_length <* advance pad_length
+  else parser payload_length
+
+let parse_data_frame ({ Frame.stream_id; payload_length; _ } as frame_header) =
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.1:
+     *   DATA frames MUST be associated with a stream. If a DATA frame is
+     *   received whose stream identifier field is 0x0, the recipient MUST
+     *   respond with a connection error (Section 5.4.1) of type
+     *   PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      ProtocolError
+      "Data frames must be associated with a stream"
+  else
+    let parse_data length =
+      lift (fun bs -> Ok (Frame.Data bs)) (take_bigstring length)
+    in
+    parse_padded_payload frame_header parse_data
+
+let parse_priority =
+  lift2
+    (fun stream_dependency weight ->
+       let e = Priority.test_exclusive stream_dependency in
+       { Priority.exclusive =
+           e
+           (* From RFC7540§6.3:
+            *   An unsigned 8-bit integer representing a priority weight for the
+            *   stream (see Section 5.3). Add one to the value to obtain a
+            *   weight between 1 and 256. *)
+       ; weight = weight + 1
+       ; stream_dependency = parse_stream_identifier stream_dependency
+       })
+    BE.any_int32
+    any_uint8
+
+let parse_headers_frame frame_header =
+  let { Frame.payload_length; stream_id; flags; _ } = frame_header in
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.2:
+     *   HEADERS frames MUST be associated with a stream. If a HEADERS frame is
+     *   received whose stream identifier field is 0x0, the recipient MUST
+     *   respond with a connection error (Section 5.4.1) of type
+     *   PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error ProtocolError "HEADERS must be associated with a stream"
+  else
+    let parse_headers length =
+      if Flags.test_priority flags
+      then
+        lift2
+          (fun priority headers -> Ok (Frame.Headers (priority, headers)))
+          parse_priority
+          (* See RFC7540§6.3:
+           *   Stream Dependency (4 octets) + Weight (1 octet). *)
+          (take_bigstring (length - 5))
+      else
+        lift
+          (fun headers_block ->
+             Ok (Frame.Headers (Priority.default_priority, headers_block)))
+          (take_bigstring length)
+    in
+    parse_padded_payload frame_header parse_headers
+
+let parse_priority_frame { Frame.payload_length; stream_id; _ } =
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.3:
+     *   The PRIORITY frame always identifies a stream. If a PRIORITY frame is
+     *   received with a stream identifier of 0x0, the recipient MUST respond
+     *   with a connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error ProtocolError "PRIORITY must be associated with a stream"
+  else if payload_length <> 5
+  then
+    (* From RFC7540§6.3:
+     *   A PRIORITY frame with a length other than 5 octets MUST be treated as
+     *   a stream error (Section 5.4.2) of type FRAME_SIZE_ERROR. *)
+    advance payload_length >>| fun () -> stream_error FrameSizeError stream_id
+  else lift (fun priority -> Ok (Frame.Priority priority)) parse_priority
+
+let parse_error_code = lift Error_code.parse BE.any_int32
+
+let parse_rst_stream_frame { Frame.payload_length; stream_id; _ } =
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.4:
+     *   RST_STREAM frames MUST be associated with a stream. If a RST_STREAM
+     *   frame is received with a stream identifier of 0x0, the recipient MUST
+     *   treat this as a connection error (Section 5.4.1) of type
+     *   PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error ProtocolError "RST_STREAM must be associated with a stream"
+  else if payload_length <> 4
+  then
+    (* From RFC7540§6.4:
+     *   A RST_STREAM frame with a length other than 4 octets MUST be treated
+     *   as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      FrameSizeError
+      "RST_STREAM payload must be 4 octets in length"
+  else lift (fun error_code -> Ok (Frame.RSTStream error_code)) parse_error_code
+
+let parse_settings_frame { Frame.payload_length; stream_id; flags; _ } =
+  if not (Stream_identifier.is_connection stream_id)
+  then
+    (* From RFC7540§6.5:
+     *   If an endpoint receives a SETTINGS frame whose stream identifier field
+     *   is anything other than 0x0, the endpoint MUST respond with a
+     *   connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      ProtocolError
+      "SETTINGS must be associated with stream id 0x0"
+  else if payload_length mod 6 <> 0
+  then
+    (* From RFC7540§6.5:
+     *   A SETTINGS frame with a length other than a multiple of 6 octets MUST
+     *   be treated as a connection error (Section 5.4.1) of type
+     *   FRAME_SIZE_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      FrameSizeError
+      "SETTINGS payload size must be a multiple of 6"
+  else if Flags.test_ack flags && payload_length <> 0
+  then
+    (* From RFC7540§6.5:
+     *   Receipt of a SETTINGS frame with the ACK flag set and a length field
+     *   value other than 0 MUST be treated as a connection error
+     *   (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error FrameSizeError "SETTINGS with ACK must be empty"
+  else
+    let num_settings = payload_length / Settings.octets_per_setting in
+    Settings.parse_settings_payload num_settings >>| fun xs ->
+    Ok (Frame.Settings xs)
+
+let parse_push_promise_frame frame_header =
+  let { Frame.payload_length; stream_id; _ } = frame_header in
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.6:
+     *   The stream identifier of a PUSH_PROMISE frame indicates the
+     *   stream it is associated with. If the stream identifier field
+     *   specifies the value 0x0, a recipient MUST respond with a
+     *   connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error ProtocolError "PUSH must be associated with a stream"
+  else
+    let parse_push_promise length =
+      lift2
+        (fun promised_stream_id fragment ->
+           if Stream_identifier.is_connection promised_stream_id
+           then
+             (* From RFC7540§6.6:
+              *   A receiver MUST treat the receipt of a PUSH_PROMISE that
+              *   promises an illegal stream identifier (Section 5.1.1) as a
+              *   connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+             connection_error
+               ProtocolError
+               "PUSH must not promise stream id 0x0"
+           else if Stream_identifier.is_request promised_stream_id
+           then
+             (* From RFC7540§6.6:
+              *   A receiver MUST treat the receipt of a PUSH_PROMISE that
+              *   promises an illegal stream identifier (Section 5.1.1) as a
+              *   connection error (Section 5.4.1) of type PROTOCOL_ERROR.
+              *
+              * Note: An odd-numbered stream is an invalid stream identifier for
+              * the server, and only the server can send PUSH_PROMISE frames:
+              *
+              * From RFC7540§8.2.1:
+              *   PUSH_PROMISE frames MUST NOT be sent by the client. *)
+             connection_error
+               ProtocolError
+               "PUSH must be associated with an even-numbered stream id"
+           else Ok Frame.(PushPromise (promised_stream_id, fragment)))
+        stream_identifier
+        (* From RFC7540§6.6:
+         *   The PUSH_PROMISE frame includes the unsigned 31-bit identifier of
+         *   the stream the endpoint plans to create along with a set of
+         *   headers that provide additional context for the stream. *)
+        (take_bigstring (length - 4))
+    in
+    parse_padded_payload frame_header parse_push_promise
+
+let parse_ping_frame { Frame.payload_length; stream_id; _ } =
+  if not (Stream_identifier.is_connection stream_id)
+  then
+    (* From RFC7540§6.7:
+     *   PING frames are not associated with any individual stream. If a PING
+     *   frame is received with a stream identifier field value other than
+     *   0x0, the recipient MUST respond with a connection error
+     *   (Section 5.4.1) of type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error ProtocolError "PING must be associated with stream id 0x0"
+  else if payload_length <> 8
+  then
+    (* From RFC7540§6.7:
+     *   Receipt of a PING frame with a length field value other than 8 MUST
+     *   be treated as a connection error (Section 5.4.1) of type
+     *   FRAME_SIZE_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error FrameSizeError "PING payload must be 8 octets in length"
+  else lift (fun bs -> Ok (Frame.Ping bs)) (take_bigstring payload_length)
+
+let parse_go_away_frame { Frame.payload_length; stream_id; _ } =
+  if not (Stream_identifier.is_connection stream_id)
+  then
+    (* From RFC7540§6.8:
+     *   The GOAWAY frame applies to the connection, not a specific stream. An
+     *   endpoint MUST treat a GOAWAY frame with a stream identifier other than
+     *   0x0 as a connection error (Section 5.4.1) of type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      ProtocolError
+      "GOAWAY must be associated with stream id 0x0"
+  else
+    lift3
+      (fun last_stream_id err debug_data ->
+         Ok (Frame.GoAway (last_stream_id, err, debug_data)))
+      stream_identifier
+      parse_error_code
+      (take_bigstring (payload_length - 8))
+
+let parse_window_update_frame { Frame.stream_id; payload_length; _ } =
+  (* From RFC7540§6.9:
+   *   A WINDOW_UPDATE frame with a length other than 4 octets MUST be treated
+   *   as a connection error (Section 5.4.1) of type FRAME_SIZE_ERROR. *)
+  if payload_length <> 4
+  then
+    advance payload_length >>| fun () ->
+    connection_error
+      FrameSizeError
+      "WINDOW_UPDATE payload must be 4 octets in length"
+  else
+    lift
+      (fun uint ->
+         (* From RFC7540§6.9:
+          *   The frame payload of a WINDOW_UPDATE frame is one reserved bit
+          *   plus an unsigned 31-bit integer indicating the number of octets
+          *   that the sender can transmit in addition to the existing
+          *   flow-control window. *)
+         let window_size_increment = Util.clear_bit_int32 uint 31 in
+         if Int32.equal window_size_increment 0l
+         then
+           if (* From RFC7540§6.9:
+               * A receiver MUST treat the receipt of a WINDOW_UPDATE frame
+               * with an flow-control window increment of 0 as a stream error
+               * (Section 5.4.2) of type PROTOCOL_ERROR; errors on the
+               * connection flow-control window MUST be treated as a connection
+               * error (Section 5.4.1). *)
+              Stream_identifier.is_connection stream_id
+           then connection_error ProtocolError "Window update must not be 0"
+           else stream_error ProtocolError stream_id
+         else Ok (Frame.WindowUpdate window_size_increment))
+      BE.any_int32
+
+let parse_continuation_frame { Frame.payload_length; stream_id; _ } =
+  if Stream_identifier.is_connection stream_id
+  then
+    (* From RFC7540§6.10:
+     *   CONTINUATION frames MUST be associated with a stream. If a
+     *   CONTINUATION frame is received whose stream identifier field is 0x0,
+     *   the recipient MUST respond with a connection error (Section 5.4.1) of
+     *   type PROTOCOL_ERROR. *)
+    advance payload_length >>| fun () ->
+    connection_error
+      ProtocolError
+      "CONTINUATION must be associated with a stream"
+  else
+    lift
+      (fun block_fragment -> Ok (Frame.Continuation block_fragment))
+      (take_bigstring payload_length)
+
+let parse_unknown_frame typ { Frame.payload_length; _ } =
+  lift
+    (fun bigstring -> Ok (Frame.Unknown (typ, bigstring)))
+    (take_bigstring payload_length)
+
+let parse_frame_payload ({ Frame.frame_type; _ } as frame_header) =
+  (match frame_type with
+    | Frame.FrameType.Data -> parse_data_frame frame_header
+    | Headers -> parse_headers_frame frame_header
+    | Priority -> parse_priority_frame frame_header
+    | RSTStream -> parse_rst_stream_frame frame_header
+    | Settings -> parse_settings_frame frame_header
+    | PushPromise -> parse_push_promise_frame frame_header
+    | Ping -> parse_ping_frame frame_header
+    | GoAway -> parse_go_away_frame frame_header
+    | WindowUpdate -> parse_window_update_frame frame_header
+    | Continuation -> parse_continuation_frame frame_header
+    | Unknown typ -> parse_unknown_frame typ frame_header)
+  <?> "frame_payload"
+
+let parse_frame parse_context =
+  parse_frame_header >>= fun ({ Frame.payload_length; _ } as frame_header) ->
+  (* If we're parsing a new frame, we didn't yet send a stream error on it *)
+  parse_context.did_report_stream_error <- false;
+  parse_context.frame_header <- frame_header;
+  (* h2 does unbuffered parsing and the bigarray we read input from is
+   * allocated based on the maximum frame payload negotiated by HTTP/2
+   * communication. If the underlying buffer is smaller than what
+   * the frame can fit, we want to skip the remaining input and skip to the
+   * next frame.
+   *
+   * From RFC7540§5.4.2:
+   *   A stream error is an error related to a specific stream that does
+   *   not affect processing of other streams. *)
+  let is_frame_size_error = payload_length > parse_context.max_frame_size in
+  if is_frame_size_error
+  then
+    parse_context.remaining_bytes_to_skip <-
+      parse_context.remaining_bytes_to_skip + payload_length;
+  lift
+    (function
+       | Ok frame_payload -> Ok { Frame.frame_header; frame_payload }
+       | Error e -> Error e)
+    (parse_frame_payload frame_header)
+
+(* This is the client connection preface. *)
+let connection_preface =
+  (* From RFC7540§3.5:
+   *   In HTTP/2, each endpoint is required to send a connection preface as a
+   *   final confirmation of the protocol in use and to establish the initial
+   *   settings for the HTTP/2 connection. *)
+  string Frame.connection_preface <?> "connection preface"
+
+module Reader = struct
+  module AU = Angstrom.Unbuffered
+
+  type parse_error =
+    (* Parse error reported by Angstrom *)
+    [ `Parse of string list * string
+    | (* Full error information *)
+      `Error of Error.t
+    | (* Just the error code, need to puzzle back connection or stream info *)
+      `Error_code of
+      Error_code.t
+    ]
+
+  type 'error parse_state =
+    | Initial
+    | Fail of 'error
+    | Partial of
+        (Bigstringaf.t
+         -> off:int
+         -> len:int
+         -> AU.more
+         -> (unit, 'error) result AU.state)
+
+  type 'error t =
+    { parser : (unit, 'error) result Angstrom.t
+    ; mutable parse_state : 'error parse_state
+          (* The state of the parse for the current request *)
+    ; mutable closed : bool
+          (* Whether the input source has left the building, indicating that no
+             further input will be received. *)
+    ; parse_context : parse_context
+    (* The current stream identifier being processed, in order to discern
+       whether the error that needs to be assembled is a stream or connection
+       error. *)
+    }
+
+  type frame = parse_error t
+
+  let create parser parse_context =
+    { parser; parse_state = Initial; closed = false; parse_context }
+
+  let create_parse_context max_frame_size =
+    { frame_header = default_frame_header
+    ; remaining_bytes_to_skip = 0
+    ; did_report_stream_error = false
+    ; max_frame_size
+    }
+
+  let settings_preface parse_context =
+    (* From RFC7540§3.5:
+     *   [...] the connection preface starts with the string
+     *   PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n). This sequence MUST be followed by
+     *   a SETTINGS frame (Section 6.5), which MAY be empty. *)
+    parse_frame parse_context >>| function
+    | Ok ({ frame_payload = Frame.Settings settings_list; _ } as frame) ->
+      Ok (frame, settings_list)
+    | Ok { frame_payload = Frame.GoAway (_, error_code, debug_data); _ } ->
+      (* From RFC7540§9.2.1:
+       *   An endpoint MAY immediately terminate an HTTP/2 connection that does
+       *   not meet these TLS requirements with a connection error (Section
+       *   5.4.1) of type INADEQUATE_SECURITY.
+       *
+       *   Note: we are liberal on purpose in this branch instead of only
+       *   accepting an error of type `INADEQUATE_SECURITY`. If an endpoint is
+       *   sending us a `GOAWAY` frame we probably did something wrong and
+       *   deserve to know what that is. *)
+      Error
+        (`Error
+          Error.(ConnectionError (error_code, Bigstringaf.to_string debug_data)))
+    | Ok _ ->
+      (* From RFC7540§3.5:
+       *   Clients and servers MUST treat an invalid connection preface as a
+       *   connection error (Section 5.4.1) of type PROTOCOL_ERROR. A GOAWAY
+       *   frame (Section 6.8) MAY be omitted in this case, since an invalid
+       *   preface indicates that the peer is not using HTTP/2. *)
+      Error
+        (`Error
+          Error.(ConnectionError (ProtocolError, "Invalid connection preface")))
+    | Error e -> Error (`Error e)
+
+  let connection_preface_and_frames
+      ~max_frame_size
+      preface_parser
+      preface_handler
+      frame_handler
+    =
+    let parse_context = create_parse_context max_frame_size in
+    let parser =
+      preface_parser parse_context <* commit >>= function
+      | Ok (frame, settings_list) ->
+        preface_handler frame settings_list;
+        (* After having received a valid connection preface, we can start
+         * reading other frames now. *)
+        skip_many (parse_frame parse_context <* commit >>| frame_handler)
+        >>| fun () -> Ok ()
+      | Error _ as error -> return error
+    in
+    create parser parse_context
+
+  let client_frames preface_handler frame_handler =
+    connection_preface_and_frames
+      (* From RFC7540§3.5:
+       *   The server connection preface consists of a potentially empty
+       *   SETTINGS frame (Section 6.5) that MUST be the first frame the server
+       *   sends in the HTTP/2 connection. *)
+      settings_preface
+      preface_handler
+      frame_handler
+
+  let server_frames ~max_frame_size preface_handler frame_handler =
+    connection_preface_and_frames
+      ~max_frame_size
+      (fun parse_context ->
+         (* From RFC7540§3.5:
+          *   The client connection preface starts with a sequence of 24 octets,
+          *   which in hex notation is:
+          *
+          *     0x505249202a20485454502f322e300d0a0d0a534d0d0a0d0a
+          *   That is, the connection preface starts with the string
+          *   PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n). This sequence MUST be followed
+          *   by a SETTINGS frame (Section 6.5), which MAY be empty. *)
+         connection_preface *> settings_preface parse_context)
+      preface_handler
+      frame_handler
+
+  let is_closed t = t.closed
+
+  let transition t state =
+    match state with
+    | AU.Done (consumed, Ok ()) ->
+      t.parse_state <- Initial;
+      consumed
+    | Done (consumed, Error error) ->
+      t.parse_state <- Fail error;
+      consumed
+    | Fail (consumed, marks, msg) ->
+      t.parse_state <- Fail (`Parse (marks, msg));
+      consumed
+    | Partial { committed; continue } ->
+      (* If we have bytes to skip over then it means we've spotted a
+       * FRAME_SIZE_ERROR, a case where, due to our unbuffered parsing, the
+       * payload length declared in a frame header is larger than the
+       * underlying buffer can fit. *)
+      if t.parse_context.remaining_bytes_to_skip > 0
+      then t.parse_state <- Fail (`Error_code Error_code.FrameSizeError)
+      else t.parse_state <- Partial continue;
+      committed
+
+  let start t state =
+    match state with
+    | AU.Done _ -> failwith "h2.Parse.Reader.unable to start parser"
+    | Fail (0, marks, msg) -> t.parse_state <- Fail (`Parse (marks, msg))
+    | Partial { committed = 0; continue } -> t.parse_state <- Partial continue
+    | Partial _ | Fail _ -> assert false
+
+  let rec read_with_more t bs ~off ~len more =
+    let consumed =
+      match t.parse_state with
+      | Fail _ ->
+        let parser_ctx = t.parse_context in
+        let remaining_bytes = parser_ctx.remaining_bytes_to_skip in
+        (* Just skip input if we need to *)
+        if remaining_bytes > 0
+        then (
+          assert (remaining_bytes >= len);
+          let remaining_bytes' = remaining_bytes - len in
+          parser_ctx.remaining_bytes_to_skip <- remaining_bytes';
+          assert (remaining_bytes' >= 0);
+          if remaining_bytes' = 0
+          then
+            (* Reset the parser state to `Done` so that we can read the next
+             * frame (after skipping through the bad input) *)
+            t.parse_state <- Initial;
+          len)
+        else 0
+      | Initial ->
+        start t (AU.parse t.parser);
+        read_with_more t bs ~off ~len more
+      | Partial continue -> transition t (continue bs more ~off ~len)
+    in
+    (match more with Complete -> t.closed <- true | Incomplete -> ());
+    consumed
+
+  let force_close t = t.closed <- true
+  let fail_to_string marks err = String.concat " > " marks ^ ": " ^ err
+
+  let next_from_error t ?(msg = "") error_code =
+    if t.parse_context.frame_header == default_frame_header
+    then `Error Error.(ConnectionError (error_code, msg))
+    else
+      match t.parse_context, error_code with
+      | ( { frame_header =
+              { frame_type =
+                  Headers | PushPromise | Continuation | Settings | Unknown _
+              ; _
+              }
+          ; _
+          }
+        , Error_code.FrameSizeError )
+      | { frame_header = { Frame.stream_id = 0x0l; _ }; _ }, _ ->
+        (* From RFC7540§4.2:
+         *   A frame size error in a frame that could alter the state of the
+         *   entire connection MUST be treated as a connection error (Section
+         *   5.4.1); this includes any frame carrying a header block (Section
+         *   4.3) (that is, HEADERS, PUSH_PROMISE, and CONTINUATION), SETTINGS,
+         *   and any frame with a stream identifier of 0. *)
+        `Error Error.(ConnectionError (error_code, msg))
+      | { did_report_stream_error = true; _ }, _ ->
+        (* If the parser is in a `Fail` state and would report a stream error,
+         * just issue a `Read` operation if we've already reported that error. *)
+        if t.closed then `Close else `Read
+      | { frame_header = { Frame.stream_id; _ }; _ }, _ ->
+        t.parse_context.did_report_stream_error <- true;
+        `Error Error.(StreamError (stream_id, error_code))
+
+  let next t =
+    match t.parse_state with
+    | Fail error ->
+      (match error with
+      | `Error e -> `Error e
+      | `Error_code error_code -> next_from_error t error_code
+      | `Parse (marks, msg) ->
+        let error_code =
+          match marks, msg with
+          | [ "frame_payload" ], "not enough input" ->
+            (* From RFC7540§4.2:
+             *   An endpoint MUST send an error code of FRAME_SIZE_ERROR if a
+             *   frame exceeds the size defined in SETTINGS_MAX_FRAME_SIZE,
+             *   exceeds any limit defined for the frame type, or is too small
+             *   to contain mandatory frame data. *)
+            Error_code.FrameSizeError
+          | _ -> Error_code.ProtocolError
+        in
+        next_from_error t ~msg:(fail_to_string marks msg) error_code)
+    | _ when t.closed -> `Close
+    | Partial _ -> `Read
+    | Initial -> if t.closed then `Close else `Read
+end

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

@@ -0,0 +1,71 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+open Util
+
+type t =
+  { exclusive : bool
+  ; stream_dependency : Stream_identifier.t
+  ; weight : int
+  }
+
+(* From RFC7540§5.3.5:
+ *   All streams are initially assigned a non-exclusive dependency on stream
+ *   0x0. Pushed streams (Section 8.2) initially depend on their associated
+ *   stream. In both cases, streams are assigned a default weight of 16. *)
+let default_priority =
+  { exclusive = false; stream_dependency = 0l; weight = 16 }
+
+(* From RFC7540§5.4.1:
+ *   All dependent streams are allocated an integer weight between 1 and 256
+ *   (inclusive). *)
+let highest_priority =
+  { exclusive = false; stream_dependency = 0l; weight = 256 }
+
+(* --- Exclusive flag ---
+ *
+ * From RFC7540§5.4.1:
+ *   +-+-------------------------------------------------------------+
+ *   |E|                  Stream Dependency (31)                     |
+ *   +-+-------------+-----------------------------------------------+
+ *   |   Weight (8)  |
+ *   +-+-------------+
+ *)
+
+let test_exclusive n = test_bit_int32 n 31
+let set_exclusive n = set_bit_int32 n 31
+let clear_exclusive n = clear_bit_int32 n 31
+
+let equal p1 p2 =
+  p1.weight = p2.weight
+  && Int32.equal p1.stream_dependency p2.stream_dependency
+  && p1.exclusive = p2.exclusive

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

@@ -0,0 +1,523 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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 Writer = Serialize.Writer
+
+type error =
+  [ `Bad_request
+  | `Internal_server_error
+  | `Exn of exn
+  ]
+
+type error_handler =
+  ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
+
+type response_state =
+  | Waiting
+  | Fixed of
+      { response : Response.t
+      ; mutable iovec :
+          [ `String of string | `Bigstring of Bigstringaf.t ]
+            Httpun_types.IOVec.t
+      }
+  | Streaming of
+      { response : Response.t
+      ; response_body : Body.Writer.t
+      ; trailers : Headers.t
+      }
+  | Complete of Response.t
+
+type request_info =
+  { request : Request.t
+  ; request_body : Body.Reader.t
+  ; mutable request_body_bytes : int64
+  }
+
+type active_state = (request_info, request_info) Stream.active_state
+
+type active_stream =
+  { body_buffer_size : int
+  ; encoder : Hpack.Encoder.t
+  ; mutable response_state : response_state
+        (* We're not doing anything with these yet, we could probably have a
+         * `Reqd.schedule_read_trailers` function that would be called once
+         * trailer headers are emitted. *)
+  ; mutable trailers_parser : Stream.partial_headers option
+  ; mutable trailers : Headers.t option
+  ; create_push_stream :
+      Stream_identifier.t
+      -> (t, [ `Push_disabled | `Stream_ids_exhausted ]) result
+  }
+
+and state =
+  (active_state, active_stream, request_info * active_stream) Stream.state
+
+and t = (state, error, error_handler) Stream.t
+
+let create_active_request request request_body =
+  { request; request_body; request_body_bytes = Int64.zero }
+
+let create_active_stream encoder body_buffer_size create_push_stream =
+  { body_buffer_size
+  ; encoder
+  ; response_state = Waiting
+  ; trailers_parser = None
+  ; trailers = None
+  ; create_push_stream
+  }
+
+let request (t : t) =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _ | FullHeaders), _) ->
+    assert false
+  | Active ((Open (ActiveMessage { request; _ }) | HalfClosed { request; _ }), _)
+  | Reserved ({ request; _ }, _) ->
+    request
+  | Closed _ -> assert false
+
+let request_body (t : t) =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _ | FullHeaders), _) ->
+    assert false
+  | Active
+      ( ( Open (ActiveMessage { request_body; _ })
+        | HalfClosed { request_body; _ } )
+      , _ ) ->
+    request_body
+  | Reserved _ ->
+    (* From RFC7540§8.1:
+     *   Promised requests MUST NOT include a request body. *)
+    failwith
+      "h2.Reqd.request_body: Promised requests must not include a request body"
+  | Closed _ -> failwith "h2.Reqd.request_body: Stream already closed"
+
+let response (t : t) =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> None
+  | Active
+      ( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
+      , { response_state; _ } )
+  | Reserved (_, { response_state; _ }) ->
+    (match response_state with
+    | Waiting -> None
+    | Streaming { response; _ } | Fixed { response; _ } | Complete response ->
+      Some response)
+  | Closed _ -> None
+
+let response_exn (t : t) =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) ->
+    failwith "h2.Reqd.response_exn: response has not started"
+  | Active
+      ( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
+      , { response_state; _ } )
+  | Reserved (_, { response_state; _ }) ->
+    (match response_state with
+    | Waiting -> failwith "h2.Reqd.response_exn: response has not started"
+    | Streaming { response; _ } | Fixed { response; _ } | Complete response ->
+      response)
+  | Closed _ -> assert false
+
+let send_fixed_response (t : t) s response data =
+  match s.response_state with
+  | Waiting ->
+    let iovec, length =
+      match data with
+      | `String s ->
+        let len = String.length s in
+        let iovec = { Httpun_types.IOVec.buffer = `String s; off = 0; len } in
+        iovec, len
+      | `Bigstring b ->
+        let len = Bigstringaf.length b in
+        let iovec =
+          { Httpun_types.IOVec.buffer = `Bigstring b; off = 0; len }
+        in
+        iovec, len
+    in
+    let should_send_data = length <> 0 in
+    let frame_info =
+      Writer.make_frame_info
+        ~max_frame_size:t.max_frame_size
+        ~flags:
+          (if should_send_data
+           then Flags.default_flags
+           else Flags.(set_end_stream default_flags))
+        t.id
+    in
+    Writer.write_response_headers t.writer s.encoder frame_info response;
+    (* From RFC7540§8.1:
+     *   An HTTP request/response exchange fully consumes a single stream.
+     *   [...] A response starts with a HEADERS frame and ends with a frame
+     *   bearing END_STREAM, which places the stream in the "closed" state. *)
+    if should_send_data
+    then s.response_state <- Fixed { response; iovec }
+    else s.response_state <- Complete response;
+    Writer.wakeup t.writer
+  | Streaming _ -> failwith "h2.Reqd.respond_with_*: response already started"
+  | Fixed _ -> failwith "h2.Reqd.respond_with_*: response already sent"
+  | Complete _ -> failwith "h2.Reqd.respond_with_*: response already complete"
+
+let schedule_trailers (t : t) new_trailers =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
+  | Closed _ -> failwith "h2.Reqd.schedule_trailers: stream already closed"
+  | Reserved _ -> failwith "h2.Reqd.schedule_trailers: response not started"
+  | Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
+    (match stream.response_state with
+    | Streaming { response; response_body; trailers = old_trailers } ->
+      if old_trailers <> Headers.empty
+      then failwith "h2.Reqd.schedule_trailers: trailers already scheduled";
+      stream.response_state <-
+        Streaming { response; response_body; trailers = new_trailers }
+    | _ ->
+      failwith
+        "h2.Reqd.schedule_trailers: can only send trailers in Streaming mode")
+
+let unsafe_respond_with_data (t : t) response data =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
+  | Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
+    send_fixed_response t stream response data
+  | Reserved (request_info, stream) ->
+    send_fixed_response t stream response data;
+    (* From RFC7540§8.1:
+     *   reserved (local): [...] In this state, only the following transitions
+     *   are possible: The endpoint can send a HEADERS frame. This causes the
+     *   stream to open in a "half-closed (remote)" state. *)
+    Writer.flush t.writer (fun _reason ->
+      (* TODO(anmonteiro): different if closed? *)
+      t.state <- Active (HalfClosed request_info, stream))
+  | Closed _ -> assert false
+
+let respond_with_string (t : t) response str =
+  match t.error_code with
+  | No_error -> unsafe_respond_with_data t response (`String str)
+  | _ ->
+    failwith
+      "h2.Reqd.respond_with_string: invalid state, currently handling error"
+
+let respond_with_bigstring (t : t) response bstr =
+  match t.error_code with
+  | No_error -> unsafe_respond_with_data t response (`Bigstring bstr)
+  | _ ->
+    failwith
+      "h2.Reqd.respond_with_bigstring: invalid state, currently handling error"
+
+let send_streaming_response ~flush_headers_immediately (t : t) s response =
+  let wait_for_first_flush = not flush_headers_immediately in
+  match s.response_state with
+  | Waiting ->
+    let frame_info =
+      Writer.make_frame_info ~max_frame_size:t.max_frame_size t.id
+    in
+    let response_body_buffer = Bigstringaf.create s.body_buffer_size in
+    let response_body =
+      Body.Writer.create response_body_buffer ~writer:t.writer
+    in
+    Writer.write_response_headers t.writer s.encoder frame_info response;
+    if wait_for_first_flush then Writer.yield t.writer;
+    s.response_state <-
+      Streaming { response; response_body; trailers = Headers.empty };
+    Writer.wakeup t.writer;
+    response_body
+  | Streaming _ ->
+    failwith "h2.Reqd.respond_with_streaming: response already started"
+  | Fixed _ | Complete _ ->
+    failwith "h2.Reqd.respond_with_streaming: response already complete"
+
+let unsafe_respond_with_streaming (t : t) ~flush_headers_immediately response =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
+  | Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
+    send_streaming_response ~flush_headers_immediately t stream response
+  | Reserved (request_info, stream) ->
+    let response_body =
+      send_streaming_response ~flush_headers_immediately t stream response
+    in
+    (* From RFC7540§8.1:
+     *   reserved (local): [...] In this state, only the following transitions
+     *   are possible: The endpoint can send a HEADERS frame. This causes the
+     *   stream to open in a "half-closed (remote)" state. *)
+    Writer.flush t.writer (fun _reason ->
+      (* TODO(anmonteiro): different if closed? *)
+      t.state <- Active (HalfClosed request_info, stream));
+    response_body
+  | Closed _ -> assert false
+
+let respond_with_streaming (t : t) ?(flush_headers_immediately = false) response
+  =
+  match t.error_code with
+  | No_error ->
+    unsafe_respond_with_streaming ~flush_headers_immediately t response
+  | _ ->
+    failwith
+      "h2.Reqd.respond_with_streaming: invalid state, currently handling error"
+
+let start_push_stream (t : t) s request =
+  match s.create_push_stream t.id with
+  | Ok promised_reqd ->
+    let frame_info =
+      Writer.make_frame_info ~max_frame_size:t.max_frame_size t.id
+    in
+    Writer.write_push_promise
+      t.writer
+      s.encoder
+      frame_info
+      ~promised_id:promised_reqd.id
+      request;
+    let { encoder; body_buffer_size; create_push_stream; _ } = s in
+    (* From RFC7540§8.2:
+     *   Promised requests [...] MUST NOT include a request body. *)
+    let request_info = create_active_request request Body.Reader.empty in
+    let active_stream =
+      create_active_stream encoder body_buffer_size create_push_stream
+    in
+    (* From RFC7540§8.2.1:
+     *   Sending a PUSH_PROMISE frame creates a new stream and puts the stream
+     *   into the "reserved (local)" state for the server and the "reserved
+     *   (remote)" state for the client.
+     *
+     * Note: we do this before flushing the writer because request handlers
+     * might immediately call one of the `respond_with` functions and expect
+     * the stream to be in the `Reserved` state. *)
+    promised_reqd.state <- Reserved (request_info, active_stream);
+    Writer.wakeup t.writer;
+    Ok promised_reqd
+  | Error e ->
+    Error (e :> [ `Push_disabled | `Stream_cant_push | `Stream_ids_exhausted ])
+
+(* TODO: We could easily allow the priority of the PUSH request to be
+ * configurable. We should allow users of this API to define the weight (maybe
+ * not strictly), dependency on the current Reqd, and exclusivity *)
+let unsafe_push (t : t) request =
+  match t.state with
+  | Idle | Active (Open (WaitingForPeer | PartialHeaders _), _) -> assert false
+  | Active ((Open (FullHeaders | ActiveMessage _) | HalfClosed _), stream) ->
+    start_push_stream t stream request
+  (* Already checked in `push` *)
+  | Reserved _ | Closed _ -> assert false
+
+let push (t : t) request =
+  match t.error_code with
+  | No_error ->
+    if Stream_identifier.is_pushed t.id
+    then
+      (* From RFC7540§6.6:
+       *   PUSH_PROMISE frames MUST only be sent on a peer-initiated stream that
+       *   is in either the "open" or "half-closed (remote)" state. *)
+      Error `Stream_cant_push
+    else unsafe_push t request
+  | _ -> failwith "h2.Reqd.push: invalid state, currently handling error"
+
+let _report_error ?request (t : t) s (error : error) error_code =
+  match s.response_state, t.error_code with
+  | Waiting, No_error ->
+    t.error_code <- Stream.error_to_code error error_code;
+    let status =
+      match (error :> [ error | Status.standard ]) with
+      | `Exn _ -> `Internal_server_error
+      | #Status.standard as status -> status
+    in
+    t.error_handler ?request error (fun headers ->
+      let response = Response.create ~headers status in
+      unsafe_respond_with_streaming ~flush_headers_immediately:true t response)
+  | Streaming { response_body; _ }, No_error ->
+    Body.Writer.close response_body;
+    t.error_code <- Stream.error_to_code error error_code;
+    Stream.reset_stream t error_code
+  | Fixed _, No_error ->
+    (* Still need to send an RST_STREAM frame. Set t.error_code with
+     * `error_code` and `flush_response_body` below will reset the stream after
+     * flushing any remaining body bytes. *)
+    t.error_code <- Stream.error_to_code error error_code;
+    Stream.reset_stream t error_code
+  | (Waiting | Fixed _ | Streaming _), Exn _ ->
+    (* XXX(seliopou): Decide what to do in this unlikely case. There is an
+     * outstanding call to the [error_handler], but an intervening exception
+     * has been reported as well. *)
+    failwith "h2.Reqd.report_exn: NYI"
+  | (Waiting | Streaming _ | Fixed _ | Complete _), _ -> ()
+
+let report_error (t : t) exn error_code =
+  match t.state with
+  | Idle | Reserved _ | Active (Open (WaitingForPeer | PartialHeaders _), _) ->
+    assert false
+  | Active (Open FullHeaders, stream) -> _report_error t stream exn error_code
+  | Active
+      ( ( Open (ActiveMessage { request; request_body; _ })
+        | HalfClosed { request; request_body; _ } )
+      , stream ) ->
+    Body.Reader.close request_body;
+    _report_error t stream ~request exn error_code
+  | Closed _ -> ()
+
+let report_exn t exn = report_error t (`Exn exn) Error_code.InternalError
+
+let try_with t f : (unit, exn) result =
+  try
+    f ();
+    Ok ()
+  with
+  | exn ->
+    report_exn t exn;
+    Error exn
+
+let error_code = Stream.error_code
+(* Private API, not exposed to the user through h2.mli *)
+
+let requires_output (t : t) =
+  match t.state with
+  | Idle -> false
+  | Reserved _ -> true
+  | Active (Open (WaitingForPeer | PartialHeaders _), _) -> false
+  | Active
+      ( (Open (FullHeaders | ActiveMessage _) | HalfClosed _)
+      , { response_state; _ } ) ->
+    (* From RFC7540§8.1:
+     *   A server can send a complete response prior to the client sending an
+     *   entire request if the response does not depend on any portion of the
+     *   request that has not been sent and received. *)
+    (match response_state with
+    | Complete _ -> false
+    | Fixed { iovec = { len; _ }; _ } -> len > 0
+    | Streaming _ -> true
+    | Waiting -> true)
+  | Closed _ -> false
+
+let flush_request_body (t : t) =
+  match t.state with
+  | Active
+      ( ( Open (ActiveMessage { request_body; _ })
+        | HalfClosed { request_body; _ } )
+      , _ ) ->
+    if Body.Reader.has_pending_output request_body
+    then (
+      try Body.Reader.execute_read request_body with exn -> report_exn t exn)
+  | _ -> ()
+
+let write_buffer_data writer ~off ~len frame_info buffer =
+  match buffer with
+  | `String str -> Writer.write_data writer ~off ~len frame_info str
+  | `Bigstring bstr -> Writer.schedule_data writer ~off ~len frame_info bstr
+
+let close_stream (t : t) =
+  match t.error_code with
+  | No_error ->
+    (match t.state with
+    | Active (Open (FullHeaders | ActiveMessage _), _) ->
+      (* From RFC7540§8.1:
+       *   A server can send a complete response prior to the client sending an
+       *   entire request if the response does not depend on any portion of the
+       *   request that has not been sent and received. When this is true, a
+       *   server MAY request that the client abort transmission of a request
+       *   without error by sending a RST_STREAM with an error code of NO_ERROR
+       *   after sending a complete response (i.e., a frame with the END_STREAM
+       *   flag). *)
+      Stream.reset_stream t Error_code.NoError
+    | Active (HalfClosed _, _) ->
+      Writer.flush t.writer (fun _reason -> Stream.finish_stream t Finished)
+    | _ -> assert false)
+  | Exn _ -> Stream.reset_stream t InternalError
+  | Other { code; _ } -> Stream.reset_stream t code
+
+let flush_response_body (t : t) ~max_bytes =
+  match t.state with
+  | Active ((Open _ | HalfClosed _), stream) ->
+    (match stream.response_state with
+    | Streaming { response; response_body; trailers } ->
+      if Body.Writer.has_pending_output response_body && max_bytes > 0
+      then
+        Body.Writer.transfer_to_writer
+          response_body
+          t.writer
+          ~max_frame_size:t.max_frame_size
+          ~max_bytes
+          t.id
+      else if Body.Writer.is_closed response_body
+      then (
+        (* no pending output and closed, we can finalize the message and close
+           the stream *)
+        let frame_info =
+          Writer.make_frame_info
+            ~max_frame_size:t.max_frame_size
+            ~flags:Flags.(set_end_stream default_flags)
+            t.id
+        in
+        match trailers with
+        | _ :: _ ->
+          Writer.write_response_trailers
+            t.writer
+            stream.encoder
+            frame_info
+            trailers;
+          close_stream t;
+          stream.response_state <- Complete response;
+          0
+        | [] ->
+          (* From RFC7540§6.9.1:
+           *   Frames with zero length with the END_STREAM flag set (that is,
+           *   an empty DATA frame) MAY be sent if there is no available space
+           *   in either flow-control window. *)
+          Writer.schedule_data t.writer frame_info ~len:0 Bigstringaf.empty;
+          close_stream t;
+          stream.response_state <- Complete response;
+          0)
+      else (* no pending output but Body is still open *)
+        0
+    | Fixed ({ iovec = { buffer; off; len } as iovec; _ } as r)
+      when max_bytes > 0 ->
+      let is_partial_flush = max_bytes < len in
+      let frame_info =
+        let flags =
+          if is_partial_flush
+          then Flags.default_flags
+          else Flags.(set_end_stream default_flags)
+        in
+        Writer.make_frame_info ~max_frame_size:t.max_frame_size ~flags t.id
+      in
+      let len_to_write = if is_partial_flush then max_bytes else len in
+      write_buffer_data t.writer ~off ~len:len_to_write frame_info buffer;
+      r.iovec <- Httpun_types.IOVec.shift iovec len_to_write;
+      if not is_partial_flush then close_stream t;
+      len_to_write
+    | Fixed _ | Waiting | Complete _ -> 0)
+  | _ -> 0
+
+let deliver_trailer_headers (t : t) headers =
+  match t.state with
+  | Active (Open (PartialHeaders _ | FullHeaders), _) -> assert false
+  | Active ((Open (ActiveMessage _) | HalfClosed _), stream) ->
+    (* TODO: call the schedule_trailers callback *)
+    stream.trailers <- Some headers
+  | _ -> assert false

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

@@ -0,0 +1,57 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+type t =
+  { meth : Httpun_types.Method.t
+  ; target : string
+  ; scheme : string
+  ; headers : Headers.t
+  }
+
+(* TODO: `:authority` pseudo-header? *)
+let create ?(headers = Headers.empty) ~scheme meth target =
+  { meth; target; scheme; headers }
+
+let body_length { headers; _ } = Message.body_length headers
+
+let pp_hum fmt { meth; target; scheme; headers } =
+  Format.fprintf
+    fmt
+    "((method \"%a\") (target %S) (scheme %S) (headers %a))"
+    Httpun_types.Method.pp_hum
+    meth
+    target
+    scheme
+    Headers.pp_hum
+    headers

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

@@ -0,0 +1,200 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+(* TODO(anmonteiro): think about whether we wanna expose this module. it might
+ * be helpful to expose a way to reset streams, and I think we'd need a
+ * reference to the Respd *)
+
+module Writer = Serialize.Writer
+
+type error =
+  [ `Malformed_response of string
+  | `Invalid_response_body_length of Response.t
+  | `Protocol_error of Error_code.t * string
+  | `Exn of exn
+  ]
+
+type error_handler = error -> unit
+type response_handler = Response.t -> Body.Reader.t -> unit
+
+type response_info =
+  { response : Response.t
+  ; response_body : Body.Reader.t
+  ; mutable response_body_bytes : int64
+  ; mutable trailers_parser : Stream.partial_headers option
+  }
+
+type trailers_handler = Headers.t -> unit
+
+type active_request =
+  { request : Request.t
+  ; request_body : Body.Writer.t
+  ; response_handler : response_handler
+  ; trailers_handler : trailers_handler
+  }
+
+type active_state =
+  (response_info, response_info Stream.remote_state) Stream.active_state
+
+type state =
+  ( active_state
+    , active_request
+    , active_request Stream.remote_state )
+    Stream.state
+
+type t = (state, error, error_handler) Stream.t
+
+let create_active_response response response_body =
+  Stream.ActiveMessage
+    { response
+    ; response_body
+    ; response_body_bytes = Int64.zero
+    ; trailers_parser = None
+    }
+
+let response_body_exn (t : t) =
+  match t.state with
+  | Idle | Reserved _ ->
+    failwith "h2.Respd.response_exn: response has not arrived"
+  | Active
+      ( ( Open (ActiveMessage { response_body; _ })
+        | HalfClosed (ActiveMessage { response_body; _ }) )
+      , _ ) ->
+    response_body
+  | Active ((Open _ | HalfClosed _), _) ->
+    failwith "h2.Respd.response_exn: response has not arrived"
+  | Closed _ -> failwith "h2.Respd.response_exn: stream already closed"
+
+let close_stream (t : t) =
+  (* TODO: reserved *)
+  match t.state with
+  | Active (HalfClosed _, _) ->
+    (* easy case, just transition to the closed state. *)
+    Stream.finish_stream t Finished
+  | Active (Open _, _) ->
+    (* Still not done sending, reset stream with no error? *)
+    (* TODO: *)
+    ()
+  | _ -> ()
+
+let _report_error (t : t) ?response_body (error : error) error_code =
+  match t.error_code with
+  | No_error ->
+    (match response_body with
+    | Some response_body -> Body.Reader.close response_body
+    | None -> ());
+    t.error_code <- Stream.error_to_code error error_code;
+    t.error_handler error
+  | Exn _ | Other _ ->
+    (* Already handling error.
+     * TODO(anmonteiro): Log a message when we add Logs support *)
+    ()
+
+let report_error (t : t) error error_code =
+  match t.state with
+  | Active
+      ( ( Open (ActiveMessage { response_body; _ })
+        | HalfClosed (ActiveMessage { response_body; _ }) )
+      , s ) ->
+    Body.Writer.close s.request_body;
+    _report_error t ~response_body error error_code;
+    Stream.reset_stream t error_code
+  | Reserved (ActiveMessage s) | Active (_, s) ->
+    Body.Writer.close s.request_body;
+    _report_error t error error_code;
+    Stream.reset_stream t error_code
+  | Reserved _ ->
+    (* Streams in the reserved state don't yet have a stream-level error
+     * handler registered with them *)
+    ()
+  | Idle | Closed _ ->
+    (* Not allowed to send RST_STREAM frames in these states *)
+    ignore (_report_error t error error_code)
+
+let requires_output (t : t) =
+  match t.state with
+  | Idle -> true
+  | Reserved _ -> false
+  | Active (Open _, _) -> true
+  | Active (HalfClosed _, _) -> false
+  | Closed _ -> false
+
+let flush_request_body (t : t) ~max_bytes =
+  match t.state with
+  | Active (Open active_state, ({ request_body; _ } as s)) ->
+    if Body.Writer.has_pending_output request_body && max_bytes > 0
+    then
+      Body.Writer.transfer_to_writer
+        request_body
+        t.writer
+        ~max_frame_size:t.max_frame_size
+        ~max_bytes
+        t.id
+    else if Body.Writer.is_closed request_body
+    then (
+      (* closed and no pending output *)
+      (* From RFC7540§6.9.1:
+       *   Frames with zero length with the END_STREAM flag set (that is, an
+       *   empty DATA frame) MAY be sent if there is no available space in
+       *   either flow-control window. *)
+      let frame_info =
+        Writer.make_frame_info
+          ~max_frame_size:t.max_frame_size
+          ~flags:Flags.(set_end_stream default_flags)
+          t.id
+      in
+      Writer.schedule_data t.writer frame_info ~len:0 Bigstringaf.empty;
+      t.state <- Active (HalfClosed active_state, s);
+      0)
+    else (* not closed and no pending output *)
+      0
+  | _ -> 0
+
+let deliver_trailer_headers (t : t) headers =
+  match t.state with
+  | Active
+      ( (Open (ActiveMessage _) | HalfClosed (ActiveMessage _))
+      , { trailers_handler; _ } ) ->
+    trailers_handler headers
+  | _ -> assert false
+
+let flush_response_body (t : t) =
+  match t.state with
+  | Active
+      ( ( Open (ActiveMessage { response_body; _ })
+        | HalfClosed (ActiveMessage { response_body; _ }) )
+      , _ ) ->
+    if Body.Reader.has_pending_output response_body
+    then (
+      try Body.Reader.execute_read response_body with
+      | exn -> report_error t (`Exn exn) InternalError)
+  | _ -> ()

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

@@ -0,0 +1,63 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+type t =
+  { status : Status.t
+  ; headers : Headers.t
+  }
+
+(* From RFC7540§8.1.2.4:
+ *   HTTP/2 does not define a way to carry the version or reason phrase that
+ *   is included in an HTTP/1.1 status line. *)
+let create ?(headers = Headers.empty) status = { status; headers }
+
+let body_length ~request_method { headers; _ } =
+  match request_method with
+  | `HEAD -> `Fixed 0L
+  | #Httpun_types.Method.standard -> Message.body_length headers
+
+let pp_hum fmt { status; headers } =
+  let reason =
+    match status with
+    | #Status.standard as status -> Status.default_reason_phrase status
+    | `Code _ -> "Non-standard status code"
+  in
+  Format.fprintf
+    fmt
+    "((status %a) (reason %S) (headers %a))"
+    Status.pp_hum
+    status
+    reason
+    Headers.pp_hum
+    headers

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

@@ -0,0 +1,571 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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 StreamsTbl = struct
+  include Hashtbl.MakeSeeded (struct
+      type t = Stream_identifier.t
+
+      let equal = Stream_identifier.( === )
+      let hash i k = Hashtbl.seeded_hash i k
+
+      (* Required for OCaml >= 5.0.0, but causes errors for older compilers
+         because it is an unused value declaration. *)
+      let[@warning "-32"] seeded_hash = hash
+    end)
+
+  let[@inline] find_opt h key = try Some (find h key) with Not_found -> None
+end
+
+module type StreamDescriptor = sig
+  type t
+
+  val id : t -> Stream_identifier.t
+  val requires_output : t -> bool
+  val flush_write_body : t -> max_bytes:int -> int
+  val finish_stream : t -> Stream.closed_reason -> unit
+  val is_idle : t -> bool
+end
+
+module Make (Streamd : StreamDescriptor) = struct
+  module rec PriorityTreeNode : sig
+    type root = Root
+    type nonroot = NonRoot
+
+    type stream = nonroot node
+    and parent = Parent : _ node -> parent
+
+    and _ node =
+      (* From RFC7540§5.3.1:
+       *   A stream that is not dependent on any other stream is given a stream
+       *   dependency of 0x0. In other words, the non-existent stream 0 forms
+       *   the root of the tree.
+       *
+       * Note:
+       *   We use a GADT because the root of the tree doesn't have an
+       *   associated request descriptor. It has the added advantage of
+       *   allowing us to enforce that all (other) streams in the tree are
+       *   associated with a request descriptor. *)
+      | Connection :
+          { all_streams : stream StreamsTbl.t
+          ; mutable t_last : int
+          ; mutable children : PriorityQueue.t
+          ; (* Connection-level flow control window.
+             * outbound flow control, what we're allowed to send.
+             *
+             * From RFC7540§6.9.1:
+             *   Two flow-control windows are applicable: the stream
+             * flow-control window and the connection flow-control window. *)
+            mutable flow : Settings.WindowSize.t
+          ; (* inbound flow control, what the client is allowed to send. *)
+            mutable inflow : Settings.WindowSize.t
+          ; mutable marked_for_removal : Stream.closed StreamsTbl.t
+          }
+          -> root node
+      | Stream :
+          { descriptor : Streamd.t
+          ; mutable t_last : int
+          ; mutable t : int
+          ; mutable priority : Priority.t
+          ; mutable parent : parent
+          ; mutable children : PriorityQueue.t
+          ; (* Stream-level flow control window. See connection-level above.
+             *
+             * From RFC7540§6.9.1:
+             *   Two flow-control windows are applicable: the stream
+             * flow-control window and the connection flow-control window. *)
+            mutable flow : Settings.WindowSize.t
+          ; mutable inflow : Settings.WindowSize.t
+          }
+          -> nonroot node
+  end =
+    PriorityTreeNode
+
+  and PriorityQueue :
+    (Psq.S with type k = Int32.t and type p = PriorityTreeNode.stream) =
+    Psq.Make
+      (Int32)
+      (struct
+        include PriorityTreeNode
+
+        type t = stream
+
+        let compare (Stream { t = t1; _ }) (Stream { t = t2; _ }) =
+          compare t1 t2
+      end)
+
+  include PriorityTreeNode
+
+  type t = root node
+
+  (* TODO(anmonteiro): change according to SETTINGS_MAX_CONCURRENT_STREAMS? *)
+  let make_root ?(capacity = 65536) () =
+    Connection
+      { t_last = 0
+      ; children = PriorityQueue.empty
+      ; all_streams = StreamsTbl.create ~random:true capacity
+      ; flow = Settings.WindowSize.default_initial_window_size
+      ; inflow = Settings.WindowSize.default_initial_window_size
+      ; marked_for_removal = StreamsTbl.create ~random:true 256
+      }
+
+  let create
+      ~parent
+      ~initial_send_window_size
+      ~initial_recv_window_size
+      descriptor
+    =
+    Stream
+      { descriptor
+      ; t_last = 0
+      ; t = 0
+      ; (* From RFC7540§5.3.5:
+         *   All streams are initially assigned a non-exclusive dependency on
+         *   stream 0x0. Pushed streams (Section 8.2) initially depend on their
+         *   associated stream. In both cases, streams are assigned a default
+         *   weight of 16. *)
+        priority = Priority.default_priority
+      ; parent
+      ; children = PriorityQueue.empty
+      ; flow = initial_send_window_size
+      ; inflow = initial_recv_window_size
+      }
+
+  let stream_id : type a. a node -> int32 = function
+    | Connection _ -> Stream_identifier.connection
+    | Stream { descriptor; _ } -> Streamd.id descriptor
+
+  let children : type a. a node -> PriorityQueue.t = function
+    | Stream { children; _ } -> children
+    | Connection { children; _ } -> children
+
+  let remove_child : type a. a node -> int32 -> unit =
+   fun parent id ->
+    match parent with
+    | Connection ({ children; _ } as node) ->
+      (* From RFC7540§5.3.1:
+       *   A stream that is not dependent on any other stream is given a stream
+       *   dependency of 0x0. In other words, the non-existent stream 0 forms
+       *   the root of the tree. *)
+      node.children <- PriorityQueue.remove id children
+    | Stream ({ children; _ } as node) ->
+      node.children <- PriorityQueue.remove id children
+
+  let update_children : type a. a node -> PriorityQueue.t -> unit =
+   fun parent updated_children ->
+    match parent with
+    | Connection s -> s.children <- updated_children
+    | Stream s -> s.children <- updated_children
+
+  let set_parent stream_node ~exclusive (Parent new_parent_node as new_parent) =
+    let (Stream ({ descriptor; parent = Parent old_parent_node; _ } as stream)) =
+      stream_node
+    in
+    let stream_id = Streamd.id descriptor in
+    remove_child old_parent_node stream_id;
+    stream.parent <- new_parent;
+    let new_children =
+      let new_children = children new_parent_node in
+      if exclusive
+      then (
+        (* From RFC7540§5.3.3:
+         *   Dependent streams move with their parent stream if the parent is
+         *   reprioritized. Setting a dependency with the exclusive flag for a
+         *   reprioritized stream causes all the dependencies of the new parent
+         *   stream to become dependent on the reprioritized stream. *)
+        stream.children <-
+          PriorityQueue.fold
+            (fun k (Stream p as p_node) pq ->
+               p.parent <- Parent stream_node;
+               PriorityQueue.add k p_node pq)
+            stream.children
+            new_children;
+        (* From RFC7540§5.3.1:
+         *   An exclusive flag allows for the insertion of a new level of
+         *   dependencies. The exclusive flag causes the stream to become the
+         *   sole dependency of its parent stream, causing other dependencies
+         *   to become dependent on the exclusive stream. *)
+        PriorityQueue.sg stream_id stream_node)
+      else PriorityQueue.add stream_id stream_node new_children
+    in
+    update_children new_parent_node new_children
+
+  let would_create_cycle ~new_parent (Stream { descriptor; _ }) =
+    let rec inner : type a. a node -> bool = function
+      | Connection _ -> false
+      | Stream { parent = Parent parent; _ }
+        when Stream_identifier.(stream_id parent === Streamd.id descriptor) ->
+        true
+      | Stream { parent = Parent parent; _ } -> inner parent
+    in
+    let (Parent parent_node) = new_parent in
+    inner parent_node
+
+  let reprioritize_stream (Connection root as t) ~priority stream_node =
+    let (Stream stream) = stream_node in
+    let new_parent, new_priority =
+      if Stream_identifier.is_connection priority.Priority.stream_dependency
+      then Parent t, priority
+      else
+        match
+          StreamsTbl.find_opt root.all_streams priority.stream_dependency
+        with
+        | Some parent_stream ->
+          (match
+             StreamsTbl.mem root.marked_for_removal priority.stream_dependency
+           with
+          | true ->
+            (* A stream that is marked for removal is also not present in the
+               tree *)
+            Parent t, Priority.default_priority
+          | false -> Parent parent_stream, priority)
+        | None ->
+          (* From RFC7540§5.3.1:
+           *   A dependency on a stream that is not currently in the tree —
+           *   such as a stream in the "idle" state — results in that stream
+           *   being given a default priority (Section 5.3.5). *)
+          Parent t, Priority.default_priority
+    in
+    (* bail early if trying to set the same priority *)
+    if not (Priority.equal stream.priority new_priority)
+    then (
+      let { Priority.stream_dependency; exclusive; _ } = new_priority in
+      let (Parent current_parent_node) = stream.parent in
+      let current_parent_id = stream_id current_parent_node in
+      (* only need to set a different parent if the parent or exclusive status
+       * changed *)
+      if (not Stream_identifier.(stream_dependency === current_parent_id))
+         || exclusive <> stream.priority.exclusive
+      then (
+        let (Parent new_parent_node) = new_parent in
+        (match new_parent_node with
+        | Stream new_parent_stream ->
+          if would_create_cycle ~new_parent stream_node
+          then (
+            (* From RFC7540§5.3.3:
+             *   If a stream is made dependent on one of its own dependencies,
+             *   the formerly dependent stream is first moved to be dependent
+             *   on the reprioritized stream's previous parent. The moved
+             *   dependency retains its weight. *)
+            set_parent new_parent_node ~exclusive:false stream.parent;
+            new_parent_stream.priority <-
+              { new_parent_stream.priority with
+                stream_dependency = current_parent_id
+              })
+        | Connection _ ->
+          (* The root node cannot be dependent on any other streams, so we
+           * don't need to worry about it creating cycles. *)
+          ());
+        (* From RFC7540§5.3.1:
+         *   When assigning a dependency on another stream, the stream is added
+         *   as a new dependency of the parent stream. *)
+        set_parent stream_node ~exclusive new_parent);
+      stream.priority <- new_priority)
+
+  let update_t node n =
+    let (Stream ({ parent = Parent parent; descriptor; _ } as stream)) = node in
+    let tlast_p =
+      match parent with
+      | Connection { t_last; _ } -> t_last
+      | Stream { t_last; _ } -> t_last
+    in
+    stream.t <- tlast_p + (n * 256 / stream.priority.weight);
+    let id = Streamd.id descriptor in
+    remove_child parent id;
+    let updated_children = PriorityQueue.add id node (children parent) in
+    update_children parent updated_children
+
+  let update_t_last : type a. a node -> int -> unit =
+   fun p_node t_last ->
+    match p_node with
+    | Connection p -> p.t_last <- t_last
+    | Stream p -> p.t_last <- t_last
+
+  let add
+      (Connection root as t)
+      ~priority
+      ~initial_send_window_size
+      ~initial_recv_window_size
+      descriptor
+    =
+    let stream =
+      create
+        ~parent:(Parent t)
+        ~initial_send_window_size
+        ~initial_recv_window_size
+        descriptor
+    in
+    let stream_id = Streamd.id descriptor in
+    StreamsTbl.add root.all_streams stream_id stream;
+    root.children <- PriorityQueue.add stream_id stream root.children;
+    if priority != Priority.default_priority
+    then reprioritize_stream t ~priority stream;
+    update_t stream 0;
+    stream
+
+  let get_node (Connection root) stream_id =
+    StreamsTbl.find_opt root.all_streams stream_id
+
+  let find t stream_id =
+    match get_node t stream_id with
+    | Some (Stream { descriptor; _ }) -> Some descriptor
+    | None -> None
+
+  let iter (Connection { all_streams; _ }) ~f =
+    StreamsTbl.iter (fun _id stream -> f stream) all_streams
+
+  let allowed_to_transmit (Connection root) (Stream stream) =
+    Int32.compare root.flow 0l > 0 && Int32.compare stream.flow 0l > 0
+
+  let allowed_to_receive (Connection root) (Stream stream) size =
+    size <= root.inflow && size <= stream.inflow
+
+  let write (Connection root as t) stream_node =
+    let (Stream ({ descriptor; _ } as stream)) = stream_node in
+    (* From RFC7540§6.9.1:
+     *   Two flow-control windows are applicable: the stream flow-control
+     *   window and the connection flow-control window. The sender MUST NOT
+     *   send a flow-controlled frame with a length that exceeds the space
+     *   available in either of the flow-control windows advertised by the
+     *   receiver. *)
+    let allowed_bytes =
+      if allowed_to_transmit t stream_node
+      then min root.flow stream.flow
+      else
+        (* There might be a zero-length DATA frame (with the end stream flag
+           set) waiting to be sent. *)
+        0l
+    in
+    let written =
+      Streamd.flush_write_body
+        ~max_bytes:(Int32.to_int allowed_bytes)
+        descriptor
+    in
+    let written32 = Int32.of_int written in
+    (* From RFC7540§6.9.1:
+     *   After sending a flow-controlled frame, the sender reduces the space
+     *   available in both windows by the length of the transmitted frame. *)
+    root.flow <- Int32.sub root.flow written32;
+    stream.flow <- Int32.sub stream.flow written32;
+    written
+
+  let mark_for_removal (Connection root) id closed =
+    StreamsTbl.replace root.marked_for_removal id closed
+
+  let implicitly_close_idle_stream descriptor max_seen_ids =
+    let implicitly_close_stream descriptor =
+      if Streamd.is_idle descriptor
+      then
+        (* From RFC7540§5.1.1:
+         *   The first use of a new stream identifier implicitly closes all
+         *   streams in the "idle" state that might have been initiated by
+         *   that peer with a lower-valued stream identifier. *)
+        Streamd.finish_stream descriptor Finished
+    in
+    let max_client_stream_id, max_pushed_stream_id = max_seen_ids in
+    let stream_id = Streamd.id descriptor in
+    if Stream_identifier.is_request stream_id
+    then (
+      if stream_id < max_client_stream_id
+      then implicitly_close_stream descriptor)
+    else if stream_id < max_pushed_stream_id
+    then implicitly_close_stream descriptor
+
+  (* Scheduling algorithm from https://goo.gl/3sSHXJ (based on nghttp2):
+   *
+   * 1  def schedule(p):
+   * 2    if stream #p has data to send:
+   * 3      send data for #p, update nsent[p]
+   * 4      return
+   * 5    if #p's queue is empty:
+   * 6      return
+   * 7    pop #i from queue
+   * 8    update t_last[p] = t[i]
+   * 9    schedule(i)
+   * 10   if #i or its descendant is "active":
+   * 11     update t[i] and push it into queue again
+   * 12
+   * 13 schedule(0)
+   *)
+  let flush t max_seen_ids =
+    let rec schedule : type a. a node -> int * bool = function
+      | Connection _ as p_node ->
+        (* The root can never send data. *)
+        traverse p_node
+      | Stream ({ descriptor; _ } as stream) as p_node ->
+        let written =
+          if Streamd.requires_output descriptor
+          then
+            (* In this branch, flow-control has no bearing on activity, otherwise
+             * a flow-controlled stream would be considered inactive (because it
+             * can't make progress at the moment) and removed from the priority
+             * tree altogether. *)
+            write t p_node
+          else 0
+        in
+        if written > 0
+        then
+          (* We check for activity again, because the stream may have gone
+           * inactive after the call to `write` above. *)
+          let subtree_is_active =
+            Streamd.requires_output descriptor
+            || not (PriorityQueue.is_empty stream.children)
+          in
+          written, subtree_is_active
+        else
+          (* If we haven't written anything, check if any of our children
+             have. *)
+          let written, subtree_is_active' = traverse p_node in
+          let subtree_is_active =
+            Streamd.requires_output descriptor || subtree_is_active'
+          in
+          (match written with
+          | 0 -> written, subtree_is_active
+          | written ->
+            (* If there's still more to write, put the node back in the tree. *)
+            if subtree_is_active then update_t p_node written;
+            written, subtree_is_active)
+    and traverse : type a. a node -> int * bool =
+     fun p_node ->
+      let rec loop remaining_children =
+        match PriorityQueue.pop remaining_children with
+        | Some ((id, (Stream i as i_node)), remaining_children') ->
+          update_t_last p_node i.t;
+          let written, subtree_is_active = schedule i_node in
+
+          if not subtree_is_active
+          then (
+            implicitly_close_idle_stream i.descriptor max_seen_ids;
+            (* XXX(anmonteiro): we may not want to remove from the tree right
+             * away. *)
+            remove_child p_node id);
+
+          (match written with
+          | 0 ->
+            (* If this subtree didn't write anything, check the other children
+               in the priority queue. *)
+            loop remaining_children'
+          | written ->
+            (* If there's still more to write, put the node back in the tree. *)
+            if subtree_is_active then update_t i_node written;
+            written, subtree_is_active)
+        | None ->
+          (* No data written, but queue was not originally empty.
+           * Therefore, we can't determine the subtree is inactive. *)
+          0, true
+      in
+      let children = children p_node in
+      match PriorityQueue.is_empty children with
+      | true ->
+        (* Queue is empty, see line 6 above. *)
+        0, false
+      | false -> loop children
+    in
+
+    let (Connection root) = t in
+    ignore (schedule t);
+    StreamsTbl.iter
+      (fun id closed ->
+         (* When a stream completes, i.e. doesn't require more output and
+          * enters the `Closed` state, we set a TTL value which represents the
+          * number of writer yields that the stream has before it is removed
+          * from the connection Hash Table. By doing this we avoid losing some
+          * potentially useful information regarding the stream's state at the
+          * cost of keeping it around for a little while longer. *)
+         if closed.Stream.ttl = 0
+         then (
+           StreamsTbl.remove root.marked_for_removal id;
+           StreamsTbl.remove root.all_streams id)
+         else closed.ttl <- closed.ttl - 1)
+      root.marked_for_removal
+
+  (* XXX(anmonteiro): Consider using `optint` for this?
+   * https://github.com/mirage/optint
+   *)
+  let check_flow flow growth flow' =
+    (* Check for overflow on 32-bit systems. *)
+    Int32.compare flow' growth > 0 = (Int32.compare flow 0l > 0)
+    && Int32.compare flow' Settings.WindowSize.max_window_size <= 0
+
+  let add_flow : type a. a node -> int32 -> bool =
+   fun t growth ->
+    match t with
+    | Connection ({ flow; _ } as root) ->
+      let flow' = Int32.add flow growth in
+      let valid_flow = check_flow flow growth flow' in
+      if valid_flow then root.flow <- flow';
+      valid_flow
+    | Stream ({ flow; _ } as stream) ->
+      let flow' = Int32.add flow growth in
+      let valid_flow = check_flow flow growth flow' in
+      if valid_flow then stream.flow <- flow';
+      valid_flow
+
+  let add_inflow : type a. a node -> int32 -> bool =
+   fun t growth ->
+    match t with
+    | Connection ({ inflow; _ } as root) ->
+      let inflow' = Int32.add inflow growth in
+      let valid_inflow = check_flow inflow growth inflow' in
+      if valid_inflow then root.inflow <- inflow';
+      valid_inflow
+    | Stream ({ inflow; _ } as stream) ->
+      let inflow' = Int32.add inflow growth in
+      let valid_inflow = check_flow inflow growth inflow' in
+      if valid_inflow then stream.inflow <- inflow';
+      valid_inflow
+
+  let deduct_inflow : type a. a node -> int32 -> unit =
+   fun t size ->
+    match t with
+    | Connection ({ inflow; _ } as root) ->
+      (* no need to check, we verify that the peer is allowed to send. *)
+      root.inflow <- Int32.sub inflow size
+    | Stream ({ inflow; _ } as stream) -> stream.inflow <- Int32.sub inflow size
+
+  let pp_hum fmt t =
+    let rec pp_hum_inner level fmt t =
+      let pp_binding fmt (id, Stream { children; t; _ }) =
+        Format.fprintf
+          fmt
+          "\n%s%ld, %d -> [%a]"
+          (String.make (level * 2) ' ')
+          id
+          t
+          (pp_hum_inner (level + 1))
+          children
+      in
+      PriorityQueue.pp pp_binding fmt t
+    in
+    pp_hum_inner 0 fmt t
+
+  let pp_hum fmt (Connection { children; _ }) = pp_hum fmt children
+end

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

@@ -0,0 +1,627 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+open Faraday
+module IOVec = Httpun_types.IOVec
+
+type frame_info =
+  { flags : Flags.t
+  ; stream_id : Stream_identifier.t
+  ; padding : Bigstringaf.t
+  ; max_frame_payload : int
+  }
+
+let write_uint24 t n =
+  let write_octet t o = write_uint8 t (o land 0xff) in
+  write_octet t (n lsr 16);
+  write_octet t (n lsr 8);
+  write_octet t n
+
+let write_frame_header t frame_header =
+  let { Frame.payload_length; flags; stream_id; frame_type } = frame_header in
+  write_uint24 t payload_length;
+  write_uint8 t (Frame.FrameType.serialize frame_type);
+  write_uint8 t flags;
+  BE.write_uint32 t stream_id
+
+let write_frame_with_padding t info frame_type length writer =
+  let header, writer =
+    if Bigstringaf.length info.padding = 0
+    then
+      let header =
+        { Frame.payload_length = length
+        ; flags = info.flags
+        ; stream_id = info.stream_id
+        ; frame_type
+        }
+      in
+      header, writer
+    else
+      let pad_length = Bigstringaf.length info.padding in
+      let writer' t =
+        write_uint8 t pad_length;
+        writer t;
+        schedule_bigstring ~off:0 ~len:pad_length t info.padding
+      in
+      let header =
+        { Frame.payload_length = length + pad_length + 1
+        ; flags = Flags.set_padded info.flags
+        ; stream_id = info.stream_id
+        ; frame_type
+        }
+      in
+      header, writer'
+  in
+  write_frame_header t header;
+  writer t
+
+let write_data_frame t ?off ?len info body =
+  let writer t = write_string t ?off ?len body in
+  let length = match len with Some len -> len | None -> String.length body in
+  write_frame_with_padding t info Data length writer
+
+let schedule_data_frame t info ?off ?len bstr =
+  let writer t = schedule_bigstring t ?off ?len bstr in
+  let length =
+    match len with Some len -> len | None -> Bigstringaf.length bstr
+  in
+  write_frame_with_padding t info Data length writer
+
+let write_priority t { Priority.exclusive; stream_dependency; weight } =
+  let stream_dependency_id =
+    if exclusive
+    then Priority.set_exclusive stream_dependency
+    else stream_dependency
+  in
+  BE.write_uint32 t stream_dependency_id;
+  (* From RFC7540§6.3:
+   *   An unsigned 8-bit integer representing a priority weight for the stream
+   *   (see Section 5.3). Add one to the value to obtain a weight between 1 and
+   *   256.
+   *
+   * Note: we store priority with values from 1 to 256, so decrement here. *)
+  write_uint8 t (weight - 1)
+
+let bounded_schedule_iovecs t ~len iovecs =
+  let rec loop t remaining iovecs =
+    match remaining, iovecs with
+    | 0, _ | _, [] -> ()
+    | remaining, { IOVec.buffer; off; len } :: xs ->
+      if remaining < len
+      then schedule_bigstring t ~off ~len:remaining buffer
+      else (
+        schedule_bigstring t ~off ~len buffer;
+        loop t (remaining - len) xs)
+  in
+  loop t len iovecs
+
+let write_headers_frame t info ~priority ?len iovecs =
+  let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
+  if priority == Priority.default_priority
+  then
+    (* See RFC7540§6.3:
+     *   Just the Header Block Fragment length if no priority. *)
+    let writer t = bounded_schedule_iovecs t ~len iovecs in
+    write_frame_with_padding t info Headers len writer
+  else
+    (* See RFC7540§6.2:
+     *   Exclusive Bit & Stream Dependency (4 octets) + Weight (1 octet) +
+     *   Header Block Fragment length. *)
+    let payload_length = len + 5 in
+    let info' = { info with flags = Flags.set_priority info.flags } in
+    let writer t =
+      write_priority t priority;
+      bounded_schedule_iovecs t ~len iovecs
+    in
+    write_frame_with_padding t info' Headers payload_length writer
+
+let write_priority_frame t info priority =
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id =
+        info.stream_id
+        (* See RFC7540§6.3:
+         *   Stream Dependency (4 octets) + Weight (1 octet). *)
+    ; payload_length = 5
+    ; frame_type = Priority
+    }
+  in
+  write_frame_header t header;
+  write_priority t priority
+
+let write_rst_stream_frame t info e =
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id =
+        info.stream_id
+        (* From RFC7540§6.4:
+         *   The RST_STREAM frame contains a single unsigned, 32-bit integer
+         *   identifying the error code (Section 7). *)
+    ; payload_length = 4
+    ; frame_type = RSTStream
+    }
+  in
+  write_frame_header t header;
+  BE.write_uint32 t (Error_code.serialize e)
+
+let write_settings_frame t info settings =
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id =
+        info.stream_id
+        (* 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. *)
+    ; payload_length = List.length settings * 6
+    ; frame_type = Settings
+    }
+  in
+  write_frame_header t header;
+  Settings.write_settings_payload t settings
+
+let write_push_promise_frame t info ~promised_id ?len iovecs =
+  let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
+  let payload_length =
+    (* From RFC7540§6.6:
+     *   The PUSH_PROMISE frame includes the unsigned 31-bit identifier of the
+     *   stream the endpoint plans to create along with a set of headers that
+     *   provide additional context for the stream. *)
+    4 + len
+  in
+  let writer t =
+    BE.write_uint32 t promised_id;
+    bounded_schedule_iovecs t ~len iovecs
+  in
+  write_frame_with_padding t info PushPromise payload_length writer
+
+let default_ping_payload =
+  (* From RFC7540§6.7:
+   *   In addition to the frame header, PING frames MUST contain 8 octets of
+   *   opaque data in the payload. *)
+  let bstr = Bigstringaf.create 8 in
+  for i = 0 to 7 do
+    Bigstringaf.unsafe_set bstr i '\000'
+  done;
+  bstr
+
+let write_ping_frame t info ?(off = 0) payload =
+  (* From RFC7540§6.7:
+   *   In addition to the frame header, PING frames MUST contain 8 octets of
+   *   opaque data in the payload. *)
+  let payload_length = 8 in
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id = info.stream_id
+    ; payload_length
+    ; frame_type = Ping
+    }
+  in
+  write_frame_header t header;
+  schedule_bigstring ~off ~len:payload_length t payload
+
+let write_go_away_frame t info stream_id error_code debug_data =
+  let debug_data_len = Bigstringaf.length debug_data in
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id =
+        info.stream_id
+        (* See RFC7540§6.8:
+         *   Last-Stream-ID (4 octets) + Error Code (4 octets) + Additional
+         *   Debug Data (opaque) *)
+    ; payload_length = 8 + debug_data_len
+    ; frame_type = GoAway
+    }
+  in
+  write_frame_header t header;
+  BE.write_uint32 t stream_id;
+  BE.write_uint32 t (Error_code.serialize error_code);
+  schedule_bigstring t ~off:0 ~len:debug_data_len debug_data
+
+let write_window_update_frame t info window_size =
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id =
+        info.stream_id
+        (* From RFC7540§6.9:
+         *   The payload of a WINDOW_UPDATE frame is one reserved bit plus an
+         *   unsigned 31-bit integer indicating the number of octets that the
+         *   sender can transmit in addition to the existing flow-control
+         *   window. *)
+    ; payload_length = 4
+    ; frame_type = WindowUpdate
+    }
+  in
+  write_frame_header t header;
+  BE.write_uint32 t window_size
+
+let write_continuation_frame t info ?len iovecs =
+  let len = match len with Some len -> len | None -> IOVec.lengthv iovecs in
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id = info.stream_id
+    ; payload_length = len
+    ; frame_type = Continuation
+    }
+  in
+  write_frame_header t header;
+  bounded_schedule_iovecs t ~len iovecs
+
+let write_unknown_frame t ~code info payload =
+  let payload_length = Bigstringaf.length payload in
+  let header =
+    { Frame.flags = info.flags
+    ; stream_id = info.stream_id
+    ; payload_length
+    ; frame_type = Unknown code
+    }
+  in
+  write_frame_header t header;
+  schedule_bigstring t ~off:0 ~len:payload_length payload
+
+let write_connection_preface t =
+  (* From RFC7540§3.5:
+   *   In HTTP/2, each endpoint is required to send a connection preface as a
+   *   final confirmation of the protocol in use and to establish the initial
+   *   settings for the HTTP/2 connection. [...] The client connection preface
+   *   starts with a sequence of 24 octets, [...] the string
+   *   PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n. *)
+  write_string t Frame.connection_preface
+
+module Writer = struct
+  type t =
+    { buffer : Bigstringaf.t
+          (* The buffer that the encoder uses for buffered writes. Managed by
+           * the control module for the encoder. *)
+    ; encoder : Faraday.t
+          (* The encoder that handles encoding for writes. Uses the [buffer]
+           * referenced above internally. *)
+    ; mutable drained_bytes : int
+          (* The number of bytes that were not written due to the output stream
+           * being closed before all buffered output could be written. Useful
+           * for detecting error cases. *)
+    ; mutable wakeup : Optional_thunk.t
+    }
+
+  let create buffer_size =
+    let buffer = Bigstringaf.create buffer_size in
+    let encoder = Faraday.of_bigstring buffer in
+    { buffer; encoder; drained_bytes = 0; wakeup = Optional_thunk.none }
+
+  let faraday t = t.encoder
+
+  let make_frame_info
+      ?(padding = Bigstringaf.empty)
+      ?(flags = Flags.default_flags)
+      ?(max_frame_size = Config.default.read_buffer_size)
+      stream_id
+    =
+    { flags; stream_id; padding; max_frame_payload = max_frame_size }
+
+  let write_connection_preface t settings_list =
+    write_connection_preface t.encoder;
+    let frame_info = make_frame_info Stream_identifier.connection in
+    (* From RFC7540§3.5:
+     *   This sequence MUST be followed by a SETTINGS frame (Section 6.5),
+     *   which MAY be empty. *)
+    write_settings_frame t.encoder frame_info settings_list
+
+  let chunk_data_frames ?(off = 0) ~f frame_info total_length =
+    let { max_frame_payload; _ } = frame_info in
+    if max_frame_payload < total_length
+    then
+      let rec loop ~off remaining =
+        if max_frame_payload < remaining
+        then (
+          (* Note: If we're splitting data into several frames, only the last
+           * one should contain the END_STREAM flag, so unset it here if it's
+           * set. *)
+          let frame_info =
+            { frame_info with flags = Flags.clear_end_stream frame_info.flags }
+          in
+          f ~off ~len:max_frame_payload frame_info;
+          loop ~off:(off + max_frame_payload) (remaining - max_frame_payload))
+        else f ~off ~len:remaining frame_info
+      in
+      loop ~off total_length
+    else f ~off ~len:total_length frame_info
+
+  let write_data t frame_info ?off ?len str =
+    if not (is_closed t.encoder)
+    then
+      let total_length =
+        match len with Some len -> len | None -> String.length str
+      in
+      chunk_data_frames
+        frame_info
+        ?off
+        total_length
+        ~f:(fun ~off ~len frame_info ->
+          write_data_frame t.encoder frame_info ~off ~len str)
+
+  let schedule_data t frame_info ?off ?len bstr =
+    if not (is_closed t.encoder)
+    then
+      let total_length =
+        match len with Some len -> len | None -> Bigstringaf.length bstr
+      in
+      chunk_data_frames
+        frame_info
+        ?off
+        total_length
+        ~f:(fun ~off ~len frame_info ->
+          schedule_data_frame t.encoder frame_info ~off ~len bstr)
+
+  (* Chunk header block fragments into HEADERS|PUSH_PROMISE + CONTINUATION
+   * frames. *)
+  let chunk_header_block_fragments
+      t
+      frame_info
+      ?(has_priority = false)
+      ~(write_frame :
+         Faraday.t -> frame_info -> ?len:int -> Bigstringaf.t iovec list -> unit)
+      faraday
+    =
+    let block_size = Faraday.pending_bytes faraday in
+    let total_length =
+      if has_priority
+      then
+        (* See RFC7540§6.2: Exclusive Bit & Stream Dependency (4 octets) +
+           Weight (1 octet) + Header Block Fragment length. *)
+        block_size + 5
+      else block_size
+    in
+    let { max_frame_payload; _ } = frame_info in
+    if max_frame_payload < total_length
+    then (
+      let headers_block_len =
+        if has_priority then max_frame_payload - 5 else max_frame_payload
+      in
+      ignore
+        (Faraday.serialize faraday (fun iovecs ->
+           write_frame t.encoder frame_info ~len:headers_block_len iovecs;
+           `Ok headers_block_len));
+      let rec loop remaining =
+        if max_frame_payload < remaining
+        then (
+          (* Note: Don't reuse flags from frame info as CONTINUATION frames
+           * only define END_HEADERS.
+           *
+           * From RFC7540§6.10:
+           *   The CONTINUATION frame defines the following flag:
+           *
+           *     END_HEADERS (0x4): When set, bit 2 indicates that this frame
+           *     ends a header block (Section 4.3). *)
+          let frame_info = { frame_info with flags = Flags.default_flags } in
+          ignore
+            (Faraday.serialize faraday (fun iovecs ->
+               write_continuation_frame
+                 t.encoder
+                 frame_info
+                 ~len:max_frame_payload
+                 iovecs;
+               `Ok max_frame_payload));
+          loop (remaining - max_frame_payload))
+        else
+          let frame_info =
+            { frame_info with flags = Flags.(set_end_header default_flags) }
+          in
+          ignore
+            (Faraday.serialize faraday (fun iovecs ->
+               write_continuation_frame
+                 t.encoder
+                 frame_info
+                 ~len:remaining
+                 iovecs;
+               `Ok remaining))
+      in
+      loop (block_size - headers_block_len))
+    else
+      let frame_info =
+        { frame_info with flags = Flags.set_end_header frame_info.flags }
+      in
+      ignore
+        (Faraday.serialize faraday (fun iovecs ->
+           let len = IOVec.lengthv iovecs in
+           write_frame t.encoder frame_info ~len iovecs;
+           `Ok len))
+
+  let encode_headers hpack_encoder faraday headers =
+    List.iter
+      (fun header -> Hpack.Encoder.encode_header hpack_encoder faraday header)
+      (Headers.to_hpack_list headers)
+
+  let write_request_like_frame t hpack_encoder ~write_frame frame_info request =
+    let { Request.meth; target; scheme; headers } = request in
+    let faraday = Faraday.create 0x1000 in
+    Hpack.Encoder.encode_header
+      hpack_encoder
+      faraday
+      { Headers.name = ":method"
+      ; value = Httpun_types.Method.to_string meth
+      ; sensitive = false
+      };
+    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.Encoder.encode_header
+        hpack_encoder
+        faraday
+        { Headers.name = ":scheme"; value = scheme; sensitive = false });
+    encode_headers hpack_encoder faraday headers;
+    chunk_header_block_fragments t frame_info ~write_frame faraday
+
+  let write_request_headers t hpack_encoder ~priority frame_info request =
+    if not (is_closed t.encoder)
+    then
+      let write_frame = write_headers_frame ~priority in
+      write_request_like_frame t hpack_encoder ~write_frame frame_info request
+
+  let write_push_promise t hpack_encoder frame_info ~promised_id request =
+    if not (is_closed t.encoder)
+    then
+      let write_frame = write_push_promise_frame ~promised_id in
+      write_request_like_frame t hpack_encoder ~write_frame frame_info request
+
+  let write_response_headers t hpack_encoder frame_info response =
+    if not (is_closed t.encoder)
+    then (
+      let { Response.status; headers; _ } = response in
+      let faraday = Faraday.create 0x1000 in
+      (* From RFC7540§8.1.2.4:
+       *   For HTTP/2 responses, a single :status pseudo-header field is defined
+       *   that carries the HTTP status code field (see [RFC7231], Section 6).
+       *   This pseudo-header field MUST be included in all responses; otherwise,
+       *   the response is malformed (Section 8.1.2.6). *)
+      Hpack.Encoder.encode_header
+        hpack_encoder
+        faraday
+        { Headers.name = ":status"
+        ; value = Status.to_string status
+        ; sensitive = false
+        };
+      encode_headers hpack_encoder faraday headers;
+      chunk_header_block_fragments
+        t
+        frame_info
+        ~write_frame:(write_headers_frame ~priority:Priority.default_priority)
+        ~has_priority:false
+        faraday)
+
+  let write_response_trailers t hpack_encoder frame_info trailers =
+    if not (is_closed t.encoder)
+    then (
+      let faraday = Faraday.create 0x1000 in
+      (* From RFC7540§8.1:
+       *  optionally, one HEADERS frame, followed by zero or more
+       *  CONTINUATION frames containing the trailer-part, if present (see
+       *  [RFC7230], Section 4.1.2). *)
+      encode_headers hpack_encoder faraday trailers;
+      chunk_header_block_fragments
+        t
+        frame_info
+        ~write_frame:(write_headers_frame ~priority:Priority.default_priority)
+        ~has_priority:false
+        faraday)
+
+  let write_rst_stream t frame_info e =
+    if not (is_closed t.encoder)
+    then write_rst_stream_frame t.encoder frame_info e
+
+  let write_window_update t frame_info n =
+    if not (is_closed t.encoder)
+    then write_window_update_frame t.encoder frame_info n
+
+  let schedule_iovecs t ~len frame_info iovecs =
+    if not (is_closed t.encoder)
+    then
+      let writer t ~len ~iovecs = bounded_schedule_iovecs t ~len iovecs in
+      chunk_data_frames frame_info len ~f:(fun ~off ~len frame_info ->
+        write_frame_with_padding
+          t.encoder
+          frame_info
+          Data
+          len
+          (writer ~iovecs:(IOVec.shiftv iovecs off) ~len))
+
+  let write_priority t frame_info priority =
+    if not (is_closed t.encoder)
+    then write_priority_frame t.encoder frame_info priority
+
+  let write_settings t frame_info settings =
+    if not (is_closed t.encoder)
+    then write_settings_frame t.encoder frame_info settings
+
+  let write_ping t frame_info ?off payload =
+    if not (is_closed t.encoder)
+    then write_ping_frame t.encoder frame_info ?off payload
+
+  let write_go_away t frame_info ~debug_data ~last_stream_id error =
+    if not (is_closed t.encoder)
+    then
+      write_go_away_frame t.encoder frame_info last_stream_id error debug_data
+
+  let on_wakeup_writer t k =
+    if Faraday.is_closed t.encoder
+    then failwith "on_wakeup_writer on closed conn"
+    else if Optional_thunk.is_some t.wakeup
+    then failwith "on_wakeup: only one callback can be registered at a time"
+    else t.wakeup <- Optional_thunk.some k
+
+  let wakeup t =
+    let f = t.wakeup in
+    t.wakeup <- Optional_thunk.none;
+    Optional_thunk.call_if_some f
+
+  let flush t f =
+    flush_with_reason t.encoder (fun reason ->
+      let result =
+        match reason with
+        | Nothing_pending | Shift -> `Written
+        | Drain -> `Closed
+      in
+      f result)
+
+  let unyield t =
+    (* Faraday doesn't have a function to take the serializer out of a yield
+       state. In the meantime, `flush` does it. *)
+    flush t (fun _reason -> ())
+
+  let yield t = Faraday.yield t.encoder
+  let close t = Faraday.close t.encoder
+
+  let close_and_drain t =
+    Faraday.close t.encoder;
+    let drained = Faraday.drain t.encoder in
+    t.drained_bytes <- t.drained_bytes + drained
+
+  let is_closed t = Faraday.is_closed t.encoder
+  let drained_bytes t = t.drained_bytes
+
+  let report_result t result =
+    match result with
+    | `Closed -> close_and_drain t
+    | `Ok len -> shift t.encoder len
+
+  let next t =
+    match Faraday.operation t.encoder with
+    | `Close -> `Close (drained_bytes t)
+    | `Yield -> `Yield
+    | `Writev iovecs -> `Write iovecs
+end

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 ")@]"

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

@@ -0,0 +1,123 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2017 Inhabited Type LLC.
+ *  Copyright (c) 2019 Antonio N. 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 author nor the names of his contributors
+ *     may be used to endorse or promote products derived from this software
+ *     without specific prior written permission.
+ *
+ *  THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
+ *---------------------------------------------------------------------------*)
+
+(* From RFC7540§8.1.1:
+ *   HTTP/2 removes support for the 101 (Switching Protocols) informational
+ *   status code ([RFC7231], Section 6.2.2).
+ *
+ *   Note: While the above is true, we don't enforce in this library, as it
+ *   makes unifying types with httpun much easier. `H2.Status.t` is, thus, a
+ *   strict superset of `Httpun_types.Status.t`. *)
+
+include (
+  Httpun_types.Status :
+    module type of Httpun_types.Status
+    with type client_error := Httpun_types.Status.client_error
+     and type standard := Httpun_types.Status.standard
+     and type t := Httpun_types.Status.t)
+
+type client_error =
+  [ Httpun_types.Status.client_error
+  | (* From RFC7540§9.1.2:
+     *   The 421 (Misdirected Request) status code indicates that the request
+     *   was directed at a server that is not able to produce a response. This
+     *   can be sent by a server that is not configured to produce responses
+     *   for the combination of scheme and authority that are included in the
+     *   request URI. *)
+    `Misdirected_request
+  ]
+
+type standard =
+  [ Httpun_types.Status.standard
+  | client_error
+  ]
+
+type t =
+  [ standard
+  | `Code of int
+  ]
+
+(* Note: The value for reason phrases is never actually serialized to the
+ * input or output channels.
+ *
+ * From RFC7540§8.1.2.4:
+ *   HTTP/2 does not define a way to carry the version or reason phrase that is
+ *   included in an HTTP/1.1 status line. *)
+let default_reason_phrase = function
+  | `Misdirected_request -> "Misdirected Request"
+  | #Httpun_types.Status.standard as t ->
+    Httpun_types.Status.default_reason_phrase t
+
+let to_code = function
+  | `Misdirected_request -> 421
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.to_code t
+
+let unsafe_of_code = function
+  | 421 -> `Misdirected_request
+  | c -> (Httpun_types.Status.unsafe_of_code c :> t)
+
+let of_code = function
+  | 421 -> `Misdirected_request
+  | c -> (Httpun_types.Status.of_code c :> t)
+
+let is_informational = function
+  | `Misdirected_request -> false
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_informational t
+
+let is_successful = function
+  | `Misdirected_request -> false
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_successful t
+
+let is_redirection = function
+  | `Misdirected_request -> false
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_redirection t
+
+let is_client_error = function
+  | `Misdirected_request -> true
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_client_error t
+
+let is_server_error = function
+  | `Misdirected_request -> false
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_server_error t
+
+let is_error = function
+  | `Misdirected_request -> true
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.is_error t
+
+let to_string = function
+  | `Misdirected_request -> "421"
+  | #Httpun_types.Status.t as t -> Httpun_types.Status.to_string t
+
+let of_string x = of_code (int_of_string x)
+let pp_hum fmt t = Format.fprintf fmt "%u" (to_code t)

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

@@ -0,0 +1,157 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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 AB = Angstrom.Buffered
+module Writer = Serialize.Writer
+
+type partial_headers =
+  { mutable parse_state : (Headers.t, Hpack.error) result AB.state
+  ; end_stream : bool
+  }
+
+type 'active_peer remote_state =
+  (* A stream is in this state when it's waiting for the peer to initiate a
+   * response. In practice, it only matters for the client implementation, when
+   * a client has opened a stream but is still waiting on the server to send
+   * the first bytes of the response. *)
+  | WaitingForPeer
+  (* A PartialHeaders state is entered when the endpoint sees the first HEADERS
+   * frame from the peer for a given stream. Its payload is an
+   * Angstrom.Buffered parse state. *)
+  | PartialHeaders of partial_headers
+  (* A stream transitions from the PartialHeaders state to the FullHeaders
+   * state when the endpoint has finished parsing all the bytes in a group of
+   * HEADER / CONTINUATION frames that the peer has sent.
+   * This state doesn't carry any payload because the stream will immediately
+   * transition to the ActiveMessage state once the message has been validated
+   * according to RFC7540§8.1.2. *)
+  | FullHeaders
+  (* The ActiveMessage state carries information about the current remote
+   * message being processed by the endpoint. *)
+  | ActiveMessage of 'active_peer
+
+type closed_reason =
+  | Finished
+  (* TODO: we could abide by the following by either 1) having I/O runtime
+   * support for timers or 2) by simply counting the number of frames received
+   * after we've sent an RST_STREAM?
+   *
+   * From RFC7540§5.4.2:
+   *   Normally, an endpoint SHOULD NOT send more than one RST_STREAM frame for
+   *   any stream. However, an endpoint MAY send additional RST_STREAM frames
+   *   if it receives frames on a closed stream after more than a round-trip
+   *   time. This behavior is permitted to deal with misbehaving
+   *   implementations. *)
+  | ResetByUs of Error_code.t
+  (* Received an RST_STREAM frame from the peer. *)
+  | ResetByThem of Error_code.t
+
+type closed =
+  { reason : closed_reason
+        (* When a stream is closed, we may want to keep it around in the hash
+         * table for a while (e.g. to know whether this stream was reset by the
+         * peer - some error handling code depends on that). We start with a
+         * default value, and on every writer yield we decrement it. If it
+         * reaches 0, the stream is finally removed from the hash table. *)
+  ; mutable ttl : int
+  }
+
+type ('opn, 'half_closed) active_state =
+  | Open of 'opn remote_state
+  | HalfClosed of 'half_closed
+
+type ('active_state, 'active, 'reserved) state =
+  | Idle
+  | Reserved of 'reserved
+  | Active of 'active_state * 'active
+  | Closed of closed
+  constraint 'active_state = (_, _) active_state
+
+type 'a error_status =
+  | No_error
+  | Exn of exn
+  | Other of
+      { error : 'a
+      ; code : Error_code.t
+      }
+
+type ('state, 'error, 'error_handler) t =
+  { id : Stream_identifier.t
+  ; writer : Serialize.Writer.t
+  ; error_handler : 'error_handler
+  ; mutable error_code : 'error error_status
+  ; mutable state : 'state
+        (* The largest frame payload we're allowed to write. *)
+  ; mutable max_frame_size : int
+  ; on_close : active:bool -> closed -> unit
+  }
+  constraint 'state = (_, _, _) state
+
+let initial_ttl = 10
+
+let create id ~max_frame_size writer error_handler on_close =
+  { id
+  ; writer
+  ; error_handler
+    (* From RFC7540§5.1:
+     *   idle: All streams start in the "idle" state. *)
+  ; state = Idle
+  ; error_code = No_error
+  ; max_frame_size
+  ; on_close
+  }
+
+let id { id; _ } = id
+let is_idle t = match t.state with Idle -> true | _ -> false
+let is_open t = match t.state with Active (Open _, _) -> true | _ -> false
+
+let finish_stream t reason =
+  let active = match t.state with Active _ -> true | _ -> false in
+  let closed = { reason; ttl = initial_ttl } in
+  t.on_close ~active closed;
+  t.state <- Closed closed
+
+let error_code t =
+  match t.error_code with
+  | Exn exn -> Some (`Exn exn)
+  | Other { error; _ } -> Some error
+  | No_error -> None
+
+let error_to_code error error_code =
+  match error with
+  | `Exn exn -> Exn exn
+  | other -> Other { error = other; code = error_code }
+
+let reset_stream t error_code =
+  let frame_info = Writer.make_frame_info t.id in
+  Writer.write_rst_stream t.writer frame_info error_code;
+  finish_stream t (ResetByUs error_code)

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

@@ -0,0 +1,65 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+(* From RFC7540§5.1.1:
+ *   Streams are identified with an unsigned 31-bit integer. *)
+type t = int32
+
+let ( === ) = Int32.equal
+let[@inline] ( <= ) s1 s2 = Int32.compare s1 s2 <= 0
+let[@inline] ( > ) s1 s2 = Int32.compare s1 s2 > 0
+let[@inline] ( >= ) s1 s2 = Int32.compare s1 s2 >= 0
+
+(* From RFC7540§5.1.1:
+ *   A stream identifier of zero (0x0) is used for connection control messages;
+ *   the stream identifier of zero cannot be used to establish a new stream. *)
+let connection = Int32.zero
+
+(* From RFC7540§5.1.1:
+ *   A stream identifier of zero (0x0) is used for connection control messages;
+ *   the stream identifier of zero cannot be used to establish a new stream. *)
+let[@inline] is_connection id = Int32.equal id connection
+
+(* From RFC7540§5.1.1:
+ *   Streams initiated by a client MUST use odd-numbered stream
+ *   identifiers [...]. *)
+let[@inline] is_request id = Int32.rem id 2l === 1l
+
+(* From RFC7540§5.1.1:
+ *   Streams initiated by [...] the server MUST use even-numbered stream
+ *   identifiers. A stream identifier of zero (0x0) is used for connection
+ *   control messages [...]. *)
+let[@inline] is_pushed = function 0l -> false | n -> Int32.rem n 2l === 0l
+
+(* From RFC7540§5.1.1:
+ *   Streams are identified with an unsigned 31-bit integer. *)
+let max_stream_id = Int32.max_int

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

@@ -0,0 +1,48 @@
+(*----------------------------------------------------------------------------
+ *  Copyright (c) 2019 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.
+ *---------------------------------------------------------------------------*)
+
+let[@inline] test_bit_int32 x i =
+  let open Int32 in
+  not (equal (logand x (shift_left 1l i)) 0l)
+
+let[@inline] test_bit x i = x land (1 lsl i) <> 0
+let[@inline] set_bit x i = x lor (1 lsl i)
+
+let[@inline] set_bit_int32 x i =
+  let open Int32 in
+  logor x (shift_left 1l i)
+
+let[@inline] clear_bit x i = x land lnot (1 lsl i)
+
+let[@inline] clear_bit_int32 x i =
+  let open Int32 in
+  logand x (lognot (shift_left 1l i))