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