Fix unikernels with the last version of ptt

mirage · Oct 14, 2024 · d8ad094 · d8ad094
1 parent 79f5f20
commit d8ad094
Show file tree

Hide file tree

Showing 18 changed files with 180 additions and 168 deletions.
diff --git a/lib/authentication.ml b/lib/authentication.ml
@@ -4,7 +4,7 @@ open Lwt.Infix
 let ( <.> ) f g x = f (g x)
 
 type 'k t = username -> 'k password -> bool Lwt.t
-and username = Emile.local
+and username = [ `Dot_string of string list | `String of string ]
 and 'k password = 'k Digestif.t
 
 external v : (username -> 'k password -> bool Lwt.t) -> 'k t
@@ -30,12 +30,12 @@ let decode_plain_authentication hash ?stamp t v =
   match stamp, payload with
   | Some stamp, Ok (v0, v1, v2) ->
     if Eqaf.equal stamp v0 then
-      match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with
+      match Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 with
       | 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) ->
-    begin match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with
+    begin match Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 with
     | Ok username -> authenticate hash username v2 t
     | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1) end
   | None, Ok (_, _, _) -> Lwt.return (R.error_msgf "Unexpected stamp")

diff --git a/lib/authentication.mli b/lib/authentication.mli
@@ -3,7 +3,7 @@ open Rresult
 type 'k t
 (** The {i authenticator} type. *)
 
-type username = Emile.local
+type username = [ `Dot_string of string list | `String of string ]
 type 'k password = 'k Digestif.t
 
 val v : (username -> 'k password -> bool Lwt.t) -> 'k t
@@ -17,7 +17,7 @@ val decode_authentication :
   -> mechanism
   -> 'k t
   -> string
-  -> (Emile.local * bool, [> R.msg ]) result Lwt.t
+  -> (username * 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

diff --git a/lib/dune b/lib/dune
@@ -42,6 +42,12 @@
  (modules ptt_server)
  (libraries lwt tls-mirage bigstringaf mirage-time mirage-flow tcpip mimic ptt))
 
+(library
+ (name ptt_fake_dns)
+ (public_name ptt.fake-dns)
+ (modules ptt_fake_dns)
+ (libraries dns-client-mirage))
+
 (library
  (name lipap)
  (public_name ptt.lipap)

diff --git a/lib/ptt_fake_dns.ml b/lib/ptt_fake_dns.ml
@@ -0,0 +1,61 @@
+let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt
+
+module Make (Destination : sig val ipaddr : Ipaddr.t end) = struct
+  module Transport = struct
+    type context = unit
+    type stack = unit
+    type t = unit
+    type 'a io = 'a Lwt.t
+    type io_addr =
+      [ `Plaintext of Ipaddr.t * int 
+      | `Tls of Tls.Config.client * Ipaddr.t * int ]
+
+    let create ?nameservers:_ ~timeout:_ _ = assert false
+    let nameservers _ = `Tcp, []
+    let rng _ = String.empty
+    let clock _ = 0L
+    let connect _ = Lwt.return_error (msgf "Ptt_fake_dns.Transport.connect: not implemented")
+    let send_recv _ _ = Lwt.return_error (msgf "Ptt_fake_dns.Transport.send_Recv: not implemented")
+    let close _ = Lwt.return_unit
+    let bind = Lwt.bind
+    let lift = Lwt.return
+    let happy_eyeballs _ = assert false
+  end
+
+  type happy_eyeballs = unit
+
+  include Dns_client.Make (Transport)
+
+  (* NOTE(dinosaure): [ptt] only uses [getaddrinfo], [gethostbyname] &
+     [gethostbyname6]. The rest is useless. *)
+
+  let getaddrinfo
+    : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (a, [> `Msg of string ]) result Lwt.t
+    = fun _ record domain_name -> match record, Domain_name.host domain_name with
+    | Dns.Rr_map.Mx, Ok mail_exchange -> Lwt.return_ok (0l, Dns.Rr_map.Mx_set.singleton { Dns.Mx.preference= 0; mail_exchange; })
+    | _ -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K record) Domain_name.pp domain_name)
+
+  let gethostbyname _t domain_name = match Destination.ipaddr with
+    | Ipaddr.V4 ipv4 -> Lwt.return_ok ipv4
+    | _ -> Lwt.return_error (msgf "%a not found" Domain_name.pp domain_name)
+
+  let gethostbyname6 _t domain_name = match Destination.ipaddr with
+    | Ipaddr.V6 ipv6 -> Lwt.return_ok ipv6
+    | _ -> Lwt.return_error (msgf "%a not found" Domain_name.pp domain_name)
+
+  let get_resource_record
+    : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (a, [> `Msg of string | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result Lwt.t
+    = fun _t record domain_name -> match record, Domain_name.host domain_name with
+    | Dns.Rr_map.Mx, Ok mail_exchange -> Lwt.return_ok (0l, Dns.Rr_map.Mx_set.singleton { Dns.Mx.preference= 0; mail_exchange; })
+    | _ -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K record) Domain_name.pp domain_name)
+
+  let get_raw_reply
+    : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (Dns.Packet.reply, [> `Msg of string | `Partial ]) result Lwt.t
+    = fun _t _record _domain_name -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K _record) Domain_name.pp _domain_name)
+
+  let nameserver_of_string _ = Error (msgf "Ptt_fake_dns.nameserver_of_string: not implemented")
+  let nameservers _ = `Tcp, []
+  let transport _ = ()
+  let connect ?cache_size ?edns ?nameservers:_ ?timeout () =
+    create ?cache_size ?edns ~nameservers:(`Tcp, []) ?timeout () |> Lwt.return
+end
diff --git a/lib/ptt_fake_dns.mli b/lib/ptt_fake_dns.mli
@@ -0,0 +1,5 @@
+module Make (Destination : sig val ipaddr : Ipaddr.t end) : sig
+  include Dns_client_mirage.S
+    with type 'a Transport.io = 'a Lwt.t
+     and type Transport.stack = unit
+end
diff --git a/lib/ptt_sendmail.ml b/lib/ptt_sendmail.ml
@@ -89,6 +89,10 @@ module Make
     let consumed = ref false in
     consumed, (fun () -> consumed := true; Lwt_stream.get stream)
 
+  (* NOTE(dinosaure): to ensure that we are able to inject a fake DNS resolver,
+     we must use an IP address as a destination to avoid the resolution mechanism
+     of happy-eyeballs! *)
+
   let sendmail ?(last_option= false) he t ~ipaddr elt =
     let ( let* ) = Lwt.bind in
     let destination = Ipaddr.to_string ipaddr in

diff --git a/lib/submission.ml b/lib/submission.ml
@@ -59,18 +59,6 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct
     | `Flow msg -> Fmt.pf ppf "Error at the protocol level: %s" msg
     | `Invalid_recipients -> Fmt.string ppf "Invalid recipients"
 
-  let to_local local =
-    if List.exists (function `String _ -> true | _ -> false) local
-    then
-      let sstr = List.map (function `Atom str -> str | `String str -> str) local in
-      let str = String.concat "." sstr in
-      `String str
-    else
-      let ws, _ = (Fun.flip List.partition_map local) @@ function
-        | `Atom str -> Either.left str
-        | _ -> Either.right () in
-      `Dot_string ws
-
   let authentication ctx ~domain_from (Runner { run; flow; })
     random hash server ?payload mechanism =
     let rec go limit ?payload m =
@@ -86,7 +74,7 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct
           >>= function
           | Ok (user, true) ->
             let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in
-            run flow m >>? fun () -> Lwt.return_ok (`Authenticated (to_local user))
+            run flow m >>? fun () -> Lwt.return_ok (`Authenticated user)
           | (Error _ | Ok (_, false)) as res -> begin
             let () =
               match res with
@@ -124,7 +112,7 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct
           | Ok (user, true) ->
             let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in
             run flow m >>? fun () ->
-            Lwt.return_ok (`Authenticated (to_local user))
+            Lwt.return_ok (`Authenticated user)
           | (Error _ | Ok (_, false)) as res ->
             let () =
               match res with

diff --git a/test/test.ml b/test/test.ml
@@ -75,6 +75,9 @@ let auth0 =
     |> Map.add Local.(v [w "hannes"]) Digestif.(digest_string SHA1 "titi")
     |> Map.add Local.(v [w "gemma"]) Digestif.(digest_string SHA1 "") in
   let f username password =
+    let username = match username with
+      | `Dot_string vs -> List.map (fun x -> `Atom x) vs
+      | `String _ -> assert false in
     match Map.find username m with
     | v -> Lwt.return Digestif.(equal SHA1 password v)
     | exception Not_found -> Lwt.return false in

diff --git a/unikernel/relay/config.ml b/unikernel/relay/config.ml
@@ -32,7 +32,7 @@ let runtime_args = [ setup ]
 
 let relay =
   main ~runtime_args ~packages "Unikernel.Make" @@
-  time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> git_client @-> job
+  time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> happy_eyeballs @-> git_client @-> job
 
 let time = default_time
 let mclock = default_monotonic_clock
@@ -47,4 +47,4 @@ let git_client =
 
 let () =
   register "relay"
-    [ relay $ time $ mclock $ pclock $ stack $ dns $ git_client ]
+    [ relay $ time $ mclock $ pclock $ stack $ dns $ he $ git_client ]
diff --git a/unikernel/relay/unikernel.ml b/unikernel/relay/unikernel.ml
@@ -2,10 +2,9 @@ open Rresult
 open Lwt.Infix
 
 let local_of_string str =
-  match Angstrom.parse_string ~consume:All Emile.Parser.local_part str with
+  match Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part str with
   | Ok v -> Ok v | Error _ -> Error (R.msgf "Invalid local-part: %S" str)
 
-let ( $ ) f g = fun x -> match f x with Ok x -> g x | Error _ as err -> err
 let ( <.> ) f g = fun x -> f (g x)
 let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt
 
@@ -18,7 +17,7 @@ module K = struct
 
   let domain =
     let doc = Arg.info ~doc:"SMTP domain-name." [ "domain" ] in
-    let domain_name = Arg.conv (Domain_name.(of_string $ host), Domain_name.pp) in
+    let domain_name = Arg.conv Colombe.Domain.(of_string, pp) in
     Arg.(required & opt (some domain_name) None doc)
 
   let postmaster =
@@ -32,7 +31,7 @@ module K = struct
 
   type t =
     { remote : string
-    ; domain : [ `host ] Domain_name.t
+    ; domain : Colombe.Domain.t
     ; postmaster : Emile.mailbox }
 
   let v remote domain postmaster =
@@ -46,33 +45,13 @@ module Make
   (Mclock : Mirage_clock.MCLOCK)
   (Pclock : Mirage_clock.PCLOCK)
   (Stack : Tcpip.Stack.V4V6)
-  (DNS : Dns_client_mirage.S with type 'a Transport.io = 'a Lwt.t)
+  (Dns_client : Dns_client_mirage.S)
+  (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow)
   (_ : sig end)
 = struct
   module Store = Git_kv.Make (Pclock)
 
-  module Resolver = struct
-    type t = DNS.t
-    type +'a io = 'a Lwt.t
-
-    (* XXX(dinosaure): it seems that Gmail does not like IPv6... A solution
-       will be to aggregate IPv4 and IPv6 from the given domain and return
-       both to test both... *)
-    let gethostbyname dns domain_name =
-      DNS.gethostbyname dns domain_name >|= function
-      | Ok ipv4 -> Ok (Ipaddr.V4 ipv4)
-      | Error _ as err -> err
-
-    let getmxbyname dns domain_name =
-      DNS.getaddrinfo dns Dns.Rr_map.Mx domain_name >>= function
-      | Ok (_ttl, mxs) -> Lwt.return_ok mxs
-      | Error _ as err -> Lwt.return err
-
-    let extension _dns ldh value =
-      Lwt.return_error (R.msgf "[%s:%s] is not supported" ldh value)
-  end
-
-  module Mti_gf = Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Stack)
+  module Mti_gf = Mti_gf.Make (Time) (Mclock) (Pclock) (Stack) (Dns_client) (Happy_eyeballs)
   module Nss = Ca_certs_nss.Make (Pclock)
 
   let relay_map relay_map ctx remote =
@@ -84,41 +63,42 @@ module Make
         Store.pp_error err);
       Lwt.return relay_map (* FIXME(dinosaure): it seems that we got an error in any situation. *)
     | Ok values ->
-      let f acc = function
-        | (_, `Dictionary) -> Lwt.return acc
+      let f = function
+        | (_, `Dictionary) -> Lwt.return_unit
         | (name, `Value) ->
           Store.get t name >>= function
           | Error err ->
             Logs.warn (fun m -> m "Got an error when we tried to get data \
                                    from %a: %a"
               Mirage_kv.Key.pp name Store.pp_error err);
-            Lwt.return acc
+            Lwt.return_unit
           | Ok str ->
             match Ptt_value.of_string_json str, local_of_string (Mirage_kv.Key.basename name) with
             | Ok { Ptt_value.targets; _ }, Ok local ->
-              let acc = List.fold_left (fun acc x ->
-                Ptt.Relay_map.add ~local x acc) acc targets in
-              Lwt.return acc
+              List.iter (fun x -> Ptt_map.add ~local x relay_map) targets;
+              Lwt.return_unit
             | _, Error (`Msg _) ->
               Logs.warn (fun m -> m "Invalid local-part: %a" Mirage_kv.Key.pp name);
-              Lwt.return acc
+              Lwt.return_unit
             | Error (`Msg err), _ ->
               Logs.warn (fun m -> m "Invalid value for %a: %s" Mirage_kv.Key.pp name err);
-              Lwt.return acc in
-      Lwt_list.fold_left_s f relay_map values
+              Lwt.return_unit in
+      Lwt_list.iter_p f values >>= fun () ->
+      Lwt.return relay_map
 
-  let start _time _mclock _pclock stack dns ctx { K.remote; domain; postmaster; } =
+  let start _time _mclock _pclock stack dns he ctx { K.remote; domain; postmaster; } =
     let authenticator = R.failwith_error_msg (Nss.authenticator ()) in
     let tls = Rresult.R.failwith_error_msg (Tls.Config.client ~authenticator ()) in
-    relay_map (Ptt.Relay_map.empty ~postmaster ~domain) ctx remote
+    relay_map (Ptt_map.empty ~postmaster) ctx remote
     >>= fun locals ->
     let ip = Stack.ip stack in
     let ipaddr = List.hd (Stack.IP.configured_ips ip) in
     let ipaddr = Ipaddr.Prefix.address ipaddr in
-    Mti_gf.fiber ~port:25 ~locals ~tls (Stack.tcp stack) dns
-      { Ptt.Logic.domain
+    let info =
+      { Ptt_common.domain
       ; ipaddr
       ; tls= None
       ; zone= Mrmime.Date.Zone.GMT
-      ; size= 10_000_000L (* 10M *) }
+      ; size= 10_000_000L (* 10M *) } in
+    Mti_gf.job ~port:25 ~locals ~tls ~info (Stack.tcp stack) dns he
 end
diff --git a/unikernel/signer/config.ml b/unikernel/signer/config.ml
@@ -69,7 +69,7 @@ let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
   [ package "randomconv"
-  ; package "ptt" ~sublibs:[ "nec" ]
+  ; package "ptt" ~sublibs:[ "nec"; "fake-dns" ]
   ; package "dns"
   ; package "dns-client"
   ; package "dns-mirage"
@@ -82,7 +82,7 @@ let runtime_args = [ setup ]
 
 let signer =
   main ~runtime_args ~packages "Unikernel.Make" @@
-  random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> job
+  random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> happy_eyeballs @-> job
 
 let random = default_random
 let time = default_time
@@ -94,4 +94,4 @@ let dns = generic_dns_client ~dns_server ~dns_port stack he
 
 let () =
   register "signer"
-    [ signer $ random $ time $ mclock $ pclock $ stack $ dns ]
+    [ signer $ random $ time $ mclock $ pclock $ stack $ dns $ he ]
diff --git a/unikernel/signer/unikernel.ml b/unikernel/signer/unikernel.ml
@@ -94,22 +94,13 @@ module Make
   (Mclock : Mirage_clock.MCLOCK)
   (Pclock : Mirage_clock.PCLOCK)
   (Stack : Tcpip.Stack.V4V6)
-  (DNS : Dns_client_mirage.S)
+  (Dns_client : Dns_client_mirage.S)
+  (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow)
 = struct
   (* XXX(dinosaure): this is a fake resolver which enforce the [signer] to
    * transmit **any** emails to only one and unique SMTP server. *)
 
-  module Resolver = struct
-    type t = Ipaddr.t
-    type +'a io = 'a Lwt.t
-
-    let gethostbyname ipaddr _domain_name = Lwt.return_ok ipaddr
-    let getmxbyname _ipaddr mail_exchange = Lwt.return_ok (Dns.Rr_map.Mx_set.singleton { Dns.Mx.preference= 0; mail_exchange; })
-    let extension ipaddr _ldh _value = Lwt.return_ok ipaddr
-  end
-
-  module Nec = Nec.Make (Time) (Mclock) (Pclock) (Resolver) (Stack)
-  module DKIM = Dkim_mirage.Make (Pclock) (DNS)
+  module DKIM = Dkim_mirage.Make (Pclock) (Dns_client)
   module Nss = Ca_certs_nss.Make (Pclock)
 
   let private_rsa_key_from_seed seed =
@@ -167,7 +158,7 @@ module Make
           | Error _ -> assert false
         end @@ fun res -> Stack.TCP.close flow >>= fun () -> Lwt.return res
 
-  let start _random _time _mclock _pclock stack dns
+  let start _random _time _mclock _pclock stack dns he
     ({ K.domain; postmaster; destination; dns_key; fields; selector; seed; timestamp; expiration; _ } as cfg) =
     let dkim = Dkim.v
       ~version:1 ?fields ~selector
@@ -184,10 +175,15 @@ module Make
     let ip = Stack.ip stack in
     let ipaddr = List.hd (Stack.IP.configured_ips ip) in
     let ipaddr = Ipaddr.Prefix.address ipaddr in
-    Nec.fiber ~port:25 ~tls (Stack.tcp stack) destination (private_key, dkim)
-      { Ptt.Logic.domain
+    let locals = Ptt_map.empty ~postmaster in
+    let module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = destination end) in
+    let module Nec = Nec.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs) in
+    let info =
+      { Ptt_common.domain= Colombe.Domain.Domain (Domain_name.to_strings domain)
       ; ipaddr
       ; tls= None
       ; zone= Mrmime.Date.Zone.GMT
-      ; size= 10_000_000L }
+      ; size= 10_000_000L } in
+    Fake_dns.connect () >>= fun dns ->
+    Nec.job ~locals ~port:25 ~tls ~info (Stack.tcp stack) dns he (private_key, dkim)
 end