unikernel/duniverse/mimic/.gitignore

@@ -0,0 +1,6 @@
+_build/
+*~
+*.install
+.merlin
+_opam
+.envrc

unikernel/duniverse/mimic/.ocamlformat

@@ -0,0 +1,7 @@
+version=0.26.2
+module-item-spacing=compact
+break-struct=natural
+break-infix=fit-or-vertical
+parens-tuple=multi-line-only
+wrap-comments=false
+break-collection-expressions=wrap

unikernel/duniverse/mimic/CHANGES.md

@@ -0,0 +1,62 @@
+### 0.0.9 (2024-06-16) Osaka - Japon
+
+* Re-introduce the DNS stack into mimic to be able to resolve domain-names
+  (@dinosaure, @hannesm, #24, #26, #28)
+
+### 0.0.8 (2024-05-31) Paris - France
+
+* Upgrade `mimic-happy-eyeballs` with `happy-eyeballs.1.1.0` (@dinosaure, #22)
+
+### 0.0.7 (2024-04-03) Paris - France
+
+* Delete `mimic_mirage` which is not used (@hannesm, #17)
+* Delete the `fmt` dependency (@dinosaure, #18)
+* Support `mirage-flow.4.0.0` (@hannesm, #20)
+
+### 0.0.6 (2022-11-29) Paris - France
+
+* Fix typo on documentation (2fac4cc, @dinosaure)
+* Add `replace` function (#14, @dinosaure)
+* Update to `ocamlformat.0.23.0` (#15, @dinosaure)
+
+### 0.0.5 (2022-03-24) Paris - France
+
+* Add support of OCaml 5.00.0 (#10, @dinosaure)
+* Add `happy-eyeballs` device for MirageOS 4 (#11, @dinosaure)
+* Add `{= version}` constraint on `mimic-happy-eyeballs` (@hannesm, #12)
+
+### 0.0.4 (2021-08-12) Paris - France
+
+- Use `Cstruct.length` instead of `Cstruct.len` (@dinosaure, #2)
+- Remove unnucessary `bigarray-compat` dependency (@hannesm, #3)
+- Remove `rresult` (@hannesm, #4)
+- Be able to introspect values produced by mimic (@dinosaure, #5)
+- Improve documentation (@dinosaure, #6 & #7)
+
+### 0.0.3 (2021-20-04) Paris - France
+
+- Move the project to https://github.com/dinosaure/mimic (@dinosaure)
+  Old distributions of `mimic` are still available on
+  https://github.com/mirage/ocaml-git but `mimic` starts to be
+  used by others projects than `ocaml-git`. We decided to make
+  its own repository.
+- Take the most recent value in the `ctx` instead of the older one
+  **breaking changes**
+  When `mimic` wants to instantiate a transmission protocol, if
+  a value `'a Mimic.value` was inserted multiple times, `mimic`
+  took the older one to instance the transmission protocol.
+
+  Now, `mimic` takes the newer one. It useful when we want to
+  implement the rediction in HTTP where we need to "replace" values
+  by the new destination.
+
+### 0.0.2 (2021-31-03) Paris - France
+
+- Add documentation (#494, @dinosaure)
+- Optimize projection of modules (#495, @dinosaure)
+- Remove `hmap` dependency (which is vendored and tweaked)
+  (fe55e14, @dinosaure)
+
+### 0.0.1 (2021-08-01) Paris - France
+
+- First release of `mimic`

unikernel/duniverse/mimic/LICENSE.md

@@ -0,0 +1,15 @@
+## ISC License
+
+Copyright (c) 2018-2021 Romain Calascibetta <romain.calascibetta@gmail.com>
+
+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/mimic/README.md

@@ -0,0 +1,151 @@
+# Mimic, a full-abstract way to instantiate a transmission protocol
+
+`mimic` is a small project which gives you the opportunity to instantiate a
+transmission protocol - such as a TCP/IP connection - from dynamic values. A
+simple tutorial is available [here][tutorial]. It explains to implement a
+ping-pong protocol and upgrade it to TLS.
+
+## Some examples
+
+[git][git] or [paf][paf] are examples where they use `mimic` as the only
+transmission protocol implementation available. It permits to be compatible
+with MirageOS without the complexity of _functors_ (commonly used with
+[functoria][functoria] to unlock the possibility to abstract anything).
+
+## Design
+
+`mimic` is pretty-small (~ 700 lines) and the API wants to fit into several
+different contexts (HTTP, [TLS][tls] or [SSH][ssh]). It's possible to make
+helpers from it such as some derivations for `unix` or `mirage` - as we
+commonly designed for [conduit][conduit]. However, with a big retro-spective,
+such piece of code should **not** include these derivations.
+
+Indeed, they give an opportunity to the user to assert a non-compaibility with
+MirageOS if you use the `unix` derivation for example.
+
+`mimic` wants to be abstract and "simple". Then, the user is able to construct
+something more complex and easy to use at his level - and it's what [paf][paf]
+does for example or [git-unix][git-unix].
+
+## The goal of `mimic`
+
+In the context of MirageOS which has a first stage which decides
+implementation of protocols according to arguments let us to provide a client
+which can work on many contexts:
+- as a simple executable which can use the host TCP/IP stack
+- as a full operating system which integrate its own TCP/IP stack
+- as something else which wants to use something else than the TCP/IP stack
+
+That mostly means that, _de facto_, we can not assert a certain implementation
+of the underlying transmission protocol used by a protocol such as HTTP or
+SMTP. This required abstraction becomes more complexe when we start to think
+about composition of protocols (such as TCP/IP and TLS for instance).
+
+This abstraction, in the context of a client, is not only determined by a
+static application of _functors_ with our implementations. It depends on an
+user's input value which will choose the right transmission protocol. For
+instance:
+- `git@github.com:repo/name` expects TCP/IP + SSH
+- `http://github.com/repo/name` expects TCP/IP + HTTP
+- `git://github.com/repo/name` expects TCP/IP
+- `https://github.com/repo/name` expects TCP/IP + TLS + HTTP
+
+`mimic` gives the opportunity to provide a full implementation of the
+[`Mirage_flow.S`][mirage-flow] interface and require a function to instantiate
+the given transmission protocol (which respects our interface). By this way and
+according to user's input values, `mimic` is able to choose an try to
+instantiate a _certain_ transmission protocol and hide it into an _not-fully_
+abstracted type `Mimic.flow`.
+
+It unlock the ability to implement a protocol such as the Git protocol - or
+something else such as the HTTP protocol. By this way, this implementation is,
+_de facto_ compatible with MirageOS in any contexts. In the case of MirageOS,
+a simple registration of available transmission protocols _via_
+[functoria][functoria] is enough. For a more concrete usage such as the Unix
+usage, a derivation of your protocol with `unix` and a registration by 
+default of some transmission protocols is enough too. The main difference is:
+- one is leaded by arguments of the user (and `functoria`)
+- the second is established by the developer
+
+### The result of the mimic's usage
+
+More practically, in the MirageOS world, a _device_ **can not** provide _via_
+its interface the `connect` function but it must implement it let write the
+`functoria` glue to to let it to call the `connect` function with available
+arguments (from the command-line).
+
+For instance, a device can be described with this interface:
+```ocaml
+module type S = sig
+  type t
+
+  val read : t -> buffer
+  val write : t -> buffer -> unit
+end
+```
+
+And its implementation can be described with:
+```ocaml
+module TCP : sig
+  include S
+
+  val connect : ipv4 -> t
+end
+```
+
+That mostly mean that, inside the `unikernel.ml` which is your application, you
+don't have an access to the `connect` function:
+```ocaml
+module Make (My_device : Device.S) = struct
+  let start (t : My_device.t) =
+    ...
+end
+```
+
+A _hot-connect_ can not be available into the interface for a specific reason:
+the abstraction. Arguments required to `connect`/allocate a resource which
+represents our device depend on the implementation. As we said earlier,
+`ocaml-tls` expects a `Tls.Config.client` where `Lwt_ssl` expects an
+`Ssl.context`. It can be difficult to shape these values into an ultimate type
+(which is, of course, non-exhaustive from possible TLS implementations).
+
+Mimic wants to provide this _hot-connect_ function into your application
+(inside the `unikernel.ml`) without a static dependency to `ocaml-tls` or
+`lwt_ssl` _à priori_. Then, the `functoria`/`mirage` tool will choose right
+dependency according to the command-line invokation and produce the glue needed
+to be able to _hot-connect_ a TLS connection over TCP/IP.
+
+## Reverse dependencies
+
+`mimic` must be thought according to who use it. The API is not designed to be
+canonic and usable as is. It has been thought to unlock the full abstraction
+and the compatibility with MirageOS for others projects.
+
+If you think that you can have an usage of `mimic` and something is missing,
+you should implement what you want **outside** `mimic`.
+
+## The `Mirage_flow.S` interface
+
+Finally, the only assumption about design of protocols, transmission protocols,
+etc. is `Mirage_flow.S`. Several issues exist about this interface but the cost
+to upgrade the interface (to be unix-friendly for example) is huge when
+several MirageOS projects trust on this specific interface.
+
+## Documentation
+
+`mimic` can be hard to explain when we don't know all details about the
+MirageOS eco-system. The existence of this project can be critized when we
+don't really understand all details and how this project fits in.
+
+The documentation is not very clear and does not explain the big-picture of
+`mimic`. So it's a real issue and the [tutorial][tutorial] wants to fix it but
+my lack of English does not help me.
+
+[tutorial]: https://dinosaure.github.io/mimic/
+[git]: https://github.com/mirage/ocaml-git
+[paf]: https://github.com/mirage/paf-le-chien
+[functoria]: https://github.com/mirage/mirage
+[tls]: https://github.com/mirleft/ocaml-tls
+[ssh]: https://github.com/mirage/awa-ssh
+[git-unix]: https://github.com/mirage/ocaml-git
+[mirage-flow]: https://github.com/mirage/mirage-flow

unikernel/duniverse/mimic/dune-project

@@ -0,0 +1,3 @@
+(lang dune 2.8)
+(name mimic)
+(version 0.0.9)

unikernel/duniverse/mimic/lib/dune

@@ -0,0 +1,9 @@
+(library
+ (name mimic)
+ (public_name mimic)
+ (modules hmap implicit mirage_protocol mimic)
+ (libraries logs mirage-flow lwt))
+
+(documentation
+ (package mimic)
+ (mld_files index))

unikernel/duniverse/mimic/lib/hmap.ml

@@ -0,0 +1,211 @@
+(*---------------------------------------------------------------------------
+   Copyright (c) 2016 Daniel C. Bünzli. All rights reserved.
+   Distributed under the ISC license, see terms at the end of the file.
+   mimic 0.0.9
+  ---------------------------------------------------------------------------*)
+
+(* Type identifiers.
+   See http://alan.petitepomme.net/cwn/2015.03.24.html#1 *)
+
+module Tid = struct type _ t = .. end
+
+module type Tid = sig
+  type t type _ Tid.t += Tid : t Tid.t
+end
+
+type 'a tid = (module Tid with type t = 'a)
+
+let tid () (type s) =
+  let module M = struct type t = s type _ Tid.t += Tid : t Tid.t end in
+  (module M : Tid with type t = s)
+
+type ('a, 'b) teq = Teq : ('a, 'a) teq
+
+let eq : type r s. r tid -> s tid -> (r, s) teq option =
+ fun r s ->
+  let module R = (val r : Tid with type t = r) in
+  let module S = (val s : Tid with type t = s) in
+  match R.Tid with S.Tid -> Some Teq | _ -> None
+
+(* Heterogeneous maps *)
+
+module type KEY_INFO = sig
+  type 'a t
+end
+
+module type VALUE_INFO = sig
+  type 'a t
+end
+
+module type S = sig
+  type 'a key
+
+  module Key : sig
+    type 'a info
+
+    val create : 'a info -> 'a key
+    val info : 'a key -> 'a info
+
+    type t
+
+    val hide_type : 'a key -> t
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+    val proof : 'a key -> 'b key -> ('a, 'b) teq option
+  end
+
+  module Make (Value_info : VALUE_INFO) : sig
+    type 'a value = 'a Value_info.t
+    type t
+
+    val empty : t
+    val is_empty : t -> bool
+    val mem : 'a key -> t -> bool
+    val add : 'a key -> 'a value -> t -> t
+    val singleton : 'a key -> 'a value -> t
+    val rem : 'a key -> t -> t
+    val find : 'a key -> t -> 'a value option
+    val get : 'a key -> t -> 'a value
+
+    type binding = B : 'a key * 'a value -> binding
+
+    val iter : (binding -> unit) -> t -> unit
+    val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a
+    val for_all : (binding -> bool) -> t -> bool
+    val exists : (binding -> bool) -> t -> bool
+    val filter : (binding -> bool) -> t -> t
+    val cardinal : t -> int
+    val any_binding : t -> binding option
+    val get_any_binding : t -> binding
+    val bindings : t -> binding list
+
+    type merge = {
+      f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option;
+    }
+
+    val merge : merge -> t -> t -> t
+  end
+end
+
+module Make (Key_info : KEY_INFO) : S with type 'a Key.info = 'a Key_info.t =
+struct
+  (* Keys *)
+
+  module Key = struct
+    type 'a info = 'a Key_info.t
+    type 'a key = { uid : int; tid : 'a tid; info : 'a Key_info.t }
+
+    let uid =
+      let id = ref (-1) in
+      fun () ->
+        incr id;
+        !id
+
+    let create info =
+      let uid = uid () in
+      let tid = tid () in
+      { uid; tid; info }
+
+    let info k = k.info
+
+    type t = V : 'a key -> t
+
+    let hide_type k = V k
+    let equal (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid = 0
+    let compare (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid
+    let proof k0 k1 = eq k0.tid k1.tid
+  end
+
+  type 'a key = 'a Key.key
+
+  module Make (Value_info : VALUE_INFO) = struct
+    type 'a value = 'a Value_info.t
+
+    (* Maps *)
+
+    module M = Map.Make (Key)
+
+    type binding = B : 'a key * 'a value -> binding
+    type t = binding M.t
+
+    let empty = M.empty
+    let is_empty = M.is_empty
+    let mem k m = M.mem (Key.V k) m
+    let add k v m = M.add (Key.V k) (B (k, v)) m
+    let singleton k v = M.singleton (Key.V k) (B (k, v))
+    let rem k m = M.remove (Key.V k) m
+
+    let find : type a. a key -> t -> a value option =
+     fun k s ->
+      try
+        match M.find (Key.V k) s with
+        | B (k', v) -> (
+            match eq k.Key.tid k'.Key.tid with
+            | None -> None
+            | Some Teq -> Some v)
+      with Not_found -> None
+
+    let get k s =
+      match find k s with
+      | None -> invalid_arg "key not found in map"
+      | Some v -> v
+
+    let iter f m = M.iter (fun _ b -> f b) m
+    let fold f m acc = M.fold (fun _ b acc -> f b acc) m acc
+    let for_all p m = M.for_all (fun _ b -> p b) m
+    let exists p m = M.exists (fun _ b -> p b) m
+    let filter p m = M.filter (fun _ b -> p b) m
+    let cardinal m = M.cardinal m
+    let any_binding m = try Some (snd (M.choose m)) with Not_found -> None
+
+    type merge = {
+      f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option;
+    }
+
+    let merge : merge -> t -> t -> t =
+     fun { f } t0 t1 ->
+      let f (Key.V k) a b =
+        match a, b with
+        | Some (B (k0, v)), None -> (
+            match Key.proof k k0 with
+            | Some Teq -> Option.map (fun v -> B (k, v)) (f k (Some v) None)
+            | None -> Option.map (fun v -> B (k, v)) (f k None None))
+        | None, Some (B (k0, v)) -> (
+            match Key.proof k k0 with
+            | Some Teq -> Option.map (fun v -> B (k, v)) (f k None (Some v))
+            | None -> Option.map (fun v -> B (k, v)) (f k None None))
+        | Some (B (k0, v0)), Some (B (k1, v1)) -> (
+            match Key.proof k k0, Key.proof k k1 with
+            | Some Teq, Some Teq ->
+                Option.map (fun v -> B (k, v)) (f k (Some v0) (Some v1))
+            | Some Teq, None ->
+                Option.map (fun v -> B (k, v)) (f k (Some v0) None)
+            | None, Some Teq ->
+                Option.map (fun v -> B (k, v)) (f k None (Some v1))
+            | None, None -> Option.map (fun v -> B (k, v)) (f k None None))
+        | None, None -> Option.map (fun v -> B (k, v)) (f k None None)
+      in
+      M.merge f t0 t1
+
+    let get_any_binding m =
+      try snd (M.choose m) with Not_found -> invalid_arg "empty map"
+
+    let bindings m = List.map snd (M.bindings m)
+  end
+end
+
+(*---------------------------------------------------------------------------
+   Copyright (c) 2016 Daniel C. Bünzli
+
+   Permission to use, copy, modify, and/or 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/mimic/lib/hmap.mli

@@ -0,0 +1,164 @@
+(*---------------------------------------------------------------------------
+   Copyright (c) 2016 Daniel C. Bünzli. All rights reserved.
+   Distributed under the ISC license, see terms at the end of the file.
+   mimic 0.0.9
+  ---------------------------------------------------------------------------*)
+
+(** Heterogeneous value maps.
+
+    {e 0.0.9 - {{:https://github.com/dinosaure/mimic }homepage}} *)
+
+(** {1:func Functorial interface}
+
+    The functorial interface allows to associate more information to the
+    keys. For example a key name or a key value pretty-printer. *)
+
+(** The type for key information. *)
+module type KEY_INFO = sig
+  type 'a t
+  (** The type for key information. *)
+end
+
+module type VALUE_INFO = sig
+  type 'a t
+  (** The type for value information. *)
+end
+
+type ('a, 'b) teq = Teq : ('a, 'a) teq
+
+(** Output signature of the functor {!Make} *)
+module type S = sig
+  (** {1:keys Keys} *)
+
+  type 'a key
+  (** The type for keys whose lookup value is of type ['a]. *)
+
+  (** Keys. *)
+  module Key : sig
+    (** {1:keys Keys} *)
+
+    type 'a info
+    (** The type for key information. *)
+
+    val create : 'a info -> 'a key
+    (** [create i] is a new key with information [i]. *)
+
+    val info : 'a key -> 'a info
+    (** [info k] is [k]'s information. *)
+
+    (** {1:exists Existential keys}
+
+        Exisential keys allow to compare keys. This can be useful for
+        functions like {!filter}. *)
+
+    type t
+    (** The type for existential keys. *)
+
+    val hide_type : 'a key -> t
+    (** [hide_type k] is an existential key for [k]. *)
+
+    val equal : t -> t -> bool
+    (** [equal k k'] is [true] iff [k] and [k'] are the same key. *)
+
+    val compare : t -> t -> int
+    (** [compare k k'] is a total order on keys compatible with {!equal}. *)
+
+    val proof : 'a key -> 'b key -> ('a, 'b) teq option
+  end
+
+  module Make (Value_info : VALUE_INFO) : sig
+    type 'a value = 'a Value_info.t
+    (** The type for values. *)
+
+    (** {1:maps Maps} *)
+
+    type t
+    (** The type for heterogeneous value maps. *)
+
+    val empty : t
+    (** [empty] is the empty map. *)
+
+    val is_empty : t -> bool
+    (** [is_empty m] is [true] iff [m] is empty. *)
+
+    val mem : 'a key -> t -> bool
+    (** [mem k m] is [true] iff [k] is bound in [m]. *)
+
+    val add : 'a key -> 'a value -> t -> t
+    (** [add k v m] is [m] with [k] bound to [v]. *)
+
+    val singleton : 'a key -> 'a value -> t
+    (** [singleton k v] is [add k v empty]. *)
+
+    val rem : 'a key -> t -> t
+    (** [rem k m] is [m] with [k] unbound. *)
+
+    val find : 'a key -> t -> 'a value option
+    (** [find k m] is the value of [k]'s binding in [m], if any. *)
+
+    val get : 'a key -> t -> 'a value
+    (** [get k m] is the value of [k]'s binding in [m].
+
+        @raise Invalid_argument if [k] is not bound in [m]. *)
+
+    (** The type for bindings. *)
+    type binding = B : 'a key * 'a value -> binding
+
+    val iter : (binding -> unit) -> t -> unit
+    (** [iter f m] applies [f] to all bindings of [m]. *)
+
+    val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a
+    (** [fold f m acc] folds over the bindings of [m] with [f], starting with
+        [acc] *)
+
+    val for_all : (binding -> bool) -> t -> bool
+    (** [for_all p m] is [true] iff all bindings of [m] satisfy [p]. *)
+
+    val exists : (binding -> bool) -> t -> bool
+    (** [exists p m] is [true] iff there exists a bindings of [m] that
+        satisfies [p]. *)
+
+    val filter : (binding -> bool) -> t -> t
+    (** [filter p m] are the bindings of [m] that satisfy [p]. *)
+
+    val cardinal : t -> int
+    (** [cardinal m] is the number of bindings in [m]. *)
+
+    val any_binding : t -> binding option
+    (** [any_binding m] is a binding of [m] (if not empty). *)
+
+    val get_any_binding : t -> binding
+    (** [get_any_binding m] is a binding of [m].
+
+        @raise Invalid_argument if [m] is empty. *)
+
+    val bindings : t -> binding list
+
+    type merge = {
+      f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option;
+    }
+
+    val merge : merge -> t -> t -> t
+  end
+end
+
+(** Functor for heterogeneous maps whose keys hold information
+    of type [Key_info.t] *)
+module Make : functor (Key_info : KEY_INFO) ->
+  S with type 'a Key.info = 'a Key_info.t
+
+(*---------------------------------------------------------------------------
+   Copyright (c) 2016 Daniel C. Bünzli
+
+   Permission to use, copy, modify, and/or 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/mimic/lib/implicit.ml

@@ -0,0 +1,150 @@
+(* (c) Frédéric Bour
+ * (c) Romain Calascibetta
+ *)
+
+module Tbl = struct
+  (* XXX(dinosaure): [Tbl] is a small re-implementation
+   * of [Hashtbl] where [find_all] is needed by [prj]. To
+   * avoid an allocation of an intermediate list, we directly
+   * use the underlying linked-list to do the projection.
+   *
+   * This implementation wants to be:
+   * - deterministic (seed = 0)
+   * - fast
+   *
+   * Memoization is done by [last_k]/[last_v] where the common use
+   * of [Conduit] is a loop with multiple calls of [send]/[recv]
+   * with the same [flow] value.
+   *)
+
+  type 'v t = {
+    mutable size : int;
+    mutable data : 'v lst array;
+    mutable last_k : int;
+    mutable last_v : 'v;
+  }
+
+  and 'v lst = Empty | Cons of { key : int; data : 'v; mutable next : 'v lst }
+
+  let rec power_2_above x n =
+    if x >= n then x
+    else if x * 2 > Sys.max_array_length then x
+    else power_2_above (x * 2) n
+
+  let create ~epsilon size =
+    let size = power_2_above 16 size in
+    { size = 0; data = Array.make size Empty; last_k = 0; last_v = epsilon }
+
+  external caml_hash : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc]
+
+  let hash v = caml_hash 10 100 0 v
+
+  let resize t =
+    let old_data = t.data in
+    let old_size = Array.length old_data in
+    let new_size = old_size * 2 in
+    if new_size < Sys.max_array_length then (
+      let new_data = Array.make new_size Empty in
+      let new_data_tail = Array.make new_size Empty in
+      t.data <- new_data;
+      let rec insert = function
+        | Empty -> ()
+        | Cons { key; next; _ } as cell ->
+            let new_idx = hash key land (new_size - 1) in
+            (match new_data_tail.(new_idx) with
+            | Empty -> new_data.(new_idx) <- cell
+            | Cons tail -> tail.next <- cell);
+            new_data_tail.(new_idx) <- cell;
+            insert next
+      in
+      for i = 0 to old_size - 1 do
+        insert old_data.(i)
+      done;
+      for i = 0 to new_size - 1 do
+        match new_data_tail.(i) with
+        | Empty -> ()
+        | Cons tail -> tail.next <- Empty
+      done)
+
+  let add t key data =
+    let i = hash key land (Array.length t.data - 1) in
+    let v = Cons { key; data; next = t.data.(i) } in
+    t.data.(i) <- v;
+    t.size <- t.size + 1;
+    if t.size > Array.length t.data lsl 1 then resize t
+end
+
+module type KEY_INFO = sig
+  type 'a t
+end
+
+module Make (Key_info : KEY_INFO) = struct
+  type t = ..
+  type 'a key = 'a Key_info.t
+
+  module type WITNESS = sig
+    type a
+    type t += T of a
+
+    val key : a key
+  end
+
+  type 'a witness = (module WITNESS with type a = 'a)
+  type pack = Key : 'a key -> pack
+  type value = Value : 'a * 'a key -> value
+
+  let epsilon _ = raise_notrace Not_found
+  let handlers = Tbl.create ~epsilon 0x10
+  let keys = Hashtbl.create 0x10
+
+  module Injection (M : sig
+    type t
+
+    val key : t key
+  end) : WITNESS with type a = M.t = struct
+    type a = M.t
+    type t += T of a
+
+    let key = M.key
+    let handler = function T a -> Value (a, key) | _ -> raise Not_found
+
+    let () =
+      let[@warning "-3"] uid =
+        Stdlib.Obj.Extension_constructor.id [%extension_constructor T]
+      in
+      Tbl.add handlers uid handler;
+      Hashtbl.add keys uid (Key key)
+  end
+
+  let inj (type a) (key : a key) : a witness =
+    (module Injection (struct
+      type t = a
+
+      let key = key
+    end))
+
+  (* XXX(dinosaure): we ensure that a value [t : t] must have an implementation
+   * availble into [handlers]. By this way,
+   * [let[@warning "-8"] Tbl.Cons _ = lst in] is safe where we must find an
+   * implementation.
+   *)
+
+  let rec iter t uid lst =
+    let[@warning "-8"] (Tbl.Cons { key = k; data = f; next = r; _ }) = lst in
+    try
+      if uid <> k then raise_notrace Not_found;
+      handlers.Tbl.last_v <- f;
+      f t
+    with _ -> (iter [@tailcall]) t uid r
+
+  let prj t =
+    let arr = handlers.Tbl.data in
+    let uid = Stdlib.Obj.Extension_constructor.(id (of_val t)) in
+    if handlers.Tbl.last_k == uid then handlers.Tbl.last_v t
+    else
+      let res = iter t uid arr.(Tbl.hash uid land (Array.length arr - 1)) in
+      handlers.Tbl.last_k <- uid;
+      res
+
+  let bindings () = Hashtbl.fold (fun _ v a -> v :: a) keys []
+end

unikernel/duniverse/mimic/lib/implicit.mli

@@ -0,0 +1,23 @@
+module type KEY_INFO = sig
+  type 'a t
+end
+
+module Make (Key_info : KEY_INFO) : sig
+  type t = private ..
+  type 'a key = 'a Key_info.t
+
+  module type WITNESS = sig
+    type a
+    type t += T of a
+
+    val key : a key
+  end
+
+  type 'a witness = (module WITNESS with type a = 'a)
+  type pack = Key : 'a key -> pack
+  type value = Value : 'a * 'a key -> value
+
+  val inj : 'a key -> 'a witness
+  val prj : t -> value
+  val bindings : unit -> pack list
+end

unikernel/duniverse/mimic/lib/mimic.ml

@@ -0,0 +1,440 @@
+type 'a info = { name : string; root : root }
+and root = Root of int option | Value
+
+let pp_info ppf { name; root } =
+  match root with
+  | Root (Some p) -> Format.fprintf ppf "<%s:%d>" name p
+  | Root None -> Format.fprintf ppf "<%s>" name
+  | Value -> Format.fprintf ppf "%s" name
+
+module Mirage_protocol = Mirage_protocol
+module Info = struct type 'a t = 'a info end
+module Hmap0 = Hmap.Make (Info)
+
+let pp_value ppf value = Format.fprintf ppf "%a" pp_info (Hmap0.Key.info value)
+let src = Logs.Src.create "mimic" ~doc:"logs mimic's event"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+module rec Fun : sig
+  type ('k, 'res) args =
+    | [] : ('res, 'res) args
+    | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args
+
+  and 'v arg =
+    | Map : ('f, 'a) args * 'f -> 'a arg
+    | Req : 'a Hmap0.key -> 'a arg
+    | Opt : 'a Hmap0.key -> 'a option arg
+    | Dft : 'a * 'a Hmap0.key -> 'a arg
+
+  val req : 'a Hmap0.key -> 'a arg
+  val opt : 'a Hmap0.key -> 'a option arg
+  val dft : 'a Hmap0.key -> 'a -> 'a arg
+  val map : ('k, 'a) args -> 'k -> 'a arg
+end = struct
+  type ('k, 'res) args =
+    | [] : ('res, 'res) args
+    | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args
+
+  and 'v arg =
+    | Map : ('f, 'a) args * 'f -> 'a arg
+    | Req : 'a Hmap0.key -> 'a arg
+    | Opt : 'a Hmap0.key -> 'a option arg
+    | Dft : 'a * 'a Hmap0.key -> 'a arg
+
+  let req value = Req value
+  let opt value = Opt value
+  let dft value v = Dft (v, value)
+  let map args k = Map (args, k)
+end
+
+and Value : sig
+  type 'a elt =
+    | Val : 'a -> 'a elt
+    | Fun : ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt
+
+  type 'a t = 'a elt list
+end = struct
+  type 'a elt =
+    | Val : 'a -> 'a elt
+    | Fun : ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt
+
+  type 'a t = 'a elt list
+end
+
+module Hmap = Hmap0.Make (Value)
+
+type ctx = Hmap.t
+type 'edn value = 'edn Hmap0.key
+
+let merge ctx0 ctx1 =
+  let f :
+      type a.
+      a value -> a Value.t option -> a Value.t option -> a Value.t option =
+   fun _k lst0 lst1 ->
+    match lst0, lst1 with
+    | Some lst0, Some lst1 -> Some (lst0 @ lst1)
+    | Some x, None | None, Some x -> Some x
+    | None, None -> None
+  in
+  Hmap.merge { f } ctx0 ctx1
+
+module Merge (A : sig
+  val ctx : ctx
+end) (B : sig
+  val ctx : ctx
+end) =
+struct
+  let ctx = merge A.ctx B.ctx
+end
+
+let add value v ctx =
+  match Hmap.find value ctx with
+  | Some lst -> Hmap.add value (lst @ [ Val v ]) ctx
+  | None -> Hmap.add value [ Val v ] ctx
+
+let fold value args ~k ctx =
+  match Hmap.find value ctx with
+  | Some lst -> Hmap.add value (lst @ [ Fun (args, k) ]) ctx
+  | None -> Hmap.add value [ Fun (args, k) ] ctx
+
+let replace value v ctx =
+  match Hmap.find value ctx with
+  | None -> Hmap.add value [ Val v ] ctx
+  | Some lst ->
+      let lst =
+        List.fold_left
+          (fun acc -> function
+            | Value.Fun _ as v -> v :: acc
+            | Value.Val _ -> acc)
+          [] lst
+      in
+      let lst = List.rev lst in
+      (* XXX(dinosaure): keep the order! *)
+      Hmap.add value (Val v :: lst) ctx
+
+(***** Mirage_flow.S part *****)
+
+module Implicit0 = Implicit.Make (struct
+  type 'flow t = (module Mirage_flow.S with type flow = 'flow)
+end)
+
+type flow = Implicit0.t = private ..
+type error = [ `Msg of string | `Not_found | `Cycle ]
+type write_error = [ `Msg of string | `Closed ]
+
+let pp_error ppf = function
+  | `Msg err -> Format.pp_print_string ppf err
+  | `Not_found -> Format.pp_print_string ppf "No connection found"
+  | `Cycle -> Format.pp_print_string ppf "Context contains a cycle"
+
+let pp_write_error ppf = function
+  | `Msg err -> Format.pp_print_string ppf err
+  | `Closed -> Format.pp_print_string ppf "Connection closed by peer"
+
+let to_to_string pp v = Format.asprintf "%a" pp v
+
+let read flow =
+  let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in
+  let open Lwt.Infix in
+  Flow.read flow
+  >|= Result.map_error (fun fe -> `Msg (to_to_string Flow.pp_error fe))
+
+let write flow cs =
+  let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in
+  let open Lwt.Infix in
+  Flow.write flow cs >|= function
+  | Error `Closed -> Error `Closed
+  | Error e -> Error (`Msg (to_to_string Flow.pp_write_error e))
+  | Ok _ as v -> v
+
+let writev flow css =
+  let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in
+  let open Lwt.Infix in
+  Flow.writev flow css
+  >|= Result.map_error (fun fe -> `Msg (to_to_string Flow.pp_write_error fe))
+
+let shutdown flow mode =
+  let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in
+  Flow.shutdown flow mode
+
+let close flow =
+  let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in
+  Flow.close flow
+
+(***** Protocol (Mirage_flow.S + connect) part *****)
+
+type ('edn, 'flow) snd = Snd : 'flow -> ('edn, 'flow) snd [@@warning "-37"]
+
+type _ pack =
+  | Protocol :
+      'edn Hmap0.key
+      * 'flow Implicit0.witness
+      * (module Mirage_protocol.S
+           with type flow = 'flow
+            and type endpoint = 'edn)
+      -> ('edn, 'flow) snd pack
+
+module Implicit1 = Implicit.Make (struct type 'v t = 'v pack end)
+
+type ('edn, 'flow) protocol = {
+  flow : 'flow Implicit0.witness;
+  protocol : ('edn, 'flow) snd Implicit1.witness;
+}
+
+let register :
+    type edn flow.
+    ?priority:int ->
+    name:string ->
+    (module Mirage_protocol.S with type flow = flow and type endpoint = edn) ->
+    edn value * (edn, flow) protocol =
+ fun ?priority ~name (module Protocol) ->
+  let value = Hmap0.Key.create { name; root = Root priority } in
+  let flow = Implicit0.inj (module Protocol) in
+  let protocol = Implicit1.inj (Protocol (value, flow, (module Protocol))) in
+  value, { flow; protocol }
+
+module type REPR = sig
+  type t type flow += (* XXX(dinosaure): private? *) T of t
+end
+
+let repr :
+    type edn flow. (edn, flow) protocol -> (module REPR with type t = flow) =
+ fun { flow; _ } ->
+  let (module Witness) = flow in
+  let module M = struct
+    include Witness
+
+    type t = a
+  end in
+  (module M)
+
+let rec apply :
+    type k res. ctx -> (k, res option Lwt.t) Fun.args -> k -> res option Lwt.t =
+ fun ctx args f ->
+  let open Lwt.Infix in
+  let rec go : type k res. ctx -> (k, res) Fun.args -> k -> res Lwt.t =
+   fun ctx -> function
+    | [] -> fun x -> Lwt.return x
+    | Map (args', f') :: tl ->
+        fun f -> go ctx args' f' >>= fun v -> go ctx tl (f v)
+    | Opt value :: tl -> fun f -> find value ctx >>= fun v -> go ctx tl (f v)
+    | Dft (v, value) :: tl -> (
+        fun f ->
+          find value ctx >>= function
+          | Some v' ->
+              Log.debug (fun m ->
+                  m "Found a value for the default argument: %a." pp_value value);
+              go ctx tl (f v')
+          | None -> go ctx tl (f v))
+    | Req value :: tl -> (
+        fun f ->
+          find value ctx >>= function
+          | Some v -> go ctx tl (f v)
+          | None -> Lwt.fail Not_found)
+  in
+  Lwt.catch (fun () -> go ctx args f >>= fun fiber -> fiber) @@ function
+  | Not_found -> Lwt.return_none
+  | exn -> Lwt.fail exn
+
+and find : type a. a value -> ctx -> a option Lwt.t =
+ fun value ctx ->
+  match Hmap.find value ctx with
+  | None | Some [] -> Lwt.return_none
+  | Some lst ->
+      (* XXX(dinosaure): priority on values, then we apply the first [Fun] *)
+      let rec go fold lst =
+        match fold, lst with
+        | None, [] -> Lwt.return_none
+        | Some (Value.Fun (args, f)), [] -> apply ctx args f
+        | Some (Value.Val _), [] -> assert false
+        | None, (Value.Fun _ as x) :: r -> go (Some x) r
+        | _, Val v :: _ -> Lwt.return_some v
+        | Some _, Fun _ :: r -> go fold r
+      in
+      go None (List.rev lst)
+(* XXX(dinosaure): the most recent value. *)
+
+type edn = Edn : 'edn value * 'edn -> edn
+type fnu = Fun : 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k -> fnu
+type dep = Dep : 'edn value -> dep
+
+let pp_fnu ppf (Fun (dep, _, _)) =
+  Format.fprintf ppf "%a" pp_info (Hmap0.Key.info dep)
+
+module Sort = struct
+  type t =
+    | Val : 'edn value * 'edn -> t
+    | Fun : 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k -> t
+
+  let pp ppf = function
+    | Val (k, _) -> pp_info ppf (Hmap0.Key.info k)
+    | Fun (k, _, _) -> pp_info ppf (Hmap0.Key.info k)
+end
+
+let partition bindings =
+  let rec go leafs nodes = function
+    | [] -> List.rev leafs, List.rev nodes
+    | Hmap.B (_, []) :: r -> go leafs nodes r
+    | Hmap.B (k, Val v :: tl) :: r ->
+        go (Sort.Val (k, v) :: leafs) nodes (Hmap.B (k, tl) :: r)
+    | Hmap.B (k, Fun (args, f) :: tl) :: r ->
+        go leafs (Fun (k, args, f) :: nodes) (Hmap.B (k, tl) :: r)
+  in
+  go [] [] bindings
+
+let exists k bindings =
+  let rec go k = function
+    | [] -> false
+    | Hmap.B (k', _) :: r -> (
+        match Hmap0.Key.proof k k' with Some _ -> true | None -> go k r)
+  in
+  go k bindings
+
+let dependencies (Fun (_, args, _)) bindings =
+  let rec go : type k r. _ -> (k, r) Fun.args -> _ =
+   fun acc -> function
+    | Fun.Req dep :: r -> go (Dep dep :: acc) r
+    | Fun.Opt dep :: r when exists dep bindings -> go (Dep dep :: acc) r
+    | Fun.Dft (_, dep) :: r when exists dep bindings -> go (Dep dep :: acc) r
+    | _ :: r -> go acc r
+    | [] -> List.rev acc
+  in
+  go [] args
+
+let exists leafs (Dep k) =
+  let rec go = function
+    | [] -> false
+    | Sort.Val (k', _) :: r -> (
+        match Hmap0.Key.proof k k' with Some _ -> true | None -> go r)
+    | Sort.Fun (k', _, _) :: r -> (
+        match Hmap0.Key.proof k k' with Some _ -> true | None -> go r)
+  in
+  go leafs
+
+let pp_list pp ppf lst =
+  let rec go = function
+    | [] -> ()
+    | [ x ] -> Format.fprintf ppf "%a" pp x
+    | x :: r ->
+        Format.fprintf ppf "%a;@ " pp x;
+        go r
+  in
+  Format.fprintf ppf "@[<1>[";
+  go lst;
+  Format.fprintf ppf "]@]"
+
+let sort bindings =
+  let rec go acc later todo progress =
+    match todo, later with
+    | [], [] -> List.rev acc
+    | [], _ when progress -> go acc [] later false
+    | [], later ->
+        (* TODO(dinosaure): check, at least, one root in [acc]. *)
+        Log.debug (fun m ->
+            m "Found a solution only for: @[<hov>%a@]." (pp_list Sort.pp) acc);
+        Log.debug (fun m ->
+            m "Unsolvable values: @[<hov>%a@]." (pp_list pp_fnu) later);
+        List.rev acc
+    | (Fun (k, args, f) as x) :: xs, _ ->
+        let deps = dependencies x bindings in
+        let available = List.for_all (exists acc) deps in
+        if available then go (Sort.Fun (k, args, f) :: acc) later xs true
+        else go acc (x :: later) xs progress
+  in
+  let leafs, nodes = partition bindings in
+  Log.debug (fun m -> m "Partition done.");
+  Log.debug (fun m -> m "Nodes: @[<hov>%a@]." (pp_list pp_fnu) nodes);
+  go leafs [] nodes false
+
+let inf = -1 and sup = 1
+
+let priority_compare (Edn (k0, _)) (Edn (k1, _)) =
+  match (Hmap0.Key.info k0).root, (Hmap0.Key.info k1).root with
+  | Root (Some p0), Root (Some p1) -> p0 - p1
+  | (Root None | Value), Root (Some _) -> sup
+  | Root (Some _), (Root None | Value) -> inf
+  | Value, Value -> 0
+  | Root None, Root None -> 0
+  | Value, Root None -> sup
+  | Root None, Value -> inf
+
+let unfold : ctx -> (edn list, [> `Cycle ]) result Lwt.t =
+ fun ctx ->
+  let open Lwt.Infix in
+  let rec go ctx acc : Sort.t list -> _ = function
+    | [] ->
+        (* XXX(dinosaure): here, we use a stable sort, [List.rev]
+         * is needed to keep a certain topological order - see [sort].
+         * [stable_sort] keeps this order too. *)
+        let acc = List.stable_sort priority_compare (List.rev acc) in
+        Lwt.return_ok acc
+    | Sort.Val (k, v) :: r ->
+        Log.debug (fun m -> m "Return a value %a." pp_value k);
+        go ctx (Edn (k, v) :: acc) r
+    | Sort.Fun (k, args, f) :: r -> (
+        Log.debug (fun m -> m "Apply a function %a." pp_value k);
+        apply ctx args f >>= function
+        | Some v -> go (add k v ctx) (Edn (k, v) :: acc) r
+        | None -> go ctx acc r)
+  in
+  let ordered_bindings = sort (Hmap.bindings ctx) in
+  go ctx [] ordered_bindings
+
+let flow_of_value :
+    type edn. edn value -> edn -> (flow, [> error ]) result Lwt.t =
+ fun k v ->
+  let open Lwt.Infix in
+  let rec go : Implicit1.pack list -> _ = function
+    | [] -> Lwt.return_error `Not_found
+    | Implicit1.Key (Protocol (k', (module Witness), (module Protocol))) :: r
+      -> (
+        match Hmap0.Key.proof k k' with
+        | None -> go r
+        | Some Teq -> (
+            Protocol.connect v >>= function
+            | Ok flow -> Lwt.return_ok (Witness.T flow)
+            | Error _err -> go r))
+  in
+  go (Implicit1.bindings ())
+
+type ('a, 'b) refl = Refl : ('a, 'a) refl
+
+let equal : type a b. a value -> b value -> (a, b) refl option =
+ fun a b ->
+  match Hmap0.Key.proof a b with Some Teq -> Some Refl | None -> None
+
+let rec connect : edn list -> (flow, [> error ]) result Lwt.t = function
+  | [] -> Lwt.return_error `Not_found
+  | Edn (k, v) :: r -> (
+      let open Lwt.Infix in
+      Log.debug (fun m -> m "Try to instantiate %a." pp_value k);
+      flow_of_value k v >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error _err -> connect r)
+
+let resolve : ctx -> (flow, [> error ]) result Lwt.t =
+ fun ctx ->
+  let open Lwt.Infix in
+  unfold ctx >>= function
+  | Ok lst ->
+      Log.debug (fun m ->
+          m "List of endpoints: @[<hov>%a@]"
+            (pp_list (fun ppf (Edn (k, _)) -> pp_value ppf k))
+            lst);
+      connect lst
+  | Error _ as err -> Lwt.return err
+
+let make ~name = Hmap0.Key.create { name; root = Value }
+let empty = Hmap.empty
+
+let get value ctx =
+  match Hmap.find value ctx with
+  | Some lst ->
+      let rec first = function
+        | [] -> None
+        | Value.Val v :: _ -> Some v
+        | _ :: r -> first r
+      in
+      first lst
+  | None -> None

unikernel/duniverse/mimic/lib/mimic.mli

@@ -0,0 +1,135 @@
+module Mirage_protocol = Mirage_protocol
+
+type flow = private ..
+(** The type for flows. A flow represents the state of a single reliable stream
+    stream that is connected to an {i endpoint}. *)
+
+include
+  Mirage_flow.S
+    with type flow := flow
+     and type error = [ `Msg of string | `Not_found | `Cycle ]
+
+type ctx
+(** The type for contexts. It's a {i heterogeneous map} of values to help mimic
+    to instantiate a new {!type:flow} {i via} {!val:resolve}. *)
+
+type 'edn value
+(** The type for {i witnesses} whose lookup value is of type ['edn]. *)
+
+module Fun : sig
+  type ('k, 'res) args =
+    | [] : ('res, 'res) args
+    | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args
+
+  and 'v arg
+
+  val req : 'a value -> 'a arg
+  val opt : 'a value -> 'a option arg
+  val dft : 'a value -> 'a -> 'a arg
+  val map : ('k, 'a) args -> 'k -> 'a arg
+end
+
+val make : name:string -> 'edn value
+(** [make ~name] is a new witness. *)
+
+val add : 'edn value -> 'edn -> ctx -> ctx
+(** [add w v ctx] is [ctx] with [w] bound to [v]. *)
+
+val get : 'edn value -> ctx -> 'edn option
+(** [get w ctx] is the value of [w]'s binding in [ctx], if any. *)
+
+val replace : 'edn value -> 'edn -> ctx -> ctx
+(** [replace w v ctx] replaces the value of [w] by [v] if it exists
+    or bound [w] to [v]. *)
+
+val fold : 'edn value -> ('k, 'edn option Lwt.t) Fun.args -> k:'k -> ctx -> ctx
+val merge : ctx -> ctx -> ctx
+
+val empty : ctx
+(** [empty] is the empty context. *)
+
+type ('edn, 'flow) protocol
+
+val register :
+  ?priority:int ->
+  name:string ->
+  (module Mirage_protocol.S with type flow = 'flow and type endpoint = 'edn) ->
+  'edn value * ('edn, 'flow) protocol
+(** [register ?priority ~name (module Protocol)] registers the given [Protocol]
+    into the internal global Mimic's state as a possible transmission protocol
+    available {i via} {!val:resolve}.
+
+    [?priority] is used to help mimic to choose between multiple solutions
+    according to the given context. Mimic will choose the lower-priority
+    solution.
+
+    [name] helps the end-user to know which solution mimic will dynamically
+    {i via} log outputs.
+
+    [register] returns 2 values:
+    - a {i witness} as the required value to initiate a transmission {i via}
+      the given [Protocol] implementation
+    - a {!type:protocol} which can help the end-user to destruct a {!type:flow}
+      to its structural type {i via} {!val:repr}. *)
+
+module type REPR = sig
+  type t type flow += (* XXX(dinosaure): private? *) T of t
+end
+
+val repr : ('edn, 'flow) protocol -> (module REPR with type t = 'flow)
+(** [repr protocol] gives a module definition with an OCaml constructor to help
+    the end-user to destruct the structural type of a given {!type:flow}:
+
+    {[
+      module Protocol
+        : Mirage_protocol.S with type flow = Lwt_unix.file_descr
+
+      let edn, protocol = Mimic.register ~name:"protocol" (module Protocol)
+      module R = (val (Mimic.repr protocol))
+
+      let () = Mimic.resolve ~ctx >>= function
+        | Ok (R.T lwt_unix_file_descr) -> ...
+        | ...
+    ]} *)
+
+val resolve : ctx -> (flow, [> error ]) result Lwt.t
+(** [resolve ctx] tries to instantiate a {!type:flow} from the given [ctx]. *)
+
+type edn =
+  | Edn : 'edn value * 'edn -> edn  (** The type of a value and its witness. *)
+
+type (_, _) refl = Refl : ('a, 'a) refl
+
+val equal : 'a value -> 'b value -> ('a, 'b) refl option
+(** [equal a b] returns a proof that [a] and [b] are
+    {i structurally} equal. *)
+
+val unfold : ctx -> (edn list, [> `Cycle ]) result Lwt.t
+(** [unfold ctx] applies any functions available into the given [ctx] and
+    and possible to compute according to available values and return a list
+    of what these functions return.
+
+    It's useful to do an introspection of what [mimic] does when it
+    {!val:resolve}s the given [ctx]. From that and {!val:equal}, the user is
+    able to introspect what [mimic] generated and which protocol it is able
+    to instantiate then.
+
+    {val:resolve} is:
+    {[
+      let resolve ctx =
+        unfold ctx >>= function
+        | Ok lst -> connect lst
+        | Error _ as err -> Lwt.return err
+    ]} *)
+
+val connect : edn list -> (flow, [> error ]) result Lwt.t
+(** [connect values] tries to instantiate a {!type:flow} from given [values]
+    and registered protocols (see {!val:register}). *)
+
+module Merge (A : sig
+  val ctx : ctx
+end) (B : sig
+  val ctx : ctx
+end) : sig
+  val ctx : ctx
+end

unikernel/duniverse/mimic/lib/mirage_protocol.ml

@@ -0,0 +1,7 @@
+module type S = sig
+  include Mirage_flow.S
+
+  type endpoint
+
+  val connect : endpoint -> (flow, write_error) result Lwt.t
+end

unikernel/duniverse/mimic/mimic-happy-eyeballs.opam

@@ -0,0 +1,22 @@
+version: "0.0.9"
+opam-version: "2.0"
+synopsis: "A happy-eyeballs integration into mimic"
+description: "A happy-eyeballs integration into mimic for MirageOS"
+maintainer: ["romain.calascibetta@gmail.com"]
+authors: "Romain Calascibetta"
+license: "ISC"
+homepage: "https://github.com/dinosaure/mimic"
+doc: "https://dinosaure.github.io/mimic/"
+bug-reports: "https://github.com/dinosaure/mimic/issues"
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.8"}
+  "mimic" {= version}
+  "happy-eyeballs-mirage" {>= "1.1.0"}
+  "dns-client-mirage" {>= "8.0.0"}
+]
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/dinosaure/mimic.git"

unikernel/duniverse/mimic/mimic.opam

@@ -0,0 +1,30 @@
+version: "0.0.9"
+opam-version: "2.0"
+synopsis: "A simple protocol dispatcher"
+description: "A middleware to dispatch protocols"
+maintainer: ["romain.calascibetta@gmail.com"]
+authors: "Romain Calascibetta"
+license: "ISC"
+homepage: "https://github.com/dinosaure/mimic"
+doc: "https://dinosaure.github.io/mimic/"
+bug-reports: "https://github.com/dinosaure/mimic/issues"
+depends: [
+  "ocaml" {>= "4.08.0"}
+  "dune" {>= "2.8"}
+  "lwt" {>= "5.3.0"}
+  "mirage-flow" {>= "4.0.0"}
+  "alcotest" {>= "1.2.3" & with-test}
+  "alcotest-lwt" {>= "1.2.3" & with-test}
+  "bigstringaf" {>= "0.7.0" & with-test}
+  "cstruct" {>= "6.0.0" & with-test}
+  "logs" {>= "0.7.0"}
+  "ke" {>= "0.4" & with-test}
+]
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+conflicts: [
+  "result" {< "1.5"}
+]
+dev-repo: "git+https://github.com/dinosaure/mimic.git"

unikernel/duniverse/mimic/mirage/dune

@@ -0,0 +1,4 @@
+(library
+ (name mimic_happy_eyeballs)
+ (public_name mimic-happy-eyeballs)
+ (libraries dns-client-mirage happy-eyeballs-mirage mimic))

unikernel/duniverse/mimic/mirage/mimic_happy_eyeballs.ml

@@ -0,0 +1,37 @@
+module type S = sig
+  type t
+  type flow
+
+  val happy_eyeballs : t Mimic.value
+
+  val resolve :
+    t ->
+    ?aaaa_timeout:int64 ->
+    ?connect_delay:int64 ->
+    ?connect_timeout:int64 ->
+    ?resolve_timeout:int64 ->
+    ?resolve_retries:int ->
+    string ->
+    int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+end
+
+module Make
+    (Stack : Tcpip.Stack.V4V6)
+    (Happy_eyeballs : Happy_eyeballs_mirage.S
+                        with type flow = Stack.TCP.flow
+                         and type stack = Stack.t)
+    (_ : Dns_client_mirage.S
+           with type happy_eyeballs = Happy_eyeballs.t
+            and type Transport.stack = Stack.t * Happy_eyeballs.t) : sig
+  include S with type t = Happy_eyeballs.t and type flow = Stack.TCP.flow
+
+  val connect : Happy_eyeballs.t -> Mimic.ctx Lwt.t
+end = struct
+  type t = Happy_eyeballs.t
+  type flow = Stack.TCP.flow
+
+  let happy_eyeballs = Mimic.make ~name:"mimic-happy-eyeballs"
+  let resolve = Happy_eyeballs.connect
+  let connect he = Lwt.return (Mimic.add happy_eyeballs he Mimic.empty)
+end

unikernel/duniverse/mimic/mirage/mimic_happy_eyeballs.mli

@@ -0,0 +1,72 @@
+module type S = sig
+  type t
+  type flow
+
+  val happy_eyeballs : t Mimic.value
+
+  val resolve :
+    t ->
+    ?aaaa_timeout:int64 ->
+    ?connect_delay:int64 ->
+    ?connect_timeout:int64 ->
+    ?resolve_timeout:int64 ->
+    ?resolve_retries:int ->
+    string ->
+    int list ->
+    ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t
+  (** [resolve happy_eyeballs domain_name ports] tries to connect the user with
+      the given endpoint. The {i domain-name} can be an IP address or a
+      {i real} domain-name. [resolve] tries to resolve {i via} a DNS request
+      the given [domain_name] if it's a real domain-name and it tries to
+      initiate a TCP/IP connection with the destination.
+
+      If it's a success, it returns the resource and the user is able to
+      [read] or [write] {i via} this resource. *)
+end
+
+(** The functor used by the MirageOS to prepare the {!Mimic.ctx} from an
+    already allocated [happy_eyeballs] resource which is able to allocate a
+    TCP/IP connection from a destination regardless the target chosen by the
+    user. *)
+module Make
+    (Stack : Tcpip.Stack.V4V6)
+    (Happy_eyeballs : Happy_eyeballs_mirage.S
+                        with type flow = Stack.TCP.flow
+                         and type stack = Stack.t)
+    (_ : Dns_client_mirage.S
+           with type happy_eyeballs = Happy_eyeballs.t
+            and type Transport.stack = Stack.t * Happy_eyeballs.t) : sig
+  include S with type t = Happy_eyeballs.t and type flow = Stack.TCP.flow
+
+  val connect : t -> Mimic.ctx Lwt.t
+  (** [connect happy_eyeballs] returns a {!Mimic.ctx} which contains an
+      {!happy_eyeballs} value which can be used and re-used by some others
+      devices which want to resolve a domain-name.
+
+      More concretely, the user is able to describe a sub-process to allocate
+      a {!type:flow} from some Mimic's values:
+      {[
+        (* main.ml, generated by the mirage tool *)
+
+        include Make (Stack) (Dns) (Happy_eyeballs)
+        let domain_name : string Mimic.value =
+          Mimic.make ~name:"domain-name"
+
+        let ctx happy_eyeballs_v =
+          let open Lwt.Infix in
+          let k0 happy_eyeballs domain_name =
+            resolve happy_eyeballs domain_name [ 80 ] >>= function
+            | Ok (_, flow) -> Lwt.return_some flow
+            | Error _ -> Lwt.return_none in
+          connect happy_eyeballs_v >|=
+          Mimic.fold edn Mimic.Fun.[ req happy_eyeballs; req domain_name ]
+            ~k:k0
+
+        (* unikernel.ml *)
+
+        let run ~ctx = Mimic.resolve ctx >>= function
+          | Ok flow -> (* ... *)
+          | Error (`Msg err) -> failwith err
+      ]}
+    *)
+end

unikernel/duniverse/mimic/test/dune

@@ -0,0 +1,24 @@
+(executable
+ (name test)
+ (libraries
+  mimic
+  mirage-flow
+  lwt
+  lwt.unix
+  logs
+  logs.fmt
+  ke
+  bigarray
+  fmt.tty
+  cstruct
+  fmt
+  alcotest
+  alcotest-lwt))
+
+(rule
+ (alias runtest)
+ (package mimic)
+ (deps
+  (:test test.exe))
+ (action
+  (run %{test} --color=always)))

unikernel/duniverse/mimic/test/test.ml

@@ -0,0 +1,311 @@
+let () = Printexc.record_backtrace true
+let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
+let () = Logs.set_level ~all:true (Some Logs.Debug)
+let () = Logs.set_reporter (Logs_fmt.reporter ~dst:Fmt.stderr ())
+
+module Memory_flow0 :
+  Mimic.Mirage_protocol.S with type endpoint = string * bytes = struct
+  type flow = {
+    mutable i : string;
+    o : bytes;
+    mutable p : int;
+    mutable c : bool;
+  }
+
+  type error = |
+  type write_error = [ `Closed ]
+
+  let pp_error : error Fmt.t = fun _ppf -> function _ -> .
+
+  let pp_write_error ppf = function
+    | `Closed -> Fmt.string ppf "!Connection closed by peer"
+
+  let read ({ i; _ } as flow) =
+    let len = min 0x1000 (String.length i) in
+    if len = 0 then (
+      flow.c <- true;
+      Lwt.return_ok `Eof)
+    else (
+      flow.i <- String.sub i len (String.length i - len);
+      Lwt.return_ok (`Data (Cstruct.of_string ~off:0 ~len i)))
+
+  let write ({ o; p = off; c; _ } as flow) cs =
+    if c then Lwt.return_error `Closed
+    else
+      let len = min (Cstruct.length cs) (Bytes.length o - off) in
+      Cstruct.blit_to_bytes cs 0 o off len;
+      if len = 0 then flow.c <- true;
+      flow.p <- flow.p + len;
+      Lwt.return_ok ()
+
+  let writev flow css =
+    let open Lwt.Infix in
+    let rec go = function
+      | [] -> Lwt.return_ok ()
+      | x :: r -> (
+          write flow x >>= function
+          | Ok () -> go r
+          | Error _ as err -> Lwt.return err)
+    in
+    go css
+
+  let close flow =
+    flow.c <- true;
+    Lwt.return ()
+
+  let shutdown flow _mode =
+    flow.c <- true;
+    Lwt.return ()
+
+  type endpoint = string * bytes
+
+  let connect (str, buf) = Lwt.return_ok { i = str; o = buf; p = 0; c = false }
+end
+
+let edn0, memory0 = Mimic.register ~name:"memory0" (module Memory_flow0)
+
+module Flow = Unixiz.Make (Mimic)
+
+let error = Alcotest.testable Flow.pp_error ( = )
+
+let recv =
+  let pp ppf = function
+    | `End_of_flow -> Fmt.string ppf "`End_of_flow"
+    | `Input len -> Fmt.pf ppf "(`Input %d)" len
+  in
+  Alcotest.testable pp ( = )
+
+let send = Alcotest.int
+
+let test_input_string =
+  Alcotest_lwt.test_case "input string" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let ctx = Mimic.add edn0 ("Hello World!", Bytes.empty) Mimic.empty in
+  Mimic.resolve ctx >>= fun flow ->
+  Alcotest.(check bool) "resolve" (Result.is_ok flow) true;
+  let flow = Flow.make (Result.get_ok flow) in
+  let buf0 = Cstruct.create 12 in
+  let buf1 = Cstruct.create 12 in
+  Flow.recv flow buf0 >>= fun res0 ->
+  Flow.recv flow buf1 >>= fun res1 ->
+  Flow.send flow (Cstruct.of_string "Hello World!") >>= fun res2 ->
+  Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 12));
+  Alcotest.(check string) "buf0" (Cstruct.to_string buf0) "Hello World!";
+  Alcotest.(check (result recv error)) "res1" res1 (Ok `End_of_flow);
+  Alcotest.(check (result send error))
+    "res2" res2
+    (Error (`Write_error `Closed));
+  Lwt.return_unit
+
+let test_output_string =
+  Alcotest_lwt.test_case "output string" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let buf = Bytes.create 12 in
+  let ctx = Mimic.add edn0 ("", buf) Mimic.empty in
+  Mimic.resolve ctx >>= fun flow ->
+  Alcotest.(check bool) "resolve" (Result.is_ok flow) true;
+  let flow = Flow.make (Result.get_ok flow) in
+  Flow.send flow (Cstruct.of_string "Hell") >>= fun res0 ->
+  Flow.send flow (Cstruct.of_string "o Wo") >>= fun res1 ->
+  Flow.send flow (Cstruct.of_string "rld!") >>= fun res2 ->
+  Flow.send flow (Cstruct.of_string "?!?!") >>= fun res3 ->
+  Flow.recv flow Cstruct.empty >>= fun res4 ->
+  Alcotest.(check (result send error)) "res0" (Ok 4) res0;
+  Alcotest.(check (result send error)) "res1" (Ok 4) res1;
+  Alcotest.(check (result send error)) "res2" (Ok 4) res2;
+  Alcotest.(check (result send error)) "res3" (Ok 4) res3;
+  (* FIXME(dinosaure) *)
+  Alcotest.(check (result recv error)) "res4" (Ok `End_of_flow) res4;
+  Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!";
+  Lwt.return_unit
+
+module Fake (Edn : sig
+  type t
+end) =
+struct
+  type error = |
+  type write_error = [ `Closed ]
+
+  let pp_error : error Fmt.t = fun _ -> function _ -> .
+
+  let pp_write_error : write_error Fmt.t =
+   fun ppf `Closed -> Fmt.string ppf "Connection closed by peer"
+
+  type flow = Edn.t and endpoint = Edn.t
+
+  let connect (edn : endpoint) = Lwt.return_ok edn
+  let read _ = Lwt.return_ok (`Data Cstruct.empty)
+  let write _ _ = Lwt.return_ok ()
+  let close _ = Lwt.return_unit
+  let shutdown _ _ = Lwt.return_unit
+  let writev _ _ = Lwt.return_ok ()
+end
+
+let edn_int, protocol_int =
+  Mimic.register ~name:"int" (module Fake (struct type t = int end))
+
+module Protocol_int = (val Mimic.repr protocol_int)
+
+let edn_string, protocol_string =
+  Mimic.register ~name:"string" (module Fake (struct type t = string end))
+
+module Protocol_string = (val Mimic.repr protocol_string)
+
+let edn_float, protocol_float =
+  Mimic.register ~name:"float" (module Fake (struct type t = float end))
+
+module Protocol_float = (val Mimic.repr protocol_float)
+
+let flow :
+    type edn flow. (edn, flow) Mimic.protocol -> Mimic.flow Alcotest.testable =
+ fun protocol ->
+  let module Repr = (val Mimic.repr protocol) in
+  let equal a b = match a, b with Repr.T a, Repr.T b -> a = b | _ -> false in
+  let pp ppf _ = Fmt.string ppf "flow" in
+  Alcotest.testable pp equal
+
+let mimic_error = Alcotest.testable Mimic.pp_error ( = )
+
+let test_values =
+  Alcotest_lwt.test_case "values" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let ctx0 = Mimic.empty |> Mimic.add edn_int 42 in
+  Mimic.resolve ctx0 >>= fun res0 ->
+  Alcotest.(check (result (flow protocol_int) mimic_error))
+    "res0" res0 (Ok (Protocol_int.T 42));
+  let ctx1 = Mimic.empty |> Mimic.add edn_string "Hello World!" in
+  Mimic.resolve ctx1 >>= fun res1 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res1" res1 (Ok (Protocol_string.T "Hello World!"));
+  let ctx2 = Mimic.empty |> Mimic.add edn_float 0.42 in
+  Mimic.resolve ctx2 >>= fun res2 ->
+  Alcotest.(check (result (flow protocol_float) mimic_error))
+    "res2" res2 (Ok (Protocol_float.T 0.42));
+  Lwt.return_unit
+
+let test_functions =
+  Alcotest_lwt.test_case "functions" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let k a b = Lwt.return_some (a + b) in
+  let ka = Mimic.make ~name:"a" and kb = Mimic.make ~name:"b" in
+  let ctx = Mimic.(fold edn_int Fun.[ req ka; req kb ] ~k Mimic.empty) in
+  let ctx = Mimic.add ka 2 ctx in
+  let ctx = Mimic.add kb 3 ctx in
+  Mimic.resolve ctx >>= fun res0 ->
+  Alcotest.(check (result (flow protocol_int) mimic_error))
+    "res0" res0 (Ok (Protocol_int.T 5));
+  let kint = Mimic.make ~name:"int" in
+  let k v = Lwt.return_some (string_of_int v) in
+  let ctx0 = Mimic.(fold edn_string Fun.[ dft kint 42 ] ~k Mimic.empty) in
+  let ctx1 = Mimic.add kint 51 ctx0 in
+  Mimic.resolve ctx0 >>= fun res1 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res1" res1 (Ok (Protocol_string.T "42"));
+  Mimic.resolve ctx1 >>= fun res2 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res2" res2 (Ok (Protocol_string.T "51"));
+  Lwt.return_unit
+
+let test_topological_sort =
+  Alcotest_lwt.test_case "topologicial" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let k v = Lwt.return_some (string_of_int v) in
+  let kint01 = Mimic.make ~name:"int01" in
+  let ctx = Mimic.empty in
+  let ctx = Mimic.(fold edn_string Fun.[ req kint01 ] ~k ctx) in
+  let kint02 = Mimic.make ~name:"int02" in
+  let k v = Lwt.return_some (succ v) in
+  let ctx = Mimic.(fold kint01 Fun.[ req kint02 ] ~k ctx) in
+  let ctx0 = Mimic.add kint01 5 ctx in
+  let ctx1 = Mimic.add kint02 4 ctx in
+  Mimic.resolve ctx0 >>= fun res0 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res0" res0 (Ok (Protocol_string.T "5"));
+  Mimic.resolve ctx1 >>= fun res1 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res1" res1 (Ok (Protocol_string.T "5"));
+  Mimic.resolve ctx >>= fun res2 ->
+  Alcotest.(check (result (flow protocol_string) mimic_error))
+    "res2" res2 (Error `Not_found);
+  Alcotest.(check (result (flow protocol_int) mimic_error))
+    "res2" res2 (Error `Not_found);
+  Lwt.return_unit
+
+let test_priority =
+  Alcotest_lwt.test_case "priority" `Quick @@ fun _sw () ->
+  let open Lwt.Infix in
+  let int_edn0, int_ptr0 =
+    Mimic.register ~priority:10 ~name:"int0"
+      (module Fake (struct type t = int end))
+  in
+  let int_edn1, int_ptr1 =
+    Mimic.register ~priority:20 ~name:"int1"
+      (module Fake (struct type t = int end))
+  in
+  let ctx0 = Mimic.empty |> Mimic.add int_edn0 1 |> Mimic.add int_edn1 2 in
+  let ctx1 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn0 1 in
+  Mimic.resolve ctx0 >>= fun res0 ->
+  Mimic.resolve ctx1 >>= fun res1 ->
+  let module Int0 = (val Mimic.repr int_ptr0) in
+  Alcotest.(check (result (flow int_ptr0) mimic_error))
+    "res0" res0 (Ok (Int0.T 1));
+  Alcotest.(check (result (flow int_ptr0) mimic_error))
+    "res1" res1 (Ok (Int0.T 1));
+  let int_edn2, _ =
+    Mimic.register ~name:"int2" (module Fake (struct type t = int end))
+  in
+  let ctx0 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn2 3 in
+  let ctx1 =
+    Mimic.empty
+    |> Mimic.add int_edn2 3
+    |> Mimic.add int_edn1 2
+    |> Mimic.add int_edn0 1
+  in
+  Mimic.resolve ctx0 >>= fun res2 ->
+  Mimic.resolve ctx1 >>= fun res3 ->
+  let module Int1 = (val Mimic.repr int_ptr1) in
+  Alcotest.(check (result (flow int_ptr1) mimic_error))
+    "res2" res2 (Ok (Int1.T 2));
+  Alcotest.(check (result (flow int_ptr0) mimic_error))
+    "res3" res3 (Ok (Int0.T 1));
+  let int_edn3, int_ptr3 =
+    Mimic.register ~priority:20 ~name:"int3"
+      (module Fake (struct type t = int end))
+  in
+  let ctx0 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn3 4 in
+  let ctx1 = Mimic.empty |> Mimic.add int_edn3 4 |> Mimic.add int_edn1 2 in
+  Mimic.resolve ctx0 >>= fun res4 ->
+  Mimic.resolve ctx1 >>= fun res5 ->
+  let module Int3 = (val Mimic.repr int_ptr3) in
+  Alcotest.(check (result (flow int_ptr3) mimic_error))
+    "res4" res4 (Ok (Int3.T 4));
+  (* XXX(dinosaure): if two roots exist, we take the most recently registered!
+     We should provide an other semantic like: the most recently inserted into the [ctx]. *)
+  Alcotest.(check (result (flow int_ptr3) mimic_error))
+    "res5" res5 (Ok (Int3.T 4));
+  Lwt.return_unit
+
+let test_order_of_values =
+  let open Lwt.Infix in
+  Alcotest_lwt.test_case "recent values" `Quick @@ fun _sw () ->
+  let int_edn, int_protocol =
+    Mimic.register ~name:"int" (module Fake (struct type t = int end))
+  in
+  let ctx = Mimic.empty |> Mimic.add int_edn 5 |> Mimic.add int_edn 6 in
+  Mimic.resolve ctx >>= fun res ->
+  let module Int = (val Mimic.repr int_protocol) in
+  Alcotest.(check (result (flow int_protocol) mimic_error))
+    "res" res (Ok (Int.T 6));
+  Lwt.return_unit
+
+let fiber =
+  Alcotest_lwt.run "mimic"
+    [
+      ( "mimic",
+        [
+          test_input_string; test_output_string; test_values; test_functions;
+          test_topological_sort; test_priority; test_order_of_values;
+        ] );
+    ]
+
+let () = Lwt_main.run fiber

unikernel/duniverse/mimic/test/unixiz.ml

@@ -0,0 +1,52 @@
+let blit0 src src_off dst dst_off len =
+  let dst = Cstruct.of_bigarray ~off:dst_off ~len dst in
+  Cstruct.blit src src_off dst 0 len
+
+let blit1 src src_off dst dst_off len =
+  let src = Cstruct.of_bigarray ~off:src_off ~len src in
+  Cstruct.blit src 0 dst dst_off len
+
+open Lwt.Infix
+
+let ( >>? ) = Lwt_result.bind
+
+module Make (Flow : Mirage_flow.S) = struct
+  type +'a fiber = 'a Lwt.t
+
+  type t = {
+    queue : (char, Bigarray.int8_unsigned_elt) Ke.Rke.t;
+    flow : Flow.flow;
+  }
+
+  type error = [ `Error of Flow.error | `Write_error of Flow.write_error ]
+
+  let pp_error ppf = function
+    | `Error err -> Flow.pp_error ppf err
+    | `Write_error err -> Flow.pp_write_error ppf err
+
+  let make flow = { flow; queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char }
+
+  let recv flow payload =
+    if Ke.Rke.is_empty flow.queue then (
+      Flow.read flow.flow >|= Result.map_error (fun err -> `Error err)
+      >>? function
+      | `Eof -> Lwt.return_ok `End_of_flow
+      | `Data res ->
+          Ke.Rke.N.push flow.queue ~blit:blit0 ~length:Cstruct.length res;
+          let len = min (Cstruct.length payload) (Ke.Rke.length flow.queue) in
+          Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.length ~off:0
+            ~len payload;
+          Ke.Rke.N.shift_exn flow.queue len;
+          Lwt.return_ok (`Input len))
+    else
+      let len = min (Cstruct.length payload) (Ke.Rke.length flow.queue) in
+      Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.length payload;
+      Ke.Rke.N.shift_exn flow.queue len;
+      Lwt.return_ok (`Input len)
+
+  let send flow payload =
+    Flow.write flow.flow payload >|= function
+    | Error `Closed -> Error (`Write_error `Closed)
+    | Error err -> Error (`Write_error err)
+    | Ok () -> Ok (Cstruct.length payload)
+end