├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── lib ├── dune ├── hmap.ml ├── hmap.mli ├── implicit.ml ├── implicit.mli ├── index.mld ├── mimic.ml ├── mimic.mli └── mirage_protocol.ml ├── mimic-happy-eyeballs.opam ├── mimic.opam ├── mirage ├── dune ├── mimic_happy_eyeballs.ml └── mimic_happy_eyeballs.mli └── test ├── dune ├── test.ml └── unixiz.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *~ 3 | *.install 4 | .merlin 5 | _opam 6 | .envrc 7 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.26.2 2 | module-item-spacing=compact 3 | break-struct=natural 4 | break-infix=fit-or-vertical 5 | parens-tuple=multi-line-only 6 | wrap-comments=false 7 | break-collection-expressions=wrap 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### 0.0.9 (2024-06-16) Osaka - Japon 2 | 3 | * Re-introduce the DNS stack into mimic to be able to resolve domain-names 4 | (@dinosaure, @hannesm, #24, #26, #28) 5 | 6 | ### 0.0.8 (2024-05-31) Paris - France 7 | 8 | * Upgrade `mimic-happy-eyeballs` with `happy-eyeballs.1.1.0` (@dinosaure, #22) 9 | 10 | ### 0.0.7 (2024-04-03) Paris - France 11 | 12 | * Delete `mimic_mirage` which is not used (@hannesm, #17) 13 | * Delete the `fmt` dependency (@dinosaure, #18) 14 | * Support `mirage-flow.4.0.0` (@hannesm, #20) 15 | 16 | ### 0.0.6 (2022-11-29) Paris - France 17 | 18 | * Fix typo on documentation (2fac4cc, @dinosaure) 19 | * Add `replace` function (#14, @dinosaure) 20 | * Update to `ocamlformat.0.23.0` (#15, @dinosaure) 21 | 22 | ### 0.0.5 (2022-03-24) Paris - France 23 | 24 | * Add support of OCaml 5.00.0 (#10, @dinosaure) 25 | * Add `happy-eyeballs` device for MirageOS 4 (#11, @dinosaure) 26 | * Add `{= version}` constraint on `mimic-happy-eyeballs` (@hannesm, #12) 27 | 28 | ### 0.0.4 (2021-08-12) Paris - France 29 | 30 | - Use `Cstruct.length` instead of `Cstruct.len` (@dinosaure, #2) 31 | - Remove unnucessary `bigarray-compat` dependency (@hannesm, #3) 32 | - Remove `rresult` (@hannesm, #4) 33 | - Be able to introspect values produced by mimic (@dinosaure, #5) 34 | - Improve documentation (@dinosaure, #6 & #7) 35 | 36 | ### 0.0.3 (2021-20-04) Paris - France 37 | 38 | - Move the project to https://github.com/dinosaure/mimic (@dinosaure) 39 | Old distributions of `mimic` are still available on 40 | https://github.com/mirage/ocaml-git but `mimic` starts to be 41 | used by others projects than `ocaml-git`. We decided to make 42 | its own repository. 43 | - Take the most recent value in the `ctx` instead of the older one 44 | **breaking changes** 45 | When `mimic` wants to instantiate a transmission protocol, if 46 | a value `'a Mimic.value` was inserted multiple times, `mimic` 47 | took the older one to instance the transmission protocol. 48 | 49 | Now, `mimic` takes the newer one. It useful when we want to 50 | implement the rediction in HTTP where we need to "replace" values 51 | by the new destination. 52 | 53 | ### 0.0.2 (2021-31-03) Paris - France 54 | 55 | - Add documentation (#494, @dinosaure) 56 | - Optimize projection of modules (#495, @dinosaure) 57 | - Remove `hmap` dependency (which is vendored and tweaked) 58 | (fe55e14, @dinosaure) 59 | 60 | ### 0.0.1 (2021-08-01) Paris - France 61 | 62 | - First release of `mimic` 63 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2018-2021 Romain Calascibetta 4 | 5 | Permission to use, copy, modify, and distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Mimic, a full-abstract way to instantiate a transmission protocol 2 | 3 | `mimic` is a small project which gives you the opportunity to instantiate a 4 | transmission protocol - such as a TCP/IP connection - from dynamic values. A 5 | simple tutorial is available [here][tutorial]. It explains to implement a 6 | ping-pong protocol and upgrade it to TLS. 7 | 8 | ## Some examples 9 | 10 | [git][git] or [paf][paf] are examples where they use `mimic` as the only 11 | transmission protocol implementation available. It permits to be compatible 12 | with MirageOS without the complexity of _functors_ (commonly used with 13 | [functoria][functoria] to unlock the possibility to abstract anything). 14 | 15 | ## Design 16 | 17 | `mimic` is pretty-small (~ 700 lines) and the API wants to fit into several 18 | different contexts (HTTP, [TLS][tls] or [SSH][ssh]). It's possible to make 19 | helpers from it such as some derivations for `unix` or `mirage` - as we 20 | commonly designed for [conduit][conduit]. However, with a big retro-spective, 21 | such piece of code should **not** include these derivations. 22 | 23 | Indeed, they give an opportunity to the user to assert a non-compaibility with 24 | MirageOS if you use the `unix` derivation for example. 25 | 26 | `mimic` wants to be abstract and "simple". Then, the user is able to construct 27 | something more complex and easy to use at his level - and it's what [paf][paf] 28 | does for example or [git-unix][git-unix]. 29 | 30 | ## The goal of `mimic` 31 | 32 | In the context of MirageOS which has a first stage which decides 33 | implementation of protocols according to arguments let us to provide a client 34 | which can work on many contexts: 35 | - as a simple executable which can use the host TCP/IP stack 36 | - as a full operating system which integrate its own TCP/IP stack 37 | - as something else which wants to use something else than the TCP/IP stack 38 | 39 | That mostly means that, _de facto_, we can not assert a certain implementation 40 | of the underlying transmission protocol used by a protocol such as HTTP or 41 | SMTP. This required abstraction becomes more complexe when we start to think 42 | about composition of protocols (such as TCP/IP and TLS for instance). 43 | 44 | This abstraction, in the context of a client, is not only determined by a 45 | static application of _functors_ with our implementations. It depends on an 46 | user's input value which will choose the right transmission protocol. For 47 | instance: 48 | - `git@github.com:repo/name` expects TCP/IP + SSH 49 | - `http://github.com/repo/name` expects TCP/IP + HTTP 50 | - `git://github.com/repo/name` expects TCP/IP 51 | - `https://github.com/repo/name` expects TCP/IP + TLS + HTTP 52 | 53 | `mimic` gives the opportunity to provide a full implementation of the 54 | [`Mirage_flow.S`][mirage-flow] interface and require a function to instantiate 55 | the given transmission protocol (which respects our interface). By this way and 56 | according to user's input values, `mimic` is able to choose an try to 57 | instantiate a _certain_ transmission protocol and hide it into an _not-fully_ 58 | abstracted type `Mimic.flow`. 59 | 60 | It unlock the ability to implement a protocol such as the Git protocol - or 61 | something else such as the HTTP protocol. By this way, this implementation is, 62 | _de facto_ compatible with MirageOS in any contexts. In the case of MirageOS, 63 | a simple registration of available transmission protocols _via_ 64 | [functoria][functoria] is enough. For a more concrete usage such as the Unix 65 | usage, a derivation of your protocol with `unix` and a registration by 66 | default of some transmission protocols is enough too. The main difference is: 67 | - one is leaded by arguments of the user (and `functoria`) 68 | - the second is established by the developer 69 | 70 | ### The result of the mimic's usage 71 | 72 | More practically, in the MirageOS world, a _device_ **can not** provide _via_ 73 | its interface the `connect` function but it must implement it let write the 74 | `functoria` glue to to let it to call the `connect` function with available 75 | arguments (from the command-line). 76 | 77 | For instance, a device can be described with this interface: 78 | ```ocaml 79 | module type S = sig 80 | type t 81 | 82 | val read : t -> buffer 83 | val write : t -> buffer -> unit 84 | end 85 | ``` 86 | 87 | And its implementation can be described with: 88 | ```ocaml 89 | module TCP : sig 90 | include S 91 | 92 | val connect : ipv4 -> t 93 | end 94 | ``` 95 | 96 | That mostly mean that, inside the `unikernel.ml` which is your application, you 97 | don't have an access to the `connect` function: 98 | ```ocaml 99 | module Make (My_device : Device.S) = struct 100 | let start (t : My_device.t) = 101 | ... 102 | end 103 | ``` 104 | 105 | A _hot-connect_ can not be available into the interface for a specific reason: 106 | the abstraction. Arguments required to `connect`/allocate a resource which 107 | represents our device depend on the implementation. As we said earlier, 108 | `ocaml-tls` expects a `Tls.Config.client` where `Lwt_ssl` expects an 109 | `Ssl.context`. It can be difficult to shape these values into an ultimate type 110 | (which is, of course, non-exhaustive from possible TLS implementations). 111 | 112 | Mimic wants to provide this _hot-connect_ function into your application 113 | (inside the `unikernel.ml`) without a static dependency to `ocaml-tls` or 114 | `lwt_ssl` _à priori_. Then, the `functoria`/`mirage` tool will choose right 115 | dependency according to the command-line invokation and produce the glue needed 116 | to be able to _hot-connect_ a TLS connection over TCP/IP. 117 | 118 | ## Reverse dependencies 119 | 120 | `mimic` must be thought according to who use it. The API is not designed to be 121 | canonic and usable as is. It has been thought to unlock the full abstraction 122 | and the compatibility with MirageOS for others projects. 123 | 124 | If you think that you can have an usage of `mimic` and something is missing, 125 | you should implement what you want **outside** `mimic`. 126 | 127 | ## The `Mirage_flow.S` interface 128 | 129 | Finally, the only assumption about design of protocols, transmission protocols, 130 | etc. is `Mirage_flow.S`. Several issues exist about this interface but the cost 131 | to upgrade the interface (to be unix-friendly for example) is huge when 132 | several MirageOS projects trust on this specific interface. 133 | 134 | ## Documentation 135 | 136 | `mimic` can be hard to explain when we don't know all details about the 137 | MirageOS eco-system. The existence of this project can be critized when we 138 | don't really understand all details and how this project fits in. 139 | 140 | The documentation is not very clear and does not explain the big-picture of 141 | `mimic`. So it's a real issue and the [tutorial][tutorial] wants to fix it but 142 | my lack of English does not help me. 143 | 144 | [tutorial]: https://dinosaure.github.io/mimic/ 145 | [git]: https://github.com/mirage/ocaml-git 146 | [paf]: https://github.com/mirage/paf-le-chien 147 | [functoria]: https://github.com/mirage/mirage 148 | [tls]: https://github.com/mirleft/ocaml-tls 149 | [ssh]: https://github.com/mirage/awa-ssh 150 | [git-unix]: https://github.com/mirage/ocaml-git 151 | [mirage-flow]: https://github.com/mirage/mirage-flow 152 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name mimic) 3 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mimic) 3 | (public_name mimic) 4 | (modules hmap implicit mirage_protocol mimic) 5 | (libraries logs mirage-flow lwt)) 6 | 7 | (documentation 8 | (package mimic) 9 | (mld_files index)) 10 | -------------------------------------------------------------------------------- /lib/hmap.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Type identifiers. 8 | See http://alan.petitepomme.net/cwn/2015.03.24.html#1 *) 9 | 10 | module Tid = struct type _ t = .. end 11 | 12 | module type Tid = sig 13 | type t type _ Tid.t += Tid : t Tid.t 14 | end 15 | 16 | type 'a tid = (module Tid with type t = 'a) 17 | 18 | let tid () (type s) = 19 | let module M = struct type t = s type _ Tid.t += Tid : t Tid.t end in 20 | (module M : Tid with type t = s) 21 | 22 | type ('a, 'b) teq = Teq : ('a, 'a) teq 23 | 24 | let eq : type r s. r tid -> s tid -> (r, s) teq option = 25 | fun r s -> 26 | let module R = (val r : Tid with type t = r) in 27 | let module S = (val s : Tid with type t = s) in 28 | match R.Tid with S.Tid -> Some Teq | _ -> None 29 | 30 | (* Heterogeneous maps *) 31 | 32 | module type KEY_INFO = sig 33 | type 'a t 34 | end 35 | 36 | module type VALUE_INFO = sig 37 | type 'a t 38 | end 39 | 40 | module type S = sig 41 | type 'a key 42 | 43 | module Key : sig 44 | type 'a info 45 | 46 | val create : 'a info -> 'a key 47 | val info : 'a key -> 'a info 48 | 49 | type t 50 | 51 | val hide_type : 'a key -> t 52 | val equal : t -> t -> bool 53 | val compare : t -> t -> int 54 | val proof : 'a key -> 'b key -> ('a, 'b) teq option 55 | end 56 | 57 | module Make (Value_info : VALUE_INFO) : sig 58 | type 'a value = 'a Value_info.t 59 | type t 60 | 61 | val empty : t 62 | val is_empty : t -> bool 63 | val mem : 'a key -> t -> bool 64 | val add : 'a key -> 'a value -> t -> t 65 | val singleton : 'a key -> 'a value -> t 66 | val rem : 'a key -> t -> t 67 | val find : 'a key -> t -> 'a value option 68 | val get : 'a key -> t -> 'a value 69 | 70 | type binding = B : 'a key * 'a value -> binding 71 | 72 | val iter : (binding -> unit) -> t -> unit 73 | val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a 74 | val for_all : (binding -> bool) -> t -> bool 75 | val exists : (binding -> bool) -> t -> bool 76 | val filter : (binding -> bool) -> t -> t 77 | val cardinal : t -> int 78 | val any_binding : t -> binding option 79 | val get_any_binding : t -> binding 80 | val bindings : t -> binding list 81 | 82 | type merge = { 83 | f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; 84 | } 85 | 86 | val merge : merge -> t -> t -> t 87 | end 88 | end 89 | 90 | module Make (Key_info : KEY_INFO) : S with type 'a Key.info = 'a Key_info.t = 91 | struct 92 | (* Keys *) 93 | 94 | module Key = struct 95 | type 'a info = 'a Key_info.t 96 | type 'a key = { uid : int; tid : 'a tid; info : 'a Key_info.t } 97 | 98 | let uid = 99 | let id = ref (-1) in 100 | fun () -> 101 | incr id; 102 | !id 103 | 104 | let create info = 105 | let uid = uid () in 106 | let tid = tid () in 107 | { uid; tid; info } 108 | 109 | let info k = k.info 110 | 111 | type t = V : 'a key -> t 112 | 113 | let hide_type k = V k 114 | let equal (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid = 0 115 | let compare (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid 116 | let proof k0 k1 = eq k0.tid k1.tid 117 | end 118 | 119 | type 'a key = 'a Key.key 120 | 121 | module Make (Value_info : VALUE_INFO) = struct 122 | type 'a value = 'a Value_info.t 123 | 124 | (* Maps *) 125 | 126 | module M = Map.Make (Key) 127 | 128 | type binding = B : 'a key * 'a value -> binding 129 | type t = binding M.t 130 | 131 | let empty = M.empty 132 | let is_empty = M.is_empty 133 | let mem k m = M.mem (Key.V k) m 134 | let add k v m = M.add (Key.V k) (B (k, v)) m 135 | let singleton k v = M.singleton (Key.V k) (B (k, v)) 136 | let rem k m = M.remove (Key.V k) m 137 | 138 | let find : type a. a key -> t -> a value option = 139 | fun k s -> 140 | try 141 | match M.find (Key.V k) s with 142 | | B (k', v) -> ( 143 | match eq k.Key.tid k'.Key.tid with 144 | | None -> None 145 | | Some Teq -> Some v) 146 | with Not_found -> None 147 | 148 | let get k s = 149 | match find k s with 150 | | None -> invalid_arg "key not found in map" 151 | | Some v -> v 152 | 153 | let iter f m = M.iter (fun _ b -> f b) m 154 | let fold f m acc = M.fold (fun _ b acc -> f b acc) m acc 155 | let for_all p m = M.for_all (fun _ b -> p b) m 156 | let exists p m = M.exists (fun _ b -> p b) m 157 | let filter p m = M.filter (fun _ b -> p b) m 158 | let cardinal m = M.cardinal m 159 | let any_binding m = try Some (snd (M.choose m)) with Not_found -> None 160 | 161 | type merge = { 162 | f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; 163 | } 164 | 165 | let merge : merge -> t -> t -> t = 166 | fun { f } t0 t1 -> 167 | let f (Key.V k) a b = 168 | match a, b with 169 | | Some (B (k0, v)), None -> ( 170 | match Key.proof k k0 with 171 | | Some Teq -> Option.map (fun v -> B (k, v)) (f k (Some v) None) 172 | | None -> Option.map (fun v -> B (k, v)) (f k None None)) 173 | | None, Some (B (k0, v)) -> ( 174 | match Key.proof k k0 with 175 | | Some Teq -> Option.map (fun v -> B (k, v)) (f k None (Some v)) 176 | | None -> Option.map (fun v -> B (k, v)) (f k None None)) 177 | | Some (B (k0, v0)), Some (B (k1, v1)) -> ( 178 | match Key.proof k k0, Key.proof k k1 with 179 | | Some Teq, Some Teq -> 180 | Option.map (fun v -> B (k, v)) (f k (Some v0) (Some v1)) 181 | | Some Teq, None -> 182 | Option.map (fun v -> B (k, v)) (f k (Some v0) None) 183 | | None, Some Teq -> 184 | Option.map (fun v -> B (k, v)) (f k None (Some v1)) 185 | | None, None -> Option.map (fun v -> B (k, v)) (f k None None)) 186 | | None, None -> Option.map (fun v -> B (k, v)) (f k None None) 187 | in 188 | M.merge f t0 t1 189 | 190 | let get_any_binding m = 191 | try snd (M.choose m) with Not_found -> invalid_arg "empty map" 192 | 193 | let bindings m = List.map snd (M.bindings m) 194 | end 195 | end 196 | 197 | (*--------------------------------------------------------------------------- 198 | Copyright (c) 2016 Daniel C. Bünzli 199 | 200 | Permission to use, copy, modify, and/or distribute this software for any 201 | purpose with or without fee is hereby granted, provided that the above 202 | copyright notice and this permission notice appear in all copies. 203 | 204 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 205 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 206 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 207 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 208 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 209 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 210 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 211 | ---------------------------------------------------------------------------*) 212 | -------------------------------------------------------------------------------- /lib/hmap.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Heterogeneous value maps. 8 | 9 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 10 | 11 | (** {1:func Functorial interface} 12 | 13 | The functorial interface allows to associate more information to the 14 | keys. For example a key name or a key value pretty-printer. *) 15 | 16 | (** The type for key information. *) 17 | module type KEY_INFO = sig 18 | type 'a t 19 | (** The type for key information. *) 20 | end 21 | 22 | module type VALUE_INFO = sig 23 | type 'a t 24 | (** The type for value information. *) 25 | end 26 | 27 | type ('a, 'b) teq = Teq : ('a, 'a) teq 28 | 29 | (** Output signature of the functor {!Make} *) 30 | module type S = sig 31 | (** {1:keys Keys} *) 32 | 33 | type 'a key 34 | (** The type for keys whose lookup value is of type ['a]. *) 35 | 36 | (** Keys. *) 37 | module Key : sig 38 | (** {1:keys Keys} *) 39 | 40 | type 'a info 41 | (** The type for key information. *) 42 | 43 | val create : 'a info -> 'a key 44 | (** [create i] is a new key with information [i]. *) 45 | 46 | val info : 'a key -> 'a info 47 | (** [info k] is [k]'s information. *) 48 | 49 | (** {1:exists Existential keys} 50 | 51 | Exisential keys allow to compare keys. This can be useful for 52 | functions like {!filter}. *) 53 | 54 | type t 55 | (** The type for existential keys. *) 56 | 57 | val hide_type : 'a key -> t 58 | (** [hide_type k] is an existential key for [k]. *) 59 | 60 | val equal : t -> t -> bool 61 | (** [equal k k'] is [true] iff [k] and [k'] are the same key. *) 62 | 63 | val compare : t -> t -> int 64 | (** [compare k k'] is a total order on keys compatible with {!equal}. *) 65 | 66 | val proof : 'a key -> 'b key -> ('a, 'b) teq option 67 | end 68 | 69 | module Make (Value_info : VALUE_INFO) : sig 70 | type 'a value = 'a Value_info.t 71 | (** The type for values. *) 72 | 73 | (** {1:maps Maps} *) 74 | 75 | type t 76 | (** The type for heterogeneous value maps. *) 77 | 78 | val empty : t 79 | (** [empty] is the empty map. *) 80 | 81 | val is_empty : t -> bool 82 | (** [is_empty m] is [true] iff [m] is empty. *) 83 | 84 | val mem : 'a key -> t -> bool 85 | (** [mem k m] is [true] iff [k] is bound in [m]. *) 86 | 87 | val add : 'a key -> 'a value -> t -> t 88 | (** [add k v m] is [m] with [k] bound to [v]. *) 89 | 90 | val singleton : 'a key -> 'a value -> t 91 | (** [singleton k v] is [add k v empty]. *) 92 | 93 | val rem : 'a key -> t -> t 94 | (** [rem k m] is [m] with [k] unbound. *) 95 | 96 | val find : 'a key -> t -> 'a value option 97 | (** [find k m] is the value of [k]'s binding in [m], if any. *) 98 | 99 | val get : 'a key -> t -> 'a value 100 | (** [get k m] is the value of [k]'s binding in [m]. 101 | 102 | @raise Invalid_argument if [k] is not bound in [m]. *) 103 | 104 | (** The type for bindings. *) 105 | type binding = B : 'a key * 'a value -> binding 106 | 107 | val iter : (binding -> unit) -> t -> unit 108 | (** [iter f m] applies [f] to all bindings of [m]. *) 109 | 110 | val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a 111 | (** [fold f m acc] folds over the bindings of [m] with [f], starting with 112 | [acc] *) 113 | 114 | val for_all : (binding -> bool) -> t -> bool 115 | (** [for_all p m] is [true] iff all bindings of [m] satisfy [p]. *) 116 | 117 | val exists : (binding -> bool) -> t -> bool 118 | (** [exists p m] is [true] iff there exists a bindings of [m] that 119 | satisfies [p]. *) 120 | 121 | val filter : (binding -> bool) -> t -> t 122 | (** [filter p m] are the bindings of [m] that satisfy [p]. *) 123 | 124 | val cardinal : t -> int 125 | (** [cardinal m] is the number of bindings in [m]. *) 126 | 127 | val any_binding : t -> binding option 128 | (** [any_binding m] is a binding of [m] (if not empty). *) 129 | 130 | val get_any_binding : t -> binding 131 | (** [get_any_binding m] is a binding of [m]. 132 | 133 | @raise Invalid_argument if [m] is empty. *) 134 | 135 | val bindings : t -> binding list 136 | 137 | type merge = { 138 | f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; 139 | } 140 | 141 | val merge : merge -> t -> t -> t 142 | end 143 | end 144 | 145 | (** Functor for heterogeneous maps whose keys hold information 146 | of type [Key_info.t] *) 147 | module Make : functor (Key_info : KEY_INFO) -> 148 | S with type 'a Key.info = 'a Key_info.t 149 | 150 | (*--------------------------------------------------------------------------- 151 | Copyright (c) 2016 Daniel C. Bünzli 152 | 153 | Permission to use, copy, modify, and/or distribute this software for any 154 | purpose with or without fee is hereby granted, provided that the above 155 | copyright notice and this permission notice appear in all copies. 156 | 157 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 158 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 159 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 160 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 161 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 162 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 163 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 164 | ---------------------------------------------------------------------------*) 165 | -------------------------------------------------------------------------------- /lib/implicit.ml: -------------------------------------------------------------------------------- 1 | (* (c) Frédéric Bour 2 | * (c) Romain Calascibetta 3 | *) 4 | 5 | module Tbl = struct 6 | (* XXX(dinosaure): [Tbl] is a small re-implementation 7 | * of [Hashtbl] where [find_all] is needed by [prj]. To 8 | * avoid an allocation of an intermediate list, we directly 9 | * use the underlying linked-list to do the projection. 10 | * 11 | * This implementation wants to be: 12 | * - deterministic (seed = 0) 13 | * - fast 14 | * 15 | * Memoization is done by [last_k]/[last_v] where the common use 16 | * of [Conduit] is a loop with multiple calls of [send]/[recv] 17 | * with the same [flow] value. 18 | *) 19 | 20 | type 'v t = { 21 | mutable size : int; 22 | mutable data : 'v lst array; 23 | mutable last_k : int; 24 | mutable last_v : 'v; 25 | } 26 | 27 | and 'v lst = Empty | Cons of { key : int; data : 'v; mutable next : 'v lst } 28 | 29 | let rec power_2_above x n = 30 | if x >= n then x 31 | else if x * 2 > Sys.max_array_length then x 32 | else power_2_above (x * 2) n 33 | 34 | let create ~epsilon size = 35 | let size = power_2_above 16 size in 36 | { size = 0; data = Array.make size Empty; last_k = 0; last_v = epsilon } 37 | 38 | external caml_hash : int -> int -> int -> 'a -> int = "caml_hash" [@@noalloc] 39 | 40 | let hash v = caml_hash 10 100 0 v 41 | 42 | let resize t = 43 | let old_data = t.data in 44 | let old_size = Array.length old_data in 45 | let new_size = old_size * 2 in 46 | if new_size < Sys.max_array_length then ( 47 | let new_data = Array.make new_size Empty in 48 | let new_data_tail = Array.make new_size Empty in 49 | t.data <- new_data; 50 | let rec insert = function 51 | | Empty -> () 52 | | Cons { key; next; _ } as cell -> 53 | let new_idx = hash key land (new_size - 1) in 54 | (match new_data_tail.(new_idx) with 55 | | Empty -> new_data.(new_idx) <- cell 56 | | Cons tail -> tail.next <- cell); 57 | new_data_tail.(new_idx) <- cell; 58 | insert next 59 | in 60 | for i = 0 to old_size - 1 do 61 | insert old_data.(i) 62 | done; 63 | for i = 0 to new_size - 1 do 64 | match new_data_tail.(i) with 65 | | Empty -> () 66 | | Cons tail -> tail.next <- Empty 67 | done) 68 | 69 | let add t key data = 70 | let i = hash key land (Array.length t.data - 1) in 71 | let v = Cons { key; data; next = t.data.(i) } in 72 | t.data.(i) <- v; 73 | t.size <- t.size + 1; 74 | if t.size > Array.length t.data lsl 1 then resize t 75 | end 76 | 77 | module type KEY_INFO = sig 78 | type 'a t 79 | end 80 | 81 | module Make (Key_info : KEY_INFO) = struct 82 | type t = .. 83 | type 'a key = 'a Key_info.t 84 | 85 | module type WITNESS = sig 86 | type a 87 | type t += T of a 88 | 89 | val key : a key 90 | end 91 | 92 | type 'a witness = (module WITNESS with type a = 'a) 93 | type pack = Key : 'a key -> pack 94 | type value = Value : 'a * 'a key -> value 95 | 96 | let epsilon _ = raise_notrace Not_found 97 | let handlers = Tbl.create ~epsilon 0x10 98 | let keys = Hashtbl.create 0x10 99 | 100 | module Injection (M : sig 101 | type t 102 | 103 | val key : t key 104 | end) : WITNESS with type a = M.t = struct 105 | type a = M.t 106 | type t += T of a 107 | 108 | let key = M.key 109 | let handler = function T a -> Value (a, key) | _ -> raise Not_found 110 | 111 | let () = 112 | let[@warning "-3"] uid = 113 | Stdlib.Obj.Extension_constructor.id [%extension_constructor T] 114 | in 115 | Tbl.add handlers uid handler; 116 | Hashtbl.add keys uid (Key key) 117 | end 118 | 119 | let inj (type a) (key : a key) : a witness = 120 | (module Injection (struct 121 | type t = a 122 | 123 | let key = key 124 | end)) 125 | 126 | (* XXX(dinosaure): we ensure that a value [t : t] must have an implementation 127 | * availble into [handlers]. By this way, 128 | * [let[@warning "-8"] Tbl.Cons _ = lst in] is safe where we must find an 129 | * implementation. 130 | *) 131 | 132 | let rec iter t uid lst = 133 | let[@warning "-8"] (Tbl.Cons { key = k; data = f; next = r; _ }) = lst in 134 | try 135 | if uid <> k then raise_notrace Not_found; 136 | handlers.Tbl.last_v <- f; 137 | f t 138 | with _ -> (iter [@tailcall]) t uid r 139 | 140 | let prj t = 141 | let arr = handlers.Tbl.data in 142 | let uid = Stdlib.Obj.Extension_constructor.(id (of_val t)) in 143 | if handlers.Tbl.last_k == uid then handlers.Tbl.last_v t 144 | else 145 | let res = iter t uid arr.(Tbl.hash uid land (Array.length arr - 1)) in 146 | handlers.Tbl.last_k <- uid; 147 | res 148 | 149 | let bindings () = Hashtbl.fold (fun _ v a -> v :: a) keys [] 150 | end 151 | -------------------------------------------------------------------------------- /lib/implicit.mli: -------------------------------------------------------------------------------- 1 | module type KEY_INFO = sig 2 | type 'a t 3 | end 4 | 5 | module Make (Key_info : KEY_INFO) : sig 6 | type t = private .. 7 | type 'a key = 'a Key_info.t 8 | 9 | module type WITNESS = sig 10 | type a 11 | type t += T of a 12 | 13 | val key : a key 14 | end 15 | 16 | type 'a witness = (module WITNESS with type a = 'a) 17 | type pack = Key : 'a key -> pack 18 | type value = Value : 'a * 'a key -> value 19 | 20 | val inj : 'a key -> 'a witness 21 | val prj : t -> value 22 | val bindings : unit -> pack list 23 | end 24 | -------------------------------------------------------------------------------- /lib/index.mld: -------------------------------------------------------------------------------- 1 | {1 Mimic, a small library to abstract transmission protocols.} 2 | 3 | {2 Introduction.} 4 | 5 | Mimic is a very small library that offers a re-implementation of virtual 6 | methods for modules. In a large project such as Git or Irmin, keeping in mind 7 | the system abstraction required to be compatible with MirageOS, one question 8 | transcends all levels: 9 | 10 | {v > How to abstract the network? v} 11 | 12 | In the specific context of Unix/[], several functions exist to 13 | communicate across the network. In particular the idea of a {e socket}. For 14 | most projects, the {e socket} seems to be the common denominator for all 15 | transmissions. 16 | 17 | In the case of Git, the {e socket} can represent a simple TCP/IP connection or 18 | a transmission through SSH (using a pipe). For HTTP with TLS, the principle 19 | remains the same as long as OpenSSL proposes an equivalent of the {e socket} 20 | through a derivation of the TCP/IP socket. 21 | 22 | As a proof, [Lwt_ssl] proposes this same derivation: 23 | 24 | {[ 25 | Lwt_ssl.embed_socket : Lwt_unix.file_descr -> Ssl.context -> Lwt_ssl.socket 26 | ]} 27 | 28 | In any case, it seems that the {e socket} principle itself is the common 29 | denominator to protocols like Git, HTTP or SMTP. 30 | 31 | It happens that MirageOS offers an interface that describes this {e socket}: 32 | 33 | {[ 34 | sig 35 | type error 36 | type write_error = private [> `Closed ] 37 | 38 | val pp_error : Format.formatter -> error -> unit 39 | val pp_write_error : Format.formatter -> write_error -> unit 40 | 41 | type flow 42 | 43 | val read : flow -> (Cstruct.t or_eof, error) result Lwt.t 44 | val write : flow -> Cstruct.t -> (unit, error) result Lwt.t 45 | val writev : flow -> Cstruct.t list -> (unit, error) result Lwt.t 46 | val close : flow -> unit Lwt.t 47 | end 48 | ]} 49 | 50 | {b NOTE:} [read] is a method that diverges from the [read]/[recv] we're used 51 | to seeing with [] where the latter requests a buffer to write to. 52 | Historically, the idea of [Mirage_flow.S.read] gives the ability to implement 53 | a {e zero-copy} stack. Indeed, the [Cstruct.t] that is returned could directly 54 | be the memory page having the TCP/IP packet. Thus, between the TCP/IP driver 55 | (the implementation) and the client application, there should be no allocation. 56 | However: 57 | - it is not known if this assertion is still true 58 | - it doesn't correspond to anything real for TLS (where there is necessarily a 59 | copy) 60 | 61 | With this interface, it can be possible to abstract the socket for protocols 62 | like HTTP, Git/Smart or SMTP such as: 63 | 64 | {[ 65 | module SMTP = Make_SMTP (Tcpip_stack_direct.TCP : Mirage_flow.S) 66 | module HTTP = Make_HTTP (Tcpip_stack_direct.TCP : Mirage_flow.S) 67 | module Smart = Make_Smart (Tcpip_stack_direct.TCP : Mirage_flow.S) 68 | ]} 69 | 70 | It turns out that [ocaml-tls] offers a derivation from a given {e socket} 71 | described through [Mirage_flow.S] to a "new" {e socket} with TLS: 72 | 73 | {[ 74 | Tls_mirage.Make : functor (_ : Mirage_flow.S) -> Mirage_flow.S 75 | ]} 76 | 77 | Therefore, it is possible to upgrade our protocols {b statically} with a TLS 78 | layer quite easily: 79 | 80 | {[ 81 | module TLS = Tls_mirage.Make (Tcpip_stack_direct.TCP) 82 | 83 | module SSMTP = Make_SMTP (TLS) 84 | module HTTPS = Make_HTTP (TLS) 85 | ]} 86 | 87 | The problem with this kind of abstraction is the eminently static aspect of 88 | this code. Indeed, the choice between SMTP and SSMTP (HTTP or HTTPS) cannot be 89 | made when choosing statically these modules. 90 | 91 | This implies that if the type of transmission depends on a value such as an 92 | [Uri.t] (and its {e scheme}), we need to have access to these 2 modules 93 | throughout our process. 94 | 95 | Especially since [SSMTP] or [HTTPS] are themselves directed by an arbitrary 96 | choice which is to use [ocaml-tls] instead of OpenSSL. It may be essential to 97 | let the user choose his TLS implementation. 98 | 99 | We would therefore need: 100 | + a functor for the TCP/IP stack (required for MirageOS) 101 | + a functor that is itself a functor waiting for our common denominator, 102 | the socket, and that can derive it into a TLS transmission 103 | 104 | {[ 105 | module type Make_SMTP = 106 | functor (Socket : Mirage_flow.S) -> 107 | functor (Tls : functor (Socket : Mirage_flow.S) -> Mirage_flow.S) -> 108 | sig ... end 109 | ]} 110 | 111 | Thus, we ensure: 112 | + the possibility to {b statically} choose the TCP/IP stack 113 | + the possibility to {b statically} choose the implementation of the TLS layer 114 | + a way to communicate with TCP/IP within our [Make] 115 | + a way to communicate with TLS within our [Make] 116 | + to propose a function making the {b dynamic} choice between these 2 types 117 | of transmission 118 | 119 | {[ 120 | module Make_HTTP (Socket : _) (Tls : _) = struct 121 | module Tls = Tls (Socket) 122 | 123 | let connect uri = match Uri.scheme with 124 | | Some "https" -> Tls.connect ... 125 | | Some "http" -> Socket.connect ... 126 | end 127 | ]} 128 | 129 | The problem remains in any case the eminently dynamic aspect of the choice of 130 | the transmission protocol which requires a static knowledge of what is a 131 | {e socket} and what is a {e socket} with TLS. The problem applies as much for 132 | Git with SSH. 133 | 134 | This static knowledge required of the modules implementing the {e socket} as 135 | well as its possible derivation into a TLS {e socket} puts us in a difficult 136 | position when we want to keep the abstraction power of the functors to be 137 | compatible with MirageOS - in which neither the TCP/IP nor the TLS 138 | implementation can be known globally in advance (in other words, their 139 | implementations can only be obtained through a functor). 140 | 141 | In MirageOS, all this complexity of the functors can be reduced with the help 142 | of [functoria] which allows to apply the functors cleanly according to the 143 | target. For the example, the TCP/IP stack depends on the target at all since 144 | with [mirage configure -t unix], we use the host system stack but for 145 | [mirage configure -t hvt], we use [mirage-tcpip]. 146 | 147 | Unfortunately, this implies to "keep" this level of abstraction for all 148 | libraries depending on our SMTP/HTTP/Smart implementation if they want to keep 149 | the compatibility with MirageOS. 150 | 151 | A "shift" on the functors then occurs systematically which leads to an 152 | exponential progression of the number of functors as one advances from layer to 153 | layer. 154 | 155 | For example, Irmin with Git will have to integrate at the same time: 156 | - a functor for the TCP/IP stack 157 | - a functor for TLS (which itself is a functor on the TCP/IP stack) 158 | - a functor for the HTTP stack which is a functor on the TCP/IP and the TLS 159 | stack 160 | - a functor for SSH which itself is a functor on the TCP/IP stack 161 | - and we are talking about communication (you can include the hash algorithm, 162 | the format of your values, etc.) 163 | 164 | It is only through all of these functors that we can: 165 | + be perfectly abstract 166 | + always be able to propose a "dispatch" of these protocols in a dynamic way 167 | + never arbitrarily choose an implementation or more specifically a type 168 | representing these {e sockets} 169 | 170 | {2 The solution.} 171 | 172 | After this "brief" introduction, it is now time to talk about the solution! But 173 | it seems clear that if we wanted to essentialize the problem, it would simply 174 | be to say: 175 | 176 | {v > how to get a protocol implementation dynamically and without functors? v} 177 | 178 | In the previous explanations we mentioned [Mirage_flow.S]. It turns out that it 179 | is canonical to any transmission protocol. It allows to describe the TCP/IP 180 | protocol, the TCP/IP protocol with TLS or the SSH protocol because in these 3 181 | cases, we only want to: 182 | - read 183 | - and write 184 | 185 | The abstraction does not work however when it comes to instantiating the 186 | {e socket}. Indeed, a TCP/IP transmission only requires an IP address and a 187 | port. However, SSH requires much more such as an RSA key. 188 | 189 | Conduit 2.0 assumes that these instantiation methods must be known statically. 190 | An ADT describes these methods and if it is not exhaustive, it corresponds to 191 | the usual cases such as HTTPS or SSMTP. 192 | 193 | However, we could also say that for protocols like SSMTP or HTTPS (or SMTP or 194 | HTTP), these instantiation methods are not our concern. Again, we would just 195 | like to be able to read and write. 196 | 197 | {2 Implement a protocol with mimic.} 198 | 199 | In the end, mimic provides an implementation of [Mirage_flow.S] that is 200 | directly usable without functors. So we will start implementating a simple 201 | protocol, a ping-pong to show how to implement a protocol (like HTTP, SMTP or 202 | Smart) with mimic. 203 | 204 | {[ 205 | open Rresult 206 | open Lwt.Infix 207 | 208 | let ( >>? ) = Lwt_result.bind 209 | 210 | let blit src src_off dst dst_off len = 211 | Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len 212 | 213 | let line_of_queue queue = 214 | let exists ~p queue = 215 | let pos = ref 0 and res = ref (-1) in 216 | Ke.Rke.iter (fun chr -> if p chr && !res = -1 then res := !pos 217 | ; incr pos) queue ; 218 | if !res = -1 then None else Some !res in 219 | match exists ~p:((=) '\n') queue with 220 | | None -> None 221 | | Some 0 -> Ke.Rke.N.shift_exn queue 1 ; Some "" 222 | | Some pos -> 223 | let tmp = Bytes.create pos in 224 | Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ; 225 | Ke.Rke.N.shift_exn queue (pos + 1) ; 226 | match Bytes.get tmp (pos - 1) with 227 | | '\r' -> Some (Bytes.sub_string tmp 0 (pos - 1)) 228 | | _ -> Some (Bytes.unsafe_to_string tmp) 229 | 230 | let blit src src_off dst dst_off len = 231 | let src = Cstruct.to_bigarray src in 232 | Bigstringaf.blit src ~src_off dst ~dst_off ~len 233 | 234 | let rec getline flow queue = match line_of_queue queue with 235 | | Some line -> Lwt.return_ok (`Line line) 236 | | None -> 237 | Mimic.read flow >>= function 238 | | Ok `Eof -> Lwt.return_ok `Close 239 | | Ok (`Data v) -> 240 | Ke.Rke.N.push queue ~blit ~length:Cstruct.length ~off:0 v ; 241 | getline flow queue 242 | | Error err -> Lwt.return_error (R.msgf "%a" Mimic.pp_error err) 243 | 244 | let sendline flow fmt = 245 | let send str = 246 | Mimic.write flow (Cstruct.of_string str) >>= function 247 | | Ok _ as v -> Lwt.return v 248 | | Error err -> Lwt.return_error (R.msgf "%a" Mimic.pp_write_error err) in 249 | Fmt.kstr send (fmt ^^ "\r\n") 250 | ]} 251 | 252 | This code is quite simple. It implements logic that is usually available with a 253 | standard library. Of course, [Mirage_flow.S] does not give us these functions 254 | (but [Mirage_channel] does). 255 | 256 | These logics are the protocol as we can define it. For example, SMTP or HTTP 257 | could be implemented with these functions. As for Smart, it's another matter 258 | since it uses another format - or rather, this protocol is not "line-directed". 259 | 260 | But what is most important is the possibility to directly implement a protocol 261 | without using a functor to abstract the implementation of the transmission. In 262 | this sense, mimic could very well be TCP/IP than TLS or SSH. At this stage, 263 | we don't know and that's the point! 264 | 265 | You can compile the code with: 266 | {[ 267 | $ ocamlfind opt -linkpkg -package rresult,lwt,mimic,bigstringaf,cstruct,ke \ 268 | main.ml 269 | ]} 270 | 271 | Once again, we can denote the dependencies necessary for compilation. There is 272 | no question of [unix]. At the beginning of this explanation, we talked about 273 | [] as the common denominator to get our {e socket}. Here we are 274 | saying that our {e socket} {b is} mimic. Of course, mimic is compatible with 275 | MirageOS. 276 | 277 | {2 The client part.} 278 | 279 | So let's start implementing the client as it should be. 280 | 281 | {[ 282 | let client ~ctx ic = 283 | let rec go flow queue = match input_line ic with 284 | | line -> 285 | if ic != stdin then Fmt.pr "> %s\n%!" line ; 286 | sendline flow "%s" line >>? fun () -> 287 | ( getline flow queue >>? function 288 | | `Close -> Lwt.return_ok () 289 | | `Line v -> 290 | Fmt.pr "<- %s\n%!" v ; 291 | if ic == stdin then Fmt.pr "> %!" ; 292 | go flow queue ) 293 | | exception End_of_file -> Lwt.return_ok () in 294 | Mimic.resolve ctx >>? fun flow -> 295 | let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in 296 | if ic == stdin then Fmt.pr "> %!" ; 297 | go flow queue >>= fun res -> 298 | Mimic.close flow >>= fun () -> Lwt.return res 299 | ]} 300 | 301 | In this small piece of code, we see the appearance of a function that is not 302 | part of [Mirage_flow.S] but strictly speaking of mimic. It's [Mimic.resolve]. 303 | 304 | It was said earlier that the instantiation of a {e socket} is not the privilege 305 | of the protocol itself. Indeed, once again, as far as our ping-pong protocol is 306 | concerned, our "line-directed" protocol (just like SMTP or HTTP again) does not 307 | care how to initialize a transmission. It just wants to be able to read and 308 | write. 309 | 310 | Thus, [Mimic.resolve] seems a bit magical but the instantiation of a {e socket} 311 | ultimately depends on a single value, the [ctx]. The context is a 312 | representation of what is allowed to do according to the end user. It contains 313 | elements that allow the famous dynamic "dispatch" to instantiate a {e socket}. 314 | 315 | In other words, it is through the context that we determine the type of 316 | transmission: if it is a TCP/IP or TLS transmission for example. 317 | 318 | We will then see how to define this context and how it works to choose this or 319 | that type of transmission. The important thing to keep in mind is that we have 320 | just done: 321 | + implement our ping-pong protocol - at least, the client part 322 | + this code will not change when it comes to upgrade the transmission with TLS 323 | + this code is compatible with MirageOS 324 | 325 | The logic of this code is very simple, it passes what it has from an 326 | [in_channel] to the server and that's it! It is important to understand that 327 | what follows must be external to the implementation of the protocol itself, 328 | because we will start to explain to mimic the instantiation of the transmission 329 | techniques. 330 | 331 | As a concrete example, [ocaml-git] is separated in 3 where [git] implements the 332 | Smart protocol, [git-unix] registers the Unix specific transmission types and 333 | [git-mirage] does the same with MirageOS compatible implementations 334 | ([mirage-tcpip], [tls-mirage] or [awa-ssh]). 335 | 336 | This part will directly depend on the said transmission protocols like TCP/IP 337 | or TLS. These choices are therefore outside the implementation of the ping-pong 338 | protocol itself. 339 | 340 | {2 Registration & Instantiation.} 341 | 342 | Mimic offers a way to "fill" the context with values. These values are needed 343 | to instantiate one of your transmission protocols. As we said, for TCP/IP, 344 | the instantiation of a {e socket} requires to get an IP address and a port. 345 | 346 | So, if we "fill" our context with these values, mimic can initialize a TCP/IP 347 | connection. More generally, 2 steps are necessary for mimic to establish 348 | a transmission: 349 | + know the transmission protocol and what it requires 350 | + add what it requires in a context 351 | 352 | The first step is quite unusual. It consists in "registering" a transmission 353 | protocol with mimic. This is a prerequisite for extending the protocols 354 | available through mimic - and of course, initially, mimic does not know any 355 | protocols (again, to be compatible with MirageOS). 356 | 357 | It is accepted, as we said from the beginning, that a transmission protocol can 358 | described with [Mirage_flow.S]. As for [mirage-tcpip], [ocaml-tls] or 359 | [awa-ssh], all three implementations respect the [Mirage_flow.S] interface. 360 | 361 | And this is what mimic expects, a protocol that respects [Mirage_flow.S]. 362 | However, mimic expects an extension to this interface. Indeed, beyond being 363 | able to relay the [read] and [write] of your implementations to the 364 | implementation of your ping-pong protocol, mimic also depends on an 365 | "instantiation" method. In other words, mimic requires a module respecting 366 | [Mirage_flow.S] and a [connect] function: {!Mimic.Mirage_protocol.S}. 367 | 368 | Let's take [mirage-tcpip] as an example. We need to tweak its implementation a 369 | bit in order to register it with mimic. 370 | 371 | {[ 372 | module TCP = struct 373 | include Tcpip_stack_socket.V4V6.TCP 374 | 375 | let pp_write_error ppf = function 376 | | #write_error as err -> pp_write_error ppf err 377 | | `Error err -> pp_error ppf err 378 | 379 | type endpoint = t * Ipaddr.t * int 380 | type nonrec write_error = [ write_error | `Error of error ] 381 | 382 | let write flow cs = write flow cs >>= function 383 | | Ok _ as v -> Lwt.return v 384 | | Error err -> Lwt.return_error (err :> write_error) 385 | 386 | let writev flow css = writev flow css >>= function 387 | | Ok _ as v -> Lwt.return v 388 | | Error err -> Lwt.return_error (err :> write_error) 389 | 390 | let connect (stack, ipaddr, port) = 391 | create_connection stack (ipaddr, port) 392 | >|= R.reword_error (fun err -> `Error err) 393 | end 394 | 395 | let tcp_edn, tcp_protocol = Mimic.register ~name:"tcp" (module TCP) 396 | ]} 397 | 398 | We have just registered the TCP/IP transmission protocol and mimic has 399 | returned 2 values: 400 | + a {i witness} of what is required to instantiate a TCP/IP transmission with 401 | this [TCP] module 402 | + a {i witness} of our [TCP] implementation 403 | 404 | {b NOTE:} it may be difficult to understand why we need to tweak 405 | [mirage-tcpip]. In fact, if mimic really wants to be a means of abstracting 406 | transmission protocols, one must admit the idea that instantiating a protocol 407 | may require writing something. This is the case for TLS which performs a 408 | {i handshake} with the server at instantiation. Thus, we must allow [connect] 409 | to return a writing error. 410 | 411 | [tcp_edn] is a value that represents what is required from our [connect]. Its 412 | type depends explicitely on the way our implementation instantiates our socket. 413 | In other words, in our example, its type is: 414 | 415 | {[ 416 | val tcp_edn : (TCP.t * Ipaddr.t * int) Mimic.value 417 | ]} 418 | 419 | This {i witness} is useful to "fill in" a context that we could then pass to 420 | our client. The idea is that if a value {i of type} [tcp_edn] exists in the 421 | [ctx] context used by [Mimic.resolve], mimic is able to instantiate a TCP/IP 422 | transmission and use your [TCP] module instead of [Mimic.{read,write,close}]. 423 | 424 | So let's try to use our code. In a shell, it makes us launch a server with 425 | [nc -l 8080]. Then we need to run out client. 426 | 427 | {[ 428 | let ctx00 stack ipaddr port = 429 | Mimic.empty 430 | |> Mimic.add tcp_edn (stack, ipaddr, port) 431 | 432 | let run00 uri ic = match Uri.host uri, Uri.port uri with 433 | | None, None 434 | | Some _, None 435 | | None, Some _ -> Fmt.failwith "Invalid uri: %a" Uri.pp uri 436 | | Some host, Some port -> match Ipaddr.of_string host with 437 | | Ok ipaddr -> 438 | let open Tcpip_stack_socket.V4V6 in 439 | TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global 440 | None >>= fun tcp -> 441 | let ctx = ctx00 tcp ipaddr port in 442 | client ~ctx ic 443 | | Error _ -> Fmt.failwith "Invalid IP address: %s" host 444 | 445 | let _0 () = match Sys.argv with 446 | | [| _; uri; |] -> 447 | Lwt_main.run (run00 (Uri.of_string uri) stdin) 448 | |> R.reword_error (R.msgf "%a" Mimic.pp_error) 449 | |> R.failwith_error_msg 450 | | [| _; uri; filename; |] when Sys.file_exists filename -> 451 | let ic = open_in filename in 452 | let rs = Lwt_main.run (run00 (Uri.of_string uri) ic) in 453 | close_in ic ; 454 | R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs) 455 | | _ -> Fmt.epr "%s [filename]\n%!" Sys.argv.(0) 456 | ]} 457 | 458 | The code is compilable with 459 | 460 | {[ 461 | $ ocamlfind opt -thread -package rresult,lwt,mimic,bigstringaf,cstruct,ke, \ 462 | tcpip.stack-socket,uri main.ml 463 | ]} 464 | 465 | Then we just need to execute our code such that [$] is our client and [#] is 466 | our server: 467 | 468 | {[ 469 | # nc -l 8080 470 | $ ./a.out tcp://127.0.0.1:8080/ 471 | $> ping 472 | #ping 473 | #pong 474 | $<- pong 475 | ]} 476 | 477 | We have several limitations here: 478 | + we have to specify the IP address 479 | + we have to specify a port 480 | + we are finally limited to full our context with a value 481 | [TCP.t * Ipaddr.t * int] 482 | 483 | However, we have something that works without having changed any of the code of 484 | our ping-pong protocol. Let's take the time to explain once again what just 485 | happened. Giving the client a context containing the information required 486 | to instantiate a TCP/IP socket causes mimic to be able to execute [TCP.connect] 487 | with these arguments. Let's not forget that it is because we took care to use 488 | [tcp_edn] that [mimic] is able to do this. 489 | 490 | Since the [connect] works and returns a [TCP.flow] (not an error), mimic can 491 | "hide" this value under the [Mimic.flow] type used in our client code. 492 | 493 | Finally, [Mimic.read] and [Mimic.write], since they handle a [Mimic.flow], they 494 | have the ability to "introspect" the hidden [TCP.flow] and call to [TCP.read] 495 | and [TCP.write] respectively. This possibility comes from the fact that we have 496 | "registered" our [TCP] protocol with mimic (with [Mimic.register]). 497 | 498 | Now we can try to solve our limitations. Indeed, mimic provides an API to: 499 | + create other {i witnesses} 500 | + {i populate} the context with functions that manipulate added values with 501 | using the {i witnesses}. 502 | 503 | For the exemple, we will try to manage domain names rather than IP addresses. 504 | Thanks to this, we will be able to write ["tcp://localhost/"]. Also, we will 505 | set a default value for the port. 506 | 507 | Again, we need to remember to be compatible with MirageOS. It may be "simple" 508 | to manage the domain name "localhost", but behind this resolution, the process 509 | is more complexe than one might imagine. It can be similar to a DNS query on 510 | the network. Of course, this kind of mechanism does not exist - at least not 511 | without wish - with MirageOS. In our case, since we already depend on [unix], 512 | we can directly use [Unix.gethostbyname]. 513 | 514 | In the context of MirageOS, like [ocaml-git] (see [git-mirage]), we will use 515 | Functoria to add or not the DNS resolution. 516 | 517 | {[ 518 | let port : int Mimic.value = Mimic.make ~name:"port" 519 | let ipaddr : Ipaddr.t Mimic.value = Mimic.make ~name:"ipaddr" 520 | let domain_name : [ `host ] Domain_name.t Mimic.value = 521 | Mimic.make ~name:"domain-name" 522 | let stack : Tcpip_stack_socket.V4V6.TCP.t Mimic.value = 523 | Mimic.make ~name:"stack" 524 | 525 | let ctx01 = 526 | let open Mimic in 527 | let k0 v = match Unix.gethostbyname (Domain_name.to_string v) with 528 | | { Unix.h_addr_list; _ } -> 529 | if Array.length h_addr_list > 0 530 | then Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0)) 531 | else Lwt.return_none 532 | | exception _ -> Lwt.return_none in 533 | let k1 stack ipaddr port = Lwt.return_some (stack, ipaddr, port) in 534 | Mimic.empty 535 | |> Mimic.fold ipaddr Fun.[ req domain_name ] ~k:k0 536 | |> Mimic.fold tcp_edn Fun.[ req stack; req ipaddr; dft port 8080 ] ~k:k1 537 | ]} 538 | 539 | We have a new context that does not contain the values required to instantiate 540 | a TCP/IP transmission. However, it contains 2 important processes that allow to 541 | "resolve" some values into others. 542 | 543 | This is the case more concretely with DNS resolution where we go from a domain 544 | name to an IP address. If we add a domain name to this context, mimis is smart 545 | enough to try to get an IP address using [k0]. 546 | 547 | Finally, the second process [k1] allows to gather some values if they exist 548 | (except for the port which has a default value of [8080]) and to produce a 549 | value of type [tcp_edn]. 550 | 551 | Thus, we now that the ability to instantiate a TCP/IP socket by different means 552 | and different values: 553 | - with a domain name 554 | - with a domain name and a port 555 | - with an IP address 556 | - with an IP address and a port 557 | 558 | We can thus make our deconstruction of the [Uri.t] a little more complex. 559 | 560 | {[ 561 | let run01 uri ic = 562 | let ctx = ctx01 in 563 | let ctx = match Uri.port uri with 564 | | Some v -> Mimic.add port v ctx 565 | | None -> ctx in 566 | let ctx = match Uri.host uri with 567 | | None -> ctx 568 | | Some v -> 569 | match Rresult.(Domain_name.(of_string v >>= host)), 570 | Ipaddr.of_string v with 571 | | Ok v, _ -> Mimic.add domain_name v ctx 572 | | _, Ok v -> Mimic.add ipaddr v ctx 573 | | _ -> ctx in 574 | let open Tcpip_stack_socket.V4V6 in 575 | TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global 576 | None >>= fun tcp -> 577 | let ctx = Mimic.add stack tcp ctx in 578 | client ~ctx ic 579 | 580 | let _1 () = match Sys.argv with 581 | | [| _; uri; |] -> 582 | Lwt_main.run (run01 (Uri.of_string uri) stdin) 583 | |> R.reword_error (R.msgf "%a" Mimic.pp_error) 584 | |> R.failwith_error_msg 585 | | [| _; uri; filename; |] when Sys.file_exists filename -> 586 | let ic = open_in filename in 587 | let rs = Lwt_main.run (run01 (Uri.of_string uri) ic) in 588 | close_in ic ; 589 | R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs) 590 | | _ -> Fmt.epr "%s [filename]\n%!" Sys.argv.(0) 591 | ]} 592 | 593 | We can say that we finally have a correct "endpoint" mangement using an 594 | [Uri.t]. But what is important is the ability to choose the endpoint 595 | independently of the logic of our ping-pong protocol 596 | 597 | This is another important aspect of mimic, it only recognizes the context [ctx] 598 | which, in the end, is a heterogeneous set of values. These values can come from 599 | any canonical representation of your endpoin. In our case, we use an [Uri.t] 600 | but another representation can be used. 601 | 602 | This is the case between [paf] (an HTTP/AF abstraction layer compatible with 603 | MirageOS) and Git. One requires an [Uri.t] as a canonical representation of a 604 | target while the other defines its own {!Smart_git.Endpoint.t} type since the 605 | target can be represented by an email address (like 606 | [git@github.com:mirage/ocaml-git]). 607 | 608 | In short, all of this shows us a rather fine control of the "dispatch". mimic 609 | just tries to put the pieces together and find a way to create values 610 | respecting the prerequisite of your protocols in order to instantiate them. 611 | 612 | {2 Upgrade TLS.} 613 | 614 | We will now see how to upgrade all our code to use TLS. 615 | 616 | {[ 617 | module TLS = struct 618 | include Tls_mirage.Make(Tcpip_stack_socket.V4V6.TCP) 619 | 620 | type endpoint = 621 | Tcpip_stack_socket.V4V6.TCP.t 622 | * Tls.Config.client * [ `host ] Domain_name.t option 623 | * Ipaddr.t * int 624 | 625 | let connect (stack, tls, host, ipaddr, port) = 626 | let open Tcpip_stack_socket.V4V6 in 627 | TCP.create_connection stack (ipaddr, port) 628 | >|= R.reword_error (fun err -> `Read err) 629 | >>? fun flow -> 630 | client_of_flow tls ?host flow 631 | end 632 | 633 | let tls_edn, tls_protocol = Mimic.register ~priority:10 ~name:"tls" 634 | (module TLS) 635 | 636 | let authenticator ?ip:_ ~host:_ _ = Ok None 637 | let default = Tls.Config.client ~authenticator () 638 | 639 | let tls : Tls.Config.client Mimic.value = Mimic.make ~name:"tls-config" 640 | let scheme : string Mimic.value = Mimic.make ~name:"scheme" 641 | 642 | let ctx02 = 643 | let open Mimic in 644 | let k0 scheme stack tls domain_name ipaddr port = match scheme with 645 | | "tls" -> Lwt.return_some (stack, tls, domain_name, ipaddr, port) 646 | | _ -> Lwt.return_none in 647 | let k1 scheme stack ipaddr port = match scheme with 648 | | "tcp" -> Lwt.return_some (stack, ipaddr, port) 649 | | _ -> Lwt.return_none in 650 | Mimic.empty 651 | |> Mimic.fold tls_edn 652 | Fun.[ req scheme; req stack; dft tls default; opt domain_name 653 | ; req ipaddr; dft port 4343 ] ~k:k0 654 | |> Mimic.fold tcp_edn 655 | Fun.[ req scheme; req stack; req ipaddr; dft port 8080 ] ~k:k1 656 | ]} 657 | 658 | Here, the method remains the same as for [TCP]. We create the module and then 659 | register it with mimic. We have two new values which allow us to better specify 660 | ths "dispatch" according to the {i scheme}. 661 | 662 | Finally, we have a new context allowing to instantiate a TLS {e socket} 663 | according to some values, some of which have a default value. We can finally 664 | complete the deconstruction of our [Uri.t] once again to manage all these 665 | parameters. 666 | 667 | {[ 668 | let run02 uri ic = 669 | let ctx = Mimic.merge ctx01 ctx02 in 670 | let ctx = match Uri.scheme uri with 671 | | Some v -> Mimic.add scheme v ctx 672 | | None -> ctx in 673 | let ctx = match Uri.port uri with 674 | | Some v -> Mimic.add port v ctx 675 | | None -> ctx in 676 | let ctx = match Uri.host uri with 677 | | None -> ctx 678 | | Some v -> 679 | match Rresult.(Domain_name.(of_string v >>= host)), 680 | Ipaddr.of_string v with 681 | | Ok v, _ -> Mimic.add domain_name v ctx 682 | | _, Ok v -> Mimic.add ipaddr v ctx 683 | | _ -> ctx in 684 | let open Tcpip_stack_socket.V4V6 in 685 | TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global 686 | None >>= fun tcp -> 687 | let ctx = Mimic.add stack tcp ctx in 688 | client ~ctx ic 689 | 690 | let () = Mirage_crypto_rng_unix.initialize () 691 | 692 | let _2 () = match Sys.argv with 693 | | [| _; uri; |] -> 694 | Lwt_main.run (run02 (Uri.of_string uri) stdin) 695 | |> R.reword_error (R.msgf "%a" Mimic.pp_error) 696 | |> R.failwith_error_msg 697 | | [| _; uri; filename |] when Sys.file_exists filename -> 698 | let ic = open_in filename in 699 | let rs = Lwt_main.run (run02 (Uri.of_string uri) ic) in 700 | close_in ic ; 701 | R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs) 702 | | _ -> Fmt.epr "%s [filename]\n%!" Sys.argv.(0) 703 | ]} 704 | 705 | These is a lot to say here and to do in order to test this code. First of all 706 | we note the use of {!Mimic.merge} which allows to merge 2 contexts to obtain 707 | only one. To avoid code repetition, we will reuse [ctx01] which contains our 708 | DNS resolver. 709 | 710 | Then we add the scheme from the given [Uri.t]. 711 | 712 | To launch a TLS server, nothing more than: 713 | {[ 714 | # openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem \ 715 | -days 365 -nodes 716 | # openssl s_server -key key.pem -cert cert.pem -accept 4343 717 | ]} 718 | 719 | As for our client, we need to compile it with: 720 | {[ 721 | $ ocamlfind opt -thread -linkpkg -package \ 722 | rresult,lwt,\ 723 | mimic,bigstringaf,cstruct,ke,tcpip.stack-socket,uri,tls-mirage,\ 724 | mirage-crypto-rng.unix main.ml 725 | $ ./a.out tls://localhost:4343/ 726 | > ping 727 | #ping 728 | #pong 729 | <- pong 730 | > ^D 731 | #DONE 732 | ]} 733 | 734 | And that's it! Again, as an example, the extension from one protocol to another 735 | is completely transparent to the protocol ping-pong logic. As you can see, 736 | mimic is very minimal but it allows a lot of things. The ability to integrate 737 | complex processes into the context allows us to extend what we are able to 738 | handle. 739 | 740 | Of course, the minimal aspect of mimic is in the spirit of MirageOS. In the 741 | end, mimic only allows one thing: re-implementing virtual methods for modules. 742 | The discrimination of available implementations in what is comparable to a 743 | {i vtable} (in C++) is done for the context. 744 | 745 | Finally the functions that are in the context can fail as well. In this case, 746 | mimic tries other solutions. This situation explains another parameter used in 747 | our exemple for TLS, the priority. This ensures that even if the required 748 | information for [tcp_edn] exists, mimic will first try to instantiate a TLS 749 | transmission (if, again, all information is available). 750 | 751 | We can finally apply to implement the server now. 752 | 753 | {2 The server side.} 754 | 755 | Mimic make the choice to let the user the way the server is made. Indeed, there 756 | is a real difference between a client and a server. There is a dynamic part in 757 | the choice of the transmission protocol as a client but it is especially not 758 | the case for the server where we know exactly how to launch our server. 759 | 760 | Indeed, everything that is initialization or the logic of the main loop remains 761 | outside mimic. However, mimic intervenes at one point. As a server, it has to 762 | manage clients that do both reading and writing. It can be interesting to 763 | implement the client management, the "handler" or the "callback" with mimic. 764 | 765 | The goal is to implement this logic with mimic and we will explain the way to 766 | pass from a TCP/IP or TLS socket to a {!Mimic.flow}. We call this process: 767 | {e injection}. 768 | 769 | {b NOTE:} we will redefine [TCP] and [TLS] to use the TCP/IP stack of the host 770 | system directly this time using [Lwt_unix.file_descr]. Besides showing another 771 | example of how to "register" other protocols, we are required to do this for 772 | the simple reason that [mirage-tcpip] offers a different server 773 | logic/interface. Indeed, for Unix/[], we are used to the triptik 774 | [socket]/[accept]/[close]. [mirage-tcpip] proposes a more "functional" 775 | interface with a listen function that registers your callback internally. 776 | Finally, [mirage-tcpip] implements its own main loop. Of course, all this is 777 | required because we cannot switch from an [Unix.file_descr] to a [mirage-tcpip] 778 | {e socker}. 779 | 780 | In order to not lose anyone and to have a coherent understanding of what is 781 | usually done when implementing a server, we have to reimplement [TCP] and [TLS] 782 | with [Unix.file_descr] and use these modules as our transmission protocols. 783 | 784 | {[ 785 | let handler flow = 786 | let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in 787 | let rec go flow queue = 788 | getline flow queue >>? function 789 | | `Close -> Lwt.return_ok () 790 | | (`Line "ping") -> sendline flow "pong" >>? fun () -> go flow queue 791 | | (`Line "pong") -> sendline flow "ping" >>? fun () -> go flow queue 792 | | (`Line line) -> sendline flow "%s" line >>? fun () -> go flow queue in 793 | go flow queue >>= fun res -> 794 | Mimic.close flow >>= fun () -> Lwt.return res 795 | 796 | let handler flow = 797 | handler flow >>= function 798 | | Ok () -> Lwt.return_unit 799 | | Error err -> 800 | Fmt.epr "Got an error: %a.\n%!" Mimic.pp_error err ; 801 | Lwt.return_unit 802 | 803 | module TCP' = struct 804 | type flow = Lwt_unix.file_descr 805 | 806 | type error = [ `Error of Unix.error * string * string ] 807 | type write_error = [ `Closed | `Error of Unix.error * string * string ] 808 | 809 | let pp_error ppf = function 810 | | `Error (err, f, v) -> 811 | Fmt.pf ppf "%s(%s) : %s" f v (Unix.error_message err) 812 | 813 | let pp_write_error ppf = function 814 | | #error as err -> pp_error ppf err 815 | | `Closed -> Fmt.pf ppf "Connection closed by peer" 816 | 817 | let read fd = 818 | let tmp = Bytes.create 0x1000 in 819 | let process () = 820 | Lwt_unix.read fd tmp 0 (Bytes.length tmp) >>= function 821 | | 0 -> Lwt.return_ok `Eof 822 | | len -> Lwt.return_ok (`Data (Cstruct.of_bytes ~off:0 ~len tmp)) in 823 | Lwt.catch process @@ function 824 | | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) 825 | | exn -> Lwt.fail exn 826 | 827 | let write fd ({ Cstruct.len; _ } as cs) = 828 | let rec process buf off max = 829 | Lwt_unix.write fd buf off max >>= fun len -> 830 | if max - len = 0 then Lwt.return_ok () 831 | else process buf (off + len) (max - len) in 832 | let buf = Cstruct.to_bytes cs in 833 | Lwt.catch (fun () -> process buf 0 len) @@ function 834 | | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) 835 | | exn -> Lwt.fail exn 836 | 837 | let rec writev fd = function 838 | | [] -> Lwt.return_ok () 839 | | x :: r -> write fd x >>? fun () -> writev fd r 840 | 841 | let close fd = Lwt_unix.close fd 842 | 843 | type endpoint = Lwt_unix.sockaddr 844 | 845 | let connect sockaddr = 846 | let process () = 847 | let domain = Unix.domain_of_sockaddr sockaddr in 848 | let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in 849 | Lwt_unix.connect socket sockaddr >>= fun () -> 850 | Lwt.return_ok socket in 851 | Lwt.catch process @@ function 852 | | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) 853 | | exn -> Lwt.fail exn 854 | end 855 | 856 | module TLS' = struct 857 | include Tls_mirage.Make(TCP') 858 | 859 | type endpoint = 860 | Tls.Config.client * [ `host ] Domain_name.t option 861 | * Unix.sockaddr 862 | 863 | let connect (tls, host, sockaddr) = 864 | TCP'.connect sockaddr 865 | >|= R.reword_error (fun err -> `Read err) 866 | >>? fun flow -> 867 | client_of_flow tls ?host flow 868 | end 869 | 870 | let _, tcp_protocol = Mimic.register ~name:"tcp" (module TCP') 871 | let _, tls_protocol = Mimic.register ~name:"tls" (module TLS') 872 | 873 | module TCPRepr = (val (Mimic.repr tcp_protocol)) 874 | module TLSRepr = (val (Mimic.repr tls_protocol)) 875 | ]} 876 | 877 | This time the values we are interested in are the protocols' witnesses. These 878 | allow us to create a module exposing the constructor that extends our 879 | {!Mimic.flow} type. 880 | 881 | This constructor is obtained with the help of {!Mimic.repr}. In out example, we 882 | obtain modules that continue a type [t] but above all, they expose a 883 | constructor [T] that allows us to inject our socket as {!Mimic.flow} type. 884 | 885 | Thus, we can create a {!Mimic.flow} value from our [Lwt_unix.file_descr] socket 886 | by doing: 887 | 888 | {[ 889 | let flow : Mimic.flow = TCPRepr.T socket in 890 | ]} 891 | 892 | The same is true for TLS, which has a different type - and thus, a different 893 | constructor. 894 | 895 | {[ 896 | let flow : Mimic.flow = TLSRepr.T socket in 897 | ]} 898 | 899 | The rest of the code is the application part of what we just did. We can 900 | compile the code with: 901 | 902 | {[ 903 | $ ocamlfind opt -thread -linkpkg -package \ 904 | mimic,bigstringaf,cstruct,ke,tcpip.stack-socket,uri,tls-mirage,\ 905 | mirage-crypto-rng.unix main.ml 906 | ]} 907 | 908 | Finally, the server side runs with [#] and the client side with [$]: 909 | 910 | {[ 911 | # ./a.out server cert.pem key.pem 4343 912 | # ./a.out 8080 913 | $ ./a.out client tcp://localhost:8080/ 914 | $ ./a.out client tsl://localhost:4343/ 915 | ]} 916 | 917 | {[ 918 | type ('v, 'flow, 'err) service = 919 | { accept : 'v -> ('flow, 'err) result Lwt.t 920 | ; close : 'v -> unit Lwt.t } 921 | constraint 'err = [> `Closed ] 922 | 923 | let serve_when_ready ?stop ~handler { accept; close; } service = 924 | `Initialized 925 | (let switched_off = 926 | let t, u = Lwt.wait () in 927 | Lwt_switch.add_hook stop (fun () -> 928 | Lwt.wakeup_later u (Ok `Stopped) ; 929 | Lwt.return_unit) ; 930 | t in 931 | let rec loop () = 932 | let accept = 933 | accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in 934 | accept >>? function 935 | | `Flow flow -> 936 | Lwt.async (fun () -> handler flow) ; 937 | Lwt.pause () >>= loop in 938 | let stop_result = 939 | Lwt.pick [ switched_off; loop () ] >>= function 940 | | Ok `Stopped -> close service >>= fun () -> Lwt.return_ok () 941 | | Error _ as err -> close service >>= fun () -> Lwt.return err in 942 | stop_result >>= function Ok () | Error _ -> Lwt.return_unit) 943 | 944 | let tcp = 945 | let accept t = Lwt_unix.accept t >>= fun (fd, _) -> 946 | Lwt.return_ok (TCPRepr.T fd) in 947 | let close t = Lwt_unix.close t in 948 | { accept; close; } 949 | 950 | let tls cfg = 951 | let accept t = 952 | Lwt_unix.accept t >>= fun (fd, _) -> 953 | TLS'.server_of_flow cfg fd >>? fun fd -> 954 | Lwt.return_ok (TLSRepr.T fd) in 955 | let close t = Lwt_unix.close t in 956 | { accept; close; } 957 | 958 | let run03 v service = 959 | let `Initialized th = serve_when_ready ~handler service v in th 960 | 961 | let run03 = function 962 | | `TCP sockaddr -> 963 | let domain = Unix.domain_of_sockaddr sockaddr in 964 | let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in 965 | Lwt_unix.bind socket sockaddr >>= fun () -> 966 | Lwt_unix.listen socket 40 ; 967 | run03 socket tcp 968 | | `TLS (cfg, sockaddr) -> 969 | let domain = Unix.domain_of_sockaddr sockaddr in 970 | let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in 971 | Lwt_unix.bind socket sockaddr >>= fun () -> 972 | Lwt_unix.listen socket 40 ; 973 | run03 socket (tls cfg) 974 | 975 | let load_file filename = 976 | let ic = open_in filename in 977 | let ln = in_channel_length ic in 978 | let rs = Bytes.create ln in 979 | really_input ic rs 0 ln ; close_in ic ; 980 | Cstruct.of_bytes rs 981 | 982 | let certificates_of_files cert key = 983 | let cert = load_file cert in 984 | let key = load_file key in 985 | match X509.Certificate.decode_pem_multiple cert, 986 | X509.Private_key.decode_pem key with 987 | | Ok certs, Ok key -> `Single (certs, key) 988 | | _ -> Fmt.failwith "Invalid key or certificate" 989 | 990 | let () = match Sys.argv with 991 | | [| _; "server"; port; |] -> 992 | let sockaddr = 993 | Unix.ADDR_INET (Unix.inet_addr_loopback, int_of_string port) in 994 | Lwt_main.run (run03 (`TCP sockaddr)) 995 | | [| _; "server"; cert; key; port; |] -> 996 | let sockaddr = 997 | Unix.ADDR_INET (Unix.inet_addr_loopback, int_of_string port) in 998 | let certificates = certificates_of_files cert key in 999 | let tls = Tls.Config.server ~certificates () in 1000 | Lwt_main.run (run03 (`TLS (tls, sockaddr))) 1001 | | [| _; "client"; uri; |] -> 1002 | Lwt_main.run (run02 (Uri.of_string uri) stdin) 1003 | |> R.reword_error (R.msgf "%a" Mimic.pp_error) 1004 | |> R.failwith_error_msg 1005 | | [| _; "client"; uri; filename; |] when Sys.file_exists filename -> 1006 | let ic = open_in filename in 1007 | let rs = Lwt_main.run (run02 (Uri.of_string uri) ic) in 1008 | close_in ic ; 1009 | R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs) 1010 | | _ -> 1011 | Fmt.epr "%s server [cert.pem] [key.pem] \n%!" Sys.argv.(0) ; 1012 | Fmt.epr "%s client [filename]\n%!" Sys.argv.(0) 1013 | ]} 1014 | -------------------------------------------------------------------------------- /lib/mimic.ml: -------------------------------------------------------------------------------- 1 | type 'a info = { name : string; root : root } 2 | and root = Root of int option | Value 3 | 4 | let pp_info ppf { name; root } = 5 | match root with 6 | | Root (Some p) -> Format.fprintf ppf "<%s:%d>" name p 7 | | Root None -> Format.fprintf ppf "<%s>" name 8 | | Value -> Format.fprintf ppf "%s" name 9 | 10 | module Mirage_protocol = Mirage_protocol 11 | module Info = struct type 'a t = 'a info end 12 | module Hmap0 = Hmap.Make (Info) 13 | 14 | let pp_value ppf value = Format.fprintf ppf "%a" pp_info (Hmap0.Key.info value) 15 | let src = Logs.Src.create "mimic" ~doc:"logs mimic's event" 16 | 17 | module Log = (val Logs.src_log src : Logs.LOG) 18 | 19 | module rec Fun : sig 20 | type ('k, 'res) args = 21 | | [] : ('res, 'res) args 22 | | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args 23 | 24 | and 'v arg = 25 | | Map : ('f, 'a) args * 'f -> 'a arg 26 | | Req : 'a Hmap0.key -> 'a arg 27 | | Opt : 'a Hmap0.key -> 'a option arg 28 | | Dft : 'a * 'a Hmap0.key -> 'a arg 29 | 30 | val req : 'a Hmap0.key -> 'a arg 31 | val opt : 'a Hmap0.key -> 'a option arg 32 | val dft : 'a Hmap0.key -> 'a -> 'a arg 33 | val map : ('k, 'a) args -> 'k -> 'a arg 34 | end = struct 35 | type ('k, 'res) args = 36 | | [] : ('res, 'res) args 37 | | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args 38 | 39 | and 'v arg = 40 | | Map : ('f, 'a) args * 'f -> 'a arg 41 | | Req : 'a Hmap0.key -> 'a arg 42 | | Opt : 'a Hmap0.key -> 'a option arg 43 | | Dft : 'a * 'a Hmap0.key -> 'a arg 44 | 45 | let req value = Req value 46 | let opt value = Opt value 47 | let dft value v = Dft (v, value) 48 | let map args k = Map (args, k) 49 | end 50 | 51 | and Value : sig 52 | type 'a elt = 53 | | Val : 'a -> 'a elt 54 | | Fun : ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt 55 | 56 | type 'a t = 'a elt list 57 | end = struct 58 | type 'a elt = 59 | | Val : 'a -> 'a elt 60 | | Fun : ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt 61 | 62 | type 'a t = 'a elt list 63 | end 64 | 65 | module Hmap = Hmap0.Make (Value) 66 | 67 | type ctx = Hmap.t 68 | type 'edn value = 'edn Hmap0.key 69 | 70 | let merge ctx0 ctx1 = 71 | let f : 72 | type a. 73 | a value -> a Value.t option -> a Value.t option -> a Value.t option = 74 | fun _k lst0 lst1 -> 75 | match lst0, lst1 with 76 | | Some lst0, Some lst1 -> Some (lst0 @ lst1) 77 | | Some x, None | None, Some x -> Some x 78 | | None, None -> None 79 | in 80 | Hmap.merge { f } ctx0 ctx1 81 | 82 | module Merge (A : sig 83 | val ctx : ctx 84 | end) (B : sig 85 | val ctx : ctx 86 | end) = 87 | struct 88 | let ctx = merge A.ctx B.ctx 89 | end 90 | 91 | let add value v ctx = 92 | match Hmap.find value ctx with 93 | | Some lst -> Hmap.add value (lst @ [ Val v ]) ctx 94 | | None -> Hmap.add value [ Val v ] ctx 95 | 96 | let fold value args ~k ctx = 97 | match Hmap.find value ctx with 98 | | Some lst -> Hmap.add value (lst @ [ Fun (args, k) ]) ctx 99 | | None -> Hmap.add value [ Fun (args, k) ] ctx 100 | 101 | let replace value v ctx = 102 | match Hmap.find value ctx with 103 | | None -> Hmap.add value [ Val v ] ctx 104 | | Some lst -> 105 | let lst = 106 | List.fold_left 107 | (fun acc -> function 108 | | Value.Fun _ as v -> v :: acc 109 | | Value.Val _ -> acc) 110 | [] lst 111 | in 112 | let lst = List.rev lst in 113 | (* XXX(dinosaure): keep the order! *) 114 | Hmap.add value (Val v :: lst) ctx 115 | 116 | (***** Mirage_flow.S part *****) 117 | 118 | module Implicit0 = Implicit.Make (struct 119 | type 'flow t = (module Mirage_flow.S with type flow = 'flow) 120 | end) 121 | 122 | type flow = Implicit0.t = private .. 123 | type error = [ `Msg of string | `Not_found | `Cycle ] 124 | type write_error = [ `Msg of string | `Closed ] 125 | 126 | let pp_error ppf = function 127 | | `Msg err -> Format.pp_print_string ppf err 128 | | `Not_found -> Format.pp_print_string ppf "No connection found" 129 | | `Cycle -> Format.pp_print_string ppf "Context contains a cycle" 130 | 131 | let pp_write_error ppf = function 132 | | `Msg err -> Format.pp_print_string ppf err 133 | | `Closed -> Format.pp_print_string ppf "Connection closed by peer" 134 | 135 | let to_to_string pp v = Format.asprintf "%a" pp v 136 | 137 | let read flow = 138 | let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in 139 | let open Lwt.Infix in 140 | Flow.read flow 141 | >|= Result.map_error (fun fe -> `Msg (to_to_string Flow.pp_error fe)) 142 | 143 | let write flow cs = 144 | let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in 145 | let open Lwt.Infix in 146 | Flow.write flow cs >|= function 147 | | Error `Closed -> Error `Closed 148 | | Error e -> Error (`Msg (to_to_string Flow.pp_write_error e)) 149 | | Ok _ as v -> v 150 | 151 | let writev flow css = 152 | let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in 153 | let open Lwt.Infix in 154 | Flow.writev flow css 155 | >|= Result.map_error (fun fe -> `Msg (to_to_string Flow.pp_write_error fe)) 156 | 157 | let shutdown flow mode = 158 | let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in 159 | Flow.shutdown flow mode 160 | 161 | let close flow = 162 | let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in 163 | Flow.close flow 164 | 165 | (***** Protocol (Mirage_flow.S + connect) part *****) 166 | 167 | type ('edn, 'flow) snd = Snd : 'flow -> ('edn, 'flow) snd [@@warning "-37"] 168 | 169 | type _ pack = 170 | | Protocol : 171 | 'edn Hmap0.key 172 | * 'flow Implicit0.witness 173 | * (module Mirage_protocol.S 174 | with type flow = 'flow 175 | and type endpoint = 'edn) 176 | -> ('edn, 'flow) snd pack 177 | 178 | module Implicit1 = Implicit.Make (struct type 'v t = 'v pack end) 179 | 180 | type ('edn, 'flow) protocol = { 181 | flow : 'flow Implicit0.witness; 182 | protocol : ('edn, 'flow) snd Implicit1.witness; 183 | } 184 | 185 | let register : 186 | type edn flow. 187 | ?priority:int -> 188 | name:string -> 189 | (module Mirage_protocol.S with type flow = flow and type endpoint = edn) -> 190 | edn value * (edn, flow) protocol = 191 | fun ?priority ~name (module Protocol) -> 192 | let value = Hmap0.Key.create { name; root = Root priority } in 193 | let flow = Implicit0.inj (module Protocol) in 194 | let protocol = Implicit1.inj (Protocol (value, flow, (module Protocol))) in 195 | value, { flow; protocol } 196 | 197 | module type REPR = sig 198 | type t type flow += (* XXX(dinosaure): private? *) T of t 199 | end 200 | 201 | let repr : 202 | type edn flow. (edn, flow) protocol -> (module REPR with type t = flow) = 203 | fun { flow; _ } -> 204 | let (module Witness) = flow in 205 | let module M = struct 206 | include Witness 207 | 208 | type t = a 209 | end in 210 | (module M) 211 | 212 | let rec apply : 213 | type k res. ctx -> (k, res option Lwt.t) Fun.args -> k -> res option Lwt.t = 214 | fun ctx args f -> 215 | let open Lwt.Infix in 216 | let rec go : type k res. ctx -> (k, res) Fun.args -> k -> res Lwt.t = 217 | fun ctx -> function 218 | | [] -> fun x -> Lwt.return x 219 | | Map (args', f') :: tl -> 220 | fun f -> go ctx args' f' >>= fun v -> go ctx tl (f v) 221 | | Opt value :: tl -> fun f -> find value ctx >>= fun v -> go ctx tl (f v) 222 | | Dft (v, value) :: tl -> ( 223 | fun f -> 224 | find value ctx >>= function 225 | | Some v' -> 226 | Log.debug (fun m -> 227 | m "Found a value for the default argument: %a." pp_value value); 228 | go ctx tl (f v') 229 | | None -> go ctx tl (f v)) 230 | | Req value :: tl -> ( 231 | fun f -> 232 | find value ctx >>= function 233 | | Some v -> go ctx tl (f v) 234 | | None -> Lwt.fail Not_found) 235 | in 236 | Lwt.catch (fun () -> go ctx args f >>= fun fiber -> fiber) @@ function 237 | | Not_found -> Lwt.return_none 238 | | exn -> Lwt.fail exn 239 | 240 | and find : type a. a value -> ctx -> a option Lwt.t = 241 | fun value ctx -> 242 | match Hmap.find value ctx with 243 | | None | Some [] -> Lwt.return_none 244 | | Some lst -> 245 | (* XXX(dinosaure): priority on values, then we apply the first [Fun] *) 246 | let rec go fold lst = 247 | match fold, lst with 248 | | None, [] -> Lwt.return_none 249 | | Some (Value.Fun (args, f)), [] -> apply ctx args f 250 | | Some (Value.Val _), [] -> assert false 251 | | None, (Value.Fun _ as x) :: r -> go (Some x) r 252 | | _, Val v :: _ -> Lwt.return_some v 253 | | Some _, Fun _ :: r -> go fold r 254 | in 255 | go None (List.rev lst) 256 | (* XXX(dinosaure): the most recent value. *) 257 | 258 | type edn = Edn : 'edn value * 'edn -> edn 259 | type fnu = Fun : 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k -> fnu 260 | type dep = Dep : 'edn value -> dep 261 | 262 | let pp_fnu ppf (Fun (dep, _, _)) = 263 | Format.fprintf ppf "%a" pp_info (Hmap0.Key.info dep) 264 | 265 | module Sort = struct 266 | type t = 267 | | Val : 'edn value * 'edn -> t 268 | | Fun : 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k -> t 269 | 270 | let pp ppf = function 271 | | Val (k, _) -> pp_info ppf (Hmap0.Key.info k) 272 | | Fun (k, _, _) -> pp_info ppf (Hmap0.Key.info k) 273 | end 274 | 275 | let partition bindings = 276 | let rec go leafs nodes = function 277 | | [] -> List.rev leafs, List.rev nodes 278 | | Hmap.B (_, []) :: r -> go leafs nodes r 279 | | Hmap.B (k, Val v :: tl) :: r -> 280 | go (Sort.Val (k, v) :: leafs) nodes (Hmap.B (k, tl) :: r) 281 | | Hmap.B (k, Fun (args, f) :: tl) :: r -> 282 | go leafs (Fun (k, args, f) :: nodes) (Hmap.B (k, tl) :: r) 283 | in 284 | go [] [] bindings 285 | 286 | let exists k bindings = 287 | let rec go k = function 288 | | [] -> false 289 | | Hmap.B (k', _) :: r -> ( 290 | match Hmap0.Key.proof k k' with Some _ -> true | None -> go k r) 291 | in 292 | go k bindings 293 | 294 | let dependencies (Fun (_, args, _)) bindings = 295 | let rec go : type k r. _ -> (k, r) Fun.args -> _ = 296 | fun acc -> function 297 | | Fun.Req dep :: r -> go (Dep dep :: acc) r 298 | | Fun.Opt dep :: r when exists dep bindings -> go (Dep dep :: acc) r 299 | | Fun.Dft (_, dep) :: r when exists dep bindings -> go (Dep dep :: acc) r 300 | | _ :: r -> go acc r 301 | | [] -> List.rev acc 302 | in 303 | go [] args 304 | 305 | let exists leafs (Dep k) = 306 | let rec go = function 307 | | [] -> false 308 | | Sort.Val (k', _) :: r -> ( 309 | match Hmap0.Key.proof k k' with Some _ -> true | None -> go r) 310 | | Sort.Fun (k', _, _) :: r -> ( 311 | match Hmap0.Key.proof k k' with Some _ -> true | None -> go r) 312 | in 313 | go leafs 314 | 315 | let pp_list pp ppf lst = 316 | let rec go = function 317 | | [] -> () 318 | | [ x ] -> Format.fprintf ppf "%a" pp x 319 | | x :: r -> 320 | Format.fprintf ppf "%a;@ " pp x; 321 | go r 322 | in 323 | Format.fprintf ppf "@[<1>["; 324 | go lst; 325 | Format.fprintf ppf "]@]" 326 | 327 | let sort bindings = 328 | let rec go acc later todo progress = 329 | match todo, later with 330 | | [], [] -> List.rev acc 331 | | [], _ when progress -> go acc [] later false 332 | | [], later -> 333 | (* TODO(dinosaure): check, at least, one root in [acc]. *) 334 | Log.debug (fun m -> 335 | m "Found a solution only for: @[%a@]." (pp_list Sort.pp) acc); 336 | Log.debug (fun m -> 337 | m "Unsolvable values: @[%a@]." (pp_list pp_fnu) later); 338 | List.rev acc 339 | | (Fun (k, args, f) as x) :: xs, _ -> 340 | let deps = dependencies x bindings in 341 | let available = List.for_all (exists acc) deps in 342 | if available then go (Sort.Fun (k, args, f) :: acc) later xs true 343 | else go acc (x :: later) xs progress 344 | in 345 | let leafs, nodes = partition bindings in 346 | Log.debug (fun m -> m "Partition done."); 347 | Log.debug (fun m -> m "Nodes: @[%a@]." (pp_list pp_fnu) nodes); 348 | go leafs [] nodes false 349 | 350 | let inf = -1 and sup = 1 351 | 352 | let priority_compare (Edn (k0, _)) (Edn (k1, _)) = 353 | match (Hmap0.Key.info k0).root, (Hmap0.Key.info k1).root with 354 | | Root (Some p0), Root (Some p1) -> p0 - p1 355 | | (Root None | Value), Root (Some _) -> sup 356 | | Root (Some _), (Root None | Value) -> inf 357 | | Value, Value -> 0 358 | | Root None, Root None -> 0 359 | | Value, Root None -> sup 360 | | Root None, Value -> inf 361 | 362 | let unfold : ctx -> (edn list, [> `Cycle ]) result Lwt.t = 363 | fun ctx -> 364 | let open Lwt.Infix in 365 | let rec go ctx acc : Sort.t list -> _ = function 366 | | [] -> 367 | (* XXX(dinosaure): here, we use a stable sort, [List.rev] 368 | * is needed to keep a certain topological order - see [sort]. 369 | * [stable_sort] keeps this order too. *) 370 | let acc = List.stable_sort priority_compare (List.rev acc) in 371 | Lwt.return_ok acc 372 | | Sort.Val (k, v) :: r -> 373 | Log.debug (fun m -> m "Return a value %a." pp_value k); 374 | go ctx (Edn (k, v) :: acc) r 375 | | Sort.Fun (k, args, f) :: r -> ( 376 | Log.debug (fun m -> m "Apply a function %a." pp_value k); 377 | apply ctx args f >>= function 378 | | Some v -> go (add k v ctx) (Edn (k, v) :: acc) r 379 | | None -> go ctx acc r) 380 | in 381 | let ordered_bindings = sort (Hmap.bindings ctx) in 382 | go ctx [] ordered_bindings 383 | 384 | let flow_of_value : 385 | type edn. edn value -> edn -> (flow, [> error ]) result Lwt.t = 386 | fun k v -> 387 | let open Lwt.Infix in 388 | let rec go : Implicit1.pack list -> _ = function 389 | | [] -> Lwt.return_error `Not_found 390 | | Implicit1.Key (Protocol (k', (module Witness), (module Protocol))) :: r 391 | -> ( 392 | match Hmap0.Key.proof k k' with 393 | | None -> go r 394 | | Some Teq -> ( 395 | Protocol.connect v >>= function 396 | | Ok flow -> Lwt.return_ok (Witness.T flow) 397 | | Error _err -> go r)) 398 | in 399 | go (Implicit1.bindings ()) 400 | 401 | type ('a, 'b) refl = Refl : ('a, 'a) refl 402 | 403 | let equal : type a b. a value -> b value -> (a, b) refl option = 404 | fun a b -> 405 | match Hmap0.Key.proof a b with Some Teq -> Some Refl | None -> None 406 | 407 | let rec connect : edn list -> (flow, [> error ]) result Lwt.t = function 408 | | [] -> Lwt.return_error `Not_found 409 | | Edn (k, v) :: r -> ( 410 | let open Lwt.Infix in 411 | Log.debug (fun m -> m "Try to instantiate %a." pp_value k); 412 | flow_of_value k v >>= function 413 | | Ok _ as v -> Lwt.return v 414 | | Error _err -> connect r) 415 | 416 | let resolve : ctx -> (flow, [> error ]) result Lwt.t = 417 | fun ctx -> 418 | let open Lwt.Infix in 419 | unfold ctx >>= function 420 | | Ok lst -> 421 | Log.debug (fun m -> 422 | m "List of endpoints: @[%a@]" 423 | (pp_list (fun ppf (Edn (k, _)) -> pp_value ppf k)) 424 | lst); 425 | connect lst 426 | | Error _ as err -> Lwt.return err 427 | 428 | let make ~name = Hmap0.Key.create { name; root = Value } 429 | let empty = Hmap.empty 430 | 431 | let get value ctx = 432 | match Hmap.find value ctx with 433 | | Some lst -> 434 | let rec first = function 435 | | [] -> None 436 | | Value.Val v :: _ -> Some v 437 | | _ :: r -> first r 438 | in 439 | first lst 440 | | None -> None 441 | -------------------------------------------------------------------------------- /lib/mimic.mli: -------------------------------------------------------------------------------- 1 | module Mirage_protocol = Mirage_protocol 2 | 3 | type flow = private .. 4 | (** The type for flows. A flow represents the state of a single reliable stream 5 | stream that is connected to an {i endpoint}. *) 6 | 7 | include 8 | Mirage_flow.S 9 | with type flow := flow 10 | and type error = [ `Msg of string | `Not_found | `Cycle ] 11 | 12 | type ctx 13 | (** The type for contexts. It's a {i heterogeneous map} of values to help mimic 14 | to instantiate a new {!type:flow} {i via} {!val:resolve}. *) 15 | 16 | type 'edn value 17 | (** The type for {i witnesses} whose lookup value is of type ['edn]. *) 18 | 19 | module Fun : sig 20 | type ('k, 'res) args = 21 | | [] : ('res, 'res) args 22 | | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args 23 | 24 | and 'v arg 25 | 26 | val req : 'a value -> 'a arg 27 | val opt : 'a value -> 'a option arg 28 | val dft : 'a value -> 'a -> 'a arg 29 | val map : ('k, 'a) args -> 'k -> 'a arg 30 | end 31 | 32 | val make : name:string -> 'edn value 33 | (** [make ~name] is a new witness. *) 34 | 35 | val add : 'edn value -> 'edn -> ctx -> ctx 36 | (** [add w v ctx] is [ctx] with [w] bound to [v]. *) 37 | 38 | val get : 'edn value -> ctx -> 'edn option 39 | (** [get w ctx] is the value of [w]'s binding in [ctx], if any. *) 40 | 41 | val replace : 'edn value -> 'edn -> ctx -> ctx 42 | (** [replace w v ctx] replaces the value of [w] by [v] if it exists 43 | or bound [w] to [v]. *) 44 | 45 | val fold : 'edn value -> ('k, 'edn option Lwt.t) Fun.args -> k:'k -> ctx -> ctx 46 | val merge : ctx -> ctx -> ctx 47 | 48 | val empty : ctx 49 | (** [empty] is the empty context. *) 50 | 51 | type ('edn, 'flow) protocol 52 | 53 | val register : 54 | ?priority:int -> 55 | name:string -> 56 | (module Mirage_protocol.S with type flow = 'flow and type endpoint = 'edn) -> 57 | 'edn value * ('edn, 'flow) protocol 58 | (** [register ?priority ~name (module Protocol)] registers the given [Protocol] 59 | into the internal global Mimic's state as a possible transmission protocol 60 | available {i via} {!val:resolve}. 61 | 62 | [?priority] is used to help mimic to choose between multiple solutions 63 | according to the given context. Mimic will choose the lower-priority 64 | solution. 65 | 66 | [name] helps the end-user to know which solution mimic will dynamically 67 | {i via} log outputs. 68 | 69 | [register] returns 2 values: 70 | - a {i witness} as the required value to initiate a transmission {i via} 71 | the given [Protocol] implementation 72 | - a {!type:protocol} which can help the end-user to destruct a {!type:flow} 73 | to its structural type {i via} {!val:repr}. *) 74 | 75 | module type REPR = sig 76 | type t type flow += (* XXX(dinosaure): private? *) T of t 77 | end 78 | 79 | val repr : ('edn, 'flow) protocol -> (module REPR with type t = 'flow) 80 | (** [repr protocol] gives a module definition with an OCaml constructor to help 81 | the end-user to destruct the structural type of a given {!type:flow}: 82 | 83 | {[ 84 | module Protocol 85 | : Mirage_protocol.S with type flow = Lwt_unix.file_descr 86 | 87 | let edn, protocol = Mimic.register ~name:"protocol" (module Protocol) 88 | module R = (val (Mimic.repr protocol)) 89 | 90 | let () = Mimic.resolve ~ctx >>= function 91 | | Ok (R.T lwt_unix_file_descr) -> ... 92 | | ... 93 | ]} *) 94 | 95 | val resolve : ctx -> (flow, [> error ]) result Lwt.t 96 | (** [resolve ctx] tries to instantiate a {!type:flow} from the given [ctx]. *) 97 | 98 | type edn = 99 | | Edn : 'edn value * 'edn -> edn (** The type of a value and its witness. *) 100 | 101 | type (_, _) refl = Refl : ('a, 'a) refl 102 | 103 | val equal : 'a value -> 'b value -> ('a, 'b) refl option 104 | (** [equal a b] returns a proof that [a] and [b] are 105 | {i structurally} equal. *) 106 | 107 | val unfold : ctx -> (edn list, [> `Cycle ]) result Lwt.t 108 | (** [unfold ctx] applies any functions available into the given [ctx] and 109 | and possible to compute according to available values and return a list 110 | of what these functions return. 111 | 112 | It's useful to do an introspection of what [mimic] does when it 113 | {!val:resolve}s the given [ctx]. From that and {!val:equal}, the user is 114 | able to introspect what [mimic] generated and which protocol it is able 115 | to instantiate then. 116 | 117 | {val:resolve} is: 118 | {[ 119 | let resolve ctx = 120 | unfold ctx >>= function 121 | | Ok lst -> connect lst 122 | | Error _ as err -> Lwt.return err 123 | ]} *) 124 | 125 | val connect : edn list -> (flow, [> error ]) result Lwt.t 126 | (** [connect values] tries to instantiate a {!type:flow} from given [values] 127 | and registered protocols (see {!val:register}). *) 128 | 129 | module Merge (A : sig 130 | val ctx : ctx 131 | end) (B : sig 132 | val ctx : ctx 133 | end) : sig 134 | val ctx : ctx 135 | end 136 | -------------------------------------------------------------------------------- /lib/mirage_protocol.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Mirage_flow.S 3 | 4 | type endpoint 5 | 6 | val connect : endpoint -> (flow, write_error) result Lwt.t 7 | end 8 | -------------------------------------------------------------------------------- /mimic-happy-eyeballs.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A happy-eyeballs integration into mimic" 3 | description: "A happy-eyeballs integration into mimic for MirageOS" 4 | maintainer: ["romain.calascibetta@gmail.com"] 5 | authors: "Romain Calascibetta" 6 | license: "ISC" 7 | homepage: "https://github.com/dinosaure/mimic" 8 | doc: "https://dinosaure.github.io/mimic/" 9 | bug-reports: "https://github.com/dinosaure/mimic/issues" 10 | depends: [ 11 | "ocaml" {>= "4.08.0"} 12 | "dune" {>= "2.8"} 13 | "mimic" {= version} 14 | "happy-eyeballs-mirage" {>= "1.1.0"} 15 | "dns-client-mirage" {>= "8.0.0"} 16 | ] 17 | build: [ 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 20 | ] 21 | dev-repo: "git+https://github.com/dinosaure/mimic.git" 22 | -------------------------------------------------------------------------------- /mimic.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A simple protocol dispatcher" 3 | description: "A middleware to dispatch protocols" 4 | maintainer: ["romain.calascibetta@gmail.com"] 5 | authors: "Romain Calascibetta" 6 | license: "ISC" 7 | homepage: "https://github.com/dinosaure/mimic" 8 | doc: "https://dinosaure.github.io/mimic/" 9 | bug-reports: "https://github.com/dinosaure/mimic/issues" 10 | depends: [ 11 | "ocaml" {>= "4.08.0"} 12 | "dune" {>= "2.8"} 13 | "lwt" {>= "5.3.0"} 14 | "mirage-flow" {>= "4.0.0"} 15 | "alcotest" {>= "1.2.3" & with-test} 16 | "alcotest-lwt" {>= "1.2.3" & with-test} 17 | "bigstringaf" {>= "0.7.0" & with-test} 18 | "cstruct" {>= "6.0.0" & with-test} 19 | "logs" {>= "0.7.0"} 20 | "ke" {>= "0.4" & with-test} 21 | ] 22 | build: [ 23 | ["dune" "build" "-p" name "-j" jobs] 24 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 25 | ] 26 | conflicts: [ 27 | "result" {< "1.5"} 28 | ] 29 | dev-repo: "git+https://github.com/dinosaure/mimic.git" 30 | -------------------------------------------------------------------------------- /mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mimic_happy_eyeballs) 3 | (public_name mimic-happy-eyeballs) 4 | (libraries dns-client-mirage happy-eyeballs-mirage mimic)) 5 | -------------------------------------------------------------------------------- /mirage/mimic_happy_eyeballs.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | type flow 4 | 5 | val happy_eyeballs : t Mimic.value 6 | 7 | val resolve : 8 | t -> 9 | ?aaaa_timeout:int64 -> 10 | ?connect_delay:int64 -> 11 | ?connect_timeout:int64 -> 12 | ?resolve_timeout:int64 -> 13 | ?resolve_retries:int -> 14 | string -> 15 | int list -> 16 | ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t 17 | end 18 | 19 | module Make 20 | (Stack : Tcpip.Stack.V4V6) 21 | (Happy_eyeballs : Happy_eyeballs_mirage.S 22 | with type flow = Stack.TCP.flow 23 | and type stack = Stack.t) 24 | (_ : Dns_client_mirage.S 25 | with type happy_eyeballs = Happy_eyeballs.t 26 | and type Transport.stack = Stack.t * Happy_eyeballs.t) : sig 27 | include S with type t = Happy_eyeballs.t and type flow = Stack.TCP.flow 28 | 29 | val connect : Happy_eyeballs.t -> Mimic.ctx Lwt.t 30 | end = struct 31 | type t = Happy_eyeballs.t 32 | type flow = Stack.TCP.flow 33 | 34 | let happy_eyeballs = Mimic.make ~name:"mimic-happy-eyeballs" 35 | let resolve = Happy_eyeballs.connect 36 | let connect he = Lwt.return (Mimic.add happy_eyeballs he Mimic.empty) 37 | end 38 | -------------------------------------------------------------------------------- /mirage/mimic_happy_eyeballs.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | type flow 4 | 5 | val happy_eyeballs : t Mimic.value 6 | 7 | val resolve : 8 | t -> 9 | ?aaaa_timeout:int64 -> 10 | ?connect_delay:int64 -> 11 | ?connect_timeout:int64 -> 12 | ?resolve_timeout:int64 -> 13 | ?resolve_retries:int -> 14 | string -> 15 | int list -> 16 | ((Ipaddr.t * int) * flow, [> `Msg of string ]) result Lwt.t 17 | (** [resolve happy_eyeballs domain_name ports] tries to connect the user with 18 | the given endpoint. The {i domain-name} can be an IP address or a 19 | {i real} domain-name. [resolve] tries to resolve {i via} a DNS request 20 | the given [domain_name] if it's a real domain-name and it tries to 21 | initiate a TCP/IP connection with the destination. 22 | 23 | If it's a success, it returns the resource and the user is able to 24 | [read] or [write] {i via} this resource. *) 25 | end 26 | 27 | (** The functor used by the MirageOS to prepare the {!Mimic.ctx} from an 28 | already allocated [happy_eyeballs] resource which is able to allocate a 29 | TCP/IP connection from a destination regardless the target chosen by the 30 | user. *) 31 | module Make 32 | (Stack : Tcpip.Stack.V4V6) 33 | (Happy_eyeballs : Happy_eyeballs_mirage.S 34 | with type flow = Stack.TCP.flow 35 | and type stack = Stack.t) 36 | (_ : Dns_client_mirage.S 37 | with type happy_eyeballs = Happy_eyeballs.t 38 | and type Transport.stack = Stack.t * Happy_eyeballs.t) : sig 39 | include S with type t = Happy_eyeballs.t and type flow = Stack.TCP.flow 40 | 41 | val connect : t -> Mimic.ctx Lwt.t 42 | (** [connect happy_eyeballs] returns a {!Mimic.ctx} which contains an 43 | {!happy_eyeballs} value which can be used and re-used by some others 44 | devices which want to resolve a domain-name. 45 | 46 | More concretely, the user is able to describe a sub-process to allocate 47 | a {!type:flow} from some Mimic's values: 48 | {[ 49 | (* main.ml, generated by the mirage tool *) 50 | 51 | include Make (Stack) (Dns) (Happy_eyeballs) 52 | let domain_name : string Mimic.value = 53 | Mimic.make ~name:"domain-name" 54 | 55 | let ctx happy_eyeballs_v = 56 | let open Lwt.Infix in 57 | let k0 happy_eyeballs domain_name = 58 | resolve happy_eyeballs domain_name [ 80 ] >>= function 59 | | Ok (_, flow) -> Lwt.return_some flow 60 | | Error _ -> Lwt.return_none in 61 | connect happy_eyeballs_v >|= 62 | Mimic.fold edn Mimic.Fun.[ req happy_eyeballs; req domain_name ] 63 | ~k:k0 64 | 65 | (* unikernel.ml *) 66 | 67 | let run ~ctx = Mimic.resolve ctx >>= function 68 | | Ok flow -> (* ... *) 69 | | Error (`Msg err) -> failwith err 70 | ]} 71 | *) 72 | end 73 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries 4 | mimic 5 | mirage-flow 6 | lwt 7 | lwt.unix 8 | logs 9 | logs.fmt 10 | ke 11 | bigarray 12 | fmt.tty 13 | cstruct 14 | fmt 15 | alcotest 16 | alcotest-lwt)) 17 | 18 | (rule 19 | (alias runtest) 20 | (package mimic) 21 | (deps 22 | (:test test.exe)) 23 | (action 24 | (run %{test} --color=always))) 25 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | let () = Printexc.record_backtrace true 2 | let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () 3 | let () = Logs.set_level ~all:true (Some Logs.Debug) 4 | let () = Logs.set_reporter (Logs_fmt.reporter ~dst:Fmt.stderr ()) 5 | 6 | module Memory_flow0 : 7 | Mimic.Mirage_protocol.S with type endpoint = string * bytes = struct 8 | type flow = { 9 | mutable i : string; 10 | o : bytes; 11 | mutable p : int; 12 | mutable c : bool; 13 | } 14 | 15 | type error = | 16 | type write_error = [ `Closed ] 17 | 18 | let pp_error : error Fmt.t = fun _ppf -> function _ -> . 19 | 20 | let pp_write_error ppf = function 21 | | `Closed -> Fmt.string ppf "!Connection closed by peer" 22 | 23 | let read ({ i; _ } as flow) = 24 | let len = min 0x1000 (String.length i) in 25 | if len = 0 then ( 26 | flow.c <- true; 27 | Lwt.return_ok `Eof) 28 | else ( 29 | flow.i <- String.sub i len (String.length i - len); 30 | Lwt.return_ok (`Data (Cstruct.of_string ~off:0 ~len i))) 31 | 32 | let write ({ o; p = off; c; _ } as flow) cs = 33 | if c then Lwt.return_error `Closed 34 | else 35 | let len = min (Cstruct.length cs) (Bytes.length o - off) in 36 | Cstruct.blit_to_bytes cs 0 o off len; 37 | if len = 0 then flow.c <- true; 38 | flow.p <- flow.p + len; 39 | Lwt.return_ok () 40 | 41 | let writev flow css = 42 | let open Lwt.Infix in 43 | let rec go = function 44 | | [] -> Lwt.return_ok () 45 | | x :: r -> ( 46 | write flow x >>= function 47 | | Ok () -> go r 48 | | Error _ as err -> Lwt.return err) 49 | in 50 | go css 51 | 52 | let close flow = 53 | flow.c <- true; 54 | Lwt.return () 55 | 56 | let shutdown flow _mode = 57 | flow.c <- true; 58 | Lwt.return () 59 | 60 | type endpoint = string * bytes 61 | 62 | let connect (str, buf) = Lwt.return_ok { i = str; o = buf; p = 0; c = false } 63 | end 64 | 65 | let edn0, memory0 = Mimic.register ~name:"memory0" (module Memory_flow0) 66 | 67 | module Flow = Unixiz.Make (Mimic) 68 | 69 | let error = Alcotest.testable Flow.pp_error ( = ) 70 | 71 | let recv = 72 | let pp ppf = function 73 | | `End_of_flow -> Fmt.string ppf "`End_of_flow" 74 | | `Input len -> Fmt.pf ppf "(`Input %d)" len 75 | in 76 | Alcotest.testable pp ( = ) 77 | 78 | let send = Alcotest.int 79 | 80 | let test_input_string = 81 | Alcotest_lwt.test_case "input string" `Quick @@ fun _sw () -> 82 | let open Lwt.Infix in 83 | let ctx = Mimic.add edn0 ("Hello World!", Bytes.empty) Mimic.empty in 84 | Mimic.resolve ctx >>= fun flow -> 85 | Alcotest.(check bool) "resolve" (Result.is_ok flow) true; 86 | let flow = Flow.make (Result.get_ok flow) in 87 | let buf0 = Cstruct.create 12 in 88 | let buf1 = Cstruct.create 12 in 89 | Flow.recv flow buf0 >>= fun res0 -> 90 | Flow.recv flow buf1 >>= fun res1 -> 91 | Flow.send flow (Cstruct.of_string "Hello World!") >>= fun res2 -> 92 | Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 12)); 93 | Alcotest.(check string) "buf0" (Cstruct.to_string buf0) "Hello World!"; 94 | Alcotest.(check (result recv error)) "res1" res1 (Ok `End_of_flow); 95 | Alcotest.(check (result send error)) 96 | "res2" res2 97 | (Error (`Write_error `Closed)); 98 | Lwt.return_unit 99 | 100 | let test_output_string = 101 | Alcotest_lwt.test_case "output string" `Quick @@ fun _sw () -> 102 | let open Lwt.Infix in 103 | let buf = Bytes.create 12 in 104 | let ctx = Mimic.add edn0 ("", buf) Mimic.empty in 105 | Mimic.resolve ctx >>= fun flow -> 106 | Alcotest.(check bool) "resolve" (Result.is_ok flow) true; 107 | let flow = Flow.make (Result.get_ok flow) in 108 | Flow.send flow (Cstruct.of_string "Hell") >>= fun res0 -> 109 | Flow.send flow (Cstruct.of_string "o Wo") >>= fun res1 -> 110 | Flow.send flow (Cstruct.of_string "rld!") >>= fun res2 -> 111 | Flow.send flow (Cstruct.of_string "?!?!") >>= fun res3 -> 112 | Flow.recv flow Cstruct.empty >>= fun res4 -> 113 | Alcotest.(check (result send error)) "res0" (Ok 4) res0; 114 | Alcotest.(check (result send error)) "res1" (Ok 4) res1; 115 | Alcotest.(check (result send error)) "res2" (Ok 4) res2; 116 | Alcotest.(check (result send error)) "res3" (Ok 4) res3; 117 | (* FIXME(dinosaure) *) 118 | Alcotest.(check (result recv error)) "res4" (Ok `End_of_flow) res4; 119 | Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!"; 120 | Lwt.return_unit 121 | 122 | module Fake (Edn : sig 123 | type t 124 | end) = 125 | struct 126 | type error = | 127 | type write_error = [ `Closed ] 128 | 129 | let pp_error : error Fmt.t = fun _ -> function _ -> . 130 | 131 | let pp_write_error : write_error Fmt.t = 132 | fun ppf `Closed -> Fmt.string ppf "Connection closed by peer" 133 | 134 | type flow = Edn.t and endpoint = Edn.t 135 | 136 | let connect (edn : endpoint) = Lwt.return_ok edn 137 | let read _ = Lwt.return_ok (`Data Cstruct.empty) 138 | let write _ _ = Lwt.return_ok () 139 | let close _ = Lwt.return_unit 140 | let shutdown _ _ = Lwt.return_unit 141 | let writev _ _ = Lwt.return_ok () 142 | end 143 | 144 | let edn_int, protocol_int = 145 | Mimic.register ~name:"int" (module Fake (struct type t = int end)) 146 | 147 | module Protocol_int = (val Mimic.repr protocol_int) 148 | 149 | let edn_string, protocol_string = 150 | Mimic.register ~name:"string" (module Fake (struct type t = string end)) 151 | 152 | module Protocol_string = (val Mimic.repr protocol_string) 153 | 154 | let edn_float, protocol_float = 155 | Mimic.register ~name:"float" (module Fake (struct type t = float end)) 156 | 157 | module Protocol_float = (val Mimic.repr protocol_float) 158 | 159 | let flow : 160 | type edn flow. (edn, flow) Mimic.protocol -> Mimic.flow Alcotest.testable = 161 | fun protocol -> 162 | let module Repr = (val Mimic.repr protocol) in 163 | let equal a b = match a, b with Repr.T a, Repr.T b -> a = b | _ -> false in 164 | let pp ppf _ = Fmt.string ppf "flow" in 165 | Alcotest.testable pp equal 166 | 167 | let mimic_error = Alcotest.testable Mimic.pp_error ( = ) 168 | 169 | let test_values = 170 | Alcotest_lwt.test_case "values" `Quick @@ fun _sw () -> 171 | let open Lwt.Infix in 172 | let ctx0 = Mimic.empty |> Mimic.add edn_int 42 in 173 | Mimic.resolve ctx0 >>= fun res0 -> 174 | Alcotest.(check (result (flow protocol_int) mimic_error)) 175 | "res0" res0 (Ok (Protocol_int.T 42)); 176 | let ctx1 = Mimic.empty |> Mimic.add edn_string "Hello World!" in 177 | Mimic.resolve ctx1 >>= fun res1 -> 178 | Alcotest.(check (result (flow protocol_string) mimic_error)) 179 | "res1" res1 (Ok (Protocol_string.T "Hello World!")); 180 | let ctx2 = Mimic.empty |> Mimic.add edn_float 0.42 in 181 | Mimic.resolve ctx2 >>= fun res2 -> 182 | Alcotest.(check (result (flow protocol_float) mimic_error)) 183 | "res2" res2 (Ok (Protocol_float.T 0.42)); 184 | Lwt.return_unit 185 | 186 | let test_functions = 187 | Alcotest_lwt.test_case "functions" `Quick @@ fun _sw () -> 188 | let open Lwt.Infix in 189 | let k a b = Lwt.return_some (a + b) in 190 | let ka = Mimic.make ~name:"a" and kb = Mimic.make ~name:"b" in 191 | let ctx = Mimic.(fold edn_int Fun.[ req ka; req kb ] ~k Mimic.empty) in 192 | let ctx = Mimic.add ka 2 ctx in 193 | let ctx = Mimic.add kb 3 ctx in 194 | Mimic.resolve ctx >>= fun res0 -> 195 | Alcotest.(check (result (flow protocol_int) mimic_error)) 196 | "res0" res0 (Ok (Protocol_int.T 5)); 197 | let kint = Mimic.make ~name:"int" in 198 | let k v = Lwt.return_some (string_of_int v) in 199 | let ctx0 = Mimic.(fold edn_string Fun.[ dft kint 42 ] ~k Mimic.empty) in 200 | let ctx1 = Mimic.add kint 51 ctx0 in 201 | Mimic.resolve ctx0 >>= fun res1 -> 202 | Alcotest.(check (result (flow protocol_string) mimic_error)) 203 | "res1" res1 (Ok (Protocol_string.T "42")); 204 | Mimic.resolve ctx1 >>= fun res2 -> 205 | Alcotest.(check (result (flow protocol_string) mimic_error)) 206 | "res2" res2 (Ok (Protocol_string.T "51")); 207 | Lwt.return_unit 208 | 209 | let test_topological_sort = 210 | Alcotest_lwt.test_case "topologicial" `Quick @@ fun _sw () -> 211 | let open Lwt.Infix in 212 | let k v = Lwt.return_some (string_of_int v) in 213 | let kint01 = Mimic.make ~name:"int01" in 214 | let ctx = Mimic.empty in 215 | let ctx = Mimic.(fold edn_string Fun.[ req kint01 ] ~k ctx) in 216 | let kint02 = Mimic.make ~name:"int02" in 217 | let k v = Lwt.return_some (succ v) in 218 | let ctx = Mimic.(fold kint01 Fun.[ req kint02 ] ~k ctx) in 219 | let ctx0 = Mimic.add kint01 5 ctx in 220 | let ctx1 = Mimic.add kint02 4 ctx in 221 | Mimic.resolve ctx0 >>= fun res0 -> 222 | Alcotest.(check (result (flow protocol_string) mimic_error)) 223 | "res0" res0 (Ok (Protocol_string.T "5")); 224 | Mimic.resolve ctx1 >>= fun res1 -> 225 | Alcotest.(check (result (flow protocol_string) mimic_error)) 226 | "res1" res1 (Ok (Protocol_string.T "5")); 227 | Mimic.resolve ctx >>= fun res2 -> 228 | Alcotest.(check (result (flow protocol_string) mimic_error)) 229 | "res2" res2 (Error `Not_found); 230 | Alcotest.(check (result (flow protocol_int) mimic_error)) 231 | "res2" res2 (Error `Not_found); 232 | Lwt.return_unit 233 | 234 | let test_priority = 235 | Alcotest_lwt.test_case "priority" `Quick @@ fun _sw () -> 236 | let open Lwt.Infix in 237 | let int_edn0, int_ptr0 = 238 | Mimic.register ~priority:10 ~name:"int0" 239 | (module Fake (struct type t = int end)) 240 | in 241 | let int_edn1, int_ptr1 = 242 | Mimic.register ~priority:20 ~name:"int1" 243 | (module Fake (struct type t = int end)) 244 | in 245 | let ctx0 = Mimic.empty |> Mimic.add int_edn0 1 |> Mimic.add int_edn1 2 in 246 | let ctx1 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn0 1 in 247 | Mimic.resolve ctx0 >>= fun res0 -> 248 | Mimic.resolve ctx1 >>= fun res1 -> 249 | let module Int0 = (val Mimic.repr int_ptr0) in 250 | Alcotest.(check (result (flow int_ptr0) mimic_error)) 251 | "res0" res0 (Ok (Int0.T 1)); 252 | Alcotest.(check (result (flow int_ptr0) mimic_error)) 253 | "res1" res1 (Ok (Int0.T 1)); 254 | let int_edn2, _ = 255 | Mimic.register ~name:"int2" (module Fake (struct type t = int end)) 256 | in 257 | let ctx0 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn2 3 in 258 | let ctx1 = 259 | Mimic.empty 260 | |> Mimic.add int_edn2 3 261 | |> Mimic.add int_edn1 2 262 | |> Mimic.add int_edn0 1 263 | in 264 | Mimic.resolve ctx0 >>= fun res2 -> 265 | Mimic.resolve ctx1 >>= fun res3 -> 266 | let module Int1 = (val Mimic.repr int_ptr1) in 267 | Alcotest.(check (result (flow int_ptr1) mimic_error)) 268 | "res2" res2 (Ok (Int1.T 2)); 269 | Alcotest.(check (result (flow int_ptr0) mimic_error)) 270 | "res3" res3 (Ok (Int0.T 1)); 271 | let int_edn3, int_ptr3 = 272 | Mimic.register ~priority:20 ~name:"int3" 273 | (module Fake (struct type t = int end)) 274 | in 275 | let ctx0 = Mimic.empty |> Mimic.add int_edn1 2 |> Mimic.add int_edn3 4 in 276 | let ctx1 = Mimic.empty |> Mimic.add int_edn3 4 |> Mimic.add int_edn1 2 in 277 | Mimic.resolve ctx0 >>= fun res4 -> 278 | Mimic.resolve ctx1 >>= fun res5 -> 279 | let module Int3 = (val Mimic.repr int_ptr3) in 280 | Alcotest.(check (result (flow int_ptr3) mimic_error)) 281 | "res4" res4 (Ok (Int3.T 4)); 282 | (* XXX(dinosaure): if two roots exist, we take the most recently registered! 283 | We should provide an other semantic like: the most recently inserted into the [ctx]. *) 284 | Alcotest.(check (result (flow int_ptr3) mimic_error)) 285 | "res5" res5 (Ok (Int3.T 4)); 286 | Lwt.return_unit 287 | 288 | let test_order_of_values = 289 | let open Lwt.Infix in 290 | Alcotest_lwt.test_case "recent values" `Quick @@ fun _sw () -> 291 | let int_edn, int_protocol = 292 | Mimic.register ~name:"int" (module Fake (struct type t = int end)) 293 | in 294 | let ctx = Mimic.empty |> Mimic.add int_edn 5 |> Mimic.add int_edn 6 in 295 | Mimic.resolve ctx >>= fun res -> 296 | let module Int = (val Mimic.repr int_protocol) in 297 | Alcotest.(check (result (flow int_protocol) mimic_error)) 298 | "res" res (Ok (Int.T 6)); 299 | Lwt.return_unit 300 | 301 | let fiber = 302 | Alcotest_lwt.run "mimic" 303 | [ 304 | ( "mimic", 305 | [ 306 | test_input_string; test_output_string; test_values; test_functions; 307 | test_topological_sort; test_priority; test_order_of_values; 308 | ] ); 309 | ] 310 | 311 | let () = Lwt_main.run fiber 312 | -------------------------------------------------------------------------------- /test/unixiz.ml: -------------------------------------------------------------------------------- 1 | let blit0 src src_off dst dst_off len = 2 | let dst = Cstruct.of_bigarray ~off:dst_off ~len dst in 3 | Cstruct.blit src src_off dst 0 len 4 | 5 | let blit1 src src_off dst dst_off len = 6 | let src = Cstruct.of_bigarray ~off:src_off ~len src in 7 | Cstruct.blit src 0 dst dst_off len 8 | 9 | open Lwt.Infix 10 | 11 | let ( >>? ) = Lwt_result.bind 12 | 13 | module Make (Flow : Mirage_flow.S) = struct 14 | type +'a fiber = 'a Lwt.t 15 | 16 | type t = { 17 | queue : (char, Bigarray.int8_unsigned_elt) Ke.Rke.t; 18 | flow : Flow.flow; 19 | } 20 | 21 | type error = [ `Error of Flow.error | `Write_error of Flow.write_error ] 22 | 23 | let pp_error ppf = function 24 | | `Error err -> Flow.pp_error ppf err 25 | | `Write_error err -> Flow.pp_write_error ppf err 26 | 27 | let make flow = { flow; queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char } 28 | 29 | let recv flow payload = 30 | if Ke.Rke.is_empty flow.queue then ( 31 | Flow.read flow.flow >|= Result.map_error (fun err -> `Error err) 32 | >>? function 33 | | `Eof -> Lwt.return_ok `End_of_flow 34 | | `Data res -> 35 | Ke.Rke.N.push flow.queue ~blit:blit0 ~length:Cstruct.length res; 36 | let len = min (Cstruct.length payload) (Ke.Rke.length flow.queue) in 37 | Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.length ~off:0 38 | ~len payload; 39 | Ke.Rke.N.shift_exn flow.queue len; 40 | Lwt.return_ok (`Input len)) 41 | else 42 | let len = min (Cstruct.length payload) (Ke.Rke.length flow.queue) in 43 | Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.length payload; 44 | Ke.Rke.N.shift_exn flow.queue len; 45 | Lwt.return_ok (`Input len) 46 | 47 | let send flow payload = 48 | Flow.write flow.flow payload >|= function 49 | | Error `Closed -> Error (`Write_error `Closed) 50 | | Error err -> Error (`Write_error err) 51 | | Ok () -> Ok (Cstruct.length payload) 52 | end 53 | --------------------------------------------------------------------------------