main.ml

(* Une explication de [mimic] et de qu'il essaye de résoudre.

   [mimic] est une toute petite librairie qui propose une ré-implementation
   des méthodes virtuelles pour les modules. Dans un projet large tel que
   Git ou Irmin, en gardant l'idée de l'abstraction du système requise pour
   être compatible avec MirageOS, une question transcende tout les niveaux:

   > comment abstraire le réseau ?

   Dans le contexte spécifique Unix/<unistrd.h>, plusieurs fonctions existent
   pour communiquer à travers le réseau. Notamment l'idée de 'socket'. Pour
   la plupart des projets, la 'socket' semble être le dénominateur commun pour
   toutes transmissions.

   Dans le cas de Git, la 'socket' peut représenter une simple connexion TCP/IP
   ou une transmission au travers de SSH (à l'aide de pipe). Pour ce qui est des
   stacks HTTP avec TLS, le principe reste la même à partir du moment où OpenSSL
   propose un équivalent de la 'socket' au travers d'une dérivation de celle-ci.

   Pour preuve, [Lwt_ssl] propose cette même abstraction avec:

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

   Dans tout les cas, il semble que le principe même de 'socket' semble être
   le dénominateur commun aux protocols comme Git, HTTP ou encore SMTP.

   Il se trouve que MirageOS propose une interface qui décrit cette abstraction:

   > sig
   >  type error
   >  val pp_error : error Fmt.t
   >  type write_error
   >  val pp_write_error : write_error Fmt.t
   >
   >  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] est une méthode qui diverge du `read`/`recv` qu'on a l'habitude
   de voir avec <unistd.h> où ce dernier demande un buffer où il peut écrire.
   Historiquement, l'idée de [Mirage_flow.S.read] donne la possibilité du
   'zero-copy'. En effet, le [Cstruct.t] qui est retourné devrait être un
   'proxy' du paquet TCP/IP. De ce faite, entre le 'driver' TCP/IP et
   l'application cliente, il ne devrait pas y avoir de copies. Cependant:

   1) on ne sait pas si cette assertion est encore vrai
   2) elle ne correspond en rien de réelle pour TLS (où il y a nécessairement
      de la copie)

   Avec cette interface, il peut être possible d'abstraire la 'socket' pour des
   protocols comme HTTP, Git/Smart ou SMTP tel que:

   > 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)

   Il se trouve que `ocaml-tls` propose une dérivation d'une 'socket' donné et
   est décrite au travers de `Mirage_flow.S` vers une "nouvelle" 'socket' avec
   TLS:

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

   De ce faite, il est possible d'"upgrade" nos protocols avec une couche TLS
   assez facilement:

   > module TLS = Tls_mirage.Make (Tcpip_stack_direct.TCP)
   > module SSMTP = Make_SMTP (TLS)
   > module HTTPS = Make_HTTP (TLS)

   Le problème de ce genre d'abstraction est l'aspect éminament statique de ce
   code. En effet, le choix entre SMTP ou SSMTP (HTTP ou HTTPS) ne peut se
   faire quand choisissant **statiquement** ces modules.

   Cela implique que si le type de la transmission dépend d'une valeur tel
   qu'une `Uri.t` (et son _scheme_), il nous faut avoir accès à ces 2 modules
   tout au long de notre processus.

   D'autant plus que `SSMTP` ou `HTTPS` sont eux même dirigés par un choix
   arbitraire qui est celui d'utiliser `ocaml-tls` en lieu est place de OpenSSL.
   Il peut être essentiel de laisser le choix à l'utilisateur de son
   implémentation TLS.

   Il nous faudrait donc:
   1) un _functor_ pour la stack TCP/IP (requis pour MirageOS)
   2) un _functor_ qui est lui même un _functor_ attendant notre dénominateur
      commun, la 'socket', et qui puisse dériver celle-ci en une transmission
      TLS

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

   De ce faite, on assure:
   1) la possibilité de choisir la stack TCP/IP
   2) la possibilité de choisir l'implémentation de la couche TLS
   3) d'obtenir à l'intérieur du _functor_ un moyen de communiquer avec TCP/IP
   4) d'obtenir à l'intérieur du _functor_ un moyen de communiquer avec TLS
   5) de proposer une fonction faisant le choix dynamique entre ces 2 types de
      transmission

   > module Make_SMTP (Socket : _) (Tls : _) = struct
   >   module Tls = Tls (Socket)
   >
   >   let connect uri = match Uri.scheme uri with
   >     | Some "https" -> Tls.connect ...
   >     | Some "http" -> Socket.connect ...
   > end

   Le problème reste en tout état de cause l'aspect éminament dynamique du choix
   du protocol de transmission qui requiert une connaissance de qu'est une
   'socket' et de ce qu'est une 'socket' avec TLS. Le problème s'applique tout
   autant pour Git avec SSH.

   Cette connaissance requise des modules implémentant la 'socket' ainsi que sa
   dérivation possible en une 'socket' TLS nous mets dans une position difficile
   lorsque nous souhaitons garder la puissance d'abstraction des _functors_ pour
   être compatible avec MirageOS - dans lequel, ni l'implémentation TCP/IP, ni
   l'implémentation TLS ne peut être su globalement (en d'autres termes, leurs
   implémentations ne peuvent s'obtenir qu'au travers d'un _functor_).

   Dans le cadre de MirageOS, toute cette complexité des _functors_ peut être
   réduite à l'aide de _functoria_ qui permet d'appliquer proprement les
   _functors_ selon la "target". Pour l'exemple, la stack TCP/IP dépends de la
   "target" en tout et pour tout puisque qu'avec `mirage configure -t unix`,
   nous utilisons la stack du système hôte mais pour `mirage configure -t hvt`,
   nous utilisons `mirage-tcpip`.

   Malheureusement, cela implique de "garder" ce niveau d'abstraction pour
   toutes librairies dépendant de notre implémentation SMTP/HTTP/Smart si ces
   dernières veulent garder la compatibilité avec MirageOS.

   Un "shift" sur les _functors_ s'opèrent alors systématiquement ce qui amène à
   une progression du nombre de _functors_ exponentielle au fur et à mesure
   qu'on avance de couche en couche.

   Par exemple, Irmin avec Git devra intégrer à la fois:
   - un _functor_ pour la stack TCP/IP
   - un _functor_ pour TLS (qui lui même est un _functor_ sur la stack TCP/IP)
   - un _functor_ pour la stack HTTP qui est un _functor_ sur la stack
     TCP/IP et TLS
   - un _functor_ pour SSH qui lui même est un _functor_ sur la stack TCP/IP

   C'est seulement au travers de tout ces _functors_ que l'on peut:
   1) être parfaitement abstrait
   2) toujours être en capacité de proposer un "dispatch" de ces protocols
      de manière dynamique
   3) ne jamais arbitrairement choisir une implémentation ou plus spécialement
      un type représentant ces 'sockets'

   Après cette "brève" présentation, il s'agit maintenant de parler de la
   solution. Mais il semble clair que si nous voulions essentialiser le
   problème, il s'agirait tout simplement de dire:

   > comment obtenir une implémentation de protocol **dynamiquement** et sans
   > _functors_ ?

   Dans les précédentes explications, nous faisions mention de `Mirage_flow.S`.
   Même si nous pouvons redire sur cette interface, il se trouve qu'elle est
   tout de même canonique à **tout** protocol de transmission. Elle permet tout
   autant de décrire le protocol TCP/IP, le protocol TCP/IP avec TLS ou le
   protocol SSH car dans ces 3 cas, nous ne cherchons qu'à:
   - lire avec `read`
   - écrire avec `write`

   L'abstraction ne fonctionne pourtant pas losrqu'il s'agit d'_instancier_ la
   'socket'. En effet, une transmission TCP/IP ne requiert qu'une adresse IP et
   un port. Cependant, SSH requiert bien plus tel qu'une clé privé.

   Conduit 2.0 part du principe que ces méthodes d'instanciation doivent être
   connu statiquement. Un ADT décrit ces méthodes et si celui ci n'est pas
   exhaustif, il correspond aux cas usuels tel que HTTPS ou SSMTP.

   Cependant, nous pourions aussi dire que pour ce qui est des protocols comme
   SSMTP ou HTTPS (ou SMTP et HTTP), ces méthodes d'instantiation ne nous
   regarde pas. Encore une fois, nous voudrions juste pouvoir _lire_ et
   _écrire_.

   Au final, [mimic] propose une **implémentation** de `Mirage_flow.S` qui est
   directement utilisable sans _functors_. Nous allons donc commencer
   l'implémentation d'un protocol simple, un ping-pong pour montrer comment
   implémenter un protocol (comme HTTP, SMTP ou Smart) avec [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 ~predicate queue =
    let pos = ref 0 and res = ref (-1) in
    Ke.Rke.iter (fun chr -> if predicate chr && !res = -1 then res := !pos
                          ; incr pos) queue ;
    if !res = -1 then None else Some !res in
  match exists ~predicate:((=) '\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.len ~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.kstrf send (fmt ^^ "\r\n")

(* Le code ci présent est assez simple. Il implémente des logiques qui sont
   habituellement disponible avec une librairie standard. Bien entendu,
   [Mirage_flow.S] ne nous donne pas ces fonctions (mais [Mirage_channel] existe
   pour cela).

   Ces logiques sont le protocol tel qu'on peut le définir. Par exemple, SMTP
   ou HTTP pourrait s'implémenter grâce à ces fonctions. Pour ce qui est de de
   Smart, c'est une autre affaire puisqu'ils utilisent un autre format - ou
   plutôt, ce protocols n'est pas _line-directed_.

   Mais ce qu'il faut surtout dénoter, c'est cette possibilité de directement
   implémenter un protocol sans passer par un _functor_ pour abstraire
   l'implémentation de la transmission. En ce sens, [mimic] pourrait très bien
   être TCP/IP que TLS ou encore SSH.

   À cette étape, nous n'en savons rien et c'est bien l'objectif!

   Le code est compilable avec:

   > ocamlfind opt -linkpkg -package mimic,bigstringaf,cstruct,ke main.ml

   Encore une fois, on peut dénoter les dépendances nécessaire à la compilation.
   Il n'est en aucun cas question de `unix`. Au début de cette explication,
   nous parlions de <unistd.h> comme étant le dénominateur commun à l'optention
   de notre 'socket'. Il s'agit de dire ici que notre 'socket' ici est [mimic].
   Bien entendu, [mimic] est, de base, compatible avec MirageOS.

   Nous allons donc commencer à implémenter le client comme il se doit.
*)

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

(* Dans ce petit bout de code, on voit l'apparition d'une fonction qui ne fait
   pas partie de [Mirage_flow.S] mais à proprement parler de [mimic]. C'est
   [Mimic.resolve].

   Il a été dit plutôt que l'instantiation d'une 'socket' n'est pas l'apanage
   du protocol à proprement parler. En effet, encore une fois, pour ce qui est
   de notre ping-pong protocol, notre _line-directed_ protocol (tout comme SMTP
   ou HTTP encore une fois) ne s'intéresse pas de savoir comment initialiser une
   transmission. Il souhaite juste pouvoir _lire_ et _écrire_.

   Ainsi, ce code semble un peu magique mais l'instantiation d'une 'socket'
   dépends finalement d'une seule valeur, [ctx]. Le contexte est une
   représentation de ce qui est admis de faire selon l'utilisateur final. Il
   contient des éléments qui permettent le fameux "dispatch" dynamique afin
   d'instantier une 'socket'.

   En d'autres termes, c'est au travers du contexte que l'on détermine le type
   de transmission: si celui ci est une transmission TCP/IP ou TLS par exemple.

   Nous allons voir ensuite comment définir ce contexte et comment celui ci
   fonctionne pour choisir tel ou tel type de transmission. Ce qu'il faut garder
   à l'esprit, c'est que nous venons de faire:
   1) l'implémentation notre ping-pong protocol - en tout cas, la partie cliente
   2) ce code **ne changera** pas lorsqu'il s'agira d'"upgrade" la transmission
      avec TLS
   3) ce code est compatible avec MirageOS

   La logique de ce code est très simple, elle transmet ce qu'elle a d'un
   `in_channel` vers le server et c'est tout! Il faut bien comprendre que ce qui
   va suivre doit être extérieur à l'implémentation même du protocol car nous
   allons commencer à expliquer à [mimic] l'instantiation des techniques de
   transmission.

   Cette partie là va directement dépendre des dit protocols de transmission
   comme TCP/IP ou TLS. Ces choix sont donc en dehors de l'implémentation même
   du protocol ping-pong.
*)

(* / *)

(* [mimic] propose un moyen de "remplir" le [ctx] avec des valeurs. Ces valeurs
   sont nécessaire à l'instantiation d'un de vos protocols de transmission.
   Comme nous l'avons dit, pour ce qui est de TCP/IP, l'instantiation d'une
   'socket' passe par l'obtention d'une adresse IP et d'un port.

   Ainsi, si nous remplissons notre contexte avec ces valeurs, [mimic] peut
   initialiser une connection TCP/IP. Plus généralement, 2 étapes sont
   nécessaire pour [mimic] afin d'établir une transmission:
   1) connaitre le protocol de transmission et ce qu'il requiert
   2) ajouter ce qu'il requiert dans un contexte

   La première étape est assez inhabituel. Elle consiste à "enregistrer" un
   protocol de transmission auprès de [mimic]. C'est un prérequis afin d'étendre
   les protocols disponible au travers de [mimic] - et bien entendu, au départ,
   [mimic] ne connait aucun protocol (encore une fois, pour être compatible avec
   MirageOS).

   Il est admis, et c'est bien ce que nous avons dit dès le départ, un protocol
   de transmission peut se décrire avec `Mirage_flow.S`. Pour ce qui est de
   [mirage-tcpip], [ocaml-tls] ou encore [awa-ssh], ces trois implémentations
   respectent l'interface `Mirage_flow.S`.

   Et c'est bien ce qu'attends [mimic], un protocol qui respecte
   `Mirage_flow.S`. Cependant, [mimic] attends une extension à cette interface.
   En effet, au delà d'être capable de relayer le `read` et le `write` de vos
   implémentations vers l'implémentation de votre protocol ping-pong, [mimic]
   dépends aussi d'une méthode d'"instantiation". En d'autres termes, [mimic]
   requiert un module respectant `Mirage_flow.S` **et** une fonction `connect`.

   Prenons pout l'exemple [mirage-tcpip]. On se doit de "tweaker" un peu son
   implémentation afin de pouvoir l'enregistrer auprès de [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)

(* Nous venons donc d'enregistrer le protocol de transmission TCP/IP et [mimic]
   vient de nous retourner 2 valeurs:
   1) un témoin de ce qui est requis pour instantier une transmission TCP/IP
      avec ce module `TCP`
   2) un témoin de notre implémentation `TCP`

   NOTE: il peut être difficile de comprendre pourquoi nous nous devons de
   "tweaker" [mirage-tcpip]. En réalite, si [mimic] veut vraiment s'inscrire
   comme étant un moyen d'abstraction des protocols de transmission, on doit
   admettre l'idée que l'instantiation d'un protocol peut être amené à écrire
   quelque chose. Ce cas est concrèt pour TLS qui opèrent à l'instantiation
   un "handshake" avec le serveur.

   Ainsi, on se doit de permettre `connect` de retourner une erreur d'écriture.

   [tcp_edn] est une valeur qui représente ce qui est requis à notre `connect`.
   Son type dépends explicitement de la manière dont notre implémentation
   instancie notre 'socket'. En d'autres termes, dans notre exemple, son type
   est:

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

   Ce témoin est utile afin de "remplir" un contexte que nous pourrions passer
   ensuite à notre client. L'idée est tel que si une valeur ajouté avec
   [tcp_edn] existe dans le contexte [ctx] utilisé par `Mimic.resolve`, [mimic]
   est en capacité d'instancier une transmission TCP/IP et d'utiliser votre
   module `TCP` en lieu et place de `Mimic.{read,write,close}`.

   Essayons donc d'utiliser notre code. Dans un shell, il nous faut lancer un
   serveur avec [nc -l 8080]. Ensuite, il nous faut exécuter notre 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)

(* Le code est compilable avec:

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

   Il suffit alors d'exécuter notre code tel que '$' est notre client et '#' est
   notre server:

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

   On a ici plusieurs limitations:
   1) nous somme obligé de spécifier l'adresse IP
   2) nous somme obligé de spécifier un port
   3) nous somme finalement limité qu'à remplire notre contexte d'une valeur
      `TCP.t * Ipaddr.t * int`

   Cependant, nous avons quelque chose qui fonctionne sans avoir rien changé du
   code de notre protocol ping-pong. Prenons le temps d'expliquer encore une
   fois ce qu'il vient de se passer.

   Le fait de donner à `client` un contexte contenant les informations requises
   pour l'instantiation d'une 'socket' TCP/IP fait que [mimic] est en capacité
   d'executer `TCP.connect` avec ces arguments. N'oublions pas que c'est bien
   parce que nous avons pris soin d'utiliser [tcp_edn] que [mimic] en est
   capable.

   Puisque le `connect` fonctionne et retourne une `TCP.flow` (et non pas une
   erreur), [mimic] peut "cacher" cette valeur sous le type `Mimic.flow` utilisé
   dans notre code client.

   Enfin, `Mimic.read` et `Mimic.write`, puisqu'ils manipulent un `Mimic.flow`,
   ils ont la capacité d'"introspecter" le `TCP.flow` caché et de faire appelle
   à `TCP.read` et `TCP.write` respectivement. Cette possibilité vient du fait
   qu'on ait "enregistrer" notre protocol `TCP` aurpès de [mimic] avec
   `Mimic.register`.

   Maintenant, nous pouvons essayer de résoudre nos limitations. En effet,
   [mimic] propose une API permettant de:
   1) créer d'autres témoins
   2) "remplir" le contexte de fonctions manipulant ces valeurs ajoutées à
      l'aide des témoins

   Pour l'exemple, nous allons essayer de gérer des noms de domaine plutôt que
   des adresse IP. Grâce à cela, nous pourront écrire "tcp://localhost/". Aussi,
   nous allons définir une valeur par défaut pour le port.

   Encore une fois, nous devons nous souvenir de la compatibilté avec MirageOS.
   Il peut être "simple" de gérer le nom de domaine "localhost", mais derrière
   cette résolution, le processus est plus complexe qu'on ne l'imagine. Il peut
   s'apparenter à une requête DNS sur le réseau. Bien entendu, ce genre de
   mecanisme n'existe pas - tout du moins sans qu'on le souhaite - avec
   MirageOS. Dans notre cas precis et puisque nous dépendons de `unix`, nous
   pouvons directement utilise `Unix.gethostbymame`.
*)

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

(* Nous avons un nouveau contexte qui ne contient pas les valeurs requises pour
   instancier une transmission TCP/IP. Cependant, il contient 2 processus
   important qui permettent de "résoudre" certaines valeurs en d'autres.

   C'est le cas plus concrètement avec la résolution DNS où l'on passe d'un
   nom de domaine à une adresse IP. Si on rajoute un nom de domaine à ce
   contexte, [mimic] est assez intelligent pour essayer d'en obtenir à l'aide de
   [k0] une adresse IP.

   Enfin, le deuxième processus [k1] permet de rassembler certaines valeurs
   si elles existent (sauf pour le port qui a pour valeur par défaut 8080) et
   de produire une valeur de type [tcp_edn].

   Ainsi, nous avons désormais la capacité d'instancier une 'socket' TCP/IP
   par différents moyens et différentes valeurs:
   - avec un nom de domaine
   - avec un nom de domaine et un port
   - avec une adresse IP
   - avec une adresse IP et un port

   On peut ainsi complexifier un tout petit peu notre deconstruction de l'url:
*)

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)

(* On peut dire qu'on a enfin une gestion du "endpoint" correcte à l'aide d'une
   `Uri.t`. Mais ce qu'il faut surtout dénoter c'est la capacité qu'on a de
   choisir ce "endpoint" indépendament de la logique de notre protocol
   ping-pong.

   C'est un autre aspect important de [mimic], il ne reconnait que le [ctx] qui,
   au final, est un ensemble hétérogène de valeurs. Ces valeurs peuvent venir
   de n'importe qu'elles représentations canoniques de votre "endpoint". Dans
   notre cas, nous utilisons une `Uri.t` mais une autre représentation peut être
   utilisé.

   C'est le cas entre Paf (un layer d'abstraction de HTTP/AF compatible avec
   MirageOS) et Git. L'un demande une `Uri.t` comme représentation canonique
   d'un cible tandis que l'autre défini son propre type `Smart_git.Endpoint.t`
   puisque la cible peut être représenté par une "adresse email" (comme
   [git@github.com:mirage/mimic]).

   Bref, tout cela nous montre un contrôle assez fin du "dispatch". [mimic]
   tente juste de recoler les morceaux entre eux et de trouver le moyen de créer
   des valeurs respectant le prérequis de vos protocols afin de pouvoir les
   instancier.

   Nous allons maintenant voir comment "upgrader" tout notre code afin
   d'utiliser 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, domain_name, ipaddr, port) =
    let open Tcpip_stack_socket.V4V6 in
    TCP.create_connection stack (ipaddr, port)
    >|= R.reword_error (fun err -> `Read err)
    >>? fun flow ->
    let host = Option.map Domain_name.to_string domain_name in
    client_of_flow tls ?host flow
end

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

let authenticator ~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

(* Ici, la méthode reste la même que pour `TCP`. On créer le module et on
   l'enregistre ensuite avec [mimic]. On a deux nouvelles valeurs qui permettent
   de mieux préciser le "dispatch" en fonction du _scheme_.

   Enfin, nous avons un nouveau contexte permettant d'instancier une 'socket'
   TLS selon certaines valeurs dont quelque unes ont une valeur par défaut.
   On peut enfin compléter la déconstruction de notre `Uri.t` encore une fois
   afin de gérer tout ces paramètres.
*)

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)

(* Il y a pas mal de chose à dire ici et à faire pour pouvoir tester ce code.
   Tout d'abord on note l'utilisation de `Mimic.merge` permettant de merger 2
   contextes pour n'en obtenir qu'un seul. Pour éviter la repétition de code,
   nous allons réutiliser [ctx01] qui contient notre résolveur DNS.

   Ensuite, nous rajoutons le _scheme_ depuis l'`Uri.t` donné.

   Pour lancer un server TLS, rien de plus simple que:
   # 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

   Pour ce qui est de notre client, nous devons le compiler avec:

   $ ocamlfind opt -thread -linkpkg -package \
       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

   Et voilà! Encore une fois et comme exemple, l'extension d'un protocol à un
   autre est complétement transparente pour la logique du protocol ping-pong.
   Comme vous pouvez le constater, [mimic] est très minimal mais il permet
   énormément de chose. La possibilité d'intégrer des processus complexes dans
   le contexte permet d'étendre ce que nous sommes capable de gérer.

   Bien entendu, l'aspect minimal de [mimic] est dans l'esprit de MirageOS. Au
   final, [mimic] ne permet qu'une chose: ré-implémenter les méthodes virtuelle
   pour les modules. La discrimination des implémentations disponible dans ce
   qui est comparable à une _vtable_ (en C++) ce fait par le contexte.

   Enfin les fonctions qui sont dans le contexte peuvent tout autant échouer.
   Dans ce cas, [mimic] va essayer d'autres solutions. Cette situation permet
   d'expliquer un autre paramètre utilisé dans notre exemple pour TLS, la
   priorité. Celle ci assure que même si les informations requises pour
   [tcp_edn] existent, [mimic] tentera d'abord d'instancier une transmission
   TLS (si, encore une fois, toutes les informations sont disponibles).

   Nous pouvons enfin nous appliquer à implémenter le serveur maintenant.
*)

(* / *)

(* [mimic] fait le choix de laisser à l'utilisateur la manière dont on fait un
   serveur. En effet, il y a une réelle différence entre un client et un
   serveur. Il y a une part dynamique dans le choix du protocol de transmission
   entant que client mais ce n'est surtout pas le cas pour le serveur où l'on
   sait exactement comment lancer notre serveur.

   En effet, tout ce qui est initialisation ou la logique de la boucle principal
   reste en dehors [mimic]. Cependant, [mimic] intervient en un point. Entant
   que serveur, il s'agit de gérer des clients qui vont tout autant _lire_ et
   _écrire_. Il peut être intéressant d'implémenter la gestion des clients, le
   _handler_ ou le _callback_ avec [mimic].

   L'objectif est donc d'implémenter cette logique avec [mimic] et nous allons
   expliquer le moyen de passer d'une 'socket' TCP/IP ou TLS vers un
   `Mimic.flow`. On nomme ce processus l'injection.

   NOTE: nous allons redéfinir [TCP] et [TLS] pour utiliser cette fois
   directement la stack TCP/IP du système hôte à l'aide de
   `Lwt_unix.file_descr`. Au delà de montrer un autre exemple de comment
   "enregistrer" d'autres protocols, il nous est requis de le faire pour la
   simple et bonne raison que [mirage-tcpip] propose une autre logique/interface
   du server. En effet, pour ce qui est de Unix/<unistd.h>, nous sommes habitué
   au triptik `socket`/`accept`/`close`. [mirage-tcpip] proposes une interface
   plus "fonctionnel" avec une fonction `listen` qui enregistre votre _callback_
   en interne. Finalement, [mirage-tcpip] implémente sa propre boucle principal.
   Bien entendu, tout ceci est requis entre parce qu'il nous est impossible de
   passer d'un `Unix.file_descr`/`Lwt_unix.file_descr` à une 'socket'
   [mirage-tcpip].

   Pour ne perdre personne et avoir une compréhension cohérente avec ce qui est
   usuellement fait dès qu'il s'agit d'implémenter un serveur, nous nous devons
   donc de réimplémenter `TCP` et `TLS` et utiliser ces modules comme étant
   nos protocols de transmission.
*)

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, domain_name, sockaddr) =
    TCP'.connect sockaddr
    >|= R.reword_error (fun err -> `Read err)
    >>? fun flow ->
    let host = Option.map Domain_name.to_string domain_name in
    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))

(* Cette fois ci les valeurs qui nous intéressent sont les témoins des
   protocols. Ces derniers nous permettent de créer un molude exposant le
   constructeur qui étend notre type `Mimic.flow`.

   L'obtention de ce constructeur se fait à l'aide de `Mimic.repr`. Dans notre
   exemple, on obtient des modules qui contiennent un type `t` mais surtout, ils
   exposent un constructeur `T` qui nous permet d'injecter notre 'socket'
   entant que `Mimic.flow` pour ainsi prendre l'opportunité d'abstraire notre
   code `handler` au travers de notre type `Mimic.flow`.

   Ainsi, on peut créer une value `Mimic.flow` à partir de notre 'socket'
   `Lwt_unix.file_descr` en faisant:

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

   Il en est de même pour TLS qui a un type différent - et donc, un constructeur
   différent:

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

   Le reste du code est la partie applicative de notre ce que nous venons de
   faire. On peut compiler le code avec:

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

   Enfin, le côté serveur s'exécute avec '#' et le côté client avec '$':

   # ./a.out server cert.pem key.pem 4343
   # ./a.out server 8080
   $ ./a.out client tcp://localhost:8080/
   $ ./a.out client tls://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 (`RSA 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)