mte/unikernel/duniverse/mimic/lib/index.mld

{1 Mimic, a small library to abstract transmission protocols.}

{2 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:

{v > How to abstract the network? v}

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

In the case of Git, the {e 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 {e 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 {e socket} principle itself is the common
denominator to protocols like Git, HTTP or SMTP.

It happens that MirageOS offers an interface that describes this {e 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
]}

{b 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 {e 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 {e socket}
described through [Mirage_flow.S] to a "new" {e socket} with TLS:

{[
Tls_mirage.Make : functor (_ : Mirage_flow.S) -> Mirage_flow.S
]}

Therefore, it is possible to upgrade our protocols {b 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 {e 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:
+ a functor for the TCP/IP stack (required for MirageOS)
+ 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:
+ the possibility to {b statically} choose the TCP/IP stack
+ the possibility to {b statically} choose the implementation of the TLS layer
+ a way to communicate with TCP/IP within our [Make]
+ a way to communicate with TLS within our [Make]
+ to propose a function making the {b 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
{e socket} and what is a {e socket} with TLS. The problem applies as much for
Git with SSH.

This static knowledge required of the modules implementing the {e socket} as
well as its possible derivation into a TLS {e 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:
+ be perfectly abstract
+ always be able to propose a "dispatch" of these protocols in a dynamic way
+ never arbitrarily choose an implementation or more specifically a type
  representing these {e sockets}

{2 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:

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

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
{e 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.

{2 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.length ~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 {e socket}. Here we are
saying that our {e socket} {b is} mimic. Of course, mimic is compatible with
MirageOS.

{2 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 {e 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 {e 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 {e 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:
+ implement our ping-pong protocol - at least, the client part
+ this code will not change when it comes to upgrade the transmission with TLS
+ 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.

{2 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 {e 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:
+ know the transmission protocol and what it requires
+ 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:
+ a {i witness} of what is required to instantiate a TCP/IP transmission with
  this [TCP] module
+ a {i witness} of our [TCP] implementation

{b 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
{i 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 {i witness} is useful to "fill in" a context that we could then pass to
our client. The idea is that if a value {i 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:
+ we have to specify the IP address
+ we have to specify a port
+ 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:
+ create other {i witnesses}
+ {i populate} the context with functions that manipulate added values with
  using the {i 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.

{2 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 {i scheme}.

Finally, we have a new context allowing to instantiate a TLS {e 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
{i 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.

{2 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:
{e injection}.

{b 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]
{e 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)
]}