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

@@ -0,0 +1,230 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2018 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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                : Bstr.t -> off:int -> len:int -> unit
+    }
+
+  let default_on_eof         = Sys.opaque_identity (fun () -> ())
+  let default_on_read        = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ())
+
+  let create buffer =
+    { faraday                = Faraday.of_bigstring buffer
+    ; read_scheduled         = false
+    ; on_eof                 = default_on_eof
+    ; on_read                = default_on_read
+    }
+
+  let create_empty () =
+    let t = create Bstr.empty 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 ()
+    (* [Faraday.operation] never returns an empty list of iovecs *)
+    | `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;
+      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.Reader.schedule_read: reader already scheduled";
+    if not (is_closed t) then begin
+      t.read_scheduled <- true;
+      t.on_eof         <- on_eof;
+      t.on_read        <- on_read;
+    end;
+    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 encoding =
+    | Identity
+    | Chunked of { mutable written_final_chunk : bool }
+
+  type t =
+    { faraday        : Faraday.t
+    ; writer         : Writer.t
+    ; encoding       : encoding
+    ; buffered_bytes : int ref
+    }
+
+  let of_faraday faraday writer ~encoding =
+    let encoding =
+      match encoding with
+      | `Fixed _ | `Close_delimited -> Identity
+      | `Chunked -> Chunked { written_final_chunk = false }
+    in
+    { faraday
+    ; encoding
+    ; writer
+    ; buffered_bytes = ref 0
+    }
+
+  let create buffer writer ~encoding =
+    of_faraday (Faraday.of_bigstring buffer) writer ~encoding
+
+  let write_char t c =
+    if not (Faraday.is_closed t.faraday) then
+      Faraday.write_char t.faraday c
+
+  let write_string t ?off ?len s =
+    if not (Faraday.is_closed t.faraday) then
+      Faraday.write_string ?off ?len t.faraday s
+
+  let write_bigstring t ?off ?len b =
+    if not (Faraday.is_closed t.faraday) then
+      Faraday.write_bigstring ?off ?len t.faraday b
+
+  let schedule_bigstring t ?off ?len (b:Bstr.t) =
+    if not (Faraday.is_closed t.faraday) then
+      Faraday.schedule_bigstring ?off ?len t.faraday b
+
+  let ready_to_write t = Writer.wakeup t.writer
+
+  let flush t kontinue =
+    Faraday.flush t.faraday kontinue;
+    ready_to_write t
+
+  let flush_with_reason t kontinue =
+    if Writer.is_closed t.writer then
+      kontinue `Closed
+    else begin
+      Faraday.flush_with_reason t.faraday (fun reason ->
+        let result =
+          match reason with
+          | Nothing_pending | Shift -> `Written
+          | Drain -> `Closed
+        in
+        kontinue result);
+      ready_to_write t
+    end
+
+  let is_closed t =
+    Faraday.is_closed t.faraday
+
+  let close_and_drain t =
+    Faraday.close t.faraday;
+    (* Resolve all pending flushes *)
+    ignore (Faraday.drain t.faraday : int)
+
+  let close t =
+    Faraday.close t.faraday;
+    ready_to_write t;
+  ;;
+
+  let has_pending_output t =
+    (* Force another write poll to make sure that the final chunk is emitted for
+       chunk-encoded bodies. *)
+    let faraday_has_output = Faraday.has_pending_output t.faraday in
+    let additional_encoding_output =
+      match t.encoding with
+      | Identity -> false
+      | Chunked { written_final_chunk } ->
+        Faraday.is_closed t.faraday && not written_final_chunk
+    in
+    faraday_has_output || additional_encoding_output
+
+  let transfer_to_writer t =
+    let faraday = t.faraday in
+    if Writer.is_closed t.writer then
+      close_and_drain t
+    else begin
+      match Faraday.operation faraday with
+      | `Yield -> ()
+      | `Close ->
+        (match t.encoding with
+         | Identity -> ()
+         | Chunked ({ written_final_chunk } as chunked) ->
+           if not written_final_chunk then begin
+             chunked.written_final_chunk <- true;
+             Serialize.Writer.schedule_chunk t.writer [];
+           end);
+        Serialize.Writer.unyield t.writer;
+      | `Writev iovecs ->
+        let buffered = t.buffered_bytes in
+        begin match Httpun_types.IOVec.shiftv iovecs !buffered with
+        | []     -> ()
+        | iovecs ->
+          let lengthv  = Httpun_types.IOVec.lengthv iovecs in
+          buffered := !buffered + lengthv;
+          begin match t.encoding with
+          | Identity  -> Serialize.Writer.schedule_fixed t.writer iovecs
+          | Chunked _ -> Serialize.Writer.schedule_chunk t.writer iovecs
+          end;
+          Serialize.Writer.flush t.writer (fun result ->
+            match result with
+            | `Closed -> close_and_drain t
+            | `Written ->
+              Faraday.shift faraday lengthv;
+              buffered := !buffered - lengthv)
+        end
+    end
+end

unikernel/duniverse/ocaml-h1/lib/client_connection.ml

@@ -0,0 +1,219 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017-2019 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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 = Parse.Reader
+module Writer = Serialize.Writer
+
+module Oneshot = struct
+  type error =
+    [ `Malformed_response of string | `Invalid_response_body_length of Response.t | `Exn of exn ]
+
+  type response_handler = Response.t -> Body.Reader.t  -> unit
+  type error_handler = error -> unit
+
+  type state =
+    | Awaiting_response
+    | Received_response of Response.t * Body.Reader.t
+    | Closed
+
+  type t =
+    { request          : Request.t
+    ; request_body     : Body.Writer.t
+    ; error_handler    : (error -> unit)
+    ; reader : Reader.response
+    ; writer : Writer.t
+    ; state  : state ref
+    ; mutable error_code : [ `Ok | error ]
+    }
+
+  let request ?(config=Config.default) request ~error_handler ~response_handler =
+    let state = ref Awaiting_response in
+    let request_method = request.Request.meth in
+    let handler response body =
+      state := Received_response(response, body);
+      response_handler response body
+    in
+    let writer = Writer.create () in
+    let request_body =
+      let encoding =
+        match Request.body_length request with
+        | `Fixed _ | `Chunked as encoding -> encoding
+        | `Error `Bad_request ->
+          failwith "H1.Client_connection.request: invalid body length"
+      in
+      Body.Writer.create (Bstr.create config.request_body_buffer_size) writer
+        ~encoding
+    in
+    let t =
+      { request
+      ; request_body
+      ; error_handler
+      ; error_code = `Ok
+      ; reader = Reader.response ~request_method handler
+      ; writer
+      ; state }
+    in
+    Writer.write_request t.writer request;
+    request_body, t
+  ;;
+
+  let flush_request_body t =
+    if Body.Writer.has_pending_output t.request_body
+    then Body.Writer.transfer_to_writer t.request_body
+  ;;
+
+  let set_error_and_handle_without_shutdown t error =
+    t.state := Closed;
+    t.error_code <- (error :> [`Ok | error]);
+    t.error_handler error;
+  ;;
+
+  let unexpected_eof t =
+    set_error_and_handle_without_shutdown t (`Malformed_response "unexpected eof");
+  ;;
+
+  let shutdown_reader t =
+    Reader.force_close t.reader;
+    begin match !(t.state) with
+    | Awaiting_response -> unexpected_eof t;
+    | Closed -> ()
+    | Received_response(_, response_body) ->
+      Body.Reader.close response_body;
+      Body.Reader.execute_read response_body;
+    end;
+  ;;
+
+  let shutdown_writer t =
+    flush_request_body t;
+    Writer.close t.writer;
+    Body.Writer.close t.request_body;
+  ;;
+
+  let shutdown t =
+    shutdown_reader t;
+    shutdown_writer t;
+  ;;
+
+  let set_error_and_handle t error =
+    Reader.force_close t.reader;
+    begin match !(t.state) with
+    | Closed -> ()
+    | Awaiting_response ->
+      set_error_and_handle_without_shutdown t error;
+    | Received_response(_, response_body) ->
+      Body.Reader.close response_body;
+      Body.Reader.execute_read response_body;
+      set_error_and_handle_without_shutdown t error;
+    end
+  ;;
+
+  let report_exn t exn =
+    set_error_and_handle t (`Exn exn)
+  ;;
+
+  let flush_response_body t =
+    match !(t.state) with
+    | Awaiting_response | Closed -> ()
+    | Received_response(_, response_body) ->
+      try Body.Reader.execute_read response_body
+      with exn -> report_exn t exn
+  ;;
+
+  let _next_read_operation t =
+    match !(t.state) with
+    | Awaiting_response | Closed -> Reader.next t.reader
+    | Received_response(_, response_body) ->
+      if not (Body.Reader.is_closed response_body)
+      then Reader.next t.reader
+      else begin
+        Reader.force_close t.reader;
+        Reader.next        t.reader
+      end
+  ;;
+
+  let next_read_operation t =
+    match _next_read_operation t with
+    | `Error (`Parse(marks, message)) ->
+      let message = String.concat "" [ String.concat ">" marks; ": "; message] in
+      set_error_and_handle t (`Malformed_response message);
+      `Close
+    | `Error (`Invalid_response_body_length _ as error) ->
+      set_error_and_handle t error;
+      `Close
+    | (`Read | `Close) as operation -> operation
+  ;;
+
+  let read_with_more t bs ~off ~len more =
+    let consumed = Reader.read_with_more t.reader bs ~off ~len more in
+    flush_response_body t;
+    consumed
+  ;;
+
+  let read t bs ~off ~len =
+    read_with_more t bs ~off ~len Incomplete
+
+  let read_eof t bs ~off ~len =
+    let bytes_read = read_with_more t bs ~off ~len Complete in
+    begin match !(t.state) with
+    | Received_response _ | Closed -> ()
+    | Awaiting_response -> unexpected_eof t;
+    end;
+    bytes_read
+  ;;
+
+  let next_write_operation t =
+    flush_request_body t;
+    if Body.Writer.is_closed t.request_body
+    (* Even though we've just done [flush_request_body], it might still be the case that
+       [Body.Writer.has_pending_output] returns true, because it does so when
+       we've written all output except for the final chunk. *)
+    && not (Body.Writer.has_pending_output t.request_body)
+    then Writer.close t.writer;
+    Writer.next t.writer
+  ;;
+
+  let yield_writer t k =
+    if Body.Writer.is_closed t.request_body
+    && not (Body.Writer.has_pending_output t.request_body)
+    then begin
+      Writer.close t.writer;
+      k ()
+    end else
+      Writer.on_wakeup t.writer k
+
+  let report_write_result t result =
+    Writer.report_result t.writer result
+
+  let is_closed t = Reader.is_closed t.reader && Writer.is_closed t.writer
+end

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

@@ -0,0 +1,11 @@
+type t =
+  { read_buffer_size          : int
+  ; request_body_buffer_size  : int
+  ; response_buffer_size      : int
+  ; response_body_buffer_size : int }
+
+let default =
+  { read_buffer_size          = 0x1000
+  ; request_body_buffer_size  = 0x1000
+  ; response_buffer_size      = 0x400
+  ; response_body_buffer_size = 0x1000 }

unikernel/duniverse/ocaml-h1/lib/dune

@@ -0,0 +1,6 @@
+(library
+ (name        h1)
+ (public_name h1)
+ (libraries
+   angstrom faraday base64 bstr httpun-types)
+ (flags (:standard -safe-string)))

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

@@ -0,0 +1,20 @@
+module Headers = Httpun_types.Headers
+module IOVec = Httpun_types.IOVec
+module Method = Httpun_types.Method
+module Status = Httpun_types.Status
+module Version = Httpun_types.Version
+module Reqd = Reqd
+module Request = Request
+module Response = Response
+module Body = Body
+module Config = Config
+
+module Server_connection = Server_connection
+module Client_connection = Client_connection.Oneshot
+
+module Websocket = Websocket
+
+module H1_private = struct
+  module Parse = Parse
+  module Serialize = Serialize
+end

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

@@ -0,0 +1,662 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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.
+  ----------------------------------------------------------------------------*)
+
+(** H1 is a high-performance, memory-efficient, and scalable web server
+    for OCaml. It implements the HTTP 1.1 specification with respect to
+    parsing, serialization, and connection pipelining. For compatibility,
+    H1 respects the imperatives of the [Server_connection] header when handling
+    HTTP 1.0 connections.
+
+    To use this library effectively, the user must be familiar with the HTTP
+    1.1 specification, and the basic principles of memory management and
+    vectorized IO. *)
+
+(** {2 Basic HTTP Types} *)
+
+module Version : module type of Httpun_types.Version
+module Method : module type of Httpun_types.Method
+module Status : module type of Httpun_types.Status
+module Headers : module type of Httpun_types.Headers
+
+(** {2 Message Body} *)
+
+module Body : sig
+  module Reader : sig
+    type t
+
+    val schedule_read
+      :  t
+      -> on_eof  : (unit -> unit)
+      -> on_read : (Bstr.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 bytes available for reading. *)
+  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 -> Bstr.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 -> Bstr.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_with_reason : t -> ([ `Written | `Closed ] -> unit) -> unit
+    (** [flush_with_reason t f] makes all bytes in [t] available for writing to the awaiting output
+        channel. Once those bytes have reached that output channel, [f `Written] will be
+        called. If instead, the output channel is closed before all of those bytes are
+        successfully written, [f `Closed] 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 flush: t -> (unit -> unit) -> unit
+    (** [flush t f] is identical to [flush_with_reason t], except ignoring the result of the flush.
+        In most situations, you should use flush_with_reason and properly handle a closed output channel. *)
+
+    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], or if the attached
+        output channel is closed (e.g. because [report_write_result `Closed] has been
+        called). 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
+    ; version : Version.t
+    ; headers : Headers.t }
+
+  val create
+    :  ?version:Version.t (** default is HTTP 1.1 *)
+    -> ?headers:Headers.t (** default is {!Headers.empty} *)
+    -> Method.t
+    -> string
+    -> t
+
+  module Body_length : sig
+    type t = [
+      | `Fixed of Int64.t
+      | `Chunked
+      | `Error of [`Bad_request]
+    ]
+
+    val pp_hum : Format.formatter -> t -> unit
+  end
+
+  val body_length : t -> Body_length.t
+  (** [body_length t] is the length of the message body accompanying [t]. It is
+      an error to generate a request with a close-delimited message body.
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
+      for more details. *)
+
+  val persistent_connection : ?proxy:bool -> t -> bool
+  (** [persistent_connection ?proxy t] indicates whether the connection for [t]
+      can be reused for multiple requests and responses. If the calling code
+      is acting as a proxy, it should pass [~proxy:true].
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for
+      more details. *)
+
+  val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer]
+
+  val is_upgrade : t -> bool
+  (** [is_upgrade t] returns true if the request has the "Connection: upgrade"
+      header. *)
+end
+
+
+(** Response
+
+    A server-generated message to a {Request}. *)
+module Response : sig
+  type t =
+    { version : Version.t
+    ; status  : Status.t
+    ; reason  : string
+    ; headers : Headers.t }
+
+  val create
+    :  ?reason:string     (** default is determined by {!Status.default_reason_phrase} *)
+    -> ?version:Version.t (** default is HTTP 1.1 *)
+    -> ?headers:Headers.t (** default is {!Headers.empty} *)
+    -> Status.t
+    -> t
+  (** [create ?reason ?version ?headers status] creates an HTTP response with
+      the given parameters. For typical use cases, it's sufficient to provide
+      values for [headers] and [status]. *)
+
+  module Body_length : sig
+    type t = [
+      | `Fixed of Int64.t
+      | `Chunked
+      | `Close_delimited
+      | `Error of [ `Bad_gateway | `Internal_server_error ]
+    ]
+
+    val pp_hum : Format.formatter -> t -> unit
+  end
+
+  val body_length : ?proxy:bool -> request_method:Method.standard -> t -> Body_length.t
+  (** [body_length ?proxy ~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]. If the calling code is acting as a proxy, it should
+      pass [~proxy:true]. This optional parameter only affects error reporting.
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-3.3.3} RFC7230§3.3.3}
+      for more details. *)
+
+  val persistent_connection : ?proxy:bool -> t -> bool
+  (** [persistent_connection ?proxy t] indicates whether the connection for [t]
+      can be reused for multiple requests and responses. If the calling code
+      is acting as a proxy, it should pass [~proxy:true].
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3 for
+      more details. *)
+
+  val pp_hum : Format.formatter -> t -> unit [@@ocaml.toplevel_printer]
+end
+
+
+(** IOVec *)
+module IOVec : module type of Httpun_types.IOVec
+
+(** {2 Request Descriptor} *)
+module Reqd : sig
+  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
+
+  (** Responding
+
+      The following functions will initiate a response for the corresponding
+      request in [t]. Depending on the state of the current connection, and the
+      header values of the response, this may cause the connection to close or
+      to persist for reuse by the client.
+
+      See {{:https://tools.ietf.org/html/rfc7230#section-6.3} RFC7230§6.3} for
+      more details. *)
+
+  val respond_with_string    : t -> Response.t -> string -> unit
+  val respond_with_bigstring : t -> Response.t -> Bstr.t -> unit
+  val respond_with_streaming : ?flush_headers_immediately:bool -> t -> Response.t -> Body.Writer.t
+
+  val respond_with_upgrade : ?reason:string -> t -> Headers.t -> unit
+  (** Initiate an HTTP upgrade. [Server_connection.next_write_request] and
+      [next_read_request] will begin returning [`Upgrade] once the response
+      headers have been written, which indicates that the runtime should take
+      over direct control of the socket rather than shuttling bytes through H1.
+
+      The headers must indicate a valid upgrade message, e.g. must include
+      "Connection: upgrade". See [Request.is_upgrade]. *)
+
+  (** {3 Exception Handling} *)
+
+  val report_exn : t -> exn -> unit
+  val try_with : t -> (unit -> unit) -> (unit, exn) result
+end
+
+(** {2 Buffer Size Configuration} *)
+module Config : sig
+  type t =
+    { read_buffer_size          : int (** Default is [4096] *)
+    ; request_body_buffer_size  : int (** Default is [4096] *)
+    ; response_buffer_size      : int (** Default is [1024] *)
+    ; response_body_buffer_size : int (** Default is [4096] *)
+    }
+
+  val default : t
+  (** [default] is a configuration record with all parameters set to their
+      default values. *)
+end
+
+(** {2 Server Connection} *)
+
+module Server_connection : sig
+  type t
+
+  type error =
+    [ `Bad_request | `Bad_gateway | `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 next_read_operation : t -> [ `Read | `Yield | `Close | `Upgrade ]
+  (** [next_read_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val read : t -> Bstr.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 -> Bstr.t -> off:int -> len:int -> int
+  (** [read_eof 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_eof} 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 yield_reader : t -> (unit -> unit) -> unit
+  (** [yield_reader t continue] registers with the connection to call
+      [continue] when reading should resume. {!yield_reader} should be called
+      after {next_read_operation} returns a [`Yield] value. *)
+
+  val next_write_operation : t -> [
+    | `Write of Bstr.t IOVec.t list
+    | `Yield
+    | `Upgrade
+    | `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.
+
+        {ul
+        {- [`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 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 return [`Write _] until all
+      buffered output has been flushed. *)
+
+  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 | `Exn of exn ]
+
+  type response_handler = Response.t -> Body.Reader.t  -> unit
+
+  type error_handler = error -> unit
+
+  val request
+    :  ?config:Config.t
+    -> Request.t
+    -> error_handler:error_handler
+    -> response_handler:response_handler
+    -> Body.Writer.t * t
+
+  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 -> Bstr.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 -> Bstr.t -> off:int -> len:int -> int
+  (** [read_eof 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_eof} 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 Bstr.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.
+
+        {ul
+        {- [`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 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
+
+  (**/**)
+  val shutdown : t -> unit
+  (**/**)
+end
+
+(**/**)
+
+(** Websocket *)
+module Websocket : sig
+  module Opcode : sig
+    type standard_non_control = [ `Continuation | `Text | `Binary ]
+    type standard_control = [ `Connection_close | `Ping | `Pong ]
+    type standard = [ standard_non_control | standard_control ]
+    type t = [ standard | `Other of int ]
+
+    val code : t -> int
+    val of_code : int -> t option
+    val of_code_exn : int -> t
+    val to_int : t -> int
+    val of_int : int -> t option
+    val of_int_exn : int -> t
+    val pp_hum : Format.formatter -> t -> unit
+  end
+
+  module Close_code : sig
+    type standard =
+      [ `Normal_closure
+      | `Going_away
+      | `Protocol_error
+      | `Unsupported_data
+      | `No_status_rcvd
+      | `Abnormal_closure
+      | `Invalid_frame_payload_data
+      | `Policy_violation
+      | `Message_too_big
+      | `Mandatory_ext
+      | `Internal_server_error
+      | `TLS_handshake ]
+
+    type t = [ standard | `Other of int ]
+
+    val code : t -> int
+    val of_code : int -> t option
+    val of_code_exn : int -> t
+    val to_int : t -> int
+    val of_int : int -> t option
+    val of_int_exn : int -> t
+  end
+
+  module Frame : sig
+    type t
+
+    val is_fin : t -> bool
+    val rsv : t -> int
+    val opcode : t -> Opcode.t
+    val has_mask : t -> bool
+    val mask : t -> int32 option
+    val mask_exn : t -> int32
+    val mask_inplace : t -> unit
+    val unmask_inplace : t -> unit
+    val length : t -> int
+    val payload_length : t -> int
+    val parse : t Angstrom.t
+
+    (* does not allocate a bigstring, but instead returns a
+       new view into the frame payload *)
+    val payload_view : t -> Bstr.t
+
+    val serialize_control :
+      Faraday.t -> mask:int32 option -> opcode:Opcode.standard_control -> unit
+
+    val schedule_serialize :
+      Faraday.t ->
+      mask:int32 option ->
+      is_fin:bool ->
+      opcode:Opcode.t ->
+      payload:Bstr.t ->
+      off:int ->
+      len:int ->
+      unit
+
+    val schedule_serialize_bytes :
+      Faraday.t ->
+      mask:int32 option ->
+      is_fin:bool ->
+      opcode:Opcode.t ->
+      payload:Bytes.t ->
+      off:int ->
+      len:int ->
+      unit
+
+    val serialize_bytes :
+      Faraday.t ->
+      mask:int32 option ->
+      is_fin:bool ->
+      opcode:Opcode.t ->
+      payload:Bytes.t ->
+      off:int ->
+      len:int ->
+      unit
+  end
+
+  type frame_handler =
+    opcode:Opcode.t -> is_fin:bool -> Bstr.t -> off:int -> len:int -> unit
+
+  type input_handlers = { frame_handler : frame_handler; eof : unit -> unit }
+
+  module Wsd : sig
+    type mode = [ `Client of unit -> int32 | `Server ]
+    type t
+
+    val create : mode -> t
+
+    val schedule :
+      t ->
+      kind:Opcode.standard_non_control ->
+      is_fin:bool ->
+      Bstr.t ->
+      off:int ->
+      len:int ->
+      unit
+
+    val send_bytes :
+      t ->
+      kind:Opcode.standard_non_control ->
+      is_fin:bool ->
+      Bytes.t ->
+      off:int ->
+      len:int ->
+      unit
+
+    val send_ping : t -> unit
+    val send_pong : t -> unit
+    val flushed : t -> (unit -> unit) -> unit
+    val close : t -> unit
+    val next : t -> [ `Write of Bstr.t IOVec.t list | `Yield | `Close of int ]
+    val report_result : t -> [ `Ok of int | `Closed ] -> unit
+    val is_closed : t -> bool
+    val when_ready_to_write : t -> (unit -> unit) -> unit
+  end
+
+  module Handshake : sig
+    val get_nonce : Request.t -> string option
+
+    val server_headers : sha1:(string -> string) -> nonce:string -> Headers.t
+  end
+
+  module Client_connection : sig
+    type t
+
+    type error =
+      [ Client_connection.error
+      | `Handshake_failure of Response.t * Body.Reader.t ]
+
+    val create :
+      nonce:string ->
+      host:string ->
+      port:int ->
+      resource:string ->
+      sha1:(string -> string) ->
+      error_handler:(error -> unit) ->
+      websocket_handler:(Wsd.t -> input_handlers) ->
+      t
+
+    val next_read_operation : t -> [ `Read | `Close ]
+
+    val next_write_operation :
+      t -> [ `Write of Bstr.t IOVec.t list | `Yield | `Close of int ]
+
+    val read : t -> Bstr.t -> off:int -> len:int -> int
+    val read_eof : t -> Bstr.t -> off:int -> len:int -> int
+    val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+    val yield_writer : t -> (unit -> unit) -> unit
+    val close : t -> unit
+  end
+
+  module Server_connection : sig
+    type t
+    type error = [ `Exn of exn ]
+
+    val create : websocket_handler:(Wsd.t -> input_handlers) -> t
+    val next_read_operation : t -> [ `Read | `Close ]
+
+    val next_write_operation :
+      t -> [ `Write of Bstr.t IOVec.t list | `Yield | `Close of int ]
+
+    val read : t -> Bstr.t -> off:int -> len:int -> int
+    val read_eof : t -> Bstr.t -> off:int -> len:int -> int
+    val report_write_result : t -> [ `Ok of int | `Closed ] -> unit
+    val yield_writer : t -> (unit -> unit) -> unit
+    val is_closed : t -> bool
+    val close : t -> unit
+  end
+end
+
+(**/**)
+
+module H1_private : sig
+  module Parse : sig
+    val request : Request.t Angstrom.t
+    val response : Response.t Angstrom.t
+  end
+
+  module Serialize : sig
+    val write_request  : Faraday.t -> Request.t  -> unit
+    val write_response : Faraday.t -> Response.t -> unit
+  end
+end

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

@@ -0,0 +1,65 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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'. *)
+
+open Httpun_types
+
+let persistent_connection ?(proxy=false) version headers =
+  let _ = proxy in
+  (* XXX(seliopou): use proxy argument in the case of HTTP/1.0 as per
+     https://tools.ietf.org/html/rfc7230#section-6.3 *)
+  match Headers.get headers "connection" with
+  | Some "close"      -> false
+  | Some "keep-alive" -> Version.(compare version v1_0) >= 0
+  | _                 -> Version.(compare version v1_1) >= 0
+
+let sort_uniq xs =
+  (* Though {!List.sort_uniq} performs a check on the input length and returns
+   * immediately for lists of length less than [2], it still allocates closures
+   * before it does that check! To avoid that just do our own checking here to
+   * avoid the allocations in the common case. *)
+  match xs with
+  | [] | [ _ ] -> xs
+  | _          -> List.sort_uniq String.compare xs
+
+let unique_content_length_values headers =
+  (* XXX(seliopou): perform proper content-length parsing *)
+  sort_uniq (Headers.get_multi headers "content-length")
+
+let content_length_of_string s =
+  try Int64.of_string s with _ -> -1L

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

@@ -0,0 +1,12 @@
+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-h1/lib/optional_thunk.mli

@@ -0,0 +1,10 @@
+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-h1/lib/parse.ml

@@ -0,0 +1,327 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2016 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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.
+  ----------------------------------------------------------------------------*)
+
+include Angstrom
+open Httpun_types
+
+module P = struct
+  let is_space = function ' ' | '\t' -> true | _ -> false
+  let is_cr = function '\r' -> true | _ -> false
+  let is_space_or_colon = function ' ' | '\t' | ':' -> true | _ -> false
+
+  let is_hex = function
+    | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
+    | _ -> false
+
+  let is_digit = function '0' .. '9' -> true | _ -> false
+
+  let is_separator = function
+    | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/' | '['
+    | ']' | '?' | '=' | '{' | '}' | ' ' | '\t' ->
+        true
+    | _ -> false
+
+  let is_token =
+    (* The commented-out ' ' and '\t' are not necessary because of the range at
+     * the top of the match. *)
+    function
+    | '\000' .. '\031'
+    | '\127' | ')' | '(' | '<' | '>' | '@' | ',' | ';' | ':' | '\\' | '"' | '/'
+    | '[' | ']' | '?' | '=' | '{' | '}' (* | ' ' | '\t' *) ->
+        false
+    | _ -> true
+end
+
+let unit = return ()
+let token = take_while1 P.is_token
+let spaces = skip_while P.is_space
+
+let digit =
+  satisfy P.is_digit >>| function
+  | '0' -> 0
+  | '1' -> 1
+  | '2' -> 2
+  | '3' -> 3
+  | '4' -> 4
+  | '5' -> 5
+  | '6' -> 6
+  | '7' -> 7
+  | '8' -> 8
+  | '9' -> 9
+  | _ -> assert false
+
+let eol = string "\r\n" <?> "eol"
+let hex str = try return (Int64.of_string ("0x" ^ str)) with _ -> fail "hex"
+let skip_line = take_till P.is_cr *> eol
+
+let version =
+  string "HTTP/"
+  *> lift2
+       (fun major minor -> { Version.major; minor })
+       (digit <* char '.')
+       digit
+
+let header =
+  (* From RFC7230§3.2.4:
+
+        "No whitespace is allowed between the header field-name and colon.  In
+        the past, differences in the handling of such whitespace have led to
+        security vulnerabilities in request routing and response handling.  A
+        server MUST reject any received request message that contains whitespace
+        between a header field-name and colon with a response code of 400 (Bad
+        Request).  A proxy MUST remove any such whitespace from a response
+        message before forwarding the message downstream."
+
+     This can be detected by checking the message and marks in a parse failure,
+     which should look like this when serialized "... > header > :". *)
+  lift2
+    (fun key value -> (key, value))
+    (take_till P.is_space_or_colon <* char ':' <* spaces)
+    (take_till P.is_cr <* eol >>| String.trim)
+  <?> "header"
+
+let headers =
+  let cons x xs = x :: xs in
+  fix (fun headers ->
+      let _emp = return [] in
+      let _rec = lift2 cons header headers in
+      peek_char_fail >>= function '\r' -> _emp | _ -> _rec)
+  >>| Headers.of_list
+
+let request =
+  let meth = take_till P.is_space >>| Method.of_string in
+  lift4
+    (fun meth target version headers ->
+      Request.create ~version ~headers meth target)
+    (meth <* char ' ')
+    (take_till P.is_space <* char ' ')
+    (version <* eol <* commit)
+    (headers <* eol)
+
+let response =
+  let status =
+    take_while P.is_digit >>= fun str ->
+    if String.length str = 0 then fail "status-code empty"
+    else if String.length str > 3 then
+      fail (Printf.sprintf "status-code too long: %S" str)
+    else return (Status.of_string str)
+  in
+  lift4
+    (fun version status reason headers ->
+      Response.create ~reason ~version ~headers status)
+    (version <* char ' ')
+    (status <* char ' ')
+    (take_till P.is_cr <* eol <* commit)
+    (headers <* eol)
+
+let finish body =
+  Body.Reader.close body;
+  commit
+
+let schedule_size body n =
+  let faraday = Body.Reader.unsafe_faraday body in
+  (* XXX(seliopou): performance regression due to switching to a single output
+   * format in Farady. Once a specialized operation is exposed to avoid the
+   * intemediate copy, this should be back to the original performance. *)
+  (if Faraday.is_closed faraday then advance n
+   else take n >>| fun s -> Faraday.write_string faraday s)
+  *> commit
+
+let body ~encoding body =
+  let rec fixed n ~unexpected =
+    if n = 0L then unit
+    else
+      at_end_of_input >>= function
+      | true -> finish body *> fail unexpected
+      | false ->
+          available >>= fun m ->
+          let m' = Int64.(min (of_int m) n) in
+          let n' = Int64.sub n m' in
+          schedule_size body (Int64.to_int m') >>= fun () ->
+          fixed n' ~unexpected
+  in
+  match encoding with
+  | `Fixed n ->
+      fixed n ~unexpected:"expected more from fixed body" >>= fun () ->
+      finish body
+  | `Chunked ->
+      (* XXX(seliopou): The [eol] in this parser should really parse a collection
+       * of "chunk extensions", as defined in RFC7230§4.1. These do not show up
+       * in the wild very frequently, and the h1 API has no way of exposing
+       * them to the suer, so for now the parser does not attempt to recognize
+       * them. This means that any chunked messages that contain chunk extensions
+       * will fail to parse. *)
+      fix (fun p ->
+          let _hex =
+            take_while1 P.is_hex
+            >>= (fun size -> hex size)
+            (* swallows chunk-ext, if present, and CRLF *)
+            <* eol *> commit
+          in
+          _hex >>= fun size ->
+          if size = 0L then eol >>= fun _eol -> finish body
+          else
+            fixed size ~unexpected:"expected more from body chunk" *> eol *> p)
+  | `Close_delimited ->
+      fix (fun p ->
+          let _rec = (available >>= fun n -> schedule_size body n) *> p in
+          at_end_of_input >>= function true -> finish body | false -> _rec)
+
+module Reader = struct
+  module AU = Angstrom.Unbuffered
+
+  type request_error =
+    [ `Bad_request of Request.t | `Parse of string list * string ]
+
+  type response_error =
+    [ `Invalid_response_body_length of Response.t
+    | `Parse of string list * string ]
+
+  type 'error parse_state =
+    | Done
+    | Fail    of 'error
+    | Partial of (Bstr.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. *)
+    }
+
+  type request = request_error t
+  type response = response_error t
+
+  let create parser =
+    { parser
+    ; parse_state = Done
+    ; closed      = false
+    }
+
+  let ok = return (Ok ())
+
+  let request handler =
+    let parser =
+      request <* commit >>= fun request ->
+      match Request.body_length request with
+      | `Error `Bad_request -> return (Error (`Bad_request request))
+      | `Fixed 0L  ->
+        handler request Body.Reader.empty;
+        ok
+      | `Fixed _ | `Chunked when Request.is_upgrade request ->
+        return (Error (`Bad_request request))
+      | `Fixed _ | `Chunked as encoding ->
+        let request_body = Body.Reader.create Bstr.empty in
+        handler request request_body;
+        body ~encoding request_body *> ok
+    in
+    create parser
+
+  let response ~request_method handler =
+    let parser =
+      response <* commit >>= fun response ->
+      let proxy = false in
+      match Response.body_length ~request_method response with
+      | `Error `Bad_gateway ->
+          assert (not proxy);
+          assert false
+      | `Error `Internal_server_error ->
+          return (Error (`Invalid_response_body_length response))
+      | `Fixed 0L ->
+        handler response Body.Reader.empty;
+        ok
+      | `Fixed _ | `Chunked | `Close_delimited as encoding ->
+        (* We do not trust the length provided in the [`Fixed] case, as the
+           client could DOS easily. *)
+        let response_body = Body.Reader.create Bstr.empty in
+        handler response response_body;
+        body ~encoding response_body *> ok
+    in
+    create parser
+
+  let is_closed t = t.closed
+
+  let transition t state =
+    match state with
+    | AU.Done(consumed, Ok ()) ->
+      t.parse_state <- Done;
+      consumed
+    | AU.Done(consumed, Error error) ->
+      t.parse_state <- Fail error;
+      consumed
+    | AU.Fail(consumed, marks, msg) ->
+      t.parse_state <- Fail (`Parse(marks, msg));
+      consumed
+    | AU.Partial { committed; continue } ->
+        t.parse_state <- Partial continue;
+        committed
+
+  and start t state =
+    match state with
+    | AU.Done _ -> failwith "H1.Parse.unable to start parser"
+    | AU.Fail (0, marks, msg) -> t.parse_state <- Fail (`Parse (marks, msg))
+    | AU.Partial { committed = 0; continue } ->
+        t.parse_state <- Partial continue
+    | _ -> assert false
+
+  let rec read_with_more t bs ~off ~len more =
+    let consumed =
+      match t.parse_state with
+      | Fail _ -> 0
+      | Done   ->
+        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 when consumed = len -> t.closed <- true
+    | Complete | Incomplete -> ());
+    consumed
+
+  let force_close t = t.closed <- true
+
+  let next t =
+    if t.closed
+    then `Close
+    else (
+      match t.parse_state with
+      | Fail err  -> `Error err
+      | Done      -> `Read
+      | Partial _ -> `Read
+    )
+  ;;
+end

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

@@ -0,0 +1,294 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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 Httpun_types
+
+type error =
+  [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
+
+module Response_state = struct
+  type t =
+    | Waiting
+    | Upgrade   of Response.t
+    | Fixed     of Response.t
+    | Streaming of Response.t * Body.Writer.t
+end
+
+module Input_state = struct
+  type t =
+    | Waiting
+    | Ready
+    | Complete
+    | Upgraded
+end
+
+module Output_state = struct
+  type t =
+    | Waiting
+    | Ready
+    | Complete
+    | Upgraded
+end
+
+type error_handler =
+  ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
+
+module Writer = Serialize.Writer
+
+(* XXX(seliopou): The current design assumes that a new [Reqd.t] will be
+ * allocated for each new request/response on a connection. This is wasteful,
+ * as it creates garbage on persistent connections. A better approach would be
+ * to allocate a single [Reqd.t] per connection and reuse it across
+ * request/responses. This would allow a single [Faraday.t] to be allocated for
+ * the body and reused. The [response_state] type could then be inlined into
+ * the [Reqd.t] record, with dummy values occuping the fields for [response].
+ * Something like this:
+ *
+ * {[
+ *   type 'handle t =
+ *     { mutable request        : Request.t
+ *     ; mutable request_body   : Response.Body.Reader.t
+ *     ; mutable response       : Response.t (* Starts off as a dummy value,
+ *                                            * using [(==)] to identify it when
+ *                                            * necessary *)
+ *     ; mutable response_body  : Response.Body.Writer.t
+ *     ; mutable persistent     : bool
+ *     ; mutable response_state : [ `Waiting | `Started | `Streaming ]
+ *     }
+ *  ]}
+ *
+ * *)
+type t = {
+  request : Request.t;
+  request_body : Body.Reader.t;
+  writer : Writer.t;
+  response_body_buffer : Bstr.t;
+  error_handler : error_handler;
+  mutable persistent : bool;
+  mutable response_state : Response_state.t;
+  mutable error_code : [ `Ok | error ];
+}
+
+let create error_handler request request_body writer response_body_buffer =
+  {
+    request;
+    request_body;
+    writer;
+    response_body_buffer;
+    error_handler;
+    persistent = Request.persistent_connection request;
+    response_state = Waiting;
+    error_code = `Ok;
+  }
+
+let request { request; _ } = request
+let request_body { request_body; _ } = request_body
+
+let response { response_state; _ } =
+  match response_state with
+  | Waiting -> None
+  | Streaming (response, _)
+  | Upgrade response
+  | Fixed response -> Some response
+
+let response_exn { response_state; _ } =
+  match response_state with
+  | Waiting -> failwith "H1.Reqd.response_exn: response has not started"
+  | Streaming (response, _)
+  | Upgrade response
+  | Fixed response -> response
+
+let respond_with_string t response str =
+  if t.error_code <> `Ok then
+    failwith
+      "H1.Reqd.respond_with_string: invalid state, currently handling error";
+  match t.response_state with
+  | Waiting ->
+      (* XXX(seliopou): check response body length *)
+      Writer.write_response t.writer response;
+      Writer.write_string t.writer str;
+      if t.persistent then
+        t.persistent <- Response.persistent_connection response;
+      t.response_state <- Fixed response;
+      Writer.wakeup t.writer
+  | Streaming _ ->
+    failwith "H1.Reqd.respond_with_string: response already started"
+  | Upgrade _
+  | Fixed _ ->
+    failwith "H1.Reqd.respond_with_string: response already complete"
+
+let respond_with_bigstring t response (bstr : Bstr.t) =
+  if t.error_code <> `Ok then
+    failwith
+      "H1.Reqd.respond_with_bigstring: invalid state, currently handling error";
+  match t.response_state with
+  | Waiting ->
+      (* XXX(seliopou): check response body length *)
+      Writer.write_response t.writer response;
+      Writer.schedule_bigstring t.writer bstr;
+      if t.persistent then
+        t.persistent <- Response.persistent_connection response;
+      t.response_state <- Fixed response;
+      Writer.wakeup t.writer
+  | Streaming _ ->
+    failwith "H1.Reqd.respond_with_bigstring: response already started"
+  | Upgrade _
+  | Fixed _ ->
+      failwith "H1.Reqd.respond_with_bigstring: response already complete"
+
+let unsafe_respond_with_streaming ~flush_headers_immediately t response =
+  match t.response_state with
+  | Waiting ->
+      let encoding =
+        match Response.body_length ~request_method:t.request.meth response with
+        | (`Fixed _ | `Close_delimited | `Chunked) as encoding -> encoding
+        | `Error (`Bad_gateway | `Internal_server_error) ->
+            failwith
+              "H1.Reqd.respond_with_streaming: invalid response body length"
+      in
+      let response_body =
+        Body.Writer.create t.response_body_buffer t.writer ~encoding
+      in
+      Writer.write_response t.writer response;
+      if t.persistent then
+        t.persistent <- Response.persistent_connection response;
+      t.response_state <- Streaming (response, response_body);
+      if flush_headers_immediately then Writer.wakeup t.writer;
+      response_body
+  | Streaming _ ->
+    failwith "H1.Reqd.respond_with_streaming: response already started"
+  | Upgrade _
+  | Fixed _ ->
+      failwith "H1.Reqd.respond_with_streaming: response already complete"
+
+let respond_with_streaming ?(flush_headers_immediately = false) t response =
+  if t.error_code <> `Ok then
+    failwith
+      "H1.Reqd.respond_with_streaming: invalid state, currently handling error";
+  unsafe_respond_with_streaming ~flush_headers_immediately t response
+
+let respond_with_upgrade ?reason t headers =
+  match t.response_state with
+  | Waiting ->
+    if not (Request.is_upgrade t.request) then
+      failwith "H1.Reqd.respond_with_upgrade: request was not an upgrade request"
+    else (
+      let response = Response.create ?reason ~headers `Switching_protocols in
+      t.response_state <- Upgrade response;
+      (* The parser ensures it only passes empty bodies in the case of an
+         upgrade request *)
+      assert (Body.Reader.is_closed t.request_body);
+      Writer.write_response t.writer response;
+      Writer.wakeup t.writer);
+  | Streaming _ ->
+    failwith "H1.Reqd.respond_with_upgrade: response already started"
+  | Upgrade _
+  | Fixed _ ->
+    failwith "H1.Reqd.respond_with_upgrade: response already complete"
+
+let report_error t error =
+  t.persistent <- false;
+  Body.Reader.close t.request_body;
+  match (t.response_state, t.error_code) with
+  | Waiting, `Ok ->
+      t.error_code <- (error :> [ `Ok | error ]);
+      let status =
+        match (error :> [ error | Status.standard ]) with
+        | `Exn _ -> `Internal_server_error
+        | #Status.standard as status -> status
+      in
+      t.error_handler ~request:t.request error (fun headers ->
+          unsafe_respond_with_streaming ~flush_headers_immediately:true t
+            (Response.create ~headers status))
+  | Waiting, `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 "H1.Reqd.report_exn: NYI"
+  | Streaming (_response, response_body), `Ok -> Body.Writer.close response_body
+  | Streaming (_response, response_body), `Exn _ ->
+    Body.Writer.close response_body;
+    Writer.close_and_drain t.writer
+  | (Fixed _ | Streaming _ | Waiting | Upgrade _) , _ ->
+    (* XXX(seliopou): Once additional logging support is added, log the error
+     * in case it is not spurious. *)
+    ()
+
+let report_exn t exn = report_error t (`Exn exn)
+
+let try_with t f : (unit, exn) result =
+  try
+    f ();
+    Ok ()
+  with exn ->
+    report_exn t exn;
+    Error exn
+
+(* Private API, not exposed to the user through h1.mli *)
+
+let close_request_body { request_body; _ } = Body.Reader.close request_body
+
+let error_code t =
+  match t.error_code with #error as error -> Some error | `Ok -> None
+
+let persistent_connection t = t.persistent
+
+let input_state t : Input_state.t =
+  match t.response_state with
+  | Upgrade _ -> Upgraded
+  | Waiting when Request.is_upgrade t.request -> Waiting
+  | Waiting | Fixed _ | Streaming _ ->
+    if Body.Reader.is_closed t.request_body
+    then Complete
+    else Ready
+;;
+
+let output_state t : Output_state.t =
+  match t.response_state with
+  | Upgrade _ -> Upgraded
+  | Fixed _ -> Complete
+  | Streaming (_, response_body) ->
+      if Body.Writer.has_pending_output response_body then Ready
+      else if Body.Writer.is_closed response_body then Complete
+      else Waiting
+  | Waiting -> Waiting
+
+let flush_request_body t =
+  if Body.Reader.has_pending_output t.request_body then
+    try Body.Reader.execute_read t.request_body with exn -> report_exn t exn
+
+let flush_response_body t =
+  match t.response_state with
+  | Streaming (_, response_body) -> Body.Writer.transfer_to_writer response_body
+  | _ -> ()

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

@@ -0,0 +1,94 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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 Httpun_types
+
+type t =
+  { meth    : Method.t
+  ; target  : string
+  ; version : Version.t
+  ; headers : Headers.t }
+
+let create ?(version=Version.v1_1) ?(headers=Headers.empty) meth target =
+  { meth; target; version; headers }
+
+let bad_request = `Error `Bad_request
+
+module Body_length = struct
+  type t = [
+    | `Fixed of Int64.t
+    | `Chunked
+    | `Error of [`Bad_request]
+  ]
+
+  let pp_hum fmt (len : t) =
+    match len with
+    | `Fixed n -> Format.fprintf fmt "Fixed %Li" n
+    | `Chunked -> Format.pp_print_string fmt "Chunked"
+    | `Error `Bad_request -> Format.pp_print_string fmt "Error: Bad request"
+  ;;
+end
+
+let body_length { headers; _ } : Body_length.t =
+  (* The last entry in transfer-encoding is the correct entry. We only accept
+     chunked transfer-encodings. *)
+  match List.rev (Headers.get_multi headers "transfer-encoding") with
+  | value::_ when Headers.ci_equal value "chunked" -> `Chunked
+  | _    ::_ -> bad_request
+  | [] ->
+    begin match Message.unique_content_length_values headers with
+    | []      -> `Fixed 0L
+    | [ len ] ->
+      let len = Message.content_length_of_string len in
+      if len >= 0L
+      then `Fixed len
+      else bad_request
+    | _       -> bad_request
+    end
+
+let persistent_connection ?proxy { version; headers; _ } =
+  Message.persistent_connection ?proxy version headers
+
+let pp_hum fmt { meth; target; version; headers } =
+  Format.fprintf fmt "((method \"%a\") (target %S) (version \"%a\") (headers %a))"
+    Method.pp_hum meth target Version.pp_hum version Headers.pp_hum headers
+
+let is_upgrade t =
+  match Headers.get t.headers "Connection" with
+  | None -> false
+  | Some v ->
+      let vs = String.split_on_char ',' v in
+      let vs = List.map String.trim vs in
+      let vs = List.map String.lowercase_ascii vs in
+      List.mem "upgrade" vs

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

@@ -0,0 +1,107 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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 Httpun_types
+
+type t =
+  { version : Version.t
+  ; status  : Status.t
+  ; reason  : string
+  ; headers : Headers.t }
+
+let create ?reason ?(version=Version.v1_1) ?(headers=Headers.empty) status =
+  let reason =
+    match reason with
+    | Some reason -> reason
+    | None ->
+      begin match status with
+      | #Status.standard as status -> Status.default_reason_phrase status
+      | `Code _                    -> "Non-standard status code"
+      end
+  in
+  { version; status; reason; headers }
+
+let persistent_connection ?proxy { version; headers; _ } =
+  Message.persistent_connection ?proxy version headers
+
+let proxy_error  = `Error `Bad_gateway
+let server_error = `Error `Internal_server_error
+
+module Body_length = struct
+  type t = [
+    | `Fixed of Int64.t
+    | `Chunked
+    | `Close_delimited
+    | `Error of [ `Bad_gateway | `Internal_server_error ]
+  ]
+
+  let pp_hum fmt (len : t) =
+    match len with
+    | `Fixed n -> Format.fprintf fmt "Fixed %Li" n
+    | `Chunked -> Format.pp_print_string fmt "Chunked"
+    | `Close_delimited -> Format.pp_print_string fmt "Close delimited"
+    | `Error `Bad_gateway -> Format.pp_print_string fmt "Error: Bad gateway"
+    | `Error `Internal_server_error ->
+        Format.pp_print_string fmt "Error: Internal server error"
+  ;;
+end
+
+let body_length ?(proxy=false) ~request_method { status; headers; _ } : Body_length.t =
+  match status, request_method with
+  | _, `HEAD                                   -> `Fixed 0L
+  | (`No_content | `Not_modified), _           -> `Fixed 0L
+  | s, _        when Status.is_informational s -> `Fixed 0L
+  | s, `CONNECT when Status.is_successful s    -> `Close_delimited
+  | _, _                                       ->
+    (* The last entry in transfer-encoding is the correct entry. We only handle
+       chunked transfer-encodings. *)
+    begin match List.rev (Headers.get_multi headers "transfer-encoding") with
+    | value::_ when Headers.ci_equal value "chunked" -> `Chunked
+    | _    ::_ -> `Close_delimited
+    | [] ->
+      begin match Message.unique_content_length_values headers with
+      | []      -> `Close_delimited
+      | [ len ] ->
+        let len = Message.content_length_of_string len in
+        if len >= 0L
+        then `Fixed len
+        else if proxy then proxy_error else server_error
+      | _       ->
+        if proxy then proxy_error else server_error
+      end
+    end
+
+let pp_hum fmt { version; status; reason; headers } =
+  Format.fprintf fmt "((version \"%a\") (status %a) (reason %S) (headers %a))"
+    Version.pp_hum version Status.pp_hum status reason Headers.pp_hum headers

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

@@ -0,0 +1,208 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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
+open Httpun_types
+
+let write_space t   = write_char t ' '
+let write_crlf  t   = write_string t "\r\n"
+
+let write_version t version =
+  write_string t (Version.to_string version)
+
+let write_method t meth =
+  write_string t (Method.to_string meth)
+
+let write_status t status =
+  write_string t (Status.to_string status)
+
+let write_headers t headers =
+  (* XXX(seliopou): escape these thigns *)
+  List.iter (fun (name, value) ->
+    write_string t name;
+    write_string t ": ";
+    write_string t value;
+    write_crlf   t)
+  (Headers.to_list headers);
+  write_crlf t
+
+let write_request t { Request.meth; target; version; headers } =
+  write_method  t meth   ; write_space t;
+  write_string  t target ; write_space t;
+  write_version t version; write_crlf  t;
+  write_headers t headers
+
+let write_response t { Response.version; status; reason; headers } =
+  write_version t version; write_space t;
+  write_status  t status ; write_space t;
+  write_string  t reason ; write_crlf  t;
+  write_headers t headers
+
+let write_chunk_length t len =
+  write_string t (Printf.sprintf "%x" len);
+  write_crlf   t
+
+let write_string_chunk t chunk =
+  write_chunk_length t (String.length chunk);
+  write_string       t chunk;
+  write_crlf         t
+
+let write_bigstring_chunk t chunk =
+  write_chunk_length t (Bstr.length chunk);
+  write_bigstring    t chunk;
+  write_crlf         t
+
+let schedule_bigstring_chunk t chunk =
+  write_chunk_length t (Bstr.length chunk);
+  schedule_bigstring t chunk;
+  write_crlf         t
+
+module Writer = struct
+  type t =
+    { buffer                : Bstr.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
+    (* The callback from the runtime to be invoked when output is ready to be
+     * flushed. *)
+    }
+
+  let create ?(buffer_size=0x800) () =
+    let buffer = Bstr.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 write_request t request =
+    write_request t.encoder request
+
+  let write_response t response =
+    write_response t.encoder response
+
+  let write_string t ?off ?len string =
+    write_string t.encoder ?off ?len string
+
+  let write_bytes t ?off ?len bytes =
+    write_bytes t.encoder ?off ?len bytes
+
+  let write_bigstring t ?off ?len bigstring =
+    write_bigstring t.encoder ?off ?len bigstring
+
+  let schedule_bigstring t ?off ?len bigstring =
+    schedule_bigstring t.encoder ?off ?len bigstring
+
+  let schedule_fixed t iovecs =
+    List.iter (fun { IOVec.buffer; off; len } ->
+      schedule_bigstring t ~off ~len buffer)
+    iovecs
+
+  let schedule_chunk t iovecs =
+    let length = IOVec.lengthv iovecs in
+    write_chunk_length t.encoder length;
+    schedule_fixed t iovecs;
+    write_crlf     t.encoder
+
+  let on_wakeup t k =
+    if Faraday.is_closed t.encoder
+    then failwith "on_wakeup on closed writer"
+    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 =
+    (* This would be better implemented by a function that just takes the
+       encoder out of a yielded state if it's in that state. Requires a change
+       to the faraday library. *)
+    flush t (fun _result -> ())
+
+  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;
+    wakeup t
+
+  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 =
+    assert (Optional_thunk.is_none t.wakeup);
+    match Faraday.operation t.encoder with
+    | `Close         -> `Close (drained_bytes t)
+    | `Yield         -> `Yield
+    | `Writev iovecs -> `Write iovecs
+
+  let has_pending_output t = Faraday.has_pending_output t.encoder
+end

unikernel/duniverse/ocaml-h1/lib/server_connection.ml

@@ -0,0 +1,307 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+
+    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 Httpun_types
+
+module Queue = struct
+  include Queue
+
+  let peek_exn = peek
+  let peek t = if is_empty t then None else Some (peek_exn t)
+end
+
+module Reader = Parse.Reader
+module Writer = Serialize.Writer
+
+type request_handler = Reqd.t -> unit
+
+type error =
+  [ `Bad_gateway | `Bad_request | `Internal_server_error | `Exn of exn ]
+
+type error_handler =
+  ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
+
+type t = {
+  reader : Reader.request;
+  writer : Writer.t;
+  response_body_buffer : Bstr.t;
+  request_handler : request_handler;
+  error_handler : error_handler;
+  request_queue : Reqd.t Queue.t;
+      (* invariant: If [request_queue] is not empty, then the head of the queue
+         has already had [request_handler] called on it. *)
+  mutable is_errored : bool;
+      (* if there is a parse or connection error, we invoke the [error_handler]
+         and set [is_errored] to indicate we should not close the writer yet. *)
+  mutable wakeup_reader : Optional_thunk.t;
+}
+
+let is_closed t = Reader.is_closed t.reader && Writer.is_closed t.writer
+let is_active t = not (Queue.is_empty t.request_queue)
+let current_reqd_exn t = Queue.peek_exn t.request_queue
+
+let yield_reader t k =
+  if is_closed t then failwith "yield_reader on closed conn"
+  else if Optional_thunk.is_some t.wakeup_reader then
+    failwith "yield_reader: only one callback can be registered at a time"
+  else t.wakeup_reader <- Optional_thunk.some k
+
+let wakeup_reader t =
+  let f = t.wakeup_reader in
+  t.wakeup_reader <- Optional_thunk.none;
+  Optional_thunk.call_if_some f
+
+let yield_writer t k =
+  if Writer.is_closed t.writer then k () else Writer.on_wakeup t.writer k
+
+let wakeup_writer t = Writer.wakeup t.writer
+
+let default_error_handler ?request:_ error handle =
+  let message =
+    match error with
+    | `Exn exn -> Printexc.to_string exn
+    | (#Status.client_error | #Status.server_error) as error ->
+        Status.to_string error
+  in
+  let body = handle Headers.empty in
+  Body.Writer.write_string body message;
+  Body.Writer.close body
+
+let create ?(config = Config.default) ?(error_handler = default_error_handler)
+    request_handler =
+  let { Config.response_buffer_size; response_body_buffer_size; _ } = config in
+  let writer = Writer.create ~buffer_size:response_buffer_size () in
+  let request_queue = Queue.create () in
+  let response_body_buffer = Bstr.create response_body_buffer_size in
+  let handler request request_body =
+    let reqd =
+      Reqd.create error_handler request request_body writer response_body_buffer
+    in
+    Queue.push reqd request_queue
+  in
+  {
+    reader = Reader.request handler;
+    writer;
+    response_body_buffer;
+    request_handler;
+    error_handler;
+    request_queue;
+    is_errored = false;
+    wakeup_reader = Optional_thunk.none;
+  }
+
+let shutdown_reader t =
+  if is_active t then Reqd.close_request_body (current_reqd_exn t);
+  Reader.force_close t.reader;
+  wakeup_reader t
+
+let shutdown_writer t =
+  if is_active t then (
+    let reqd = current_reqd_exn t in
+    (* XXX(dpatti): I'm not sure I understand why we close the *request* body
+       here. Maybe we can write a test such that removing this line causes it to
+       fail? *)
+    Reqd.close_request_body reqd;
+    Reqd.flush_response_body reqd);
+  Writer.close t.writer;
+  wakeup_writer t
+
+let error_code t =
+  if is_active t then Reqd.error_code (current_reqd_exn t) else None
+
+let shutdown t =
+  shutdown_reader t;
+  shutdown_writer t
+
+let set_error_and_handle ?request t error =
+  if is_active t then (
+    assert (request = None);
+    let reqd = current_reqd_exn t in
+    Reqd.report_error reqd error)
+  else (
+    t.is_errored <- true;
+    let status =
+      match (error :> [ error | Status.standard ]) with
+      | `Exn _ -> `Internal_server_error
+      | #Status.standard as status -> status
+    in
+    shutdown_reader t;
+    let writer = t.writer in
+    t.error_handler ?request error (fun headers ->
+        let response = Response.create ~headers status in
+        Writer.write_response writer response;
+        let encoding =
+          (* If we haven't parsed the request method, just use GET as a standard
+             placeholder. The method is only used for edge cases, like HEAD or
+             CONNECT. *)
+          let request_method =
+            match request with None -> `GET | Some request -> request.meth
+          in
+          match Response.body_length ~request_method response with
+          | (`Fixed _ | `Close_delimited) as encoding -> encoding
+          | `Chunked ->
+              (* XXX(dpatti): Because we pass the writer's faraday directly to the
+                 new body, we don't write the chunked encoding. A client won't be
+                 able to interpret this. *)
+              `Close_delimited
+          | `Error (`Bad_gateway | `Internal_server_error) ->
+              failwith
+                "H1.Server_connection.error_handler: invalid response body \
+                 length"
+        in
+        Body.Writer.of_faraday (Writer.faraday writer) writer ~encoding
+    )
+  )
+
+let report_exn t exn = set_error_and_handle t (`Exn exn)
+
+let advance_request_queue t =
+  ignore (Queue.take t.request_queue);
+  if not (Queue.is_empty t.request_queue) then
+    t.request_handler (Queue.peek_exn t.request_queue)
+
+let rec _next_read_operation t =
+  if not (is_active t)
+  then (
+    (* If the request queue is empty, there is no connection error, and the
+       reader is closed, then we can assume that no more user code will be able
+       to write. *)
+    if Reader.is_closed t.reader && not t.is_errored then shutdown_writer t;
+    Reader.next t.reader)
+  else
+    let reqd = current_reqd_exn t in
+    match Reqd.input_state reqd with
+    | Waiting  -> _yield_reader t
+    | Ready    -> Reader.next t.reader
+    | Complete -> _final_read_operation_for t reqd
+    | Upgraded -> `Upgrade
+
+and _final_read_operation_for t reqd =
+  if not (Reqd.persistent_connection reqd) then (
+    shutdown_reader t;
+    Reader.next t.reader;
+  ) else (
+    match Reqd.output_state reqd with
+    | Waiting | Ready -> _yield_reader t
+    | Upgraded ->
+      (* If the input state is not [Upgraded], the output state cannot be
+         either. *)
+      assert false
+    | Complete ->
+      advance_request_queue t;
+      _next_read_operation t;
+  )
+
+and _yield_reader t =
+  (* XXX(dpatti): This is a way in which the reader and writer are not
+     parallel -- we tell the writer when it needs to yield but the reader is
+     always asking for more data. This is the only branch in either
+     operation function that does not return `(Reader|Writer).next`, which
+     means there are surprising states you can get into. For example, we ask
+     the runtime to yield but then raise when it tries to because the reader
+     is closed. I think this can be avoided if we allow this module to tell the
+     reader when it should yield/resume, then we'd just do an inlined
+     `Reader.next` call instead. I put this function here to describe why this
+     is subtle. *)
+  if Reader.is_closed t.reader
+  then Reader.next t.reader
+  else `Yield
+;;
+
+let next_read_operation t =
+  match _next_read_operation t with
+  | `Error (`Parse _)             -> set_error_and_handle          t `Bad_request; `Close
+  | `Error (`Bad_request request) -> set_error_and_handle ~request t `Bad_request; `Close
+  | (`Read | `Yield | `Close | `Upgrade) as operation -> operation
+
+let rec read_with_more t bs ~off ~len more =
+  let call_handler = Queue.is_empty t.request_queue in
+  let consumed = Reader.read_with_more t.reader bs ~off ~len more in
+  if is_active t then (
+    let reqd = current_reqd_exn t in
+    if call_handler then t.request_handler reqd;
+    Reqd.flush_request_body reqd);
+  (* Keep consuming input as long as progress is made and data is
+     available, in case multiple requests were received at once. *)
+  if consumed > 0 && consumed < len then
+    let off = off + consumed and len = len - consumed in
+    consumed + read_with_more t bs ~off ~len more
+  else consumed
+
+let read t bs ~off ~len = read_with_more t bs ~off ~len Incomplete
+let read_eof t bs ~off ~len = read_with_more t bs ~off ~len Complete
+
+let rec _next_write_operation t =
+  if not (is_active t)
+  then Writer.next t.writer
+  else (
+    let reqd = current_reqd_exn t in
+    match Reqd.output_state reqd with
+    | Waiting ->
+      (* XXX(dpatti): I don't think we should need to call this, but it is
+         necessary in the case of a streaming, non-chunked body so that you can
+         set the appropriate flag. *)
+      Reqd.flush_response_body reqd;
+      Writer.next t.writer
+    | Ready ->
+      Reqd.flush_response_body reqd;
+      Writer.next t.writer
+    | Complete -> _final_write_operation_for t reqd
+    | Upgraded ->
+      wakeup_reader t;
+      (* Even in the Upgrade case, we're still responsible for writing the
+         response header, so we might have work to do. *)
+      if Writer.has_pending_output t.writer
+      then Writer.next t.writer
+      else `Upgrade)
+
+and _final_write_operation_for t reqd =
+  let next =
+    if not (Reqd.persistent_connection reqd) then (
+      shutdown_writer t;
+      Writer.next t.writer)
+    else
+      match Reqd.input_state reqd with
+      | Waiting -> `Yield
+      | Ready -> Writer.next t.writer;
+      | Upgraded -> `Upgrade
+      | Complete ->
+          advance_request_queue t;
+          _next_write_operation t
+  in
+  wakeup_reader t;
+  next
+
+let next_write_operation t = _next_write_operation t
+let report_write_result t result = Writer.report_result t.writer result

unikernel/duniverse/ocaml-h1/lib/websocket.ml

@@ -0,0 +1,656 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2018 Inhabited Type LLC.
+    Copyright (c) 2025 Robur Cooperative
+    Copyright (c) 2025 Swrup <swrup@protonmail.com>
+
+    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.
+  ----------------------------------------------------------------------------
+
+  Modified by Swrup <swrup@protonmail.com> *)
+
+open Httpun_types
+module H1_client_connection = Client_connection.Oneshot
+
+module Opcode = struct
+  type standard_non_control = [ `Continuation | `Text | `Binary ]
+  type standard_control = [ `Connection_close | `Ping | `Pong ]
+  type standard = [ standard_non_control | standard_control ]
+  type t = [ standard | `Other of int ]
+
+  let code = function
+    | `Continuation -> 0x0
+    | `Text -> 0x1
+    | `Binary -> 0x2
+    | `Connection_close -> 0x8
+    | `Ping -> 0x9
+    | `Pong -> 0xa
+    | `Other code -> code
+
+  let code_table : t array =
+    [|
+      `Continuation;
+      `Text;
+      `Binary;
+      `Other 0x3;
+      `Other 0x4;
+      `Other 0x5;
+      `Other 0x6;
+      `Other 0x7;
+      `Connection_close;
+      `Ping;
+      `Other 0xb;
+      `Other 0xc;
+      `Other 0xd;
+      `Other 0xe;
+      `Other 0xf;
+    |]
+
+  let unsafe_of_code code = Array.unsafe_get code_table code
+
+  let of_code code =
+    if code > 0xf then None else Some (Array.unsafe_get code_table code)
+
+  let of_code_exn code =
+    if code > 0xf then
+      failwith "Opcode.of_code_exn: value can't fit in four bits";
+    Array.unsafe_get code_table code
+
+  let to_int = code
+  let of_int = of_code
+  let of_int_exn = of_code_exn
+
+  let pp_hum fmt = function
+    | `Continuation -> Format.fprintf fmt "`Continuation"
+    | `Text -> Format.fprintf fmt "`Text"
+    | `Binary -> Format.fprintf fmt "`Binary"
+    | `Connection_close -> Format.fprintf fmt "`Connection_close"
+    | `Ping -> Format.fprintf fmt "`Ping"
+    | `Pong -> Format.fprintf fmt "`Pong"
+    | `Other code -> Format.fprintf fmt "`Other %#x" code
+end
+
+module Close_code = struct
+  type standard =
+    [ `Normal_closure
+    | `Going_away
+    | `Protocol_error
+    | `Unsupported_data
+    | `No_status_rcvd
+    | `Abnormal_closure
+    | `Invalid_frame_payload_data
+    | `Policy_violation
+    | `Message_too_big
+    | `Mandatory_ext
+    | `Internal_server_error
+    | `TLS_handshake ]
+
+  type t = [ standard | `Other of int ]
+
+  let code = function
+    | `Normal_closure -> 1000
+    | `Going_away -> 1001
+    | `Protocol_error -> 1002
+    | `Unsupported_data -> 1003
+    | `No_status_rcvd -> 1005
+    | `Abnormal_closure -> 1006
+    | `Invalid_frame_payload_data -> 1007
+    | `Policy_violation -> 1008
+    | `Message_too_big -> 1009
+    | `Mandatory_ext -> 1010
+    | `Internal_server_error -> 1011
+    | `TLS_handshake -> 1015
+    | `Other code -> code
+
+  let code_table : t array =
+    [|
+      `Normal_closure;
+      `Going_away;
+      `Protocol_error;
+      `Unsupported_data;
+      `Other 1004;
+      `No_status_rcvd;
+      `Abnormal_closure;
+      `Invalid_frame_payload_data;
+      `Policy_violation;
+      `Message_too_big;
+      `Mandatory_ext;
+      `Internal_server_error;
+      `Other 1012;
+      `Other 1013;
+      `Other 1014;
+      `TLS_handshake;
+    |]
+
+  let unsafe_of_code code = Array.unsafe_get code_table code
+
+  let of_code code =
+    if code > 0xffff || code < 1000 then None
+    else if code < 1016 then Some (unsafe_of_code (code land 0b1111))
+    else Some (`Other code)
+
+  let of_code_exn code =
+    if code > 0xffff then
+      failwith "Close_code.of_code_exn: value can't fit in two bytes";
+    if code < 1000 then
+      failwith "Close_code.of_code_exn: value in invalid range 0-999";
+    if code < 1016 then unsafe_of_code (code land 0b1111) else `Other code
+
+  let to_int = code
+  let of_int = of_code
+  let of_int_exn = of_code_exn
+end
+
+module Frame = struct
+  type t = Bstr.t
+
+  let is_fin t =
+    let bits = Bstr.unsafe_get t 0 |> Char.code in
+    bits land (1 lsl 7) = 1 lsl 7
+
+  let rsv t =
+    let bits = Bstr.unsafe_get t 0 |> Char.code in
+    (bits lsr 4) land 0b0111
+
+  let opcode t =
+    let bits = Bstr.unsafe_get t 0 |> Char.code in
+    bits land 0b1111 |> Opcode.unsafe_of_code
+
+  let payload_length_of_offset t off =
+    let bits = Bstr.unsafe_get t (off + 1) |> Char.code in
+    let length = bits land 0b01111111 in
+    if length = 126 then Bstr.get_int16_be t (off + 2)
+    else if
+      (* This is technically unsafe, but if somebody's asking us to read 2^63
+       * bytes, then we're already screwd. *)
+      length = 127
+    then Bstr.get_int64_be t (off + 2) |> Int64.to_int
+    else length
+
+  let payload_length t = payload_length_of_offset t 0
+
+  let has_mask t =
+    let bits = Bstr.unsafe_get t 1 |> Char.code in
+    bits land (1 lsl 7) = 1 lsl 7
+
+  let mask t =
+    if not (has_mask t) then None
+    else
+      Some
+        (let bits = Bstr.unsafe_get t 1 |> Char.code in
+         if bits = 254 then Bstr.get_int32_be t 4
+         else if bits = 255 then Bstr.get_int32_be t 10
+         else Bstr.get_int32_be t 2)
+
+  let mask_exn t =
+    let bits = Bstr.unsafe_get t 1 |> Char.code in
+    if bits = 254 then Bstr.get_int32_be t 4
+    else if bits = 255 then Bstr.get_int32_be t 10
+    else if bits >= 127 then Bstr.get_int32_be t 2
+    else failwith "Frame.mask_exn: no mask present"
+
+  let payload_offset_of_bits bits =
+    let initial_offset = 2 in
+    let mask_offset = (bits land (1 lsl 7)) lsr (7 - 2) in
+    let length_offset =
+      let length = bits land 0b01111111 in
+      if length < 126 then 0 else 2 lsl (length land 0b1) lsl 2
+    in
+    initial_offset + mask_offset + length_offset
+
+  let payload_offset t =
+    let bits = Bstr.unsafe_get t 1 |> Char.code in
+    payload_offset_of_bits bits
+
+  let payload_view t =
+    let len = payload_length t in
+    let off = payload_offset t in
+    Bstr.sub t ~off ~len
+
+  let length_of_offset t off =
+    let bits = Bstr.unsafe_get t (off + 1) |> Char.code in
+    let payload_offset = payload_offset_of_bits bits in
+    let payload_length = payload_length_of_offset t off in
+    payload_offset + payload_length
+
+  let length t = length_of_offset t 0
+
+  let apply_mask mask bs ~off ~len =
+    for i = off to off + len - 1 do
+      let j = (i - off) mod 4 in
+      let c = Bstr.unsafe_get bs i |> Char.code in
+      let c =
+        c lxor Int32.(logand (shift_right mask (8 * (3 - j))) 0xffl |> to_int)
+      in
+      Bstr.unsafe_set bs i (Char.unsafe_chr c)
+    done
+
+  let apply_mask_bytes mask bs ~off ~len =
+    for i = off to off + len - 1 do
+      let j = (i - off) mod 4 in
+      let c = Bytes.unsafe_get bs i |> Char.code in
+      let c =
+        c lxor Int32.(logand (shift_right mask (8 * (3 - j))) 0xffl |> to_int)
+      in
+      Bytes.unsafe_set bs i (Char.unsafe_chr c)
+    done
+
+  let unmask_inplace t =
+    if has_mask t then
+      let mask = mask_exn t in
+      let len = payload_length t in
+      let off = payload_offset t in
+      apply_mask mask t ~off ~len
+
+  let mask_inplace = unmask_inplace
+
+  let parse =
+    let open Angstrom in
+    Unsafe.peek 2 (fun bs ~off ~len:_ -> length_of_offset bs off) >>= fun len ->
+    Unsafe.take len Bstr.sub
+
+  let serialize_headers faraday ~mask ~is_fin ~opcode ~payload_length =
+    let opcode = Opcode.to_int opcode in
+    let is_fin = if is_fin then 1 lsl 7 else 0 in
+    let is_mask = match mask with None -> 0 | Some _ -> 1 lsl 7 in
+    Faraday.write_uint8 faraday (is_fin lor opcode);
+    if payload_length <= 125 then
+      Faraday.write_uint8 faraday (is_mask lor payload_length)
+    else if payload_length <= 0xffff then (
+      Faraday.write_uint8 faraday (is_mask lor 126);
+      Faraday.BE.write_uint16 faraday payload_length)
+    else (
+      Faraday.write_uint8 faraday (is_mask lor 127);
+      Faraday.BE.write_uint64 faraday (Int64.of_int payload_length));
+    match mask with
+    | None -> ()
+    | Some mask -> Faraday.BE.write_uint32 faraday mask
+
+  let serialize_control faraday ~mask ~opcode =
+    let opcode = (opcode :> Opcode.t) in
+    serialize_headers faraday ~mask ~is_fin:true ~opcode ~payload_length:0
+
+  let schedule_serialize faraday ~mask ~is_fin ~opcode ~payload ~off ~len =
+    serialize_headers faraday ~mask ~is_fin ~opcode ~payload_length:len;
+    (match mask with
+    | None -> ()
+    | Some mask -> apply_mask mask payload ~off ~len);
+    Faraday.schedule_bigstring faraday payload ~off ~len
+
+  let serialize_bytes faraday ~mask ~is_fin ~opcode ~payload ~off ~len =
+    serialize_headers faraday ~mask ~is_fin ~opcode ~payload_length:len;
+    (match mask with
+    | None -> ()
+    | Some mask -> apply_mask_bytes mask payload ~off ~len);
+    Faraday.write_bytes faraday payload ~off ~len
+
+  let schedule_serialize_bytes faraday ~mask ~is_fin ~opcode ~payload ~off ~len
+      =
+    serialize_headers faraday ~mask ~is_fin ~opcode ~payload_length:len;
+    (match mask with
+    | None -> ()
+    | Some mask -> apply_mask_bytes mask payload ~off ~len);
+    Faraday.write_bytes faraday payload ~off ~len
+end
+
+type frame_handler =
+  opcode:Opcode.t -> is_fin:bool -> Bstr.t -> off:int -> len:int -> unit
+
+type input_handlers = { frame_handler : frame_handler; eof : unit -> unit }
+
+module Wsd = struct
+  type mode = [ `Client of unit -> int32 | `Server ]
+
+  type t = {
+    faraday : Faraday.t;
+    mode : mode;
+    mutable when_ready_to_write : unit -> unit;
+  }
+
+  let default_ready_to_write = Sys.opaque_identity (fun () -> ())
+
+  let create mode =
+    {
+      faraday = Faraday.create 0x1000;
+      mode;
+      when_ready_to_write = default_ready_to_write;
+    }
+
+  let mask t = match t.mode with `Client m -> Some (m ()) | `Server -> None
+
+  let ready_to_write t =
+    let callback = t.when_ready_to_write in
+    t.when_ready_to_write <- default_ready_to_write;
+    callback ()
+
+  let schedule t ~kind ~is_fin payload ~off ~len =
+    let opcode :> Opcode.t = kind in
+    let mask = mask t in
+    Frame.schedule_serialize t.faraday ~mask ~is_fin ~opcode ~payload
+      ~off ~len;
+    ready_to_write t
+
+  let send_bytes t ~kind ~is_fin payload ~off ~len =
+    let opcode :> Opcode.t = kind in
+    let mask = mask t in
+    Frame.schedule_serialize_bytes t.faraday ~mask ~is_fin ~opcode
+      ~payload ~off ~len;
+    ready_to_write t
+
+  let send_ping t =
+    Frame.serialize_control t.faraday ~mask:None ~opcode:`Ping;
+    ready_to_write t
+
+  let send_pong t =
+    Frame.serialize_control t.faraday ~mask:None ~opcode:`Pong;
+    ready_to_write t
+
+  let flushed t f = Faraday.flush t.faraday f
+
+  let close t =
+    Frame.serialize_control t.faraday ~mask:None
+      ~opcode:`Connection_close;
+    Faraday.close t.faraday;
+    ready_to_write t
+
+  let next t =
+    match Faraday.operation t.faraday with
+    | `Close -> `Close 0 (* XXX(andreas): should track unwritten bytes *)
+    | `Yield -> `Yield
+    | `Writev iovecs -> `Write iovecs
+
+  let report_result t result =
+    match result with
+    | `Closed -> close t
+    | `Ok len -> Faraday.shift t.faraday len
+
+  let is_closed t = Faraday.is_closed t.faraday
+
+  let when_ready_to_write t callback =
+    if not (t.when_ready_to_write == default_ready_to_write) then
+      failwith
+        "Wsd.when_ready_to_write: only one callback can be registered at a time"
+    else if is_closed t then callback ()
+    else t.when_ready_to_write <- callback
+end
+
+module Reader = struct
+  module AU = Angstrom.Unbuffered
+
+  type 'error parse_state =
+    | Done
+    | Fail of 'error
+    | Partial of (Bstr.t -> off:int -> len:int -> AU.more -> unit AU.state)
+
+  type 'error t = {
+    parser : unit Angstrom.t;
+    mutable parse_state : 'error parse_state;
+    mutable closed : bool;
+  }
+
+  let create frame_handler =
+    let parser =
+      let open Angstrom in
+      Frame.parse >>| fun frame ->
+      let is_fin = Frame.is_fin frame in
+      let opcode = Frame.opcode frame in
+      Frame.unmask_inplace frame;
+      let off = Frame.payload_offset frame in
+      let len = Frame.payload_length frame in
+      frame_handler ~opcode ~is_fin frame ~off ~len
+    in
+    { parser; parse_state = Done; closed = false }
+
+  let transition t state =
+    match state with
+    | AU.Done (consumed, ()) | AU.Fail ((0 as consumed), _, _) ->
+        t.parse_state <- Done;
+        consumed
+    | AU.Fail (consumed, marks, msg) ->
+        t.parse_state <- Fail (`Parse (marks, msg));
+        consumed
+    | AU.Partial { committed; continue } ->
+        t.parse_state <- Partial continue;
+        committed
+
+  and start t state =
+    match state with
+    | AU.Done _ -> failwith "Websocket.Reader.unable to start parser"
+    | AU.Fail (0, marks, msg) -> t.parse_state <- Fail (`Parse (marks, msg))
+    | AU.Partial { committed = 0; continue } -> t.parse_state <- Partial continue
+    | _ -> assert false
+
+  let next t =
+    match t.parse_state with
+    | Done -> if t.closed then `Close else `Read
+    | Fail _ -> `Close
+    | Partial _ -> `Read
+
+  let rec read_with_more t bs ~off ~len more =
+    let consumed =
+      match t.parse_state with
+      | Fail _ -> 0
+      | Done ->
+          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
+end
+
+module Connection = struct
+  type t = {
+    wsd : Wsd.t;
+    reader : [ `Parse of string list * string ] Reader.t;
+    eof : unit -> unit;
+  }
+
+  let create ~mode ~websocket_handler =
+    let wsd = Wsd.create mode in
+    let { frame_handler; eof } = websocket_handler wsd in
+    { wsd; reader = Reader.create frame_handler; eof }
+
+  let next_read_operation t = Reader.next t.reader
+  let next_write_operation t = Wsd.next t.wsd
+  let read t bs ~off ~len = Reader.read_with_more t.reader bs ~off ~len Incomplete
+
+  let read_eof t bs ~off ~len =
+    let len = Reader.read_with_more t.reader bs ~off ~len Complete in
+    t.eof ();
+    len
+
+  let is_closed t = Wsd.is_closed t.wsd
+  let close t = Wsd.close t.wsd
+
+  let yield_writer t k =
+    if is_closed t then (
+      close t;
+      k ())
+    else Wsd.when_ready_to_write t.wsd k
+
+  let report_write_result t result = Wsd.report_result t.wsd result
+end
+
+module Handshake = struct
+  let compute_accept ~sha1 nonce = sha1 (nonce ^ "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")
+
+  let get_nonce request = Headers.get request.Request.headers "sec-websocket-key"
+
+  let server_headers ~sha1 ~nonce =
+    Headers.of_list
+      [ ("connection", "upgrade"); ("upgrade", "websocket")
+      ; ("sec-websocket-accept", compute_accept ~sha1 nonce ) ]
+
+  let is_valid_accept_headers ~sha1 ~nonce headers =
+    let sec_websocket_accept = Headers.get headers "sec-websocket-accept" in
+    let upgrade = Headers.get headers "upgrade" |> Option.map String.lowercase_ascii in
+    let connection = Headers.get headers "connection" |> Option.map String.lowercase_ascii in
+    (sec_websocket_accept = Some (compute_accept ~sha1 nonce))
+    && (upgrade = Some "websocket")
+    && (connection = Some "upgrade")
+end
+
+module Client_handshake = struct
+  type t = { connection : H1_client_connection.t; body : Body.Writer.t }
+
+  (* assumes [nonce] is base64 encoded *)
+  let create ~nonce ~host ~port ~resource ~error_handler ~response_handler =
+    let headers = Headers.of_list
+      [ ("upgrade", "websocket");
+        ("connection", "upgrade");
+        ("host", String.concat ":" [ host; string_of_int port ]);
+        ("sec-websocket-version", "13");
+        ("sec-websocket-key", nonce); ]
+    in
+    let body, connection =
+       H1_client_connection.request
+        (Request.create ~headers `GET resource)
+        ~error_handler ~response_handler
+    in
+    { connection; body }
+
+  let next_read_operation t =
+     H1_client_connection.next_read_operation t.connection
+
+  let next_write_operation t =
+     H1_client_connection.next_write_operation t.connection
+
+  let read t = H1_client_connection.read t.connection
+
+  let report_write_result t =
+     H1_client_connection.report_write_result t.connection
+
+  let yield_writer t = H1_client_connection.yield_writer t.connection
+  let close t = Body.Writer.close t.body
+
+end
+
+module Client_connection = struct
+  type state =
+    | Uninitialized
+    | Handshake of Client_handshake.t
+    | Websocket of Connection.t
+
+  type t = state ref
+
+  type error =
+    [ H1_client_connection.error
+    | `Handshake_failure of Response.t * Body.Reader.t ]
+
+  let handshake_exn t =
+    match !t with
+    | Handshake handshake -> handshake
+    | Uninitialized | Websocket _ -> assert false
+
+  let create ~nonce ~host ~port ~resource ~sha1 ~error_handler ~websocket_handler
+      =
+    let t = ref Uninitialized in
+    let nonce = Base64.encode_exn nonce in
+    let response_handler response response_body =
+      match response.Response.status with
+      | `Switching_protocols when Handshake.is_valid_accept_headers ~sha1 ~nonce response.headers ->
+          Body.Reader.close response_body;
+          let handshake = handshake_exn t in
+          t :=
+            Websocket
+              (Connection.create
+                 ~mode:(`Client (fun () -> Random.int32 Int32.max_int))
+                 ~websocket_handler);
+          Client_handshake.close handshake
+      | _ -> error_handler (`Handshake_failure (response, response_body))
+    in
+    let handshake =
+      let error_handler = (error_handler :> H1_client_connection.error_handler) in
+      Client_handshake.create ~nonce ~host ~port ~resource ~error_handler
+        ~response_handler
+    in
+    t := Handshake handshake;
+    t
+
+  let next_read_operation t =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.next_read_operation handshake
+    | Websocket websocket -> Connection.next_read_operation websocket
+
+  let read t bs ~off ~len =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.read handshake bs ~off ~len
+    | Websocket websocket -> Connection.read websocket bs ~off ~len
+
+  let read_eof t bs ~off ~len =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.read handshake bs ~off ~len
+    | Websocket websocket -> Connection.read_eof websocket bs ~off ~len
+
+  let next_write_operation t =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.next_write_operation handshake
+    | Websocket websocket -> Connection.next_write_operation websocket
+
+  let report_write_result t result =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.report_write_result handshake result
+    | Websocket websocket -> Connection.report_write_result websocket result
+
+  let yield_writer t f =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.yield_writer handshake f
+    | Websocket websocket -> Connection.yield_writer websocket f
+
+  let close t =
+    match !t with
+    | Uninitialized -> assert false
+    | Handshake handshake -> Client_handshake.close handshake
+    | Websocket websocket -> Connection.close websocket
+end
+
+module Server_connection = struct
+  type t = Connection.t
+  type error = [ `Exn of exn ]
+
+  let create ~websocket_handler =
+    let t = Connection.create ~mode:`Server ~websocket_handler in
+    t
+
+  let next_read_operation = Connection.next_read_operation
+  let next_write_operation = Connection.next_write_operation
+  let read t bs ~off ~len = Connection.read t bs ~off ~len
+  let read_eof t bs ~off ~len = Connection.read_eof t bs ~off ~len
+  let report_write_result t result = Connection.report_write_result t result
+  let yield_writer t f = Connection.yield_writer t f
+  let is_closed t = Connection.is_closed t
+  let close t = Connection.close t
+end