unikernel/duniverse/faraday/.github/workflows/test.yml

@@ -0,0 +1,77 @@
+name: build
+
+on:
+  - push
+  - pull_request
+
+jobs:
+  builds:
+    name: Earliest Supported Version
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - ubuntu-latest
+        ocaml-version:
+          - 4.03.0
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v2
+
+      - name: Use OCaml ${{ matrix.ocaml-version }}
+        uses: avsm/setup-ocaml@v1
+        with:
+          ocaml-version: ${{ matrix.ocaml-version }}
+
+      - name: Deps
+        run: |
+          opam pin add -n faraday .
+          opam install --deps-only faraday
+
+      - name: Build
+        run: opam exec -- dune build -p faraday
+
+  tests:
+    name: Tests
+    strategy:
+      fail-fast: false
+      matrix:
+        os:
+          - ubuntu-latest
+        ocaml-version:
+          - 4.08.1
+          - 4.10.2
+          - 4.11.2
+          - 4.12.0
+
+    runs-on: ${{ matrix.os }}
+
+    steps:
+      - name: Checkout code
+        uses: actions/checkout@v2
+
+      - name: Use OCaml ${{ matrix.ocaml-version }}
+        uses: avsm/setup-ocaml@v1
+        with:
+          ocaml-version: ${{ matrix.ocaml-version }}
+
+      - name: Deps
+        run: |
+          opam pin add -n faraday .
+          opam pin add -n faraday-async .
+          opam pin add -n faraday-lwt .
+          opam pin add -n faraday-lwt-unix .
+          opam install -t --deps-only .
+
+      - name: Build
+        run: opam exec -- dune build
+
+      - name: Test
+        run: opam exec -- dune runtest
+
+      - name: Examples
+        run: |
+          opam exec -- make examples

unikernel/duniverse/faraday/.gitignore

@@ -0,0 +1,12 @@
+.*.sw[a-z]
+*~
+_build/
+_tests/
+lib_test/tests_
+setup.log
+setup.data
+*.native
+*.byte
+*.docdir
+*.install
+.merlin

unikernel/duniverse/faraday/LICENSE

@@ -0,0 +1,30 @@
+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.

unikernel/duniverse/faraday/META.faraday.template

@@ -0,0 +1,16 @@
+# JBUILDER_GEN
+
+package "lwt" (
+  description = "Deprecated. Use faraday-lwt directly"
+  requires = "faraday-lwt"
+)
+
+package "lwt-unix" (
+  description = "Deprecated. Use faraday-lwt-unix directly"
+  requires = "faraday-lwt-unix"
+)
+
+package "async" (
+  description = "Deprecated. Use faraday-async directly"
+  requires = "faraday-async"
+)

unikernel/duniverse/faraday/Makefile

@@ -0,0 +1,24 @@
+.PHONY: all build clean test examples
+
+build:
+	dune build @install
+
+all: build
+
+doc:
+	dune build @doc
+
+test:
+	dune runtest
+
+examples:
+	dune build @examples
+
+install:
+	dune install
+
+uninstall:
+	dune uninstall
+
+clean:
+	rm -rf _build *.install

unikernel/duniverse/faraday/README.md

@@ -0,0 +1,97 @@
+# Faraday
+
+Faraday is a library for writing fast and memory-efficient serializers. Its
+core type and related operation gives the user fine-grained control over
+copying and allocation behavior while serializing user-defined types, and
+presents the output in a form that makes it possible to use vectorized write
+operations, such as the [writev][] system call, or any other platform or
+application-specific output APIs.
+
+
+[![Build Status](https://github.com/inhabitedtype/faraday/workflows/build/badge.svg)](https://github.com/inhabitedtype/faraday/actions?query=workflow%3A%22build%22)
+
+[writev]: http://man7.org/linux/man-pages/man2/writev.2.html
+
+## Installation
+
+Install the library and its depenencies via [OPAM][opam]:
+
+[opam]: http://opam.ocaml.org/
+
+```bash
+opam install faraday
+```
+
+## Usage
+
+Like its sister project [Angstrom][], Faraday is written with network protocols
+and serialization formats in mind. As such, its source distribution inclues
+implementations of various RFCs that are illustrative of real-world
+applications of the library. This includes a [JSON serializer][json].
+
+[angstrom]: https://github.com/inhabitedtype/angstrom
+[json]: https://github.com/inhabitedtype/faraday/blob/master/examples/rFC7159.ml
+
+In addition, it's appropriate here to include a serializer for the simple
+arithmetic expression language described in Angstrom's README.
+
+```ocaml
+open Faraday
+
+type 'a binop = [
+  | `Sub of 'a * 'a
+  | `Add of 'a * 'a
+  | `Div of 'a * 'a
+  | `Mul of 'a * 'a
+]
+;;
+
+type t = [ `Num of int | t binop ]
+
+let rec serialize ?(prec=0) t expr =
+  match expr with
+  | `Num n          -> write_string t (Printf.sprintf "%d" n)
+  | #binop as binop ->
+    let prec', op, l, r =
+      match binop with
+      | `Sub(l, r) -> 2, '-', l, r
+      | `Add(l, r) -> 3, '+', l, r
+      | `Div(l, r) -> 4, '/', l, r
+      | `Mul(l, r) -> 5, '*', l, r
+    in
+    if prec' < prec then write_char t '(';
+    serialize t ~prec:prec' l;
+    write_char t op;
+    serialize t ~prec:prec' r;
+    if prec' < prec then write_char t ')'
+
+let to_string expr =
+  let t = create 0x1000 in
+  serialize t expr;
+  serialize_to_string t
+```
+
+## Development
+
+To install development dependencies, pin the package from the root of the
+repository:
+
+```bash
+opam pin add -n faraday .
+opam install --deps-only faraday
+```
+
+After this, you may install a development version of the library using the
+install command as usual.
+
+For building and running the tests during development, you will need to install
+the `alcotest` package:
+
+```bash
+opam install alcotest
+make test
+```
+
+## License
+
+BSD3, see LICENSE file for its text.

unikernel/duniverse/faraday/async/dune

@@ -0,0 +1,5 @@
+(library
+ (name        faraday_async)
+ (public_name faraday-async)
+ (libraries   faraday async core_unix)
+ (flags (:standard -safe-string)))

unikernel/duniverse/faraday/async/faraday_async.ml

@@ -0,0 +1,70 @@
+open Core
+open Async
+
+module Unix = Core_unix
+
+
+let serialize t ~yield ~writev =
+  let shutdown () =
+    Faraday.close t;
+    (* It's necessary to drain the serializer in order to free any buffers that
+     * be queued up. *)
+    ignore (Faraday.drain t)
+  in
+  let rec loop t =
+    match Faraday.operation t with
+    | `Writev iovecs ->
+      writev iovecs
+      >>= (function
+        | `Closed   -> shutdown (); return () (* XXX(seliopou): this should be reported *)
+        | `Ok n     -> Faraday.shift t n; loop t)
+    | `Yield ->
+      yield t >>= fun () -> loop t
+    | `Close -> return ()
+  in
+  try_with
+    ~rest:`Log (* consider [`Raise] instead *)
+    ~run:`Schedule (* consider [`Now] instead *)
+    ~extract_exn:true (fun () -> loop t)
+  >>| function
+    | Result.Ok () -> ()
+    | Result.Error exn ->
+      shutdown ();
+      raise exn
+
+let writev_of_fd fd =
+  let badfd =
+    failwithf "writev_of_fd got bad fd: %s" (Fd.to_string fd)
+  in
+  let finish result =
+    let open Unix.Error in
+    match result with
+    | `Ok n           -> return (`Ok n)
+    | `Already_closed -> return `Closed
+    | `Error (Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _)) ->
+      begin Fd.ready_to fd `Write
+      >>| function
+        | `Bad_fd -> badfd ()
+        | `Closed -> `Closed
+        | `Ready  -> `Ok 0
+      end
+    | `Error (Unix.Unix_error (EBADF, _, _)) ->
+      badfd ()
+    | `Error exn ->
+      Deferred.don't_wait_for (Fd.close fd);
+      raise exn
+  in
+  fun iovecs ->
+    let iovecs = Array.of_list_map iovecs ~f:(fun iovec ->
+      let { Faraday.buffer; off = pos; len } = iovec in
+      Unix.IOVec.of_bigstring ~pos ~len buffer)
+    in
+    if Fd.supports_nonblock fd then
+      finish
+        (Fd.syscall fd ~nonblocking:true
+           (fun file_descr ->
+             Bigstring_unix.writev_assume_fd_is_nonblocking file_descr iovecs))
+    else
+      Fd.syscall_in_thread fd ~name:"writev"
+        (fun file_descr -> Bigstring_unix.writev file_descr iovecs)
+      >>= finish

unikernel/duniverse/faraday/async/faraday_async.mli

@@ -0,0 +1,15 @@
+open! Core
+open Async
+
+open Faraday
+
+
+val serialize
+  :  Faraday.t
+  -> yield  : (t -> unit Deferred.t)
+  -> writev : (bigstring iovec list -> [ `Ok of int | `Closed ] Deferred.t)
+  -> unit Deferred.t
+
+val writev_of_fd
+  :  Fd.t
+  -> bigstring iovec list -> [ `Ok of int | `Closed ] Deferred.t

unikernel/duniverse/faraday/dune-project

@@ -0,0 +1,2 @@
+(lang dune 1.11)
+(name faraday)

unikernel/duniverse/faraday/examples/dune

@@ -0,0 +1,8 @@
+(library
+ (name      RFC7159)
+ (modules   RFC7159)
+ (libraries faraday))
+
+(alias
+ (name examples)
+ (deps RFC7159.cmxa))

unikernel/duniverse/faraday/examples/rFC7159.ml

@@ -0,0 +1,81 @@
+open Faraday
+
+type json =
+  [ `Null
+  | `False
+  | `True
+  | `String of string
+  | `Number of float
+  | `Object of (string * json) list
+  | `Array of json list ]
+
+let to_hex_digit i =
+  Char.unsafe_chr (if i < 10 then i + 48 else i + 87)
+
+let serialize_string t s =
+  (* TODO: Implement proper unicode verification. *)
+  let flush ~off ~len = 
+    if len <> 0 then write_string t ~off ~len s in
+  let rec go ~off ~len = 
+    if String.length s = off + len 
+    then flush ~off ~len
+    else
+      let i = off + len in
+      match String.get s i with
+      | c when c <= '\031' -> (* non-visible characters have to be escaped *)
+        let i = Char.code c in
+        flush ~off ~len;
+        write_string t "\\u00"; 
+        write_char   t (to_hex_digit (i lsr 4));
+        write_char   t (to_hex_digit (i land 0xf));
+        go ~off:(i+1) ~len:0
+      | '"'    -> flush ~off ~len; write_string t "\\"  ; go ~off:(i+1) ~len:0
+      | '/'    -> flush ~off ~len; write_string t "\\/" ; go ~off:(i+1) ~len:0
+      | '\b'   -> flush ~off ~len; write_string t "\\b" ; go ~off:(i+1) ~len:0
+      | '\012' -> flush ~off ~len; write_string t "\\f" ; go ~off:(i+1) ~len:0
+      | '\n'   -> flush ~off ~len; write_string t "\\n" ; go ~off:(i+1) ~len:0
+      | '\r'   -> flush ~off ~len; write_string t "\\r" ; go ~off:(i+1) ~len:0
+      | '\t'   -> flush ~off ~len; write_string t "\\t" ; go ~off:(i+1) ~len:0
+      | '\\'   -> flush ~off ~len; write_string t "\\\\"; go ~off:(i+1) ~len:0
+      | _      -> go ~off ~len:(len + 1)
+  in
+  write_char t '"';
+  go ~off:0 ~len:0;
+  write_char t '"'
+
+let serialize_number t f =
+  let f = string_of_float f in
+  let len = String.length f in
+  let len = if String.get f (len - 1) = '.' then len - 1 else len in
+  write_string t ~len f
+
+let rec serialize_json t json =
+  match json with
+  | `Null      -> write_string t "null"
+  | `True      -> write_string t "true"
+  | `False     -> write_string t "false"
+  | `Number n  -> serialize_number t n
+  | `String s  -> serialize_string t s
+  | `Object [] -> write_string t "{}"
+  | `Object ((k, v)::kvs) ->
+      write_char t '{';
+      serialize_kv t k v;
+      List.iter (fun (k, v) ->
+        write_char t ',';
+        serialize_kv t k v)
+      kvs;
+      write_char t '}';
+  | `Array  [] -> write_string t "[]"
+  | `Array (v::vs) ->
+    write_char t '[';
+    serialize_json t v;
+    List.iter (fun v ->
+      write_char t ',';
+      serialize_json t v)
+    vs;
+    write_char t ']'
+
+and serialize_kv t k v =
+  serialize_string t k;
+  write_char       t ':';
+  serialize_json   t v

unikernel/duniverse/faraday/faraday-async.opam

@@ -0,0 +1,22 @@
+version: "0.8.2"
+opam-version: "2.0"
+maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
+authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
+license: "BSD-3-clause"
+homepage: "https://github.com/inhabitedtype/faraday"
+bug-reports: "https://github.com/inhabitedtype/faraday/issues"
+dev-repo: "git+https://github.com/inhabitedtype/faraday.git"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "1.11"}
+  "faraday" {>= "0.5.0"}
+  "core" {>= "v0.14.0"}
+  "core_unix" {>= "v0.14.0"}
+  "async" {>= "v0.14.0"}
+]
+synopsis: "Async support for Faraday"

unikernel/duniverse/faraday/faraday-lwt-unix.opam

@@ -0,0 +1,21 @@
+version: "0.8.2"
+opam-version: "2.0"
+maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
+authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
+license: "BSD-3-clause"
+homepage: "https://github.com/inhabitedtype/faraday"
+bug-reports: "https://github.com/inhabitedtype/faraday/issues"
+dev-repo: "git+https://github.com/inhabitedtype/faraday.git"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+depends: [
+  "ocaml" {>= "4.03.0"}
+  "dune" {>= "1.11"}
+  "faraday-lwt"
+  "lwt" {>= "2.7.0"}
+  "base-unix"
+]
+synopsis: "Lwt_unix support for Faraday"

unikernel/duniverse/faraday/faraday-lwt.opam

@@ -0,0 +1,20 @@
+version: "0.8.2"
+opam-version: "2.0"
+maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
+authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
+license: "BSD-3-clause"
+homepage: "https://github.com/inhabitedtype/faraday"
+bug-reports: "https://github.com/inhabitedtype/faraday/issues"
+dev-repo: "git+https://github.com/inhabitedtype/faraday.git"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+depends: [
+  "ocaml" {>= "4.03.0"}
+  "dune" {>= "1.11"}
+  "faraday" {>= "0.5.0"}
+  "lwt"
+]
+synopsis: "Lwt support for Faraday"

unikernel/duniverse/faraday/faraday.opam

@@ -0,0 +1,27 @@
+version: "0.8.2"
+opam-version: "2.0"
+maintainer: "Spiros Eliopoulos <spiros@inhabitedtype.com>"
+authors: [ "Spiros Eliopoulos <spiros@inhabitedtype.com>" ]
+license: "BSD-3-clause"
+homepage: "https://github.com/inhabitedtype/faraday"
+bug-reports: "https://github.com/inhabitedtype/faraday/issues"
+dev-repo: "git+https://github.com/inhabitedtype/faraday.git"
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+depends: [
+  "ocaml" {>= "4.03.0"}
+  "dune" {>= "1.11"}
+  "alcotest" {with-test & >= "0.4.1"}
+  "bigstringaf"
+]
+synopsis: "A library for writing fast and memory-efficient serializers"
+description: """
+Faraday is a library for writing fast and memory-efficient serializers. Its
+core type and related operation gives the user fine-grained control over
+copying and allocation behavior while serializing user-defined types, and
+presents the output in a form that makes it possible to use vectorized write
+operations, such as the writev system call, or any other platform or
+application-specific output APIs."""

unikernel/duniverse/faraday/lib/dune

@@ -0,0 +1,5 @@
+(library
+ (name        faraday)
+ (public_name faraday)
+ (libraries   bigstringaf)
+ (flags (:standard -safe-string)))

unikernel/duniverse/faraday/lib/faraday.ml

@@ -0,0 +1,492 @@
+(*----------------------------------------------------------------------------
+    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.
+  ----------------------------------------------------------------------------*)
+
+
+type bigstring = Bigstringaf.t
+
+type 'a iovec =
+  { buffer : 'a
+  ; off    : int
+  ; len    : int }
+
+exception Dequeue_empty
+
+module Deque(T:sig type t val sentinel : t end) : sig
+  type elem = T.t
+
+  type t
+
+  val create : int -> t
+
+  val is_empty : t -> bool
+
+  val enqueue : elem -> t -> unit
+  val dequeue_exn : t -> elem
+  val enqueue_front : elem -> t -> unit
+
+  val map_to_list : t -> f:(elem -> 'b) -> 'b list
+end = struct
+  type elem = T.t
+
+  type t =
+    { mutable elements : elem array
+    ; mutable front    : int
+    ; mutable back     : int }
+
+  let sentinel = T.sentinel
+
+  let create size =
+    { elements = Array.make size sentinel; front = 0; back = 0 }
+
+  let is_empty t =
+    t.front = t.back
+
+  let ensure_space t =
+    if t.back = Array.length t.elements - 1 then begin
+      let len = t.back - t.front in
+      if t.front > 0 then begin
+        (* Shift everything to the front of the array and then clear out
+         * dangling pointers to elements from their previous locations. *)
+        Array.blit t.elements t.front t.elements 0 len;
+        Array.fill t.elements len t.front sentinel
+      end else begin
+        let old  = t.elements in
+        let new_ = Array.(make (2 * length old) sentinel) in
+        Array.blit old t.front new_ 0 len;
+        t.elements <- new_
+      end;
+      t.front <- 0;
+      t.back <- len
+    end
+
+  let enqueue e t =
+    ensure_space t;
+    t.elements.(t.back) <- e;
+    t.back <- t.back + 1
+
+  let dequeue_exn t =
+    if is_empty t then
+      raise_notrace Dequeue_empty
+    else
+      let result = Array.unsafe_get t.elements t.front in
+      Array.unsafe_set t.elements t.front sentinel;
+      t.front <- t.front + 1;
+      result
+
+  let enqueue_front e t =
+    (* This is in general not true for Deque data structures, but the usage
+     * below ensures that there is always space to push an element back on the
+     * front. An [enqueue_front] is always preceded by a [dequeue], with no
+     * intervening operations. *)
+    assert (t.front > 0);
+    t.front <- t.front - 1;
+    t.elements.(t.front) <- e
+
+  let map_to_list t ~f =
+    let result = ref [] in
+    for i = t.back - 1 downto t.front do
+      result := f t.elements.(i) :: !result
+    done;
+    !result
+end
+
+module IOVec = struct
+  let create buffer ~off ~len =
+    { buffer; off; len }
+
+  let length t =
+    t.len
+
+  let shift { buffer; off; len } n =
+    assert (n < len);
+    { buffer; off = off + n; len = len - n }
+
+  let lengthv ts =
+    let rec loop ts acc =
+      match ts with
+      | []        -> acc
+      | iovec::ts -> loop ts (length iovec + acc)
+    in
+    loop ts 0
+end
+
+module Flushed_reason = struct
+  type t = Shift | Drain | Nothing_pending
+end
+
+module Buffers = Deque(struct
+  type t = bigstring iovec
+  let sentinel =
+    let deadbeef = "\222\173\190\239" in
+    let len      = String.length deadbeef in
+    let buffer   = Bigstringaf.create len in
+    String.iteri (Bigstringaf.unsafe_set buffer) deadbeef;
+    { buffer; off = 0; len }
+end)
+module Flushes = Deque(struct
+  type t = int * (Flushed_reason.t -> unit)
+  let sentinel = 0, fun _ -> ()
+end)
+
+type t =
+  { mutable buffer         : bigstring
+  ; mutable scheduled_pos  : int
+  ; mutable write_pos      : int
+  ; scheduled              : Buffers.t
+  ; flushed                : Flushes.t
+  ; mutable bytes_received : int
+  ; mutable bytes_written  : int
+  ; mutable closed         : bool
+  ; mutable yield          : bool
+  }
+
+type operation = [
+  | `Writev of bigstring iovec list
+  | `Yield
+  | `Close
+  ]
+
+let of_bigstring buffer =
+  { buffer
+  ; write_pos       = 0
+  ; scheduled_pos   = 0
+  ; scheduled       = Buffers.create 4
+  ; flushed         = Flushes.create 1
+  ; bytes_received  = 0
+  ; bytes_written   = 0
+  ; closed          = false
+  ; yield           = false }
+
+let create size =
+  of_bigstring (Bigstringaf.create size)
+
+let writable_exn t =
+  if t.closed then
+    failwith "cannot write to closed writer"
+
+let schedule_iovec t ?(off=0) ~len buffer =
+  t.bytes_received <- t.bytes_received + len;
+  Buffers.enqueue (IOVec.create buffer ~off ~len) t.scheduled
+
+let flush_buffer t =
+  let len = t.write_pos - t.scheduled_pos in
+  if len > 0 then begin
+    let off = t.scheduled_pos in
+    schedule_iovec t ~off ~len t.buffer;
+    t.scheduled_pos <- t.write_pos
+  end
+
+let flush_with_reason t f =
+  t.yield <- false;
+  flush_buffer t;
+  if Buffers.is_empty t.scheduled then f Flushed_reason.Nothing_pending
+  else Flushes.enqueue (t.bytes_received, f) t.flushed
+
+let flush t f = flush_with_reason t (fun _ -> f ())
+
+let free_bytes_in_buffer t =
+  let buf_len = Bigstringaf.length t.buffer in
+  buf_len - t.write_pos
+
+let schedule_bigstring t ?(off=0) ?len a =
+  writable_exn t;
+  flush_buffer t;
+  let len =
+    match len with
+    | None     -> Bigstringaf.length a - off
+    | Some len -> len
+  in
+  if len > 0 then schedule_iovec t ~off ~len a
+
+let ensure_space t len =
+  if free_bytes_in_buffer t < len then begin
+    flush_buffer t;
+    t.buffer <- Bigstringaf.create (max (Bigstringaf.length t.buffer) len);
+    t.write_pos <- 0;
+    t.scheduled_pos <- 0
+  end
+
+let write_gen t ~length ~blit ?(off=0) ?len a =
+  writable_exn t;
+  let len =
+    match len with
+    | None     -> length a - off
+    | Some len -> len
+  in
+  ensure_space t len;
+  blit a ~src_off:off t.buffer ~dst_off:t.write_pos ~len;
+  t.write_pos <- t.write_pos + len
+
+let write_string =
+  let length   = String.length in
+  let blit     = Bigstringaf.unsafe_blit_from_string in
+  fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a
+
+let write_bytes =
+  let length = Bytes.length in
+  let blit   = Bigstringaf.unsafe_blit_from_bytes in
+  fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a
+
+let write_bigstring =
+  let length = Bigstringaf.length in
+  let blit   = Bigstringaf.unsafe_blit in
+  fun t ?off ?len a -> write_gen t ~length ~blit ?off ?len a
+
+let write_char t c =
+  writable_exn t;
+  ensure_space t 1;
+  Bigstringaf.unsafe_set t.buffer t.write_pos c;
+  t.write_pos <- t.write_pos + 1
+
+let write_uint8 t b =
+  writable_exn t;
+  ensure_space t 1;
+  Bigstringaf.unsafe_set t.buffer t.write_pos (Char.unsafe_chr b);
+  t.write_pos <- t.write_pos + 1
+
+module BE = struct
+  let write_uint16 t i =
+    writable_exn t;
+    ensure_space t 2;
+    Bigstringaf.unsafe_set_int16_be t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 2
+
+  let write_uint32 t i =
+    writable_exn t;
+    ensure_space t 4;
+    Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 4
+
+  let write_uint48 t i =
+    writable_exn t;
+    ensure_space t 6;
+    Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos
+      Int64.(to_int32 (shift_right_logical i 4));
+    Bigstringaf.unsafe_set_int16_be t.buffer (t.write_pos + 2)
+      Int64.(to_int i);
+    t.write_pos <- t.write_pos + 6
+
+  let write_uint64 t i =
+    writable_exn t;
+    ensure_space t 8;
+    Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 8
+
+  let write_float t f =
+    writable_exn t;
+    ensure_space t 4;
+    Bigstringaf.unsafe_set_int32_be t.buffer t.write_pos (Int32.bits_of_float f);
+    t.write_pos <- t.write_pos + 4
+
+  let write_double t d =
+    writable_exn t;
+    ensure_space t 8;
+    Bigstringaf.unsafe_set_int64_be t.buffer t.write_pos (Int64.bits_of_float d);
+    t.write_pos <- t.write_pos + 8
+end
+
+module LE = struct
+  let write_uint16 t i =
+    writable_exn t;
+    ensure_space t 2;
+    Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 2
+
+  let write_uint32 t i =
+    writable_exn t;
+    ensure_space t 4;
+    Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 4
+
+  let write_uint48 t i =
+    writable_exn t;
+    ensure_space t 6;
+    Bigstringaf.unsafe_set_int16_le t.buffer t.write_pos
+      Int64.(to_int i);
+    Bigstringaf.unsafe_set_int32_le t.buffer (t.write_pos + 2)
+      Int64.(to_int32 (shift_right_logical i 2));
+    t.write_pos <- t.write_pos + 6
+
+  let write_uint64 t i =
+    writable_exn t;
+    ensure_space t 8;
+    Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos i;
+    t.write_pos <- t.write_pos + 8
+
+  let write_float t f =
+    writable_exn t;
+    ensure_space t 4;
+    Bigstringaf.unsafe_set_int32_le t.buffer t.write_pos (Int32.bits_of_float f);
+    t.write_pos <- t.write_pos + 4
+
+  let write_double t d =
+    writable_exn t;
+    ensure_space t 8;
+    Bigstringaf.unsafe_set_int64_le t.buffer t.write_pos (Int64.bits_of_float d);
+    t.write_pos <- t.write_pos + 8
+end
+
+let close t =
+  t.closed <- true;
+  flush_buffer t
+
+let is_closed t =
+  t.closed
+
+let pending_bytes t =
+  (t.write_pos - t.scheduled_pos) + (t.bytes_received - t.bytes_written)
+
+let has_pending_output t =
+  pending_bytes t <> 0
+
+let yield t =
+  t.yield <- true
+
+let rec shift_buffers t written =
+  match Buffers.dequeue_exn t.scheduled with
+  | exception Dequeue_empty ->
+    assert (written = 0);
+    if t.scheduled_pos = t.write_pos then begin
+      t.scheduled_pos <- 0;
+      t.write_pos <- 0
+    end
+  | { len; _ } as iovec ->
+    if len <= written then begin
+      shift_buffers t (written - len)
+    end else
+      Buffers.enqueue_front (IOVec.shift iovec written) t.scheduled
+
+let rec shift_flushes t ~reason =
+  match Flushes.dequeue_exn t.flushed with
+  | exception Dequeue_empty -> ()
+  | (threshold, f) as flush ->
+    (* Edited notes from @dinosaure:
+     *
+     * The quantities [t.bytes_written] and [threshold] are always going to be
+     * positive integers. Therefore, we can treat them as unsinged integers for
+     * the purposes of comparision. Doing so allows us to handle overflows in
+     * either quantity as long as they're both within one overflow of each other.
+     * We can accomplish this by subracting [min_int] from both quantities before
+     * comparision. This shift a quantity that has not overflowed into the
+     * negative integer range while shifting a quantity that has overflow into
+     * the positive integer range.
+     *
+     * This effectively restablishes the relative difference when an overflow
+     * has occurred, and otherwise just compares numbers that haven't
+     * overflowed as similarly, just shifted down a bit.
+     *)
+    if t.bytes_written - min_int >= threshold - min_int
+    then begin f reason; shift_flushes t ~reason end
+    else Flushes.enqueue_front flush t.flushed
+
+let shift_internal t written ~reason =
+  shift_buffers t written;
+  t.bytes_written <- t.bytes_written + written;
+  shift_flushes t ~reason
+;;
+
+let shift t written = shift_internal t written ~reason:Shift
+
+let operation t =
+  if t.closed then begin
+    t.yield <- false
+  end;
+  flush_buffer t;
+  let nothing_to_do = not (has_pending_output t) in
+  if t.closed && nothing_to_do then
+    `Close
+  else if t.yield || nothing_to_do then begin
+    t.yield <- false;
+    `Yield
+  end else begin
+    let iovecs = Buffers.map_to_list t.scheduled ~f:(fun x -> x) in
+    `Writev iovecs
+  end
+
+let rec serialize t writev =
+  match operation t with
+  | `Writev iovecs ->
+    begin match writev iovecs with
+    | `Ok   n -> shift t n; if not (Buffers.is_empty t.scheduled) then yield t
+    | `Closed -> close t
+    end;
+    serialize t writev
+  | (`Close|`Yield) as next -> next
+
+let serialize_to_string t =
+  close t;
+  match operation t with
+  | `Writev iovecs ->
+    let len = IOVec.lengthv iovecs in
+    let bytes = Bytes.create len in
+    let pos = ref 0 in
+    List.iter (function
+      | { buffer; off; len } ->
+        Bigstringaf.unsafe_blit_to_bytes buffer ~src_off:off bytes ~dst_off:!pos ~len;
+        pos := !pos + len)
+    iovecs;
+    shift t len;
+    assert (operation t = `Close);
+    Bytes.unsafe_to_string bytes
+  | `Close -> ""
+  | `Yield -> assert false
+
+let serialize_to_bigstring t =
+  close t;
+  match operation t with
+  | `Writev iovecs ->
+    let len = IOVec.lengthv iovecs in
+    let bs = Bigstringaf.create len in
+    let pos = ref 0 in
+    List.iter (function
+      | { buffer; off; len } ->
+        Bigstringaf.unsafe_blit buffer ~src_off:off bs ~dst_off:!pos ~len;
+        pos := !pos + len)
+    iovecs;
+    shift t len;
+    assert (operation t = `Close);
+    bs
+  | `Close -> Bigstringaf.create 0
+  | `Yield -> assert false
+
+let drain =
+  let rec loop t acc =
+    match operation t with
+    | `Writev iovecs ->
+      let len = IOVec.lengthv iovecs in
+      shift_internal t len ~reason:Drain;
+      loop t (len + acc)
+    | `Close         -> acc
+    | `Yield         -> loop t acc
+  in
+  fun t -> loop t 0

unikernel/duniverse/faraday/lib/faraday.mli

@@ -0,0 +1,324 @@
+(*----------------------------------------------------------------------------
+    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.
+  ----------------------------------------------------------------------------*)
+
+(** Serialization primitives built for speed an memory-efficiency.
+
+
+    Faraday is a library for writing fast and memory-efficient serializers. Its
+    core type and related operation gives the user fine-grained control over
+    copying and allocation behavior while serializing user-defined types, and
+    presents the output in a form that makes it possible to use vectorized
+    write operations, such as the [writev][] system call, or any other platform
+    or application-specific output APIs.
+
+    A Faraday serializer manages an internal buffer and a queue of output
+    buffers. The output bufferes may be a sub range of the serializer's
+    internal buffer or one that is user-provided. Buffered writes such as
+    {!write_string}, {!write_char}, {!write_bigstring}, etc., copy the source
+    bytes into the serializer's internal buffer. Unbuffered writes such as
+    {!schedule_string}, {!schedule_bigstring}, etc., on the other hand perform
+    no copying. Instead, they enqueue the source bytes into the serializer's
+    write queue directly. *)
+
+
+type bigstring =
+  (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
+
+type t
+(** The type of a serializer. *)
+
+
+(** {2 Constructors} *)
+
+val create : int -> t
+(** [create len] creates a serializer with a fixed-length internal buffer of
+    length [len]. See the Buffered writes section for details about what happens
+    when [len] is not large enough to support a write. *)
+
+val of_bigstring : bigstring -> t
+(** [of_bigstring buf] creates a serializer, using [buf] as its internal
+    buffer. The serializer takes ownership of [buf] until the serializer has
+    been closed and flushed of all output. *)
+
+
+(** {2 Buffered Writes}
+
+    A serializer manages an internal buffer for coalescing small writes. The
+    size of this buffer is determined when the serializer is created. If the
+    buffer does not contain sufficient space to service a caller's buffered
+    write, the serializer will allocate a new buffer of the sufficient size and
+    use it for the current and subsequent writes. The old buffer will be
+    garbage collected once all of its contents have been {!flush}ed. *)
+
+val write_string : t -> ?off:int -> ?len:int -> string -> unit
+(** [write_string t ?off ?len str] copies [str] into the serializer's
+    internal buffer. *)
+
+val write_bytes : t -> ?off:int -> ?len:int -> Bytes.t -> unit
+(** [write_bytes t ?off ?len bytes] copies [bytes] into the serializer's
+    internal buffer. It is safe to modify [bytes] after this call returns. *)
+
+val write_bigstring : t -> ?off:int -> ?len:int -> bigstring -> unit
+(** [write_bigstring t ?off ?len bigstring] copies [bigstring] into the
+    serializer's internal buffer. It is safe to modify [bigstring] after this
+    call returns.  *)
+
+val write_gen
+  :  t
+  -> length:('a -> int)
+  -> blit:('a -> src_off:int -> bigstring -> dst_off:int -> len:int -> unit)
+  -> ?off:int
+  -> ?len:int
+  -> 'a -> unit
+(** [write_gen t ~length ~blit ?off ?len x] copies [x] into the serializer's
+    internal buffer using the provided [length] and [blit] operations.
+    See {!Bigstring.blit} for documentation of the arguments. *)
+
+val write_char : t -> char -> unit
+(** [write_char t char] copies [char] into the serializer's internal buffer. *)
+
+val write_uint8 : t -> int -> unit
+(** [write_uint8 t n] copies the lower 8 bits of [n] into the serializer's
+    internal buffer. *)
+
+
+(** Big endian serializers *)
+module BE : sig
+  val write_uint16 : t -> int -> unit
+  (** [write_uint16 t n] copies the lower 16 bits of [n] into the serializer's
+      internal buffer in big-endian byte order. *)
+
+  val write_uint32 : t -> int32 -> unit
+  (** [write_uint32 t n] copies [n] into the serializer's internal buffer in
+      big-endian byte order. *)
+
+  val write_uint48 : t -> int64 -> unit
+  (** [write_uint48 t n] copies the lower 48 bits of [n] into the serializer's
+      internal buffer in big-endian byte order. *)
+
+  val write_uint64 : t -> int64 -> unit
+  (** [write_uint64 t n] copies [n] into the serializer's internal buffer in
+      big-endian byte order. *)
+
+  val write_float : t -> float -> unit
+  (** [write_float t n] copies the lower 32 bits of [n] into the serializer's
+      internal buffer in big-endian byte order. *)
+
+  val write_double : t -> float -> unit
+  (** [write_double t n] copies [n] into the serializer's internal buffer in
+      big-endian byte order. *)
+end
+
+
+(** Little endian serializers *)
+module LE : sig
+  val write_uint16 : t -> int -> unit
+  (** [write_uint16 t n] copies the lower 16 bits of [n] into the
+      serializer's internal buffer in little-endian byte order. *)
+
+  val write_uint32 : t -> int32 -> unit
+  (** [write_uint32 t n] copies [n] into the serializer's internal buffer in
+      little-endian byte order. *)
+
+  val write_uint48 : t -> int64 -> unit
+  (** [write_uint48 t n] copies the lower 48 bits of [n] into the serializer's
+      internal buffer in little-endian byte order. *)
+
+  val write_uint64 : t -> int64 -> unit
+  (** [write_uint64 t n] copies [n] into the serializer's internal buffer in
+      little-endian byte order. *)
+
+  val write_float : t -> float -> unit
+  (** [write_float t n] copies the lower 32 bits of [n] into the serializer's
+      internal buffer in little-endian byte order. *)
+
+  val write_double : t -> float -> unit
+  (** [write_double t n] copies [n] into the serializer's internal buffer in
+      little-endian byte order. *)
+end
+
+
+(** {2 Unbuffered Writes}
+
+    Unbuffered writes do not involve copying bytes to the serializers internal
+    buffer. *)
+
+val schedule_bigstring : t -> ?off:int -> ?len:int -> bigstring -> unit
+(** [schedule_bigstring t ?off ?len bigstring] schedules [bigstring] to
+    be written the next time the serializer surfaces writes to the user.
+    [bigstring] is not copied in this process, so [bigstring] should only be
+    modified after [t] has been {!flush}ed. *)
+
+
+(** {2 Querying A Serializer's State} *)
+
+val free_bytes_in_buffer : t -> int
+(** [free_bytes_in_buffer t] returns the free space, in bytes, of the
+    serializer's write buffer. If a [write_*] call has a length that exceeds
+    this value, the serializer will allocate a new buffer that will replace the
+    serializer's internal buffer for that and subsequent calls. *)
+
+val has_pending_output : t -> bool
+(** [has_pending_output t] is [true] if [t]'s output queue is non-empty. It may
+    be the case that [t]'s queued output is being serviced by some other thread
+    of control, but has not yet completed. *)
+
+val pending_bytes : t -> int
+(** [pending_bytes t] is the size of the next write, in bytes, that [t] will
+    surface to the caller as a [`Writev]. *)
+
+
+(** {2 Control Operations} *)
+
+val yield : t -> unit
+(** [yield t] causes [t] to delay surfacing writes to the user, instead
+    returning a [`Yield]. This gives the serializer an opportunity to collect
+    additional writes before sending them to the underlying device, which will
+    increase the write batch size.
+
+    As one example, code may want to call this function if it's about to
+    release the OCaml lock and perform a blocking system call, but would like
+    to batch output across that system call. To hint to the thread of control
+    that is performing the writes on behalf of the serializer, the code might
+    call [yield t] before releasing the lock. *)
+
+val flush : t -> (unit -> unit) -> unit
+(** [flush t f] registers [f] to be called when all prior writes have been
+    successfully completed. If [t] has no pending writes, then [f] will be
+    called immediately. If {!yield} was recently called on [t], then the effect
+    of the [yield] will be ignored so that client code has an opportunity to
+    write pending output, regardless of how it handles [`Yield] operations.  *)
+
+module Flushed_reason : sig
+  (** Indicates why a flush callback was called. *)
+  type t =
+    | Shift
+    (** [shift t] was called, normally indicating that bytes were written successfully. *)
+    | Drain
+    (** [drain t] was called, normally indicating that the downstream consumer of [t]'s
+        bytes stopped accepting new input. *)
+    | Nothing_pending
+    (** Passed to [f] when [flush_with_reason t f] is called when there is not any pending
+        output, so [t] is considered immediately flushed. *)
+end
+
+val flush_with_reason : t -> (Flushed_reason.t -> unit) -> unit
+(** [flush_with_reason t f] is like [flush t f], but [f] is suppplied with the reason that
+    the callback was triggered. *)
+
+val close : t -> unit
+(** [close t] closes [t]. All subsequent write calls will raise, and any
+    pending or subsequent {!yield} calls will be ignored. If the serializer has
+    any pending writes, user code will have an opportunity to service them
+    before it receives the [Close] operation. Flush callbacks will continue to
+    be invoked while output is {!shift}ed out of [t] as needed. *)
+
+val is_closed : t -> bool
+(** [is_closed t] is [true] if [close] has been called on [t] and [false]
+    otherwise. A closed [t] may still have pending output. *)
+
+val shift : t -> int -> unit
+(** [shift t n] removes the first [n] bytes in [t]'s write queue. Any flush
+    callbacks registered with [t] within this span of the write queue will be
+    called. *)
+
+val drain : t -> int
+(** [drain t] removes all pending writes from [t], returning the number of
+    bytes that were enqueued to be written and freeing any scheduled
+    buffers in the process. *)
+
+
+(** {2 Running}
+
+    Low-level operations for runing a serializer. For production use-cases,
+    consider the Async and Lwt support that this library includes before
+    attempting to use this these operations directly.  *)
+
+type 'a iovec =
+  { buffer : 'a
+  ; off    : int
+  ; len    : int }
+(** A view into {!iovec.buffer} starting at {!iovec.off} and with length
+    {!iovec.len}. *)
+
+type operation = [
+  | `Writev of bigstring iovec list
+  | `Yield
+  | `Close ]
+(** The type of operations that the serialier may wish to perform.
+  {ul
+
+  {li [`Writev iovecs]: Write the bytes in {!iovecs}s reporting the actual
+  number of bytes written by calling {!shift}. You must accurately report the
+  number of bytes written. Failure to do so will result in the same bytes being
+  surfaced in a [`Writev] operation multiple times.}
+
+  {li [`Yield]: Yield to other threads of control, waiting for additional
+  output before procedding. The method for achieving this is
+  application-specific, but once complete, the caller can proceed with
+  serialization by simply making another call to {!val:operation} or
+  {!serialize}.}
+
+  {li [`Close]: Serialization is complete. No further output will generated.
+  The action to take as a result, if any, is application-specific.}} *)
+
+
+val operation : t -> operation
+(** [operation t] is the next operation that the caller must perform on behalf
+    of the serializer [t]. Users should consider using {!serialize} before this
+    function. See the documentation for the {!type:operation} type for details
+    on how callers should handle these operations. *)
+
+val serialize : t -> (bigstring iovec list -> [`Ok of int | `Closed]) -> [`Yield | `Close]
+(** [serialize t writev] sufaces the next operation of [t] to the caller,
+    handling a [`Writev] operation with [writev] function and performing an
+    additional bookkeeping on the caller's behalf. In the event that [writev]
+    indicates a partial write, {!serialize} will call {!yield} on the
+    serializer rather than attempting successive [writev] calls. *)
+
+
+(** {2 Convenience Functions}
+
+    These functions are included for testing, debugging, and general
+    development. They are not the suggested way of driving a serializer in a
+    production setting. *)
+
+val serialize_to_string : t -> string
+(** [serialize_to_string t] runs [t], collecting the output into a string and
+    returning it. [serialzie_to_string t] immediately closes [t] and ignores
+    any calls to {!yield} on [t]. *)
+
+val serialize_to_bigstring : t -> bigstring
+(** [serialize_to_string t] runs [t], collecting the output into a bigstring
+    and returning it. [serialzie_to_bigstring t] immediately closes [t] and
+    ignores any calls to {!yield} on [t]. *)

unikernel/duniverse/faraday/lib_test/dune

@@ -0,0 +1,10 @@
+(executables
+ (libraries alcotest faraday)
+ (modules   test_faraday)
+ (names     test_faraday))
+
+(alias
+ (name    runtest)
+ (package faraday)
+ (deps    test_faraday.exe)
+ (action  (run %{deps})))

unikernel/duniverse/faraday/lib_test/test_faraday.ml

@@ -0,0 +1,299 @@
+open Faraday
+
+module Operation = struct
+  type t =
+    [ `Writev of Bigstringaf.t iovec list
+    | `Yield
+    | `Close ]
+
+  let pp_hum fmt t =
+    match t with
+    | `Yield -> Format.pp_print_string fmt "Yield"
+    | `Close -> Format.pp_print_string fmt "Close"
+    | `Writev iovecs ->
+      let writev_len = List.length iovecs in
+      Format.pp_print_string fmt "Writev [";
+      List.iteri (fun i { off; len; buffer } ->
+        Format.fprintf fmt "%S" (Bigstringaf.substring ~off ~len buffer);
+        if i < writev_len - 1 then Format.pp_print_string fmt ", ")
+        iovecs;
+      Format.pp_print_string fmt "]";
+    ;;
+
+  let equal x y =
+    match x, y with
+    | `Yield, `Yield -> true
+    | `Close, `Close -> true
+    | `Writev xs, `Writev ys ->
+      let to_string { off; len; buffer } = Bigstringaf.substring ~off ~len buffer in
+      let xs = List.map to_string xs in
+      let ys = List.map to_string ys in
+      xs = ys
+    | _, _ -> false
+  ;;
+
+  let writev ss =
+    `Writev
+      (List.map (fun s ->
+        let len = String.length s in
+        { off = 0; len; buffer = Bigstringaf.of_string ~off:0 ~len s })
+        ss)
+  ;;
+end
+
+module Flushed_reason = struct
+  type t = Flushed_reason.t
+
+  let pp_hum fmt (t:t) =
+    match t with
+    | Shift           -> Format.pp_print_string fmt "Shift"
+    | Drain           -> Format.pp_print_string fmt "Drain"
+    | Nothing_pending -> Format.pp_print_string fmt "Nothing_pending"
+
+  let equal (t:t) (t':t) =
+    match t, t' with
+    | Shift, Shift | Drain, Drain | Nothing_pending, Nothing_pending -> true
+    | _ -> false
+end
+
+module Alcotest = struct
+  include Alcotest
+
+  let operation : Operation.t testable = testable Operation.pp_hum Operation.equal
+  let flush_reason : Flushed_reason.t testable = testable Flushed_reason.pp_hum Flushed_reason.equal
+end
+
+let test ?(buf_size=0x100) f =
+  let t = create buf_size in
+  f t;
+  operation t
+;;
+
+let noop () =
+  Alcotest.(check operation) "noop"
+    `Yield (test ignore);
+;;
+
+let yield () =
+  Alcotest.(check operation) "yield"
+    `Yield (test yield)
+;;
+
+let empty_writes () =
+  Alcotest.(check operation) "empty string"
+    `Yield (test (fun t -> write_string t ""));
+  Alcotest.(check operation) "empty bytes"
+    `Yield (test (fun t -> write_bytes t (Bytes.make 0 '\000')));
+  Alcotest.(check operation) "empty bigstring"
+    `Yield (test (fun t -> write_bigstring t (Bigstringaf.create 0)));
+;;
+
+let empty_schedule () =
+  Alcotest.(check operation) "empty schedule"
+    `Yield (test (fun t -> schedule_bigstring t (Bigstringaf.create 0)));
+;;
+
+let empty =
+  [ "noop"          , `Quick, noop
+  ; "yield"         , `Quick, yield
+  ; "empty writes"  , `Quick, empty_writes
+  ; "empty schedule", `Quick, empty_schedule
+  ]
+;;
+
+let endianness () =
+  Alcotest.(check operation) "unit16 le"
+    (Operation.writev ["\005\000"])
+    (test (fun t -> LE.write_uint16 t 5));
+  Alcotest.(check operation) "unit16 be"
+    (Operation.writev ["\000\005"])
+    (test (fun t -> BE.write_uint16 t 5));
+;;
+
+let endian =
+  [ "endian", `Quick, endianness ]
+
+let write ?buf_size () =
+  let check msg f =
+  Alcotest.(check operation) msg
+    (Operation.writev [ "test" ])
+    (test ?buf_size f)
+  in
+  check "string"    (fun t -> write_string    t "test");
+  check "bytes"     (fun t -> write_bytes     t (Bytes.of_string "test"));
+  check "bigstring" (fun t -> write_bigstring t (Bigstringaf.of_string ~off:0 ~len:4 "test"))
+
+let char () =
+  Alcotest.(check operation) "char"
+    (Operation.writev [ "A" ])
+    (test (fun t -> write_char t 'A'));
+;;
+
+let write_multiple () =
+  let f t =
+    write_string t "te";
+    write_string t "st";
+    write_string t "te";
+    write_string t "st";
+    write_char   t 't';
+    write_char   t 'e'
+  in
+  Alcotest.(check operation) "with room"
+    (Operation.writev ["testtestte"])
+    (test f);
+  Alcotest.(check operation) "with room"
+    (Operation.writev ["te"; "st"; "te"; "st"; "te"])
+    (test ~buf_size:1 f);
+;;
+
+let write =
+  [ "char"           , `Quick, char
+  ; "single w/ room" , `Quick, (write : unit -> unit)
+  ; "single w/o room", `Quick, write ~buf_size:1
+  ; "multiple"       , `Quick, write_multiple
+  ]
+
+let schedule () =
+  let check msg f =
+  Alcotest.(check operation) msg
+    (Operation.writev ["one"; "two"])
+    (test f)
+  in
+  check "schedule first" (fun t ->
+    schedule_bigstring t (Bigstringaf.of_string ~off:0 ~len:3 "one");
+    write_string       t "two");
+  check "schedule last" (fun t ->
+    write_string       t "one";
+    schedule_bigstring t (Bigstringaf.of_string ~off:0 ~len:3 "two"));
+;;
+
+let schedule =
+  [ "single", `Quick, schedule ]
+
+let rec cross xs ys =
+  match xs with
+  | [] -> []
+  | x::xs' -> List.(map (fun y -> [x; y]) ys) @ (cross xs' ys)
+
+let string_of_bigstring b =
+  Bigstringaf.substring ~off:0 ~len:(Bigstringaf.length b) b
+
+let serialize_to_bigstring' t =
+  serialize_to_bigstring t
+  |> string_of_bigstring
+
+let check ?(buf_size=0x100) ?(serialize=serialize_to_string) ~iovecs ~msg ops result =
+  let bigstring_of_string str =
+    Bigstringaf.of_string ~off:0 ~len:(String.length str) str
+  in
+  let t = create buf_size in
+  List.iter (function
+    | `Write_le        i -> LE.write_uint16 t i
+    | `Write_be        i -> BE.write_uint16 t i
+    | `Write_string    s -> write_string    t s
+    | `Write_bytes     s -> write_bytes     t (Bytes.unsafe_of_string s)
+    | `Write_bigstring s -> write_bigstring t (bigstring_of_string s)
+    | `Write_char      c -> write_char      t c
+    | `Schedule_bigstring s -> schedule_bigstring t (bigstring_of_string s)
+    | `Yield -> Faraday.yield t)
+  ops;
+  Alcotest.(check int) "iovec count" iovecs
+    (match operation t with
+    | `Writev iovecs  -> List.length iovecs
+    | _               -> 0);
+  Alcotest.(check string) msg result (serialize t)
+
+let interleaved serialize =
+  (* XXX(seliopou): Replace with property-based testing. The property should
+     really be: Given a string, for any partition of that string and for any
+     assignment of writes and schedules on the partition, the output will be
+     the same as the input. *)
+  [ "write_then_schedule", `Quick, begin fun () ->
+    List.iteri (fun i ops ->
+      check ~iovecs:2 ~serialize ~msg:(Printf.sprintf "write_then_schedule: %d" i) ops "test")
+    (cross
+      [`Write_string "te"; `Write_bytes "te"; `Write_bigstring "te"]
+      [`Schedule_bigstring "st"]);
+    List.iter (fun ops ->
+      check ~iovecs:2 ~serialize ~msg:"write_then_schedule: char" ops "test")
+    (cross
+      [`Write_char 't'; `Write_string "t"; `Write_bytes "t"]
+      [`Schedule_bigstring "est"])
+  end
+  ; "schedule_then_write", `Quick, begin fun () ->
+    List.iteri (fun i ops ->
+      check ~iovecs:2 ~serialize ~msg:(Printf.sprintf "schedule_then_write: %d" i) ops "stte")
+    (cross
+      [`Schedule_bigstring "st"]
+      [`Write_string "te"; `Write_bytes "te"; `Write_bigstring "te"]);
+    List.iter (fun ops ->
+      check ~iovecs:2 ~serialize ~msg:"schedule_then_write: char" ops "estt")
+    (cross
+      [`Schedule_bigstring "est"]
+      [`Write_char 't'; `Write_bytes "t"; `Write_string "t"])
+  end ]
+
+let test_flush () =
+  let t = create 0x100 in
+
+  let set_up_flush () =
+    let flush_reason = ref None in
+    flush_with_reason t (fun reason -> flush_reason := Some reason);
+    flush_reason
+  in
+
+  let flush_reason = set_up_flush () in
+  Alcotest.(check (option flush_reason))
+    "flushes resolved immediately if no waiting bytes"
+    (Some Nothing_pending)
+    !flush_reason;
+
+  write_string t "hello world";
+  let flush_reason = set_up_flush () in
+  shift t 5;
+  Alcotest.(check (option flush_reason))
+    "flush not yet resolved as not enough bytes shifted"
+    None
+    !flush_reason;
+  shift t 6;
+  Alcotest.(check (option flush_reason))
+    "flush during shift"
+    (Some Shift)
+    !flush_reason;
+
+  write_string t "one";
+  let flush_reason1 = set_up_flush () in
+  write_string t "two";
+  let flush_reason2 = set_up_flush () in
+  shift t 6;
+  Alcotest.(check (option flush_reason))
+    "flush during shift past the flush point"
+    (Some Shift)
+    !flush_reason1;
+  Alcotest.(check (option flush_reason))
+    "flush during shift past the flush point"
+    (Some Shift)
+    !flush_reason2;
+
+  write_string t "hello world";
+  close t;
+  let flush_reason = set_up_flush () in
+  ignore (drain t : int);
+  Alcotest.(check (option flush_reason))
+    "flush during drain"
+    (Some Drain)
+    !flush_reason;
+;;
+
+let flush = [ "flush", `Quick, test_flush ]
+
+let () =
+  Alcotest.run "test suite"
+    [ "empty output"                  , empty
+    ; "endianness"                    , endian
+    ; "write"                         , write
+    ; "single schedule"               , schedule
+    ; "interleaved calls (string)"    , interleaved serialize_to_string
+    ; "interleaved calls (bigstring)" , interleaved serialize_to_bigstring'
+    ; "flush"                         , flush
+    ]

unikernel/duniverse/faraday/lwt/dune

@@ -0,0 +1,5 @@
+(library
+ (name        faraday_lwt)
+ (public_name faraday-lwt)
+ (libraries   faraday lwt)
+ (flags (:standard -safe-string)))

unikernel/duniverse/faraday/lwt/faraday_lwt.ml

@@ -0,0 +1,25 @@
+open Lwt
+
+let serialize t ~yield ~writev =
+  let shutdown () =
+    Faraday.close t;
+    (* It's necessary to drain the serializer in order to free any buffers that
+     * may be be queued up. *)
+    ignore (Faraday.drain t);
+  in
+  let rec loop t =
+    match Faraday.operation t with
+    | `Writev iovecs ->
+      writev iovecs
+      >>= (function
+        | `Closed   -> shutdown (); return () (* XXX(seliopou): this should be reported *)
+        | `Ok n     -> Faraday.shift t n; loop t)
+    | `Yield ->
+      yield t >>= fun () -> loop t
+    | `Close -> return ()
+  in
+  catch
+    (fun ()  -> loop t)
+    (fun exn ->
+      shutdown ();
+      fail exn)

unikernel/duniverse/faraday/lwt/faraday_lwt.mli

@@ -0,0 +1,8 @@
+open Faraday
+
+
+val serialize
+  :  t
+  -> yield  : (t -> unit Lwt.t)
+  -> writev : (bigstring iovec list -> [ `Ok of int | `Closed ] Lwt.t)
+  -> unit Lwt.t

unikernel/duniverse/faraday/lwt_unix/dune

@@ -0,0 +1,5 @@
+(library
+ (name        faraday_lwt_unix)
+ (public_name faraday-lwt-unix)
+ (libraries   faraday lwt lwt.unix faraday-lwt)
+ (flags (:standard -safe-string)))

unikernel/duniverse/faraday/lwt_unix/faraday_lwt_unix.ml

@@ -0,0 +1,20 @@
+include Faraday_lwt
+
+open Lwt.Infix
+
+let writev_of_fd fd =
+  fun iovecs ->
+    let lwt_iovecs = Lwt_unix.IO_vectors.create () in
+    iovecs |> List.iter (fun {Faraday.buffer; off; len} ->
+      Lwt_unix.IO_vectors.append_bigarray lwt_iovecs buffer off len);
+
+    Lwt.catch
+      (fun () ->
+        Lwt_unix.writev fd lwt_iovecs
+        >|= fun n -> `Ok n)
+      (function
+      | Unix.Unix_error (Unix.EBADF, "check_descriptor", _)
+      | Unix.Unix_error (Unix.EPIPE, _, _) ->
+        Lwt.return `Closed
+      | exn ->
+        Lwt.fail exn)

unikernel/duniverse/faraday/lwt_unix/faraday_lwt_unix.mli

@@ -0,0 +1,8 @@
+open Faraday
+
+
+include module type of Faraday_lwt
+
+val writev_of_fd
+  :  Lwt_unix.file_descr
+  -> bigstring iovec list -> [ `Ok of int | `Closed ] Lwt.t