Merge pull request #47 from mirage/ng

New version of PTT

bin/lipap.ml

@@ -11,26 +11,16 @@ let ( <.> ) f g x = f (g x)
 
 open Rresult
 
-module Resolver = struct
-  type +'a io = 'a Lwt.t
-  type t = Dns_client_lwt.t
+module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make
+  (Time) (Mclock) (Tcpip_stack_socket.V4V6)
 
-  let gethostbyname t v =
-    let open Lwt.Infix in
-    Dns_client_lwt.gethostbyname t v >|= function
-    | Ok v -> Ok (Ipaddr.V4 v)
-    | Error _ as err -> err
-
-  let getmxbyname t v =
-    let open Lwt_result in
-    Dns_client_lwt.getaddrinfo t Dns.Rr_map.Mx v >|= fun (_, mxs) -> mxs
-
-  let extension _t _ldh _v =
-    Lwt.return (R.error_msgf "Impossible to resolve [%s:%s]" _ldh _v)
-end
+module Dns_client = Dns_client_mirage.Make
+  (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
+  (Happy_eyeballs_daemon)
 
 module Server =
-  Lipap.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6)
+  Lipap.Make (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
+    (Dns_client) (Happy_eyeballs_daemon)
 
 let load_file filename = Bos.OS.File.read filename
 
@@ -48,12 +38,11 @@ let private_key =
 
 let private_key = Rresult.R.get_ok private_key
 
-let authenticator _username _password =
-  Ptt_tuyau.Lwt_backend.Lwt_scheduler.inj (Lwt.return true)
+let authenticator _username _password = Lwt.return true
 
 let authenticator = Ptt.Authentication.v authenticator
 
-let fiber ~domain locals =
+let job ~domain locals =
   let open Lwt.Infix in
   let open Tcpip_stack_socket.V4V6 in
   let ipv4_only = false and ipv6_only = false in
@@ -63,8 +52,9 @@ let fiber ~domain locals =
       ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None)
       () in
   let tls = Rresult.R.failwith_error_msg tls in
-  TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
-  >>= fun tcpv4v6 ->
+  TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 ->
+  UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 ->
+  connect udpv4v6 tcpv4v6 >>= fun stack ->
   let info =
     {
       Ptt.SMTP.domain
@@ -73,25 +63,23 @@ let fiber ~domain locals =
     ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT
     ; Ptt.SMTP.size= 0x1000000L
     } in
-  let he = Happy_eyeballs_lwt.create () in
-  let resolver = Dns_client_lwt.create he in
+  Happy_eyeballs_daemon.connect_device stack >>= fun he ->
+  let dns = Dns_client.create (stack, he) in
   let tls =
     let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in
     Tls.Config.client ~authenticator () in
   let tls = Rresult.R.failwith_error_msg tls in
-  Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver None Digestif.BLAKE2B
-    info authenticator [Ptt.Mechanism.PLAIN]
+  Server.job ~port:4242 ~locals ~tls ~info None Digestif.BLAKE2B tcpv4v6 dns he
+    authenticator [Ptt.Mechanism.PLAIN]
 
 let romain_calascibetta =
   let open Mrmime.Mailbox in
   Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"])
 
 let () =
-  let domain = Domain_name.(host_exn <.> of_string_exn) "x25519.net" in
-  let locals = Ptt.Relay_map.empty ~postmaster:romain_calascibetta ~domain in
-  let locals =
-    let open Mrmime.Mailbox in
-    Ptt.Relay_map.add
-      ~local:Local.(v [w "romain"; w "calascibetta"])
-      romain_calascibetta locals in
-  Lwt_main.run (fiber ~domain locals)
+  let locals = Ptt_map.empty ~postmaster:romain_calascibetta in
+  let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in
+  Ptt_map.add
+    ~local:(`Dot_string [ "romain"; "calascibetta" ])
+    romain_calascibetta locals;
+  Lwt_main.run (job ~domain locals)

bin/mti_gf.ml

@@ -11,26 +11,16 @@ let ( <.> ) f g x = f (g x)
 
 open Rresult
 
-module Resolver = struct
-  type +'a io = 'a Lwt.t
-  type t = Dns_client_lwt.t
+module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make
+  (Time) (Mclock) (Tcpip_stack_socket.V4V6)
 
-  let gethostbyname t v =
-    let open Lwt.Infix in
-    Dns_client_lwt.gethostbyname t v >|= function
-    | Ok v -> Ok (Ipaddr.V4 v)
-    | Error _ as err -> err
+module Dns_client = Dns_client_mirage.Make
+  (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
+  (Happy_eyeballs_daemon)
 
-  let getmxbyname t v =
-    let open Lwt_result in
-    Dns_client_lwt.getaddrinfo t Dns.Rr_map.Mx v >|= fun (_, mxs) -> mxs
-
-  let extension _t _ldh _v =
-    Lwt.return (R.error_msgf "Impossible to resolve [%s:%s]" _ldh _v)
-end
-
-module Server =
-  Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6)
+module Server = Mti_gf.Make
+  (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
+  (Dns_client) (Happy_eyeballs_daemon)
 
 let load_file filename = Bos.OS.File.read filename
 
@@ -50,12 +40,13 @@ let tls =
   let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in
   R.failwith_error_msg (Tls.Config.client ~authenticator ())
 
-let fiber ~domain locals =
+let job ~domain locals =
   let open Lwt.Infix in
   let open Tcpip_stack_socket.V4V6 in
   let ipv4_only = false and ipv6_only = false in
-  TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
-  >>= fun tcpv4v6 ->
+  TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 ->
+  UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 ->
+  connect udpv4v6 tcpv4v6 >>= fun stack ->
   let info =
     {
       Ptt.SMTP.domain
@@ -64,20 +55,18 @@ let fiber ~domain locals =
     ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT
     ; Ptt.SMTP.size= 0x1000000L
     } in
-  let he = Happy_eyeballs_lwt.create () in
-  let resolver = Dns_client_lwt.create he in
-  Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver info
+  Happy_eyeballs_daemon.connect_device stack >>= fun he ->
+  let dns = Dns_client.create (stack, he) in
+  Server.job ~port:4242 ~locals ~tls ~info tcpv4v6 dns he
 
 let romain_calascibetta =
   let open Mrmime.Mailbox in
   Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"])
 
 let () =
-  let domain = Domain_name.(host_exn <.> of_string_exn) "x25519.net" in
-  let locals = Ptt.Relay_map.empty ~postmaster:romain_calascibetta ~domain in
-  let locals =
-    let open Mrmime.Mailbox in
-    Ptt.Relay_map.add
-      ~local:Local.(v [w "romain"; w "calascibetta"])
-      romain_calascibetta locals in
-  Lwt_main.run (fiber ~domain locals)
+  let locals = Ptt_map.empty ~postmaster:romain_calascibetta in
+  let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in
+  Ptt_map.add
+    ~local:(`Dot_string [ "romain"; "calascibetta" ])
+    romain_calascibetta locals;
+  Lwt_main.run (job ~domain locals)

lib/authentication.ml

@@ -1,24 +1,24 @@
-open Colombe.Sigs
 open Rresult
+open Lwt.Infix
 
 let ( <.> ) f g x = f (g x)
 
-type ('s, 'k) t = username -> 'k password -> (bool, 's) io
+type 'k t = username -> 'k password -> bool Lwt.t
 and username = Emile.local
 and 'k password = 'k Digestif.t
 
-external v : (username -> 'k password -> (bool, 's) io) -> ('s, 'k) t
+external v : (username -> 'k password -> bool Lwt.t) -> 'k t
   = "%identity"
 
 let is_zero = ( = ) '\000'
 
-let authenticate {return; bind} hash username password t =
-  let ( >>= ) = bind in
+let authenticate hash username password t =
   let p = Digestif.digest_string hash password in
   Bytes.fill (Bytes.unsafe_of_string password) 0 (String.length password) '\000';
-  t username p >>= fun v -> return (R.ok v)
+  t username p >>= fun v -> Lwt.return_ok (username, v)
 
-let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v =
+let decode_plain_authentication hash ?stamp t v =
+  let ( >>= ) = Result.bind in
   let parser =
     let open Angstrom in
     take_till is_zero >>= fun v0 ->
@@ -33,18 +33,18 @@ let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v =
   | Some stamp, Ok (v0, v1, v2) ->
     if Eqaf.equal stamp v0 then
       match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with
-      | Ok username -> authenticate scheduler hash username v2 t
-      | Error _ -> return (R.error_msgf "Invalid username: %S" v1)
-    else return (R.error_msgf "Invalid stamp")
+      | Ok username -> authenticate hash username v2 t
+      | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1)
+    else Lwt.return (R.error_msgf "Invalid stamp")
   | None, Ok ("", v1, v2) -> (
     match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with
-    | Ok username -> authenticate scheduler hash username v2 t
-    | Error _ -> return (R.error_msgf "Invalid username: %S" v1))
-  | None, Ok (_, _, _) -> return (R.error_msgf "Unexpected stamp")
-  | _, (Error _ as err) -> return err
+    | Ok username -> authenticate hash username v2 t
+    | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1))
+  | None, Ok (_, _, _) -> Lwt.return (R.error_msgf "Unexpected stamp")
+  | _, (Error _ as err) -> Lwt.return err
 
 type mechanism = PLAIN of string option
 
-let decode_authentication scheduler hash m t v =
+let decode_authentication hash m t v =
   match m with
-  | PLAIN stamp -> decode_plain_authentication scheduler hash ?stamp t v
+  | PLAIN stamp -> decode_plain_authentication hash ?stamp t v

lib/authentication.mli

@@ -1,25 +1,23 @@
-open Colombe.Sigs
 open Rresult
 
-type ('s, 'k) t
+type 'k t
 (** The {i authenticator} type. *)
 
 type username = Emile.local
 type 'k password = 'k Digestif.t
 
-val v : (username -> 'k password -> (bool, 's) io) -> ('s, 'k) t
+val v : (username -> 'k password -> bool Lwt.t) -> 'k t
 (** [v authenticator] makes an {i authenticator}. *)
 
 type mechanism =
   | PLAIN of string option  (** Type of mechanism used by the client. *)
 
 val decode_authentication :
-     's impl
-  -> 'k Digestif.hash
+     'k Digestif.hash
   -> mechanism
-  -> ('s, 'k) t
+  -> 'k t
   -> string
-  -> ((bool, [> R.msg ]) result, 's) io
+  -> (Emile.local * bool, [> R.msg ]) result Lwt.t
 (** [decode_authentication scheduler hash mechanism t payload] tries to decode
     [payload] according [mechanism] used. Then, it applies the {i authenticator}
     [t] with decoded value. [hash] is used as a {i witness} of which hash