unikernel/duniverse/httpun/lib/body.ml

@@ -0,0 +1,249 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2018 Inhabited Type LLC.
+
+    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 eof_has_been_called    : bool
+    ; mutable on_read                : Bigstringaf.t -> off:int -> len:int -> unit
+    ; when_ready_to_read             : Optional_thunk.t
+    }
+
+  let default_on_eof         = Sys.opaque_identity (fun () -> ())
+  let default_on_read        = Sys.opaque_identity (fun _ ~off:_ ~len:_ -> ())
+
+  let create buffer ~when_ready_to_read =
+    { faraday                = Faraday.of_bigstring buffer
+    ; read_scheduled         = false
+    ; eof_has_been_called    = false
+    ; on_eof                 = default_on_eof
+    ; on_read                = default_on_read
+    ; when_ready_to_read
+    }
+
+  let create_empty () =
+    let t = create Bigstringaf.empty ~when_ready_to_read:Optional_thunk.none in
+    Faraday.close t.faraday;
+    t
+
+  let is_closed t =
+    Faraday.is_closed t.faraday
+
+  let unsafe_faraday t =
+    t.faraday
+
+  let ready_to_read t = Optional_thunk.call_if_some t.when_ready_to_read
+
+  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;
+      if not t.eof_has_been_called then begin
+        t.eof_has_been_called <- true;
+        on_eof ()
+      end
+    (* [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 { 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.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;
+  ready_to_read t
+
+  let close t =
+    Faraday.close t.faraday;
+    execute_read t;
+    ready_to_read t
+  ;;
+
+  let has_pending_output t = Faraday.has_pending_output t.faraday
+
+  let is_read_scheduled t = t.read_scheduled
+end
+
+module Writer = struct
+  type encoding =
+    | Identity
+    | Chunked of { mutable written_final_chunk : bool }
+
+  type t =
+    { faraday             : Faraday.t
+    ; encoding            : encoding
+    ; writer              : Serialize.Writer.t
+    ; mutable buffered_bytes : int
+    }
+
+  let of_faraday faraday ~encoding ~writer =
+    let encoding =
+      match encoding with
+      | `Fixed _ | `Close_delimited -> Identity
+      | `Chunked -> Chunked { written_final_chunk = false }
+    in
+    { faraday
+    ; encoding
+    ; writer
+    ; buffered_bytes = 0
+    }
+
+  let create buffer ~encoding =
+    of_faraday (Faraday.of_bigstring buffer) ~encoding
+
+  let create_empty ~writer =
+    let t =
+      create
+        Bigstringaf.empty
+        ~encoding:(`Fixed 0)
+        ~writer
+    in
+    Faraday.close t.faraday;
+    t
+
+  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:Bigstringaf.t) =
+    if not (Faraday.is_closed t.faraday) then
+      Faraday.schedule_bigstring ?off ?len t.faraday b
+
+  let ready_to_write t = Serialize.Writer.wakeup t.writer
+
+  let flush t kontinue =
+    if Serialize.Writer.is_closed t.writer then
+      kontinue `Closed
+    else begin
+      Faraday.flush_with_reason t.faraday (function
+        | Drain -> kontinue `Closed
+        | Nothing_pending | Shift -> Serialize.Writer.flush t.writer kontinue);
+      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 =
+    Serialize.Writer.unyield t.writer;
+    Faraday.close t.faraday;
+    ready_to_write t;
+  ;;
+
+  let force_close t =
+    begin match t.encoding with
+    | Chunked t -> t.written_final_chunk <- true
+    | Identity -> ()
+    end;
+    close 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 requires_output t =
+    not (is_closed t) || has_pending_output t
+
+  let transfer_to_writer t =
+    let faraday = t.faraday in
+    if Serialize.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);
+    | `Writev iovecs ->
+      begin match IOVec.shiftv iovecs t.buffered_bytes with
+      | []     -> ()
+      | iovecs ->
+        let lengthv  = IOVec.lengthv iovecs in
+        t.buffered_bytes <- t.buffered_bytes + 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 (function
+          | `Closed -> close_and_drain t
+          | `Written ->
+            Faraday.shift faraday lengthv;
+            t.buffered_bytes <- t.buffered_bytes - lengthv)
+      end
+    end
+end

unikernel/duniverse/httpun/lib/client_connection.ml

@@ -0,0 +1,308 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017-2019 Inhabited Type LLC.
+    Copyright (c) 2019 Antonio Nuno Monteiro.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the 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
+
+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 t =
+  { config : Config.t
+  ; reader : Reader.response
+  ; writer : Writer.t
+  ; request_queue : Respd.t Queue.t
+    (* invariant: If [request_queue] is not empty, then the head of the queue
+       has already written the request headers to the wire. *)
+  }
+
+let is_closed t =
+  Reader.is_closed t.reader && Writer.is_closed t.writer
+
+let is_waiting t =
+  not (is_closed t) && Queue.is_empty t.request_queue
+
+let is_active t =
+  not (Queue.is_empty t.request_queue)
+
+let current_respd_exn t =
+  Queue.peek t.request_queue
+
+let yield_reader t k = Reader.on_wakeup t.reader k
+
+let wakeup_reader t = Reader.wakeup t.reader
+
+let yield_writer t k = Writer.on_wakeup t.writer k
+
+let wakeup_writer t = Writer.wakeup t.writer
+
+let create ?(config=Config.default) () =
+  let request_queue = Queue.create () in
+  { config
+  ; reader = Reader.response request_queue
+  ; writer = Writer.create ()
+  ; request_queue
+  }
+
+let create_request_body ~request t =
+  match Request.body_length request with
+  | `Fixed 0L -> Body.Writer.create_empty ~writer:t.writer
+  | `Fixed _ | `Chunked as encoding ->
+    Body.Writer.create
+      (Bigstringaf.create t.config.request_body_buffer_size)
+      ~encoding
+      ~writer:t.writer
+  | `Error `Bad_request ->
+    failwith "httpun.Client_connection.request: invalid body length"
+
+let request t ?(flush_headers_immediately=false) request ~error_handler ~response_handler =
+  let request_body = create_request_body ~request t in
+  let respd =
+    Respd.create error_handler request request_body t.writer response_handler in
+  let handle_now = Queue.is_empty t.request_queue in
+  Queue.push respd t.request_queue;
+  if handle_now then
+    Respd.write_request respd;
+
+  if not flush_headers_immediately
+  then Writer.yield t.writer;
+
+  (* Not handling the request now means it may be pipelined.
+   * `advance_request_queue_if_necessary` will take care of it, but we still
+   * wanna wake up the writer so that the function gets called. *)
+  wakeup_writer t;
+  request_body
+;;
+
+let shutdown_reader t =
+  if is_active t
+  then Respd.close_response_body (current_respd_exn t);
+  Reader.force_close t.reader;
+  wakeup_reader t
+
+let shutdown_writer t =
+  if is_active t
+  then Respd.close_request_body (current_respd_exn t);
+  Writer.close t.writer;
+  wakeup_writer t
+
+let shutdown t =
+  shutdown_reader t;
+  shutdown_writer t
+
+let set_error_and_handle t error =
+  Queue.iter (fun respd ->
+   match Respd.input_state respd with
+   | Wait | Ready ->
+     Respd.report_error respd error
+   | Complete ->
+     match Reader.next t.reader with
+     | `Error _ | `Read ->
+       Respd.report_error respd error
+     | _ ->
+       (* Don't bother reporting errors to responses that have already
+        * completed. *)
+       ())
+  t.request_queue;
+  (* From RFC7230§6.5:
+   *   A client sending a message body SHOULD monitor the network connection
+   *   for an error response while it is transmitting the request.  If the
+   *   client sees a response that indicates the server does not wish to
+   *   receive the message body and is closing the connection, the client
+   *   SHOULD immediately cease transmitting the body and close its side of the
+   *   connection. *)
+  shutdown t;
+;;
+
+let unexpected_eof t =
+  set_error_and_handle t (`Malformed_response "unexpected eof");
+;;
+
+let report_exn t exn =
+  set_error_and_handle t (`Exn exn)
+;;
+
+exception Local
+
+let maybe_pipeline_queued_requests t =
+  (* Don't bother trying to pipeline if there aren't multiple requests in the
+   * queue. *)
+  if Queue.length t.request_queue > 1 then
+    try
+      let _ = Queue.fold (fun prev respd ->
+        begin match prev with
+        | None -> ()
+        | Some prev ->
+          match respd.Respd.state, Respd.output_state prev with
+          | Uninitialized, Complete ->
+            Respd.write_request respd;
+            Respd.flush_request_body respd
+          | _ ->
+            (* bail early. If we can't pipeline this request, we can't write
+             * next ones either. *)
+            raise Local
+        end;
+        Some respd)
+        None
+        t.request_queue
+      in ()
+    with
+    | _ -> ()
+
+let advance_request_queue t =
+  ignore (Queue.take t.request_queue);
+  if not (Queue.is_empty t.request_queue) then begin
+    (* write request to the wire *)
+    let respd = current_respd_exn t in
+    match respd.state with
+    | Uninitialized ->
+      (* Only write request if it hasn't been written to the wire yet (e.g. via
+       * pipelining). *)
+      Respd.write_request respd;
+      wakeup_writer t
+    | _ -> ()
+  end
+
+let rec _next_read_operation t =
+  if not (is_active t) then (
+    if Reader.is_closed t.reader
+    then shutdown t;
+    Reader.next t.reader
+  ) else (
+    let respd = current_respd_exn t in
+    match Respd.input_state respd with
+    | Wait -> `Yield
+    | Ready  -> Reader.next t.reader
+    | Complete -> _final_read_operation_for t respd
+  )
+
+and _final_read_operation_for t respd =
+  let next =
+    if not (Respd.persistent_connection respd) then (
+      shutdown_reader t;
+      Reader.next t.reader;
+    ) else (
+      match Respd.output_state respd with
+      | Waiting | Ready -> `Yield
+      | Complete       ->
+         match Reader.next t.reader with
+         | `Error _ | `Read as operation ->
+           (* Keep reading when in a "partial" state (`Read).
+            * Don't advance the request queue if in an error state. *)
+           operation
+         | _ ->
+           advance_request_queue t;
+           _next_read_operation t;
+    )
+  in
+  wakeup_writer t;
+  next
+;;
+
+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
+  | `Start -> `Read
+  | (`Read | `Yield | `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
+  if is_active t then
+    Respd.flush_response_body (current_respd_exn 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
+  if is_active t
+  then unexpected_eof t;
+  bytes_read
+;;
+
+let rec _next_write_operation t =
+  if not (is_active t) then (
+    if Reader.is_closed t.reader
+    then shutdown t;
+    Writer.next t.writer
+  ) else (
+    let respd = current_respd_exn t in
+    match Respd.output_state respd with
+    | Waiting -> `Yield
+    | Ready ->
+      Respd.flush_request_body respd;
+      Writer.next t.writer
+    | Complete -> _final_write_operation_for t respd
+  )
+
+and _final_write_operation_for t respd =
+  if not (Respd.persistent_connection respd) then (
+    shutdown_writer t;
+    Writer.next t.writer;
+  ) else (
+    (* From RFC7230§6.3.2:
+     *   A client that supports persistent connections MAY "pipeline" its
+     *   requests (i.e., send multiple requests without waiting for each
+     *   response). *)
+    maybe_pipeline_queued_requests t;
+    match Respd.input_state respd with
+    | Wait | Ready ->
+      wakeup_reader t;
+      Writer.next t.writer;
+    | Complete ->
+       match Reader.next t.reader with
+       | `Error _ -> Writer.next t.writer
+       | _ ->
+         advance_request_queue t;
+         wakeup_reader t;
+         _next_write_operation t
+  )
+;;
+
+let next_write_operation t = _next_write_operation t
+
+let report_write_result t result =
+  Writer.report_result t.writer result

unikernel/duniverse/httpun/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/httpun/lib/dune

@@ -0,0 +1,6 @@
+(library
+ (name httpun)
+ (public_name httpun)
+ (libraries
+   angstrom faraday bigstringaf httpun-types)
+ (flags :standard -open Httpun_types))

unikernel/duniverse/httpun/lib/httpun.ml

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

unikernel/duniverse/httpun/lib/httpun.mli

@@ -0,0 +1,462 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+    Copyright (c) 2019 Antonio Nuno Monteiro.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the 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.
+  ----------------------------------------------------------------------------*)
+
+(** httpun is a high-performance, memory-efficient, and scalable HTTP/1.x
+    library for OCaml. It implements the HTTP 1.1 specification with respect to
+    parsing, serialization, and pipelining. *)
+
+(** {2 Basic HTTP Types} *)
+
+module IOVec : module type of Httpun_types.IOVec
+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 : (Bigstringaf.t -> off:int -> len:int -> unit)
+      -> unit
+    (** [schedule_read t ~on_eof ~on_read] will setup [on_read] and [on_eof] as
+        callbacks for when bytes are available in [t] for the application to
+        consume, or when the input channel has been closed and no further bytes
+        will be received by the application.
+
+        Once either of these callbacks have been called, they become inactive.
+        The application is responsible for scheduling subsequent reads, either
+        within the [on_read] callback or by some other mechanism. *)
+
+    val close : t -> unit
+    (** [close t] closes [t], indicating that any subsequent input
+        received should be discarded. *)
+
+    val is_closed : t -> bool
+    (** [is_closed t] is [true] if {!close} has been called on [t] and [false]
+        otherwise. A closed [t] may still have 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 -> Bigstringaf.t -> unit
+    (** [write_bigstring w ?off ?len bs] copies [bs] into an internal buffer. If
+        possible, this write will be combined with previous and/or subsequent
+        writes before transmission. *)
+
+    val schedule_bigstring : t -> ?off:int -> ?len:int -> Bigstringaf.t -> unit
+    (** [schedule_bigstring w ?off ?len bs] schedules [bs] to be transmitted at
+        the next opportunity without performing a copy. [bs] should not be
+        modified until a subsequent call to {!flush} has successfully
+        completed. *)
+
+    val flush : t -> ([ `Written | `Closed ] -> unit) -> unit
+    (** [flush t f] makes all bytes in [t] available for writing to the
+        awaiting output channel. Once those bytes have reached that output
+        channel, [f `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 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]
+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
+
+
+
+(** {2 Request Descriptor} *)
+module Reqd : sig
+  type t
+
+  type error =
+    [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
+
+  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 -> Bigstringaf.t -> unit
+  val respond_with_streaming : ?flush_headers_immediately:bool -> t -> Response.t -> Body.Writer.t
+  val respond_with_upgrade : t -> Headers.t -> (unit -> unit) -> unit
+
+  (** {3 Exception Handling} *)
+
+  val error_code : t -> error option
+  val report_exn : t -> exn -> unit
+  val try_with : t -> (unit -> unit) -> (unit, exn) result
+end
+
+(** {2 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 = Reqd.error
+
+  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 ]
+  (** [next_read_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the
+      connection.  {!read} should be called after {!next_read_operation}
+      returns a [`Read] value and additional input is available for the
+      connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read_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 Bigstringaf.t IOVec.t list
+    | `Yield
+    | `Close of int ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val report_write_result : t -> [`Ok of int | `Closed] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {report_write_result} should be called after a
+      call to {next_write_operation} that returns a [`Write buffer] value.
+
+        {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 create : ?config:Config.t -> unit -> t
+
+  val request
+    :  t
+    -> ?flush_headers_immediately:bool
+    -> Request.t
+    -> error_handler:error_handler
+    -> response_handler:response_handler
+    -> Body.Writer.t
+
+  val next_read_operation : t -> [ `Read | `Yield | `Close ]
+  (** [next_read_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val read : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read t bigstring ~off ~len] reads bytes of input from the provided range
+      of [bigstring] and returns the number of bytes consumed by the
+      connection.  {!read} should be called after {!next_read_operation}
+      returns a [`Read] value and additional input is available for the
+      connection to consume. *)
+
+  val read_eof : t -> Bigstringaf.t -> off:int -> len:int -> int
+  (** [read_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 Bigstringaf.t IOVec.t list
+    | `Yield
+    | `Close of int ]
+  (** [next_write_operation t] returns a value describing the next operation
+      that the caller should conduct on behalf of the connection. *)
+
+  val report_write_result : t -> [`Ok of int | `Closed] -> unit
+  (** [report_write_result t result] reports the result of the latest write
+      attempt to the connection. {report_write_result} should be called after a
+      call to {next_write_operation} that returns a [`Write buffer] value.
+
+        {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_reader : t -> (unit -> unit) -> unit
+
+  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, at which point it will also return
+      `Close. *)
+
+  val shutdown : t -> unit
+  (** [shutdown connection] closes the underlying input and output channels of
+      the connection, rendering it unusable for any further communication. *)
+end
+
+(**/**)
+
+module Httpun_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/httpun/lib/input_state.ml

@@ -0,0 +1,4 @@
+type t =
+ | Ready
+ | Wait
+ | Complete

unikernel/duniverse/httpun/lib/message.ml

@@ -0,0 +1,62 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+
+(* This module contains functionality that applies to both requests and
+   responses, which are collectively referred to in the HTTP 1.1 specifications
+   as 'messages'. *)
+
+let 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/httpun/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/httpun/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/httpun/lib/output_state.ml

@@ -0,0 +1,4 @@
+type t =
+  | Waiting
+  | Ready
+  | Complete

unikernel/duniverse/httpun/lib/parse.ml

@@ -0,0 +1,382 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2016 Inhabited Type LLC.
+
+    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
+
+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)
+  <* commit
+  <?> "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. *)
+  begin if Faraday.is_closed faraday
+  then advance n
+  else take_bigstring n >>| fun s -> Faraday.schedule_bigstring faraday s
+  end *> commit
+
+let body ~encoding body =
+  let rec fixed n ~unexpected =
+    if n = 0L
+    then unit
+    else
+      at_end_of_input
+      >>= function
+        | true -> commit *> 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 httpun 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 (Bigstringaf.t -> off:int -> len:int -> AU.more -> (unit, 'error) result AU.state)
+
+  type 'error t =
+    { parser              : (unit, 'error) result Angstrom.t
+    ; mutable parse_state : 'error parse_state
+      (* The state of the parse for the current request *)
+    ; mutable closed      : bool
+      (* Whether the input source has left the building, indicating that no
+       * further input will be received. *)
+    ; mutable wakeup      : Optional_thunk.t
+    }
+
+  type request  = request_error t
+  type response = response_error t
+
+  let create parser =
+    { parser
+    ; parse_state = Done
+    ; closed      = false
+    ; wakeup      = Optional_thunk.none
+    }
+
+  let ok = return (Ok ())
+
+  let is_closed t =
+    t.closed
+
+  let on_wakeup t k =
+    if is_closed t
+    then failwith "on_wakeup on closed reader"
+    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 request handler =
+    let rec parser t handler =
+      request <* commit >>= fun request ->
+        match Request.body_length request with
+      | `Error `Bad_request -> return (Error (`Bad_request request))
+      | `Fixed 0L  ->
+        handler request (Body.Reader.create_empty ());
+        ok
+      | `Fixed _ | `Chunked as encoding ->
+        let request_body =
+          Body.Reader.create
+            Bigstringaf.empty
+            ~when_ready_to_read:(Optional_thunk.some (fun () -> wakeup (Lazy.force t)))
+        in
+        handler request request_body;
+        body ~encoding request_body *> ok
+    and
+    t = lazy (create (parser t handler))
+    in
+    Lazy.force t
+
+  let response request_queue =
+    let parser t request_queue =
+      response <* commit >>= fun response ->
+      assert (not (Queue.is_empty request_queue));
+      let exception Local of Respd.t in
+      let respd = match
+        (Queue.iter (fun respd ->
+          if respd.Respd.state = Awaiting_response then
+            raise (Local respd)) request_queue)
+        with
+        | exception Local respd -> respd
+        | () -> assert false
+      in
+      let request = Respd.request respd in
+      let proxy = false in
+      match Response.body_length ~request_method:request.meth response with
+      | `Error `Bad_gateway           -> assert (not proxy); assert false
+      | `Error `Internal_server_error -> return (Error (`Invalid_response_body_length response))
+      | `Fixed 0L ->
+        respd.response_handler response (Body.Reader.create_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 Bigstringaf.empty ~when_ready_to_read:(Optional_thunk.some (fun () ->
+            wakeup (Lazy.force t)))
+        in
+        respd.response_handler response response_body;
+        body ~encoding response_body *> ok
+    in
+    let rec t = lazy (create (parser t request_queue)) in
+    Lazy.force t
+  ;;
+
+
+  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 "httpun.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 initial = match t.parse_state with Done -> true | _ -> false in
+    let consumed =
+      match t.parse_state with
+      | Fail _ -> 0
+      (* Don't feed empty input when we're at a request boundary *)
+      | Done when len = 0 -> 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
+    (* Special case where the parser just started and was fed a zero-length
+     * bigstring. Avoid putting them parser in an error state in this scenario.
+     * If we were already in a `Partial` state, return the error. *)
+    if initial && len = 0 then t.parse_state <- Done;
+    match t.parse_state with
+    | Done when consumed < len ->
+      let off = off + consumed
+      and len = len - consumed in
+      consumed + _read_with_more t bs ~off ~len more
+    | _ -> consumed
+  ;;
+
+  let read_with_more t bs ~off ~len more =
+    let consumed = _read_with_more t bs ~off ~len more in
+    (match more with
+     | Complete ->
+       t.closed <- true
+     | Incomplete -> ());
+    consumed
+
+  let force_close t =
+    t.closed <- true;
+  ;;
+
+  let next t =
+    match t.parse_state with
+    | Fail failure -> `Error failure
+    | _ when t.closed -> `Close
+    | Done      -> `Start
+    | Partial _ -> `Read
+  ;;
+end

unikernel/duniverse/httpun/lib/reqd.ml

@@ -0,0 +1,278 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+type error =
+  [ `Bad_request | `Bad_gateway | `Internal_server_error | `Exn of exn ]
+
+type error_handler =
+  ?request:Request.t -> error -> (Headers.t -> Body.Writer.t) -> unit
+
+module Reader = Parse.Reader
+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
+  ; reader                  : Reader.request
+  ; writer                  : Writer.t
+  ; response_body_buffer    : Bigstringaf.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 reader writer response_body_buffer =
+  { request
+  ; request_body
+  ; reader
+  ; 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, _)
+  | Fixed response
+  | Upgrade (response, _) -> Some response
+
+let response_exn { response_state; _ } =
+  match response_state with
+  | Waiting -> failwith "httpun.Reqd.response_exn: response has not started"
+  | Streaming(response, _)
+  | Fixed response
+  | Upgrade (response, _) -> response
+
+let respond_with_string t response str =
+  if t.error_code <> `Ok then
+    failwith "httpun.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 _ | Upgrade _ ->
+    failwith "httpun.Reqd.respond_with_string: response already started"
+  | Fixed _ ->
+    failwith "httpun.Reqd.respond_with_string: response already complete"
+
+let respond_with_bigstring t response (bstr:Bigstringaf.t) =
+  if t.error_code <> `Ok then
+    failwith "httpun.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 _ | Upgrade _ ->
+    failwith "httpun.Reqd.respond_with_bigstring: response already started"
+  | Fixed _ ->
+    failwith "httpun.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 "httpun.Reqd.respond_with_streaming: invalid response body length"
+    in
+    let response_body =
+      Body.Writer.create
+        t.response_body_buffer
+        ~encoding
+        ~writer:t.writer
+    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 _ | Upgrade _ ->
+    failwith "httpun.Reqd.respond_with_streaming: response already started"
+  | Fixed _ ->
+    failwith "httpun.Reqd.respond_with_streaming: response already complete"
+
+let respond_with_streaming ?(flush_headers_immediately=false) t response =
+  if t.error_code <> `Ok then
+    failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
+  unsafe_respond_with_streaming ~flush_headers_immediately t response
+
+let unsafe_respond_with_upgrade t headers upgrade_handler =
+  match t.response_state with
+  | Waiting ->
+    let response = Response.create ~headers `Switching_protocols in
+    Writer.write_response t.writer response;
+    if t.persistent then
+      t.persistent <- Response.persistent_connection response;
+    t.response_state <- Upgrade (response, upgrade_handler);
+    Writer.flush t.writer (fun _reason ->
+      (* TODO(anmonteiro): probably need to check `Closed here? *)
+      upgrade_handler ());
+    Body.Reader.close t.request_body;
+    Writer.wakeup t.writer
+  | Streaming _ | Upgrade _ ->
+    failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already started"
+  | Fixed _ ->
+    failwith "httpun.Reqd.unsafe_respond_with_upgrade: response already complete"
+
+let respond_with_upgrade t response upgrade_handler =
+  if t.error_code <> `Ok then
+    failwith "httpun.Reqd.respond_with_streaming: invalid state, currently handling error";
+  unsafe_respond_with_upgrade t response upgrade_handler
+
+let report_error t error =
+  t.persistent <- false;
+  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 ->
+      let response_body =
+        unsafe_respond_with_streaming
+          t
+          ~flush_headers_immediately:true
+          (Response.create ~headers status)
+      in
+      (* NOTE(anmonteiro): When reporting an error that calls the error
+         handler, we can only deliver an EOF to the request body once the error
+         response has started. Otherwise, the request body `on_eof` handler
+         could erroneously send a successful response instead of letting us
+         handle the error. *)
+      Body.Reader.close t.request_body;
+      response_body)
+  | other ->
+    Body.Reader.close t.request_body;
+    match other with
+    | 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 "httpun.Reqd.report_exn: NYI"
+    | Streaming (_response, response_body), `Ok ->
+      Body.Writer.force_close response_body;
+      Reader.wakeup t.reader;
+    | Streaming (_response, response_body), `Exn _ ->
+      Body.Writer.close response_body;
+      Writer.close_and_drain t.writer;
+      Reader.wakeup t.reader;
+    | (Fixed _ | Streaming _ | Upgrade _ | Waiting) , _ ->
+      (* 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 httpun.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 _ -> Ready
+  | _ ->
+    if Body.Reader.is_closed t.request_body
+    then Complete
+    else if Body.Reader.is_read_scheduled t.request_body
+    then Ready
+    else Wait
+
+let output_state { response_state; writer; _ } =
+  Response_state.output_state response_state ~writer
+
+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 =
+  Response_state.flush_response_body t.response_state

unikernel/duniverse/httpun/lib/request.ml

@@ -0,0 +1,82 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+type t =
+  { meth    : 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

unikernel/duniverse/httpun/lib/respd.ml

@@ -0,0 +1,135 @@
+module Writer = Serialize.Writer
+
+type error =
+  [ `Malformed_response of string
+  | `Invalid_response_body_length of Response.t
+  | `Exn of exn ]
+
+module Request_state = struct
+  type t =
+    | Uninitialized
+    | Awaiting_response
+    | Received_response of Response.t * Body.Reader.t
+    | Upgraded of Response.t
+    | Closed
+end
+
+type t =
+  { request          : Request.t
+  ; request_body     : Body.Writer.t
+  ; response_handler : (Response.t -> Body.Reader.t -> unit)
+  ; error_handler    : (error -> unit)
+  ; mutable error_code : [ `Ok | error ]
+  ; writer : Writer.t
+  ; mutable state : Request_state.t
+  ; mutable persistent : bool
+  }
+
+let create error_handler request request_body writer response_handler =
+  let rec handler response body =
+    let t = Lazy.force t in
+    if t.persistent then
+      t.persistent <- Response.persistent_connection response;
+    let next_state : Request_state.t = match response.status with
+      | `Switching_protocols ->
+        Upgraded response
+      | _ ->
+        Received_response (response, body)
+    in
+    t.state <- next_state;
+    response_handler response body
+  and t =
+    lazy
+    { request
+    ; request_body
+    ; response_handler = handler
+    ; error_handler
+    ; error_code = `Ok
+    ; writer
+    ; state = Uninitialized
+    ; persistent = Request.persistent_connection request
+    }
+  in
+  Lazy.force t
+
+let request { request; _ } = request
+
+let write_request t =
+  Writer.write_request t.writer t.request;
+  t.state <- Awaiting_response
+
+let report_error t error =
+  t.persistent <- false;
+  Body.Writer.force_close t.request_body;
+  match t.state, t.error_code with
+  | (Uninitialized | Awaiting_response | Upgraded _), `Ok ->
+    t.state <- Closed;
+    t.error_code <- (error :> [`Ok | error]);
+    t.error_handler error
+  | Uninitialized, `Exn _ ->
+    (* TODO(anmonteiro): Not entirely sure this is possible in the client. *)
+    assert false
+  | Received_response (_, response_body), `Ok ->
+     t.error_code <- (error :> [`Ok | error]);
+     t.error_handler error;
+     Body.Reader.close response_body;
+  | (Uninitialized | Awaiting_response | Received_response _ | Closed | Upgraded _), _ ->
+    (* XXX(seliopou): Once additional logging support is added, log the error
+     * in case it is not spurious. *)
+    ()
+
+let persistent_connection t =
+  t.persistent
+
+let close_request_body t =
+  Body.Writer.close t.request_body
+
+let close_response_body t =
+  match t.state with
+  | Uninitialized
+  | Awaiting_response
+  | Closed -> ()
+  | Received_response (_, response_body) ->
+    Body.Reader.close response_body
+  | Upgraded _ -> t.state <- Closed
+
+let input_state t : Input_state.t =
+  match t.state with
+  | Uninitialized
+  | Awaiting_response -> Ready
+  | Received_response (_, response_body) ->
+    if Body.Reader.is_closed response_body
+    then Complete
+    else if Body.Reader.is_read_scheduled response_body
+    then Ready
+    else Wait
+    (* Upgraded is "Complete" because the descriptor doesn't wish to receive
+     * any more input. *)
+  | Upgraded _
+  | Closed -> Complete
+
+let output_state { request_body; state; writer; _ } : Output_state.t =
+  match state with
+  | Upgraded _ ->
+    (* XXX(anmonteiro): Connections that have been upgraded "require output"
+     * forever, but outside the HTTP layer, meaning they're permanently
+     * "yielding". For now they need to be explicitly shutdown in order to
+     * transition the response descriptor to the `Closed` state. *)
+    Waiting
+  | state ->
+    if Writer.is_closed writer then Complete
+    else if state = Uninitialized || Body.Writer.requires_output request_body
+    then Ready
+    else Complete
+
+let flush_request_body { request_body; _ } =
+  if Body.Writer.has_pending_output request_body then
+    Body.Writer.transfer_to_writer request_body
+
+let flush_response_body t =
+  match t.state with
+  | Uninitialized | Awaiting_response | Closed | Upgraded _ -> ()
+  | Received_response(_, response_body) ->
+    if Body.Reader.has_pending_output response_body
+    then try Body.Reader.execute_read response_body
+    with exn -> report_error t (`Exn exn)

unikernel/duniverse/httpun/lib/response.ml

@@ -0,0 +1,119 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in the
+       documentation and/or other materials provided with the distribution.
+
+    3. Neither the name of the author nor the names of his contributors
+       may be used to endorse or promote products derived from this software
+       without specific prior written permission.
+
+    THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+    OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+    DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+    ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+    OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+    HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+    STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+  ----------------------------------------------------------------------------*)
+
+type t =
+  { 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                                   ->
+    (* From RFC7230§3.3.2:
+         A server MAY send a Content-Length header field in a response to a
+         HEAD request (Section 4.3.2 of [RFC7231]); a server MUST NOT send
+         Content-Length in such a response unless its field-value equals the
+         decimal number of octets that would have been sent in the payload body
+         of a response if the same request had used the GET method. *)
+    `Fixed 0L
+  | (`No_content | `Not_modified), _           ->
+    (* From RFC7230§3.3.2:
+         A server MAY send a Content-Length header field in a 304 (Not
+         Modified) response to a conditional GET request (Section 4.1 of
+         [RFC7232]); a server MUST NOT send Content-Length in such a response
+         unless its field-value equals the decimal number of octets that would
+         have been sent in the payload body of a 200 (OK) response to the same
+         request. *)
+    `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/httpun/lib/response_state.ml

@@ -0,0 +1,24 @@
+type t =
+  | Waiting
+  | Fixed  of Response.t
+  | Streaming of Response.t * Body.Writer.t
+  | Upgrade of Response.t * (unit -> unit)
+
+let output_state t ~writer : Output_state.t =
+  match t with
+  | Fixed _ -> Complete
+  | Waiting ->
+    if Serialize.Writer.is_closed writer then Complete
+    else Waiting
+  | Streaming(_, response_body) ->
+    if Serialize.Writer.is_closed writer then Complete
+    else if Body.Writer.requires_output response_body
+    then Ready
+    else Complete
+  | Upgrade _ -> Ready
+
+let flush_response_body t =
+  match t with
+  | Streaming (_, response_body) ->
+    Body.Writer.transfer_to_writer response_body
+  | _ -> ()

unikernel/duniverse/httpun/lib/serialize.ml

@@ -0,0 +1,204 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    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
+
+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 (Bigstringaf.length chunk);
+  write_bigstring    t chunk;
+  write_crlf         t
+
+let schedule_bigstring_chunk t chunk =
+  write_chunk_length t (Bigstringaf.length chunk);
+  schedule_bigstring t chunk;
+  write_crlf         t
+
+module Writer = struct
+  type t =
+    { buffer                : Bigstringaf.t
+      (* The buffer that the encoder uses for buffered writes. Managed by the
+       * control module for the encoder. *)
+    ; encoder               : Faraday.t
+      (* The encoder that handles encoding for writes. Uses the [buffer]
+       * referenced above internally. *)
+    ; mutable drained_bytes : int
+      (* The number of bytes that were not written due to the output stream
+       * being closed before all buffered output could be written. Useful for
+       * detecting error cases. *)
+    ; mutable wakeup        : Optional_thunk.t
+      (* The callback from the runtime to be invoked when output is ready to be
+       * flushed. *)
+    }
+
+  let create ?(buffer_size=0x800) () =
+    let buffer = Bigstringaf.create buffer_size in
+    let encoder = Faraday.of_bigstring buffer in
+    { buffer
+    ; encoder
+    ; drained_bytes = 0
+    ; wakeup = Optional_thunk.none
+    }
+
+  let faraday t = t.encoder
+
+  let 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 _reason -> ())
+
+  let yield t =
+    Faraday.yield t.encoder
+
+  let close t =
+    Faraday.close t.encoder
+
+  let close_and_drain t =
+    Faraday.close t.encoder;
+    let drained = Faraday.drain t.encoder in
+    t.drained_bytes <- t.drained_bytes + drained;
+    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
+end

unikernel/duniverse/httpun/lib/server_connection.ml

@@ -0,0 +1,392 @@
+(*----------------------------------------------------------------------------
+    Copyright (c) 2017 Inhabited Type LLC.
+
+    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
+
+
+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 error_code =
+  | No_error
+  | Error of
+    { request: Request.t option
+    ; mutable response_state: Response_state.t
+    }
+
+type t =
+  { reader                 : Reader.request
+  ; writer                 : Writer.t
+  ; response_body_buffer   : Bigstringaf.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 error_code : error_code
+    (* Represents an unrecoverable error that will cause the connection to
+     * shutdown. Holds on to the response body created by the error handler
+     * that might be streaming to the client. *)
+  }
+
+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 t.request_queue
+
+let yield_reader t k =
+  Reader.on_wakeup t.reader k
+
+let wakeup_reader t =
+  if is_active t then begin
+    let reqd = current_reqd_exn t in
+    (* Before going through another read loop, give the body a chance to flush
+       its buffered bytes to the application. This fixes a pathological case
+       where the body could buffer too much without a chance of executing
+       scheduled reads. *)
+    Reqd.flush_request_body reqd;
+  end;
+  Reader.wakeup t.reader
+
+let yield_writer t k =
+ 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 = Bigstringaf.create response_body_buffer_size in
+  let rec reader = lazy (Reader.request handler)
+  and handler request request_body =
+    let reqd =
+      Reqd.create error_handler request request_body (Lazy.force reader) writer response_body_buffer
+    in
+    let call_handler = Queue.is_empty request_queue in
+    Queue.push reqd request_queue;
+    if call_handler
+    then request_handler reqd;
+
+  and t = lazy
+    { reader = Lazy.force reader
+    ; writer
+    ; response_body_buffer
+    ; request_handler = request_handler
+    ; error_handler   = error_handler
+    ; request_queue
+    ; error_code = No_error
+    }
+  in
+  Lazy.force t
+
+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 begin
+    assert (request = None);
+    let reqd = current_reqd_exn t in
+    Reqd.report_error reqd error
+  end else begin
+    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
+    match t.error_code with
+    | No_error ->
+      t.error_code <- Error { request; response_state = Waiting };
+      t.error_handler ?request error (fun headers ->
+          let response = Response.create ~headers status in
+          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.t) -> request.meth
+            in
+            match Response.body_length ~request_method response with
+            | `Fixed _ | `Close_delimited | `Chunked as encoding -> encoding
+            | `Error (`Bad_gateway | `Internal_server_error) ->
+              failwith "httpun.Server_connection.error_handler: invalid response body length"
+          in
+          let response_body =
+            (* The (shared) response body buffer can be used in this case
+             * because in this conditional branch we're not sending a response
+             * (is_active t == false), and are therefore not making use of that
+             * buffer. *)
+
+            Body.Writer.create
+              t.response_body_buffer
+              ~encoding ~writer:t.writer
+          in
+          Writer.write_response writer response;
+          t.error_code <- Error { request; response_state = Streaming(response, response_body) };
+          wakeup_writer t;
+          response_body)
+    | Error _ ->
+      (* When reading, this should be impossible: even if we try to read more,
+       * the parser does not ingest it, and even if someone attempts to feed
+       * more bytes to the parser when we already told them to [`Close], that's
+       * really their own fault.
+       *
+       * We do, however, need to handle this case if any other exception is
+       * reported (we're already handling an error and e.g. the writing channel
+       * is closed). Just shut down the connection in that case.
+       *)
+      Writer.close_and_drain t.writer;
+      shutdown t
+  end
+
+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 t.request_queue);
+;;
+
+let rec _next_read_operation t =
+  if not (is_active t) then (
+    let next = Reader.next t.reader in
+    begin match next with
+    | `Error _ ->
+      (* Don't tear down the whole connection if we saw an unrecoverable
+       * parsing error, as we might be in the process of streaming back the
+       * error response body to the client. *)
+      shutdown_reader t
+    | `Close ->
+      (match t.error_code with
+      | No_error -> shutdown t
+      | Error _ -> ())
+    | _ -> ()
+    end;
+    next
+  ) else (
+    let reqd = current_reqd_exn t in
+    match Reqd.input_state reqd with
+    | Wait ->
+      begin match Reqd.output_state reqd with
+      | Complete ->
+        (* this branch happens if the writer has completed sending the response
+           and there are still bytes remaining to be read in the request body.
+         *)
+        Reader.next t.reader
+      | Waiting | Ready ->
+        (* `Wait` signals that we should add backpressure to the read channel,
+         * meaning the reader should tell the runtime to yield.
+         *
+         * The exception here is if there has been an error in the parser; in
+         * that case, we need to return that exception and signal the runtime to
+         * close. *)
+        begin match Reader.next t.reader with
+        | `Error _ as operation -> operation
+        | _ -> `Yield
+        end
+      end
+    | Ready -> Reader.next t.reader
+    | Complete -> _final_read_operation_for t reqd
+  )
+
+and _final_read_operation_for t reqd =
+  if Reader.is_closed t.reader || not (Reqd.persistent_connection reqd) then (
+    shutdown_reader t;
+    Reader.next t.reader;
+  ) else
+    match Reqd.output_state reqd with
+    | Waiting | Ready -> `Yield
+    | Complete       ->
+      (* The "final read" operation for a request descriptor that is
+       * `Complete` from both input and output perspectives needs to account
+       * for the fact that the reader may not have finished reading the
+       * request body.
+       * It's important that we don't advance the request queue in this case
+       * for persistent connections, or we'd break the invariant that a
+       * non-empty `request_queue` has had the request handler called on its
+       * head element. *)
+       match Reader.next t.reader with
+       | `Error _ as op ->
+         (* Keep reading when in a "partial" state (`Read).
+          * Don't advance the request queue if in an error state. *)
+         op
+       | `Read as op ->
+         (* we just don't advance the request queue in the case of a parser
+           error. *)
+         advance_request_queue t;
+         op
+       | _ ->
+         advance_request_queue t;
+         _next_read_operation t
+
+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
+  | `Start | `Read -> `Read
+  | (`Yield | `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
+  if is_active t
+  then (
+    let reqd = current_reqd_exn t in
+    Reqd.flush_request_body reqd;
+  );
+  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 flush_response_error_body response_state =
+  Response_state.flush_response_body response_state
+
+let rec _next_write_operation t =
+  if not (is_active t) then (
+    match t.error_code with
+    | No_error ->
+      if Reader.is_closed t.reader
+      then shutdown t;
+      Writer.next t.writer
+    | Error { response_state; _ } ->
+      match Response_state.output_state response_state ~writer:t.writer with
+      | Waiting -> `Yield
+      | Ready ->
+        flush_response_error_body response_state;
+        Writer.next t.writer
+      | Complete ->
+        shutdown_writer t;
+        Writer.next t.writer
+  ) else (
+    let reqd = current_reqd_exn t in
+    match Reqd.output_state reqd with
+    | Waiting -> Writer.next t.writer
+    | Ready ->
+      Reqd.flush_response_body reqd;
+      Writer.next t.writer
+    | Complete -> _final_write_operation_for t reqd
+  )
+
+and _final_write_operation_for t reqd =
+  if not (Reqd.persistent_connection reqd) then (
+    shutdown_writer t;
+    wakeup_reader t;
+    Writer.next t.writer;
+  ) else (
+    match Reqd.input_state reqd with
+    | Wait ->
+      wakeup_reader t;
+      Writer.next t.writer
+    | Ready ->
+      (* we can't close the request body here, otherwise the reader loop is
+         going to think that its "input state" is complete, and remove the
+         request descriptor from the request queue, when in fact it needs to
+         read the remainder of the request body. It needs to hang around
+         because there could be a sudden EOF while discarding the request body,
+         which we need to handle. *)
+      wakeup_reader t;
+      Writer.next t.writer
+    | Complete ->
+       match Reader.next t.reader with
+       | `Error _ -> Writer.next t.writer
+       | _ ->
+         advance_request_queue t;
+         wakeup_reader t;
+         _next_write_operation t
+  )
+;;
+
+let next_write_operation t = _next_write_operation t
+
+let report_write_result t result =
+  Writer.report_result t.writer result