unikernel/duniverse/mirage-channel/.gitignore

@@ -0,0 +1,3 @@
+_build
+.merlin
+*.install

unikernel/duniverse/mirage-channel/CHANGES.md

@@ -0,0 +1,68 @@
+v5.0.0 2025-05-31
+-----------------
+
+* Add lower bounds in opam file
+* Add x-maintenance-intent: [ "(latest)" ] to the opam file (@hannesm #36 #37)
+* Remove deprecated Mirage_channel_lwt (reported by @vog in #35, fixed in #37)
+* Adapt README to the curent API (reported by @Ulrar in #26, fixed in #37)
+* Add the `shutdown` function to the interface (since mirage-flow 4), initially
+  #9 by @djs55, #37 @hannesm
+* Fix tests with mirage-flow 4 being released (#37 @hannesm)
+
+v4.1.0 2022-04-04
+-----------------
+
+* Add an optional size limit to `read_line` (#32 @djs55)
+* Redefine type error as private type of polymorphic variant (#32 @dinosaure)
+* Restore compatibility with alcotest 1.4.0 (#33 @CraigFE)
+* Update to cstruct 6.0.0 API, remove use of deprecated Cstruct.len (#34 @hannesm)
+
+v4.0.1 2019-11-04
+-----------------
+
+* provide deprecated Mirage_channel_lwt for smooth transition (#31 @hannesm)
+
+
+v4.0.0 2019-10-24
+-----------------
+
+- remove mirage-channel-lwt, fold Make(Flow):S into mirage-channel (#29 @hannesm)
+- mirage-channel specialised on Lwt.t and Cstruct.t (#29 @hannesm)
+- raise lower OCaml bound to 4.06.0 (#29 @hannesm)
+
+v3.2.0 2019-02-07
+-----------------
+
+- Port build to Dune (@avsm)
+- Fix ocamldoc format to be odoc-clean (@avsm)
+- Update opam metadata to 2.0 format (@avsm)
+- Update test matrix to OCaml 4.07 (#24 @hannesm)
+- Use io-page-unix instead of io-page.unix (#24 @hannesm)
+
+v3.1.0 2017-06-14
+-----------------
+
+- Port build to Jbuilder.
+
+v3.0.0
+------
+
+Adapt to MirageOS 3 CHANNEL interface:
+
+- use `result` instead of exceptions
+- hide `read_until` as an internal implementation
+- remove `read_stream` from external interface as it is
+  difficult to combine Lwt_stream and error handling.
+
+v1.1.1 2016-10-20
+-----------------
+
+- port to topkg and odig conventions
+
+v1.1.0 2016-06-28
+-----------------
+
+- don't call `close` on `Eof`
+- add `read_exactly`
+- add LICENSE
+- add conflict with old versions of TCP/IP

unikernel/duniverse/mirage-channel/LICENSE.md

@@ -0,0 +1,15 @@
+Copyright (c) 2011-2015 Anil Madhavapeddy <anil@recoil.org>
+Copyright (c) 2015 Mindy Preston
+Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
+
+Permission to use, copy, modify, and distribute this software for any
+purpose with or without fee is hereby granted, provided that the above
+copyright notice and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

unikernel/duniverse/mirage-channel/Makefile

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

unikernel/duniverse/mirage-channel/README.md

@@ -0,0 +1,64 @@
+mirage-channel — Buffered channels for MirageOS FLOW types
+----------------------------------------------------------
+v5.0.0
+
+Channels are buffered reader/writers built on top of unbuffered `FLOW`
+implementations.
+
+Example:
+
+```ocaml
+module Channel = Channel.Make(Flow)
+...
+Channel.read_exactly ~len:16 t >>= function
+| Error read_error
+| Ok `Eof -> ...
+| Ok `Data bufs -> (* read header of message *)
+  let payload_length = Cstruct.(LE.get_uint16 (concat bufs) 0) in
+  Channel.read_exactly ~len:payload_length t >>= function
+  | Ok `Data bufs -> (* payload of message *)
+  | Ok `Eof -> ...
+  | Error read_error
+(* process message *)
+
+Channel.write_buffer t header;
+Channel.write_buffer t payload;
+Channel.flush t >>= function
+| Error write_error -> ...
+| Ok () -> ...
+```
+
+mirage-channel is distributed under the ISC license.
+
+* Homepage: https://github.com/mirage/mirage-channel
+* Issue: <https://github.com/mirage/mirage-channel/issues>
+* Contact: `<mirageos-devel@lists.xenproject.org>`
+
+## Installation
+
+mirage-channel can be installed with `opam`:
+
+    opam install mirage-channel
+
+If you don't use `opam` consult the [`opam`](opam) file for build
+instructions.
+
+## Documentation
+
+The documentation and API reference is automatically generated by
+`ocamldoc` from the interfaces. It can be consulted [online][doc]
+and there is a generated version in the `doc` directory of the
+distribution.
+
+[doc]: http://docs.mirage.io/channel
+
+## Sample programs
+
+If you installed mirage-channel with `opam` sample programs are located in
+the directory `opam config var channel:doc`.
+
+In the distribution sample programs and tests are located in the
+[`test`](test) directory of the distribution. They can be built with:
+
+    dune runtest
+

unikernel/duniverse/mirage-channel/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name mirage-channel)
+(version v5.0.0)

unikernel/duniverse/mirage-channel/mirage-channel.opam

@@ -0,0 +1,56 @@
+version: "5.0.0"
+opam-version: "2.0"
+maintainer: "Anil Madhavapeddy <anil@recoil.org>"
+authors: ["Anil Madhavapeddy" "Mindy Preston" "Thomas Gazagnaire"]
+license: "ISC"
+tags: "org:mirage"
+homepage: "https://github.com/mirage/mirage-channel"
+doc: "https://mirage.github.io/mirage-channel/"
+bug-reports: "https://github.com/mirage/mirage-channel/issues"
+depends: [
+  "ocaml" {>= "4.07.0"}
+  "dune" {>= "1.0"}
+  "mirage-flow" {>= "4.0.0"}
+  "lwt" {>= "4.0.0"}
+  "cstruct" {>= "6.0.0"}
+  "logs"
+  "fmt" {>= "0.8.7"}
+  "alcotest" {with-test}
+  "mirage-flow-combinators" {with-test & >= "2.0.0"}
+]
+conflicts: [
+  "tcpip" {< "3.0.0"}
+]
+build: [
+  ["dune" "subst"] {dev}
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/mirage/mirage-channel.git"
+synopsis: "Buffered channels for MirageOS FLOW types"
+description: """
+Channels are buffered reader/writers built on top of unbuffered `FLOW`
+implementations.
+
+Example:
+
+```ocaml
+module Channel = Channel.Make(Flow)
+...
+Channel.read_exactly ~len:16 t
+>>= fun bufs -> (* read header of message *)
+let payload_length = Cstruct.(LE.get_uint16 (concat bufs) 0) in
+Channel.read_exactly ~len:payload_length t
+>>= fun bufs -> (* payload of message *)
+
+(* process message *)
+
+Channel.write_buffer t header;
+Channel.write_buffer t payload;
+Channel.flush t
+>>= fun () ->
+```
+
+mirage-channel is distributed under the ISC license.
+"""
+x-maintenance-intent: [ "(latest)" ]

unikernel/duniverse/mirage-channel/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name mirage_channel)
+ (public_name mirage-channel)
+ (libraries mirage-flow lwt cstruct logs)
+ (wrapped false))

unikernel/duniverse/mirage-channel/src/mirage_channel.ml

@@ -0,0 +1,261 @@
+(*
+ * Copyright (c) 2011-2015 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2013-2015 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013      Citrix Systems Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+module type S = sig
+  type error
+  val pp_error: error Fmt.t
+  type write_error = private [> Mirage_flow.write_error]
+  val pp_write_error: write_error Fmt.t
+  type flow
+  type t
+  val create: flow -> t
+  val to_flow: t -> flow
+  val read_char: t -> (char Mirage_flow.or_eof, error) result Lwt.t
+  val read_some: ?len:int -> t -> (Cstruct.t Mirage_flow.or_eof, error) result Lwt.t
+  val read_exactly: len:int -> t -> (Cstruct.t list Mirage_flow.or_eof, error) result Lwt.t
+  val read_line: ?len:int -> t -> (Cstruct.t list Mirage_flow.or_eof, error) result Lwt.t
+  val write_char: t -> char -> unit
+  val write_string: t -> string -> int -> int -> unit
+  val write_buffer: t -> Cstruct.t -> unit
+  val write_line: t -> string -> unit
+  val flush: t -> (unit, write_error) result Lwt.t
+  val close: t -> (unit, write_error) result Lwt.t
+  val shutdown: t -> [ `read | `write | `read_write ] -> (unit, write_error) result Lwt.t
+end
+
+open Lwt.Infix
+
+let src = Logs.Src.create "channel"
+    ~doc:"Buffered reading and writing over the Flow API"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module Make(Flow: Mirage_flow.S) = struct
+
+  type flow = Flow.flow
+
+  type error = [`Line_too_long|`Read_zero | `Flow of Flow.error]
+  type write_error = Flow.write_error
+
+  let pp_error ppf = function
+  | `Flow e    -> Flow.pp_error ppf e
+  | `Read_zero ->
+      Fmt.string ppf
+        "FLOW.read returned 0 bytes in violation of the specification"
+  | `Line_too_long ->
+      Fmt.string ppf
+        "Unable to read a line because it is too long"
+
+  let pp_write_error = Flow.pp_write_error
+
+  type t = {
+    flow: flow;
+    mutable ibuf: Cstruct.t option; (* Queue of incoming buf *)
+    mutable obufq: Cstruct.t list;  (* Queue of completed writebuf *)
+    mutable obuf: Cstruct.t option; (* Active write buffer *)
+    mutable opos: int;                 (* Position in active write buffer *)
+  }
+
+  let create flow =
+    let ibuf = None in
+    let obufq = [] in
+    let obuf = None in
+    let opos = 0 in
+    { ibuf; obuf; flow; obufq; opos }
+
+  let to_flow { flow; _ } = flow
+
+  let ibuf_refill t =
+    Flow.read t.flow >|= function
+    | Ok (`Data buf) when Cstruct.length buf = 0 ->
+        Log.err (fun l -> l "%a" pp_error `Read_zero);
+        Error `Read_zero
+    | Ok (`Data buf) ->
+        t.ibuf <- Some buf;
+        Ok (`Data buf)
+    | Ok `Eof -> Ok `Eof
+    | Error e -> Error (`Flow e)
+
+  let bind v fn =
+   v >>= function
+   | Ok (`Data buf) -> fn buf
+   | Ok `Eof -> Lwt.return (Ok `Eof)
+   | Error e -> Lwt.return (Error e)
+
+  let (>>=~) = bind
+
+  let rec get_ibuf t =
+    match t.ibuf with
+    | None -> ibuf_refill t >>=~ fun _ -> get_ibuf t
+    | Some buf when Cstruct.length buf = 0 -> ibuf_refill t >>=~ fun _ -> get_ibuf t
+    | Some buf -> Lwt.return (Ok (`Data buf))
+
+  (* Read one character from the input channel *)
+  let read_char t =
+    get_ibuf t (* the fact that we returned means we have at least 1 char *)
+    >>=~ fun buf ->
+    let c = Cstruct.get_char buf 0 in
+    t.ibuf <- Some (Cstruct.shift buf 1); (* advance read buffer, possibly to
+                                             EOF *)
+    Lwt.return (Ok (`Data c))
+
+  (* Read up to len characters from the input channel
+     and at most a full view. If not specified, read all *)
+  let read_some ?len t =
+    (* get_ibuf potentially throws EOF-related exceptions *)
+    get_ibuf t >>=~ fun buf ->
+    let avail = Cstruct.length buf in
+    let len = match len with |Some len -> len |None -> avail in
+    if len < avail then begin
+      let hd,tl = Cstruct.split buf len in
+      t.ibuf <- Some tl; (* leave some in the buffer; next time, we won't do a
+                            blocking read *)
+      Lwt.return (Ok (`Data hd))
+    end else begin
+      t.ibuf <- None;
+      Lwt.return (Ok (`Data buf))
+    end
+
+  let read_exactly ~len t =
+    let rec loop acc = function
+      | 0 ->
+        Lwt.return (Ok (`Data (List.rev acc)))
+      | len ->
+        read_some ~len t
+        >>=~ fun buffer ->
+        loop (buffer :: acc) (len - (Cstruct.length buffer)) in
+    loop [] len
+
+  (* Read until a character is found *)
+  let read_until ?len t ch =
+    get_ibuf t >>=~ fun buf ->
+    (* Scan up to the length of the buffer or the supplied limit, whichever
+       is smaller. *)
+    let scan_len =
+      let len' = Cstruct.length buf in
+      match len with None -> len' | Some x -> min x len' in
+    let rec scan off =
+      if off = scan_len then None
+      else if Cstruct.get_char buf off = ch then Some off else scan (off+1)
+    in
+    match scan 0 with
+    | None -> (* not found, return what we have until EOF *)
+      t.ibuf <- Some (Cstruct.shift buf scan_len);
+      Lwt.return (Ok (`Not_found (Cstruct.sub buf 0 scan_len)))
+    | Some off -> (* found, so split the buffer *)
+      let hd = Cstruct.sub buf 0 off in
+      t.ibuf <- Some (Cstruct.shift buf (off+1));
+      Lwt.return (Ok (`Found hd))
+
+  (* This reads a line of input, which is terminated either by a CRLF
+     sequence, or the end of the channel (which counts as a line).
+     @return Returns a stream of views that terminates at EOF. *)
+  let read_line ?len t =
+    let rec get ?len acc =
+      match len with
+      | Some 0 -> Lwt.return (Error `Line_too_long)
+      | _ ->
+        read_until ?len t '\n' >>= function
+        | Error e -> Lwt.return (Error e)
+        | Ok `Eof -> Lwt.return (Ok (`Data acc))
+        | Ok (`Not_found buf) when Cstruct.length buf = 0 -> Lwt.return (Ok (`Data acc))
+        | Ok (`Not_found buf) ->
+          let len = match len with None -> None | Some l -> Some (l - (Cstruct.length buf)) in
+          get ?len (buf::acc)
+        | Ok (`Found buf) ->
+            (* chop the CR if present *)
+            let buflen = Cstruct.length buf in
+            let buf =
+              if buflen > 0 && (Cstruct.get_char buf (buflen-1) = '\r') then
+                Cstruct.sub buf 0 (buflen-1) else buf
+            in
+            Lwt.return (Ok (`Data (buf :: acc)))
+    in
+    get ?len [] >>=~ fun bits -> Lwt.return (Ok (`Data (List.rev bits)))
+
+  (* Output functions *)
+
+  let alloc_obuf t =
+    let buf = Cstruct.create 4096 in
+    t.obuf <- Some buf;
+    t.opos <- 0;
+    buf
+
+  (* Queue the active write buffer onto the write queue, resizing the
+   * view if necessary to the correct size. *)
+  let queue_obuf t =
+    match t.obuf with
+    |None -> ()
+    |Some buf when Cstruct.length buf = t.opos -> (* obuf is full *)
+      t.obufq <- buf :: t.obufq;
+      t.obuf <- None
+    |Some _ when t.opos = 0 -> (* obuf wasnt ever used, so discard *)
+      t.obuf <- None
+    |Some buf -> (* partially filled obuf, so resize *)
+      let buf = Cstruct.sub buf 0 t.opos in
+      t.obufq <- buf :: t.obufq;
+      t.obuf <- None
+
+  (* Get an active output buffer, which will allocate it if needed.
+   * The position to write into is stored in t.opos *)
+  let get_obuf t =
+    match t.obuf with
+    |None -> alloc_obuf t
+    |Some buf when Cstruct.length buf = t.opos -> queue_obuf t; alloc_obuf t
+    |Some buf -> buf
+
+  (* Non-blocking character write, since Io page allocation never blocks.
+   * That may change in the future... *)
+  let write_char t ch =
+    let buf = get_obuf t in
+    Cstruct.set_char buf t.opos ch;
+    t.opos <- t.opos + 1
+
+  (* This is zero copy; flush current IO page and queue up the incoming
+   * buffer directly. *)
+  let write_buffer t buf =
+    queue_obuf t;
+    t.obufq <- buf :: t.obufq
+
+  let rec write_string t s off len =
+    let buf = get_obuf t in
+    let avail = Cstruct.length buf - t.opos in
+    if avail < len then begin
+      Cstruct.blit_from_string s off buf t.opos avail;
+      t.opos <- t.opos + avail;
+      write_string t s (off+avail) (len-avail)
+    end else begin
+      Cstruct.blit_from_string s off buf t.opos len;
+      t.opos <- t.opos + len
+    end
+
+  let write_line t buf =
+    write_string t buf 0 (String.length buf);
+    write_char t '\n'
+
+  let flush t =
+    queue_obuf t;
+    let l = List.rev t.obufq in
+    t.obufq <- [];
+    Flow.writev t.flow l
+
+  let close t =
+    Lwt.finalize (fun () -> flush t) (fun () -> Flow.close t.flow)
+
+  let shutdown t mode =
+    Lwt.finalize (fun () -> flush t) (fun () -> Flow.shutdown t.flow mode)
+end

unikernel/duniverse/mirage-channel/src/mirage_channel.mli

@@ -0,0 +1,117 @@
+(*
+ * Copyright (c) 2011-2015 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2013-2015 Thomas Gazagnaire <thomas@gazagnaire.org>
+ * Copyright (c) 2013      Citrix Systems Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(** MirageOS signature for channel devices.
+
+    Channels are buffered byte-streams which are attached to an
+    unbuffered flow (e.g. a TCPv4 connection).
+
+    {e Release v5.0.0 } *)
+
+module type S = sig
+
+  type error
+  (** The type for errors. *)
+
+  val pp_error: error Fmt.t
+  (** [pp_error] is the pretty-printer for errors. *)
+
+  type write_error = private [> Mirage_flow.write_error]
+  (** The type for write errors. *)
+
+  val pp_write_error: write_error Fmt.t
+  (** [pp_write_error] is the pretty-printer for write errors. *)
+
+  type flow
+  (** The type for unbuffered network flow. *)
+
+  type t
+  (** The type for the state associated with channels, such as the
+      inflight buffers. *)
+
+  val create: flow -> t
+  (** [create flow] allocates send and receive buffers and
+      associates them with the given unbuffered [flow]. *)
+
+  val to_flow: t -> flow
+  (** [to_flow t] returns the flow that backs this channel. *)
+
+  val read_char: t -> (char Mirage_flow.or_eof, error) result Lwt.t
+  (** Reads a single character from the channel, blocking if there is
+      no immediately available input data. *)
+
+  val read_some: ?len:int -> t -> (Cstruct.t Mirage_flow.or_eof, error) result Lwt.t
+  (** [read_some ?len t] reads up to [len] characters from the
+      input channel and at most a full [buffer]. If [len] is not
+      specified, it reads all available data and returns that
+      buffer. *)
+
+  val read_exactly: len:int -> t -> (Cstruct.t list Mirage_flow.or_eof, error) result Lwt.t
+  (** [read_exactly len t] reads [len] bytes from the channel [t] or fails
+      with [Eof]. *)
+
+  val read_line: ?len:int -> t -> (Cstruct.t list Mirage_flow.or_eof, error) result Lwt.t
+  (** [read_line t] reads a line of input, which is terminated
+      either by a CRLF sequence, or the end of the channel (which
+      counts as a line).
+
+      If [?len] is provided then the maximum length of the line returned will be
+      [len] bytes. If the line is longer than [len] then an error will be
+      returned. With [len = 0], [read_line] always returns an error.
+
+      If the input data is untrusted then care should be taken to ensure [len]
+      is set to an application-specific small value to bound the amount of
+      memory allocated by [read_line].
+
+      @return Returns a list of views that terminates at EOF. *)
+
+  val write_char: t -> char -> unit
+  (** [write_char t ch] writes a single character to the output
+      channel. *)
+
+  val write_string: t -> string -> int -> int -> unit
+  (** [write_string t buf off len] writes [len] bytes from a string
+      [buf], starting from from offset [off]. *)
+
+  val write_buffer: t -> Cstruct.t -> unit
+  (** [write_buffer t buf] copies the buffer to the channel's
+      output buffer.  The buffer should not be modified after being
+      written, and it will be recycled into the buffer allocation pool
+      at some future point. *)
+
+  val write_line: t -> string -> unit
+  (** [write_line t buf] writes the string [buf] to the output
+      channel and append a newline character afterwards. *)
+
+  val flush: t -> (unit, write_error) result Lwt.t
+  (** [flush t] flushes the output buffer and block if necessary
+      until it is all written out to the flow. *)
+
+  val close: t -> (unit, write_error) result Lwt.t
+  (** [close t] calls {!flush} and then close the underlying
+      flow. *)
+
+  val shutdown : t -> [ `read | `write | `read_write ] -> (unit, write_error) result Lwt.t
+  (** [shutdown t mode] calls {!flush} and then shutdown on the underlying
+      flow. *)
+end
+
+(** Functor to create a CHANNEL from a flow implementation *)
+module Make(F: Mirage_flow.S)
+  : S with type flow = F.flow
+       and type error = private [> `Read_zero | `Flow of F.error | `Line_too_long ]

unikernel/duniverse/mirage-channel/test/dune

@@ -0,0 +1,15 @@
+(executables
+ (names test test_channel)
+ (libraries mirage-channel mirage-flow-combinators alcotest lwt.unix logs))
+
+(alias
+ (name runtest)
+ (package mirage-channel)
+ (deps (:< test.exe))
+ (action (run %{<} -e -v)))
+
+(alias
+ (name runtest)
+ (package mirage-channel)
+ (deps (:< test_channel.exe))
+ (action (run %{<} -e -v)))

unikernel/duniverse/mirage-channel/test/test.ml

@@ -0,0 +1,29 @@
+(*
+ * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let suite = [
+  "channel", Test_channel.suite ;
+]
+
+let run test () =
+  Lwt_main.run (test ())
+
+let () =
+  let suite = List.map (fun (n, s) ->
+      n, List.map (fun (d, s, f) -> d, s, run f) s
+    ) suite
+  in
+  Alcotest.run "channel" suite

unikernel/duniverse/mirage-channel/test/test_channel.ml

@@ -0,0 +1,184 @@
+open Lwt.Infix
+
+module F = Mirage_flow_combinators.F
+
+let fail fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt
+
+(* this is a very small set of tests for the channel interface,
+   intended to ensure that EOF conditions on the underlying flow are
+   handled properly *)
+module Channel = Mirage_channel.Make(F)
+
+let check_eof = function
+| Ok (`Data ch) ->
+    fail "character %c was returned from Channel.read_char on an empty flow" ch
+| Ok `Eof -> Lwt.return ()
+| Error e -> fail "unexpected error: %a" Channel.pp_error e
+
+let err_no_exception () = fail "no exception"
+let err_wrong_exception e = fail "wrong exception: %s" (Printexc.to_string e)
+
+let test_read_char_eof () =
+  let f = F.make () in
+  let c = Channel.create f in
+  Channel.read_char c >>=
+  check_eof
+
+let test_read_line () =
+  let input = "I am the very model of a modern major general" in
+  let f = F.make ~input:(F.input_string input) () in
+  let c = Channel.create f in
+  Channel.read_line c >|= function
+  | Ok (`Data buf) -> Alcotest.(check string) "read line" input (Cstruct.copyv buf)
+  | Ok `Eof -> fail "eof"
+  | Error e -> fail "error: %a" Channel.pp_error e
+
+(* The line is longer than the limit *)
+let test_read_line_len () =
+  let input = "I am the very model of a modern major general" in
+  let f = F.make ~input:(F.input_string input) () in
+  let c = Channel.create f in
+  Channel.read_line ~len:5 c >|= function
+  | Ok (`Data _) -> fail "read a line which was too big"
+  | Ok `Eof -> fail "eof"
+  | Error _ -> ()
+
+(* The line is shorter than the limit and bounded by \r\n *)
+let test_read_line_len2 () =
+  let input = "I\r\n am the very model of a modern major general" in
+  let f = F.make ~input:(F.input_string input) () in
+  let c = Channel.create f in
+  Channel.read_line ~len:5 c >|= function
+  | Ok (`Data buf) -> Alcotest.(check string) "read line" "I" (Cstruct.copyv buf)
+  | Ok `Eof -> fail "eof"
+  | Error e -> fail "error: %a" Channel.pp_error e
+
+(* The line is shorter than the limit and bounded by EOF *)
+let test_read_line_len3 () =
+  let input = "I am the very model of a modern major general" in
+  let f = F.make ~input:(F.input_string input) () in
+  let c = Channel.create f in
+  Channel.read_line ~len:50 c >|= function
+  | Ok (`Data buf) -> Alcotest.(check string) "read line" input (Cstruct.copyv buf)
+  | Ok `Eof -> fail "eof"
+  | Error e -> fail "error: %a" Channel.pp_error e
+
+type channel = V : (module Mirage_channel.S with type t = 'a and type error = [> `Line_too_long ]) * 'a -> channel
+
+let channel_from_raw_string s =
+  let consumed = ref false in
+  let module Flow = struct
+    type flow = unit
+    type error = |
+    type write_error = Mirage_flow.write_error
+
+    let pp_error : error Fmt.t = fun _ -> function _ -> .
+    let pp_write_error : Mirage_flow.write_error Fmt.t =
+      fun ppf `Closed -> Fmt.string ppf "Flow closed"
+
+    let read () =
+      if not !consumed
+      then ( consumed := true
+           ; Lwt.return_ok (`Data (Cstruct.of_string s)) )
+      else Lwt.return_ok `Eof
+    let write _ _ = assert false
+    let writev _ _ = assert false
+    let close _ = Lwt.return ()
+    let shutdown _ _ = Lwt.return_unit
+  end in
+  let module Channel = Mirage_channel.Make(Flow) in
+  V ((module Channel), Channel.create ())
+
+let test_read_line_len4 () =
+  let V ((module Channel), c) = channel_from_raw_string "foo" in
+  Channel.read_line ~len:3 c >|= function
+  | Ok (`Data bufs) -> fail "Unexpected data: %S"
+                         Cstruct.(to_string (concat bufs))
+  | Ok `Eof -> fail "eof"
+  | Error e -> match e with
+    | `Line_too_long -> ()
+    | e -> fail "Unexpected error: %a" Channel.pp_error e
+
+let test_read_line_len5 () =
+  let V ((module Channel), c) = channel_from_raw_string "foo\r" in
+  Channel.read_line ~len:3 c >|= function
+  | Ok (`Data bufs) -> fail "Unexpected data: %S"
+                         Cstruct.(to_string (concat bufs))
+  | Ok `Eof -> fail "eof"
+  | Error e -> match e with
+    | `Line_too_long -> ()
+    | e -> fail "Unexpected error: %a" Channel.pp_error e
+
+let test_read_line_len6 () =
+  let V ((module Channel), c) = channel_from_raw_string "foo\r\n" in
+  Channel.read_line ~len:3 c >|= function
+  | Ok (`Data bufs) -> fail "Unexpected data: %S"
+                         Cstruct.(to_string (concat bufs))
+  | Ok `Eof -> fail "eof"
+  | Error e -> match e with
+    | `Line_too_long -> ()
+    | e -> fail "Unexpected error: %a" Channel.pp_error e
+
+let test_read_line_len7 () =
+  let V ((module Channel), c) = channel_from_raw_string "foo\r\n" in
+  Channel.read_line ~len:4 c >|= function
+  | Ok (`Data bufs) -> fail "Unexpected data: %S"
+                         Cstruct.(to_string (concat bufs))
+  | Ok `Eof -> fail "eof"
+  | Error e -> match e with
+    | `Line_too_long -> ()
+    | e -> fail "Unexpected error: %a" Channel.pp_error e
+
+let test_read_line_len8 () =
+  let V ((module Channel), c) = channel_from_raw_string "foo\r\n" in
+  Channel.read_line ~len:5 c >|= function
+  | Ok (`Data bufs) ->
+    Alcotest.(check string) "read line" "foo" Cstruct.(to_string (concat bufs))
+  | Ok `Eof -> fail "eof"
+  | Error e -> fail "Unexpected error: %a" Channel.pp_error e
+
+let test_read_exactly () =
+  let input = "I am the very model of a modern major general" in
+  let f = F.make ~input:(F.input_string input) () in
+  let c = Channel.create f in
+  Channel.read_exactly ~len:4 c >|= function
+  | Ok (`Data bufs) ->
+      Alcotest.(check int) "wrong length" 4 (Cstruct.(length (concat bufs)))
+  | Ok `Eof -> fail "eof"
+  | Error e -> fail "error: %a" Channel.pp_error e
+
+let test_read_until_eof_then_write () =
+  let str = "I am the very model of a modern major general" in
+  let closed = ref false in
+  let output _buf _off len =
+    if !closed
+    then Alcotest.fail "attempted to write after the flow was closed"
+    else Lwt.return len in
+  let close () =
+    closed := true;
+    Lwt.return_unit in
+  let input = F.input_string str in
+  let f = F.make ~close ~input ~output () in
+  let c = Channel.create f in
+  (* Should read to EOF: *)
+  Channel.read_line c >>= fun _ ->
+  Channel.write_line c "Even though I've read to EOF, I should be able to write";
+  Channel.flush c >|= function
+  | Ok () -> ()
+  | Error `Closed -> fail "error: closed"
+  | Error e       -> fail "error: %a" Channel.pp_write_error e
+
+let suite = [
+  "read_char + EOF" , `Quick, test_read_char_eof;
+  "read_line"       , `Quick, test_read_line;
+  "read_exactly"    , `Quick, test_read_exactly;
+  "write after read EOF", `Quick, test_read_until_eof_then_write;
+  "read_line_len"   , `Quick, test_read_line_len;
+  "read_line_len2"  , `Quick, test_read_line_len2;
+  "read_line_len3"  , `Quick, test_read_line_len3;
+  "read_line_len4"  , `Quick, test_read_line_len4;
+  "read_line_len5"  , `Quick, test_read_line_len5;
+  "read_line_len6"  , `Quick, test_read_line_len6;
+  "read_line_len7"  , `Quick, test_read_line_len7;
+  "read_line_len8"  , `Quick, test_read_line_len8;
+]