Created
March 21, 2021 14:15
-
-
Save dinosaure/ad854e197ad5d8bf455d34987281e5bc to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(* 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment