.

Dockerfile.verifier

@@ -1,6 +1,6 @@
 FROM ocaml/opam:ubuntu-20.04-ocaml-4.14
 RUN sudo ln -f /usr/bin/opam-2.1 /usr/bin/opam
-RUN cd ~/opam-repository && git pull origin master && git reset --hard cd449b28e1149a5bafa7f1c6262879ce509b7eea && opam update
+RUN cd ~/opam-repository && git pull origin master && git reset --hard 164c8ecdbe88cb6ee4c0b137997c2e7f3763577e && opam update
 RUN opam depext -ui mirage
 RUN mkdir -p /home/opam/src
 WORKDIR /home/opam/src
@@ -13,4 +13,4 @@ COPY --chown=opam:root unikernel/verifier/ /home/opam/src
 RUN opam pin add ptt -ny git+https://github.com/dinosaure/ptt.git#$BRANCH
 RUN opam depext -ui ptt
 RUN opam config exec -- make depends
-RUN opam config exec -- mirage build
+RUN opam config exec -- make build

unikernel/verifier/config.ml

@@ -1,45 +1,7 @@
 open Mirage
 
-let domain =
-  let doc = Key.Arg.info ~doc:"SMTP domain-name." [ "domain" ] in
-  Key.(create "domain" Arg.(required string doc))
-
-let destination =
-  let doc = Key.Arg.info ~doc:"SMTP server destination." [ "destination" ] in
-  Key.(create "destination" Arg.(required ip_address doc))
-
-let postmaster =
-  let doc = Key.Arg.info ~doc:"The postmaster of the SMTP service." [ "postmaster" ] in
-  Key.(create "postmaster" Arg.(required string doc))
-
-let key_seed =
-  let doc = Key.Arg.info ~doc:"Certificate key seed." [ "key-seed" ] in
-  Key.(create "key-seed" Arg.(required string doc))
-
-let dns_key =
-  let doc = Key.Arg.info ~doc:"nsupdate key (name:type:value,...)" ["dns-key"] in
-  Key.(create "dns-key" Arg.(required string doc))
-
-let dns_server =
-  let doc = Key.Arg.info ~doc:"IP of the primary DNS server." ["dns-server"] in
-  Key.(create "dns-server" Arg.(required ip_address doc))
-
-let dns_port =
-  let doc = Key.Arg.info ~doc:"Port of the primary DNS server." ["dns-port"] in
-  Key.(create "dns-port" Arg.(opt int 53 doc))
-
-let nameservers =
-  let doc = Key.Arg.info ~doc:"DNS nameserver used by the SPF verificator." [ "nameserver" ] in
-  Key.(create "nameservers" Arg.(opt_all string doc))
-
-let keys =
-  Key.[ v domain
-      ; v postmaster
-      ; v destination
-      ; v key_seed
-      ; v dns_server
-      ; v dns_port
-      ; v dns_key ]
+let nameservers = Runtime_arg.create ~pos:__POS__ "Unikernel.K.nameservers"
+let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
   [ package "ptt" ~sublibs:[ "hm" ]
@@ -50,16 +12,19 @@ let packages =
   ; package "dns-mirage"
   ; package "dns-certify" ~sublibs:[ "mirage" ] ]
 
+let runtime_args = [ setup ]
+
 let verifier =
-  foreign ~keys ~packages "Unikernel.Make" @@
+  main ~runtime_args ~packages "Unikernel.Make" @@
   random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> job
 
 let random = default_random
 let time = default_time
 let mclock = default_monotonic_clock
 let pclock = default_posix_clock
 let stack = generic_stackv4v6 default_network
-let dns = generic_dns_client ~nameservers stack
+let he = generic_happy_eyeballs stack
+let dns = generic_dns_client ~nameservers stack he
 
 let () =
   register "verifier"

unikernel/verifier/unikernel.ml

@@ -1,19 +1,73 @@
 open Rresult
 open Lwt.Infix
 
+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
+
 exception Invalid_certificate
 
 let ( >>? ) = Lwt_result.bind
-let ( <.> ) f g = fun x -> f (g x)
+
+module K = struct
+  open Cmdliner
+
+  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
+    Arg.(required & opt (some domain_name) None doc)
+
+  let postmaster =
+    let doc = Arg.info ~doc:"The postmaster of the SMTP service." [ "postmaster" ] in
+    let mailbox = Arg.conv (Result.map_error (msgf "%a" Emile.pp_error) <.> Emile.of_string, Emile.pp_mailbox) in
+    Arg.(required & opt (some mailbox) None doc)
+
+  let dns_key =
+    let doc = Arg.info ~doc:"nsupdate key" ["dns-key"] in
+    let key = Arg.conv ~docv:"HOST:HASH:DATA" Dns.Dnskey.(name_key_of_string, pp_name_key) in
+    Arg.(required & opt (some key) None doc)
+
+  let dns_server =
+    let doc = Arg.info ~doc:"dns server IP" ["dns-server"] in
+    Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc)
+
+  let key_seed =
+    let doc = Arg.info ~doc:"certificate key seed" ["key-seed"] in
+    Arg.(required & opt (some string) None doc)
+
+  let destination =
+    let doc = Arg.info ~doc:"Next SMTP server IP" ["destination"] in
+    Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc)
+
+  let key_seed =
+    let doc = Arg.info ~doc:"certificate key seed" ["key-seed"] in
+    Arg.(required & opt (some string) None doc)
+
+  let nameservers =
+    let doc = Arg.info ~doc:"DNS nameservers." [ "nameserver" ] in
+    Arg.(value & opt_all string [] doc)
+
+  type t =
+    { domain : [ `host ] Domain_name.t
+    ; postmaster : Emile.mailbox
+    ; destination : Ipaddr.t
+    ; dns_key : [ `raw ] Domain_name.t * Dns.Dnskey.t
+    ; dns_server : Ipaddr.t
+    ; key_seed : string }
+
+  let v domain postmaster destination dns_key dns_server key_seed =
+    { domain; postmaster; destination; dns_key; dns_server; key_seed }
+
+  let setup = Term.(const v $ domain $ postmaster $ destination $ dns_key $ dns_server $ key_seed)
+end
 
 module Make
-  (Random : Mirage_random.S)
+  (Random : Mirage_crypto_rng_mirage.S)
   (Time : Mirage_time.S)
   (Mclock : Mirage_clock.MCLOCK)
   (Pclock : Mirage_clock.PCLOCK)
   (Stack : Tcpip.Stack.V4V6)
-  (DNS : Dns_client_mirage.S with type Transport.stack = Stack.t
-                              and type 'a Transport.io = 'a Lwt.t)
+  (DNS : Dns_client_mirage.S with type 'a Transport.io = 'a Lwt.t)
 = struct
   (* XXX(dinosaure): this is a fake resolver which enforce the [verifier] to
    * transmit **any** emails to only one and unique SMTP server. *)
@@ -27,15 +81,13 @@ module Make
     let extension ipaddr _ldh _value = Lwt.return_ok ipaddr
   end
 
-  module Verifier = Hm.Make (Random) (Time) (Mclock) (Pclock) (Resolver) (Stack) (DNS)
+  module Verifier = Hm.Make (Time) (Mclock) (Pclock) (Resolver) (Stack) (DNS)
   module Nss = Ca_certs_nss.Make (Pclock)
   module Certify = Dns_certify_mirage.Make (Random) (Pclock) (Time) (Stack)
 
-  let retrieve_certs stack =
-    let domain = Key_gen.domain () in
-    Certify.retrieve_certificate stack ~dns_key:(Key_gen.dns_key ())
-      ~key_seed:(Key_gen.key_seed ()) ~hostname:Domain_name.(host_exn (of_string_exn domain))
-      (Key_gen.dns_server ()) 53 >>= function
+  let retrieve_certs stack { K.domain; dns_key; dns_server; key_seed; _ } =
+    Certify.retrieve_certificate stack ~dns_key:Fmt.(to_to_string Dns.Dnskey.pp_name_key dns_key)
+      ~key_seed ~hostname:domain dns_server 53 >>= function
     | Error (`Msg err) -> failwith err
     | Ok certificates ->
       let now = Ptime.v (Pclock.now_d_ps ()) in
@@ -50,31 +102,28 @@ module Make
         (Duration.of_day (max 0 (next_expire - 7))) in
       Lwt.return (`Single certificates, seven_days_before_expire)
 
-  let start _random _time _mclock _pclock stack dns =
-    let postmaster =
-      let postmaster = Key_gen.postmaster () in
-      R.failwith_error_msg (R.reword_error (fun _ -> R.msgf "Invalid postmaster email: %S" postmaster)
-        (Emile.of_string postmaster)) in
-    let domain = R.failwith_error_msg (Domain_name.of_string (Key_gen.domain ())) in
-    let domain = Domain_name.host_exn domain in
+  let start _random _time _mclock _pclock stack dns ({ K.domain; postmaster; destination; _ } as cfg)=
     let authenticator = R.failwith_error_msg (Nss.authenticator ()) in
-    let tls = Tls.Config.client ~authenticator () in
+    let tls = R.failwith_error_msg (Tls.Config.client ~authenticator ()) in
+    let ip = Stack.ip stack in
+    let ipaddr = List.hd (Stack.IP.configured_ips ip) in
+    let ipaddr = Ipaddr.Prefix.address ipaddr in
     let rec loop (certificates, expiration) =
       let stop = Lwt_switch.create () in
       let wait_and_stop () =
         Time.sleep_ns expiration >>= fun () ->
-        retrieve_certs stack >>= fun result ->
+        retrieve_certs stack cfg >>= fun result ->
         Lwt_switch.turn_off stop >>= fun () ->
         Lwt.return result in
       let server () =
-        Verifier.fiber ~port:25 ~tls (Stack.tcp stack) (Key_gen.destination ())
+        Verifier.fiber ~port:25 ~tls (Stack.tcp stack) destination
           { Ptt.Logic.domain
-          ; ipaddr= Ipaddr.(V4 (V4.Prefix.address (Key_gen.ipv4 ())))
-          ; tls= Some (Tls.Config.server ~certificates ())
+          ; ipaddr
+          ; tls= Some (R.failwith_error_msg (Tls.Config.server ~certificates ()))
           ; zone= Mrmime.Date.Zone.GMT
           ; size= 10_000_000L (* 10M *) }
           dns in
       Lwt.both (server ()) (wait_and_stop ()) >>= fun ((), result) ->
       loop result in
-    retrieve_certs stack >>= loop
+    retrieve_certs stack cfg >>= loop
 end