package mimic

Mimic, a small library to abstract transmission protocols.

Introduction.

Mimic is a very small library that offers a re-implementation of virtual methods for modules. In a large project such as Git or Irmin, keeping in mind the system abstraction required to be compatible with MirageOS, one question transcends all levels:

> How to abstract the network?

In the specific context of Unix/<unistd.h>, several functions exist to communicate across the network. In particular the idea of a socket. For most projects, the socket seems to be the common denominator for all transmissions.

In the case of Git, the socket can represent a simple TCP/IP connection or a transmission through SSH (using a pipe). For HTTP with TLS, the principle remains the same as long as OpenSSL proposes an equivalent of the socket through a derivation of the TCP/IP socket.

As a proof, Lwt_ssl proposes this same derivation:

Lwt_ssl.embed_socket : Lwt_unix.file_descr -> Ssl.context -> Lwt_ssl.socket

In any case, it seems that the socket principle itself is the common denominator to protocols like Git, HTTP or SMTP.

It happens that MirageOS offers an interface that describes this socket:

sig
  type error
  type write_error = private [> `Closed ]

  val pp_error : Format.formatter -> error -> unit
  val pp_write_error : Format.formatter -> write_error -> unit

  type flow

  val read : flow -> (Cstruct.t or_eof, error) result Lwt.t
  val write : flow -> Cstruct.t -> (unit, error) result Lwt.t
  val writev : flow -> Cstruct.t list -> (unit, error) result Lwt.t
  val close : flow -> unit Lwt.t
end

NOTE: read is a method that diverges from the read/recv we're used to seeing with <unistd.h> where the latter requests a buffer to write to. Historically, the idea of Mirage_flow.S.read gives the ability to implement a zero-copy stack. Indeed, the Cstruct.t that is returned could directly be the memory page having the TCP/IP packet. Thus, between the TCP/IP driver (the implementation) and the client application, there should be no allocation. However:

• it is not known if this assertion is still true
• it doesn't correspond to anything real for TLS (where there is necessarily a copy)

With this interface, it can be possible to abstract the socket for protocols like HTTP, Git/Smart or SMTP such as:

module SMTP  = Make_SMTP  (Tcpip_stack_direct.TCP : Mirage_flow.S)
module HTTP  = Make_HTTP  (Tcpip_stack_direct.TCP : Mirage_flow.S)
module Smart = Make_Smart (Tcpip_stack_direct.TCP : Mirage_flow.S)

It turns out that ocaml-tls offers a derivation from a given socket described through Mirage_flow.S to a "new" socket with TLS:

Tls_mirage.Make : functor (_ : Mirage_flow.S) -> Mirage_flow.S

Therefore, it is possible to upgrade our protocols statically with a TLS layer quite easily:

module TLS = Tls_mirage.Make (Tcpip_stack_direct.TCP)

module SSMTP = Make_SMTP (TLS)
module HTTPS = Make_HTTP (TLS)

The problem with this kind of abstraction is the eminently static aspect of this code. Indeed, the choice between SMTP and SSMTP (HTTP or HTTPS) cannot be made when choosing statically these modules.

This implies that if the type of transmission depends on a value such as an Uri.t (and its scheme), we need to have access to these 2 modules throughout our process.

Especially since SSMTP or HTTPS are themselves directed by an arbitrary choice which is to use ocaml-tls instead of OpenSSL. It may be essential to let the user choose his TLS implementation.

We would therefore need:

1. a functor for the TCP/IP stack (required for MirageOS)
2. a functor that is itself a functor waiting for our common denominator, the socket, and that can derive it into a TLS transmission

module type Make_SMTP =
  functor (Socket : Mirage_flow.S) ->
  functor (Tls : functor (Socket : Mirage_flow.S) -> Mirage_flow.S) ->
  sig ... end

Thus, we ensure:

1. the possibility to statically choose the TCP/IP stack
2. the possibility to statically choose the implementation of the TLS layer
3. a way to communicate with TCP/IP within our Make
4. a way to communicate with TLS within our Make
5. to propose a function making the dynamic choice between these 2 types of transmission

module Make_HTTP (Socket : _) (Tls : _) = struct
  module Tls = Tls (Socket)

  let connect uri = match Uri.scheme with
    | Some "https" -> Tls.connect ...
    | Some "http" -> Socket.connect ...
end

The problem remains in any case the eminently dynamic aspect of the choice of the transmission protocol which requires a static knowledge of what is a socket and what is a socket with TLS. The problem applies as much for Git with SSH.

This static knowledge required of the modules implementing the socket as well as its possible derivation into a TLS socket puts us in a difficult position when we want to keep the abstraction power of the functors to be compatible with MirageOS - in which neither the TCP/IP nor the TLS implementation can be known globally in advance (in other words, their implementations can only be obtained through a functor).

In MirageOS, all this complexity of the functors can be reduced with the help of functoria which allows to apply the functors cleanly according to the target. For the example, the TCP/IP stack depends on the target at all since with mirage configure -t unix, we use the host system stack but for mirage configure -t hvt, we use mirage-tcpip.

Unfortunately, this implies to "keep" this level of abstraction for all libraries depending on our SMTP/HTTP/Smart implementation if they want to keep the compatibility with MirageOS.

A "shift" on the functors then occurs systematically which leads to an exponential progression of the number of functors as one advances from layer to layer.

For example, Irmin with Git will have to integrate at the same time:

• a functor for the TCP/IP stack
• a functor for TLS (which itself is a functor on the TCP/IP stack)
• a functor for the HTTP stack which is a functor on the TCP/IP and the TLS stack
• a functor for SSH which itself is a functor on the TCP/IP stack
• and we are talking about communication (you can include the hash algorithm, the format of your values, etc.)

It is only through all of these functors that we can:

1. be perfectly abstract
2. always be able to propose a "dispatch" of these protocols in a dynamic way
3. never arbitrarily choose an implementation or more specifically a type representing these sockets

The solution.

After this "brief" introduction, it is now time to talk about the solution! But it seems clear that if we wanted to essentialize the problem, it would simply be to say:

> how to get a protocol implementation dynamically and without functors?

In the previous explanations we mentioned Mirage_flow.S. It turns out that it is canonical to any transmission protocol. It allows to describe the TCP/IP protocol, the TCP/IP protocol with TLS or the SSH protocol because in these 3 cases, we only want to:

• read
• and write

The abstraction does not work however when it comes to instantiating the socket. Indeed, a TCP/IP transmission only requires an IP address and a port. However, SSH requires much more such as an RSA key.

Conduit 2.0 assumes that these instantiation methods must be known statically. An ADT describes these methods and if it is not exhaustive, it corresponds to the usual cases such as HTTPS or SSMTP.

However, we could also say that for protocols like SSMTP or HTTPS (or SMTP or HTTP), these instantiation methods are not our concern. Again, we would just like to be able to read and write.

Implement a protocol with mimic.

In the end, mimic provides an implementation of Mirage_flow.S that is directly usable without functors. So we will start implementating a simple protocol, a ping-pong to show how to implement a protocol (like HTTP, SMTP or Smart) with mimic.

open Rresult
open Lwt.Infix

let ( >>? ) = Lwt_result.bind

let blit src src_off dst dst_off len =
  Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len

let line_of_queue queue =
  let exists ~p queue =
    let pos = ref 0 and res = ref (-1) in
    Ke.Rke.iter (fun chr -> if p chr && !res = -1 then res := !pos
                          ; incr pos) queue ;
    if !res = -1 then None else Some !res in
  match exists ~p:((=) '\n') queue with
  | None -> None
  | Some 0 -> Ke.Rke.N.shift_exn queue 1 ; Some ""
  | Some pos ->
    let tmp = Bytes.create pos in
    Ke.Rke.N.keep_exn queue ~blit ~length:Bytes.length ~off:0 ~len:pos tmp ;
    Ke.Rke.N.shift_exn queue (pos + 1) ;
    match Bytes.get tmp (pos - 1) with
    | '\r' -> Some (Bytes.sub_string tmp 0 (pos - 1))
    | _ -> Some (Bytes.unsafe_to_string tmp)

let blit src src_off dst dst_off len =
  let src = Cstruct.to_bigarray src in
  Bigstringaf.blit src ~src_off dst ~dst_off ~len

let rec getline flow queue = match line_of_queue queue with
  | Some line -> Lwt.return_ok (`Line line)
  | None ->
    Mimic.read flow >>= function
    | Ok `Eof -> Lwt.return_ok `Close
    | Ok (`Data v) ->
      Ke.Rke.N.push queue ~blit ~length:Cstruct.lne ~off:0 v ;
      getline flow queue
    | Error err -> Lwt.return_error (R.msgf "%a" Mimic.pp_error err)

let sendline flow fmt =
  let send str =
    Mimic.write flow (Cstruct.of_string str) >>= function
    | Ok _ as v -> Lwt.return v
    | Error err -> Lwt.return_error (R.msgf "%a" Mimic.pp_write_error err) in
  Fmt.kstr send (fmt ^^ "\r\n")

This code is quite simple. It implements logic that is usually available with a standard library. Of course, Mirage_flow.S does not give us these functions (but Mirage_channel does).

These logics are the protocol as we can define it. For example, SMTP or HTTP could be implemented with these functions. As for Smart, it's another matter since it uses another format - or rather, this protocol is not "line-directed".

But what is most important is the possibility to directly implement a protocol without using a functor to abstract the implementation of the transmission. In this sense, mimic could very well be TCP/IP than TLS or SSH. At this stage, we don't know and that's the point!

You can compile the code with:

$ ocamlfind opt -linkpkg -package rresult,lwt,mimic,bigstringaf,cstruct,ke \
    main.ml

Once again, we can denote the dependencies necessary for compilation. There is no question of unix. At the beginning of this explanation, we talked about <unistd.h> as the common denominator to get our socket. Here we are saying that our socket is mimic. Of course, mimic is compatible with MirageOS.

The client part.

So let's start implementing the client as it should be.

let client ~ctx ic =
  let rec go flow queue = match input_line ic with
    | line ->
      if ic != stdin then Fmt.pr "> %s\n%!" line ;
      sendline flow "%s" line >>? fun () ->
      ( getline flow queue >>? function
      | `Close -> Lwt.return_ok ()
      | `Line v ->
        Fmt.pr "<- %s\n%!" v ;
	if ic == stdin then Fmt.pr "> %!" ;
	go flow queue )
    | exception End_of_file -> Lwt.return_ok () in
  Mimic.resolve ctx >>? fun flow ->
  let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in
  if ic == stdin then Fmt.pr "> %!" ;
  go flow queue >>= fun res ->
  Mimic.close flow >>= fun () -> Lwt.return res

In this small piece of code, we see the appearance of a function that is not part of Mirage_flow.S but strictly speaking of mimic. It's Mimic.resolve.

It was said earlier that the instantiation of a socket is not the privilege of the protocol itself. Indeed, once again, as far as our ping-pong protocol is concerned, our "line-directed" protocol (just like SMTP or HTTP again) does not care how to initialize a transmission. It just wants to be able to read and write.

Thus, Mimic.resolve seems a bit magical but the instantiation of a socket ultimately depends on a single value, the ctx. The context is a representation of what is allowed to do according to the end user. It contains elements that allow the famous dynamic "dispatch" to instantiate a socket.

In other words, it is through the context that we determine the type of transmission: if it is a TCP/IP or TLS transmission for example.

We will then see how to define this context and how it works to choose this or that type of transmission. The important thing to keep in mind is that we have just done:

1. implement our ping-pong protocol - at least, the client part
2. this code will not change when it comes to upgrade the transmission with TLS
3. this code is compatible with MirageOS

The logic of this code is very simple, it passes what it has from an in_channel to the server and that's it! It is important to understand that what follows must be external to the implementation of the protocol itself, because we will start to explain to mimic the instantiation of the transmission techniques.

As a concrete example, ocaml-git is separated in 3 where git implements the Smart protocol, git-unix registers the Unix specific transmission types and git-mirage does the same with MirageOS compatible implementations (mirage-tcpip, tls-mirage or awa-ssh).

This part will directly depend on the said transmission protocols like TCP/IP or TLS. These choices are therefore outside the implementation of the ping-pong protocol itself.

Registration & Instantiation.

Mimic offers a way to "fill" the context with values. These values are needed to instantiate one of your transmission protocols. As we said, for TCP/IP, the instantiation of a socket requires to get an IP address and a port.

So, if we "fill" our context with these values, mimic can initialize a TCP/IP connection. More generally, 2 steps are necessary for mimic to establish a transmission:

1. know the transmission protocol and what it requires
2. add what it requires in a context

The first step is quite unusual. It consists in "registering" a transmission protocol with mimic. This is a prerequisite for extending the protocols available through mimic - and of course, initially, mimic does not know any protocols (again, to be compatible with MirageOS).

It is accepted, as we said from the beginning, that a transmission protocol can described with Mirage_flow.S. As for mirage-tcpip, ocaml-tls or awa-ssh, all three implementations respect the Mirage_flow.S interface.

And this is what mimic expects, a protocol that respects Mirage_flow.S. However, mimic expects an extension to this interface. Indeed, beyond being able to relay the read and write of your implementations to the implementation of your ping-pong protocol, mimic also depends on an "instantiation" method. In other words, mimic requires a module respecting Mirage_flow.S and a connect function: Mimic.Mirage_protocol.S.

Let's take mirage-tcpip as an example. We need to tweak its implementation a bit in order to register it with mimic.

module TCP = struct
  include Tcpip_stack_socket.V4V6.TCP

  let pp_write_error ppf = function
    | #write_error as err -> pp_write_error ppf err
    | `Error err -> pp_error ppf err

  type endpoint = t * Ipaddr.t * int
  type nonrec write_error = [ write_error | `Error of error ]

  let write flow cs = write flow cs >>= function
    | Ok _ as v -> Lwt.return v
    | Error err -> Lwt.return_error (err :> write_error)

  let writev flow css = writev flow css >>= function
    | Ok _ as v -> Lwt.return v
    | Error err -> Lwt.return_error (err :> write_error)

  let connect (stack, ipaddr, port) =
    create_connection stack (ipaddr, port)
    >|= R.reword_error (fun err -> `Error err)
end

let tcp_edn, tcp_protocol = Mimic.register ~name:"tcp" (module TCP)

We have just registered the TCP/IP transmission protocol and mimic has returned 2 values:

1. a witness of what is required to instantiate a TCP/IP transmission with this TCP module
2. a witness of our TCP implementation

NOTE: it may be difficult to understand why we need to tweak mirage-tcpip. In fact, if mimic really wants to be a means of abstracting transmission protocols, one must admit the idea that instantiating a protocol may require writing something. This is the case for TLS which performs a handshake with the server at instantiation. Thus, we must allow connect to return a writing error.

tcp_edn is a value that represents what is required from our connect. Its type depends explicitely on the way our implementation instantiates our socket. In other words, in our example, its type is:

val tcp_edn : (TCP.t * Ipaddr.t * int) Mimic.value

This witness is useful to "fill in" a context that we could then pass to our client. The idea is that if a value of type tcp_edn exists in the ctx context used by Mimic.resolve, mimic is able to instantiate a TCP/IP transmission and use your TCP module instead of Mimic.{read,write,close}.

So let's try to use our code. In a shell, it makes us launch a server with nc -l 8080. Then we need to run out client.

let ctx00 stack ipaddr port =
  Mimic.empty
  |> Mimic.add tcp_edn (stack, ipaddr, port)

let run00 uri ic = match Uri.host uri, Uri.port uri with
  | None, None
  | Some _, None
  | None, Some _ -> Fmt.failwith "Invalid uri: %a" Uri.pp uri
  | Some host, Some port -> match Ipaddr.of_string host with
    | Ok ipaddr ->
      let open Tcpip_stack_socket.V4V6 in
      TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global
        None >>= fun tcp ->
      let ctx = ctx00 tcp ipaddr port in
      client ~ctx ic
    | Error _ -> Fmt.failwith "Invalid IP address: %s" host

let _0 () = match Sys.argv with
  | [| _; uri; |] ->
    Lwt_main.run (run00 (Uri.of_string uri) stdin)
    |> R.reword_error (R.msgf "%a" Mimic.pp_error)
    |> R.failwith_error_msg
  | [| _; uri; filename; |] when Sys.file_exists filename ->
    let ic = open_in filename in
    let rs = Lwt_main.run (run00 (Uri.of_string uri) ic) in
    close_in ic ;
    R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs)
  | _ -> Fmt.epr "%s <uri> [filename]\n%!" Sys.argv.(0)

The code is compilable with

$ ocamlfind opt -thread -package rresult,lwt,mimic,bigstringaf,cstruct,ke, \
    tcpip.stack-socket,uri main.ml

Then we just need to execute our code such that $ is our client and # is our server:

# nc -l 8080
$ ./a.out tcp://127.0.0.1:8080/
$> ping
#ping
#pong
$<- pong

We have several limitations here:

1. we have to specify the IP address
2. we have to specify a port
3. we are finally limited to full our context with a value TCP.t * Ipaddr.t * int

However, we have something that works without having changed any of the code of our ping-pong protocol. Let's take the time to explain once again what just happened. Giving the client a context containing the information required to instantiate a TCP/IP socket causes mimic to be able to execute TCP.connect with these arguments. Let's not forget that it is because we took care to use tcp_edn that mimic is able to do this.

Since the connect works and returns a TCP.flow (not an error), mimic can "hide" this value under the Mimic.flow type used in our client code.

Finally, Mimic.read and Mimic.write, since they handle a Mimic.flow, they have the ability to "introspect" the hidden TCP.flow and call to TCP.read and TCP.write respectively. This possibility comes from the fact that we have "registered" our TCP protocol with mimic (with Mimic.register).

Now we can try to solve our limitations. Indeed, mimic provides an API to:

1. create other witnesses
2. populate the context with functions that manipulate added values with using the witnesses.

For the exemple, we will try to manage domain names rather than IP addresses. Thanks to this, we will be able to write "tcp://localhost/". Also, we will set a default value for the port.

Again, we need to remember to be compatible with MirageOS. It may be "simple" to manage the domain name "localhost", but behind this resolution, the process is more complexe than one might imagine. It can be similar to a DNS query on the network. Of course, this kind of mechanism does not exist - at least not without wish - with MirageOS. In our case, since we already depend on unix, we can directly use Unix.gethostbyname.

In the context of MirageOS, like ocaml-git (see git-mirage), we will use Functoria to add or not the DNS resolution.

let port : int Mimic.value = Mimic.make ~name:"port"
let ipaddr : Ipaddr.t Mimic.value = Mimic.make ~name:"ipaddr"
let domain_name : [ `host ] Domain_name.t Mimic.value =
  Mimic.make ~name:"domain-name"
let stack : Tcpip_stack_socket.V4V6.TCP.t Mimic.value =
  Mimic.make ~name:"stack"

let ctx01 =
  let open Mimic in
  let k0 v = match Unix.gethostbyname (Domain_name.to_string v) with
    | { Unix.h_addr_list; _ } ->
      if Array.length h_addr_list > 0
      then Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0))
      else Lwt.return_none
    | exception _ -> Lwt.return_none in
  let k1 stack ipaddr port = Lwt.return_some (stack, ipaddr, port) in
  Mimic.empty
  |> Mimic.fold ipaddr Fun.[ req domain_name ] ~k:k0
  |> Mimic.fold tcp_edn Fun.[ req stack; req ipaddr; dft port 8080 ] ~k:k1

We have a new context that does not contain the values required to instantiate a TCP/IP transmission. However, it contains 2 important processes that allow to "resolve" some values into others.

This is the case more concretely with DNS resolution where we go from a domain name to an IP address. If we add a domain name to this context, mimis is smart enough to try to get an IP address using k0.

Finally, the second process k1 allows to gather some values if they exist (except for the port which has a default value of 8080) and to produce a value of type tcp_edn.

Thus, we now that the ability to instantiate a TCP/IP socket by different means and different values:

• with a domain name
• with a domain name and a port
• with an IP address
• with an IP address and a port

We can thus make our deconstruction of the Uri.t a little more complex.

let run01 uri ic =
  let ctx = ctx01 in
  let ctx = match Uri.port uri with
    | Some v -> Mimic.add port v ctx
    | None -> ctx in
  let ctx = match Uri.host uri with
    | None -> ctx
    | Some v ->
      match Rresult.(Domain_name.(of_string v >>= host)),
            Ipaddr.of_string v with
      | Ok v, _ -> Mimic.add domain_name v ctx
      | _, Ok v -> Mimic.add ipaddr v ctx
      | _ -> ctx in
  let open Tcpip_stack_socket.V4V6 in
  TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global
    None >>= fun tcp ->
  let ctx = Mimic.add stack tcp ctx in
  client ~ctx ic

let _1 () = match Sys.argv with
  | [| _; uri; |] ->
    Lwt_main.run (run01 (Uri.of_string uri) stdin)
    |> R.reword_error (R.msgf "%a" Mimic.pp_error)
    |> R.failwith_error_msg
  | [| _; uri; filename; |] when Sys.file_exists filename ->
    let ic = open_in filename in
    let rs = Lwt_main.run (run01 (Uri.of_string uri) ic) in
    close_in ic ;
    R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs)
  | _ -> Fmt.epr "%s <uri> [filename]\n%!" Sys.argv.(0)

We can say that we finally have a correct "endpoint" mangement using an Uri.t. But what is important is the ability to choose the endpoint independently of the logic of our ping-pong protocol

This is another important aspect of mimic, it only recognizes the context ctx which, in the end, is a heterogeneous set of values. These values can come from any canonical representation of your endpoin. In our case, we use an Uri.t but another representation can be used.

This is the case between paf (an HTTP/AF abstraction layer compatible with MirageOS) and Git. One requires an Uri.t as a canonical representation of a target while the other defines its own Smart_git.Endpoint.t type since the target can be represented by an email address (like git@github.com:mirage/ocaml-git).

In short, all of this shows us a rather fine control of the "dispatch". mimic just tries to put the pieces together and find a way to create values respecting the prerequisite of your protocols in order to instantiate them.

Upgrade TLS.

We will now see how to upgrade all our code to use TLS.

module TLS = struct
  include Tls_mirage.Make(Tcpip_stack_socket.V4V6.TCP)

  type endpoint =
    Tcpip_stack_socket.V4V6.TCP.t
    * Tls.Config.client * [ `host ] Domain_name.t option
    * Ipaddr.t * int

  let connect (stack, tls, host, ipaddr, port) =
    let open Tcpip_stack_socket.V4V6 in
    TCP.create_connection stack (ipaddr, port)
    >|= R.reword_error (fun err -> `Read err)
    >>? fun flow ->
    client_of_flow tls ?host flow
end

let tls_edn, tls_protocol = Mimic.register ~priority:10 ~name:"tls"
  (module TLS)

let authenticator ?ip:_ ~host:_ _ = Ok None
let default = Tls.Config.client ~authenticator ()

let tls : Tls.Config.client Mimic.value = Mimic.make ~name:"tls-config"
let scheme : string Mimic.value = Mimic.make ~name:"scheme"

let ctx02 =
  let open Mimic in
  let k0 scheme stack tls domain_name ipaddr port = match scheme with
    | "tls" -> Lwt.return_some (stack, tls, domain_name, ipaddr, port)
    | _ -> Lwt.return_none in
  let k1 scheme stack ipaddr port = match scheme with
    | "tcp" -> Lwt.return_some (stack, ipaddr, port)
    | _ -> Lwt.return_none in
  Mimic.empty
  |> Mimic.fold tls_edn
    Fun.[ req scheme; req stack; dft tls default; opt domain_name
        ; req ipaddr; dft port 4343 ] ~k:k0
  |> Mimic.fold tcp_edn
    Fun.[ req scheme; req stack; req ipaddr; dft port 8080 ] ~k:k1

Here, the method remains the same as for TCP. We create the module and then register it with mimic. We have two new values which allow us to better specify ths "dispatch" according to the scheme.

Finally, we have a new context allowing to instantiate a TLS socket according to some values, some of which have a default value. We can finally complete the deconstruction of our Uri.t once again to manage all these parameters.

let run02 uri ic =
  let ctx = Mimic.merge ctx01 ctx02 in
  let ctx = match Uri.scheme uri with
    | Some v -> Mimic.add scheme v ctx
    | None -> ctx in
  let ctx = match Uri.port uri with
    | Some v -> Mimic.add port v ctx
    | None -> ctx in
  let ctx = match Uri.host uri with
    | None -> ctx
    | Some v ->
      match Rresult.(Domain_name.(of_string v >>= host)),
            Ipaddr.of_string v with
      | Ok v, _ -> Mimic.add domain_name v ctx
      | _, Ok v -> Mimic.add ipaddr v ctx
      | _ -> ctx in
  let open Tcpip_stack_socket.V4V6 in
  TCP.connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global
    None >>= fun tcp ->
  let ctx = Mimic.add stack tcp ctx in
  client ~ctx ic

let () = Mirage_crypto_rng_unix.initialize ()

let _2 () = match Sys.argv with
  | [| _; uri; |] ->
    Lwt_main.run (run02 (Uri.of_string uri) stdin)
    |> R.reword_error (R.msgf "%a" Mimic.pp_error)
    |> R.failwith_error_msg
  | [| _; uri; filename |] when Sys.file_exists filename ->
    let ic = open_in filename in
    let rs = Lwt_main.run (run02 (Uri.of_string uri) ic) in
    close_in ic ;
    R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs)
  | _ -> Fmt.epr "%s <uri> [filename]\n%!" Sys.argv.(0)

These is a lot to say here and to do in order to test this code. First of all we note the use of Mimic.merge which allows to merge 2 contexts to obtain only one. To avoid code repetition, we will reuse ctx01 which contains our DNS resolver.

Then we add the scheme from the given Uri.t.

To launch a TLS server, nothing more than:

# openssl req -x509 -newkey rsa:2048 -keyout key.pem -out cert.pem \
    -days 365 -nodes
# openssl s_server -key key.pem -cert cert.pem -accept 4343

As for our client, we need to compile it with:

$ ocamlfind opt -thread -linkpkg -package \
    rresult,lwt,\
    mimic,bigstringaf,cstruct,ke,tcpip.stack-socket,uri,tls-mirage,\
    mirage-crypto-rng.unix main.ml
$ ./a.out tls://localhost:4343/
> ping
#ping
#pong
<- pong
> ^D
#DONE

And that's it! Again, as an example, the extension from one protocol to another is completely transparent to the protocol ping-pong logic. As you can see, mimic is very minimal but it allows a lot of things. The ability to integrate complex processes into the context allows us to extend what we are able to handle.

Of course, the minimal aspect of mimic is in the spirit of MirageOS. In the end, mimic only allows one thing: re-implementing virtual methods for modules. The discrimination of available implementations in what is comparable to a vtable (in C++) is done for the context.

Finally the functions that are in the context can fail as well. In this case, mimic tries other solutions. This situation explains another parameter used in our exemple for TLS, the priority. This ensures that even if the required information for tcp_edn exists, mimic will first try to instantiate a TLS transmission (if, again, all information is available).

We can finally apply to implement the server now.

The server side.

Mimic make the choice to let the user the way the server is made. Indeed, there is a real difference between a client and a server. There is a dynamic part in the choice of the transmission protocol as a client but it is especially not the case for the server where we know exactly how to launch our server.

Indeed, everything that is initialization or the logic of the main loop remains outside mimic. However, mimic intervenes at one point. As a server, it has to manage clients that do both reading and writing. It can be interesting to implement the client management, the "handler" or the "callback" with mimic.

The goal is to implement this logic with mimic and we will explain the way to pass from a TCP/IP or TLS socket to a Mimic.flow. We call this process: injection.

NOTE: we will redefine TCP and TLS to use the TCP/IP stack of the host system directly this time using Lwt_unix.file_descr. Besides showing another example of how to "register" other protocols, we are required to do this for the simple reason that mirage-tcpip offers a different server logic/interface. Indeed, for Unix/<unistrd.h>, we are used to the triptik socket/accept/close. mirage-tcpip proposes a more "functional" interface with a listen function that registers your callback internally. Finally, mirage-tcpip implements its own main loop. Of course, all this is required because we cannot switch from an Unix.file_descr to a mirage-tcpip socker.

In order to not lose anyone and to have a coherent understanding of what is usually done when implementing a server, we have to reimplement TCP and TLS with Unix.file_descr and use these modules as our transmission protocols.

let handler flow =
  let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in
  let rec go flow queue =
    getline flow queue >>? function
    | `Close -> Lwt.return_ok ()
    | (`Line "ping") -> sendline flow "pong" >>? fun () -> go flow queue
    | (`Line "pong") -> sendline flow "ping" >>? fun () -> go flow queue
    | (`Line line) -> sendline flow "%s" line >>? fun () -> go flow queue in
  go flow queue >>= fun res ->
  Mimic.close flow >>= fun () -> Lwt.return res

let handler flow =
  handler flow >>= function
  | Ok () -> Lwt.return_unit
  | Error err ->
    Fmt.epr "Got an error: %a.\n%!" Mimic.pp_error err ;
    Lwt.return_unit

module TCP' = struct
  type flow = Lwt_unix.file_descr

  type error = [ `Error of Unix.error * string * string ]
  type write_error = [ `Closed | `Error of Unix.error * string * string ]

  let pp_error ppf = function
    | `Error (err, f, v) ->
      Fmt.pf ppf "%s(%s) : %s" f v (Unix.error_message err)

  let pp_write_error ppf = function
    | #error as err -> pp_error ppf err
    | `Closed -> Fmt.pf ppf "Connection closed by peer"

  let read fd =
    let tmp = Bytes.create 0x1000 in
    let process () =
      Lwt_unix.read fd tmp 0 (Bytes.length tmp) >>= function
      | 0 -> Lwt.return_ok `Eof
      | len -> Lwt.return_ok (`Data (Cstruct.of_bytes ~off:0 ~len tmp)) in
    Lwt.catch process @@ function
    | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v))
    | exn -> Lwt.fail exn

  let write fd ({ Cstruct.len; _ } as cs) =
    let rec process buf off max =
      Lwt_unix.write fd buf off max >>= fun len ->
      if max - len = 0 then Lwt.return_ok ()
      else process buf (off + len) (max - len) in
    let buf = Cstruct.to_bytes cs in
    Lwt.catch (fun () -> process buf 0 len) @@ function
    | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v))
    | exn -> Lwt.fail exn

  let rec writev fd = function
    | [] -> Lwt.return_ok ()
    | x :: r -> write fd x >>? fun () -> writev fd r

  let close fd = Lwt_unix.close fd

  type endpoint = Lwt_unix.sockaddr

  let connect sockaddr =
    let process () =
      let domain = Unix.domain_of_sockaddr sockaddr in
      let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in
      Lwt_unix.connect socket sockaddr >>= fun () ->
      Lwt.return_ok socket in
    Lwt.catch process @@ function
    | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v))
    | exn -> Lwt.fail exn
end

module TLS' = struct
  include Tls_mirage.Make(TCP')

  type endpoint =
    Tls.Config.client * [ `host ] Domain_name.t option
    * Unix.sockaddr

  let connect (tls, host, sockaddr) =
    TCP'.connect sockaddr
    >|= R.reword_error (fun err -> `Read err)
    >>? fun flow ->
    client_of_flow tls ?host flow
end

let _, tcp_protocol = Mimic.register ~name:"tcp" (module TCP')
let _, tls_protocol = Mimic.register ~name:"tls" (module TLS')

module TCPRepr = (val (Mimic.repr tcp_protocol))
module TLSRepr = (val (Mimic.repr tls_protocol))

This time the values we are interested in are the protocols' witnesses. These allow us to create a module exposing the constructor that extends our Mimic.flow type.

This constructor is obtained with the help of Mimic.repr. In out example, we obtain modules that continue a type t but above all, they expose a constructor T that allows us to inject our socket as Mimic.flow type.

Thus, we can create a Mimic.flow value from our Lwt_unix.file_descr socket by doing:

let flow : Mimic.flow = TCPRepr.T socket in

The same is true for TLS, which has a different type - and thus, a different constructor.

let flow : Mimic.flow = TLSRepr.T socket in

The rest of the code is the application part of what we just did. We can compile the code with:

$ ocamlfind opt -thread -linkpkg -package \
    mimic,bigstringaf,cstruct,ke,tcpip.stack-socket,uri,tls-mirage,\
    mirage-crypto-rng.unix main.ml

Finally, the server side runs with # and the client side with $:

# ./a.out server cert.pem key.pem 4343
# ./a.out 8080
$ ./a.out client tcp://localhost:8080/
$ ./a.out client tsl://localhost:4343/

type ('v, 'flow, 'err) service =
  { accept : 'v -> ('flow, 'err) result Lwt.t
  ; close : 'v -> unit Lwt.t }
  constraint 'err = [> `Closed ]

let serve_when_ready ?stop ~handler { accept; close; } service =
  `Initialized
    (let switched_off =
       let t, u = Lwt.wait () in
       Lwt_switch.add_hook stop (fun () ->
           Lwt.wakeup_later u (Ok `Stopped) ;
           Lwt.return_unit) ;
       t in
     let rec loop () =
       let accept =
         accept service >>? fun flow -> Lwt.return_ok (`Flow flow) in
       accept >>? function
       | `Flow flow ->
         Lwt.async (fun () -> handler flow) ;
         Lwt.pause () >>= loop in
     let stop_result =
       Lwt.pick [ switched_off; loop () ] >>= function
       | Ok `Stopped -> close service >>= fun () -> Lwt.return_ok ()
       | Error _ as err -> close service >>= fun () -> Lwt.return err in
     stop_result >>= function Ok () | Error _ -> Lwt.return_unit)

let tcp =
  let accept t = Lwt_unix.accept t >>= fun (fd, _) ->
    Lwt.return_ok (TCPRepr.T fd) in
  let close t = Lwt_unix.close t in
  { accept; close; }

let tls cfg =
  let accept t =
    Lwt_unix.accept t >>= fun (fd, _) ->
    TLS'.server_of_flow cfg fd >>? fun fd ->
    Lwt.return_ok (TLSRepr.T fd) in
  let close t = Lwt_unix.close t in
  { accept; close; }

let run03 v service =
  let `Initialized th = serve_when_ready ~handler service v in th

let run03 = function
  | `TCP sockaddr ->
    let domain = Unix.domain_of_sockaddr sockaddr in
    let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in
    Lwt_unix.bind socket sockaddr >>= fun () ->
    Lwt_unix.listen socket 40 ;
    run03 socket tcp
  | `TLS (cfg, sockaddr) ->
    let domain = Unix.domain_of_sockaddr sockaddr in
    let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in
    Lwt_unix.bind socket sockaddr >>= fun () ->
    Lwt_unix.listen socket 40 ;
    run03 socket (tls cfg)

let load_file filename =
  let ic = open_in filename in
  let ln = in_channel_length ic in
  let rs = Bytes.create ln in
  really_input ic rs 0 ln ; close_in ic ;
  Cstruct.of_bytes rs

let certificates_of_files cert key =
  let cert = load_file cert in
  let key  = load_file key in
  match X509.Certificate.decode_pem_multiple cert,
        X509.Private_key.decode_pem key with
  | Ok certs, Ok key -> `Single (certs, key)
  | _ -> Fmt.failwith "Invalid key or certificate"

let () = match Sys.argv with
  | [| _; "server"; port; |] ->
    let sockaddr =
      Unix.ADDR_INET (Unix.inet_addr_loopback, int_of_string port) in
    Lwt_main.run (run03 (`TCP sockaddr))
  | [| _; "server"; cert; key; port; |] ->
    let sockaddr =
      Unix.ADDR_INET (Unix.inet_addr_loopback, int_of_string port) in
    let certificates = certificates_of_files cert key in
    let tls = Tls.Config.server ~certificates () in
    Lwt_main.run (run03 (`TLS (tls, sockaddr)))
  | [| _; "client"; uri; |] ->
    Lwt_main.run (run02 (Uri.of_string uri) stdin)
    |> R.reword_error (R.msgf "%a" Mimic.pp_error)
    |> R.failwith_error_msg
  | [| _; "client"; uri; filename; |] when Sys.file_exists filename ->
    let ic = open_in filename in
    let rs = Lwt_main.run (run02 (Uri.of_string uri) ic) in
    close_in ic ;
    R.failwith_error_msg (R.reword_error (R.msgf "%a" Mimic.pp_error) rs)
  | _ ->
    Fmt.epr "%s server [cert.pem] [key.pem] <port>\n%!" Sys.argv.(0) ;
    Fmt.epr "%s client <uri> [filename]\n%!" Sys.argv.(0)