.

Dockerfile.relay

@@ -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/relay/ /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

ptt.opam

@@ -15,7 +15,7 @@ depends: [
   "dune"
   "mrmime"
   "digestif"
-  "colombe"           {>= "0.7.0"}
+  "colombe"           {>= "0.9.0"}
   "received"          {>= "0.5.1"}
   "sendmail"          {>= "0.7.0"}
   "sendmail-lwt"      {>= "0.6.0"}
@@ -54,9 +54,4 @@ pin-depends: [
   [ "spamtacus-bayesian.dev" "git+https://github.com/mirage/spamtacus.git#2d10c6f114e63621bb26999fefd7881f3e673bad" ]
   [ "spamtacus.dev"          "git+https://github.com/mirage/spamtacus.git#2d10c6f114e63621bb26999fefd7881f3e673bad" ]
   [ "spamtacus-mirage.dev"   "git+https://github.com/mirage/spamtacus.git#2d10c6f114e63621bb26999fefd7881f3e673bad" ]
-  [ "colombe.dev"            "git+https://github.com/mirage/colombe.git#d921ff08672fcf95da7e7082302f91759ffa3c29" ]
-  [ "sendmail.dev"           "git+https://github.com/mirage/colombe.git#d921ff08672fcf95da7e7082302f91759ffa3c29" ]
-  [ "sendmail-lwt.dev"       "git+https://github.com/mirage/colombe.git#d921ff08672fcf95da7e7082302f91759ffa3c29" ]
-  [ "dkim.dev"               "git+https://github.com/mirage/ocaml-dkim.git#1c0ed6f8b91b07ab05c841dd184f90ae468c7e56" ]
-  [ "dkim-mirage.dev"        "git+https://github.com/mirage/ocaml-dkim.git#1c0ed6f8b91b07ab05c841dd184f90ae468c7e56" ]
 ]

unikernel/relay/config.ml

@@ -1,37 +1,25 @@
 open Mirage
 
-let remote =
-  let doc = Key.Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in
-  Key.(create "remote" Arg.(required string doc))
-
 let ssh_key =
-  let doc = Key.Arg.info ~doc:"The private SSH key." [ "ssh-key" ] in
-  Key.(create "ssh_key" Arg.(opt (some string) None doc))
-
-let ssh_password =
-  let doc = Key.Arg.info ~doc:"The SSH password." [ "ssh-password" ] in
-  Key.(create "ssh_password" Arg.(opt (some string) None doc))
+  Runtime_arg.create ~pos:__POS__
+    {|let open Cmdliner in
+      let doc = Arg.info ~doc:"The private SSH key (rsa:<seed> or ed25519:<b64-key>)." ["ssh-key"] in
+      Arg.(value & opt (some string) None doc)|}
 
 let ssh_authenticator =
-  let doc = Key.Arg.info ~doc:"SSH public key of the remote Git repository." [ "ssh-authenticator" ] in
-  Key.(create "ssh_authenticator" Arg.(opt (some string) None doc))
-
-let domain =
-  let doc = Key.Arg.info ~doc:"SMTP domain-name." [ "domain" ] in
-  Key.(create "domain" Arg.(required string doc))
+  Runtime_arg.create ~pos:__POS__
+    {|let open Cmdliner in
+      let doc = Arg.info ~doc:"SSH authenticator." ["ssh-auth"] in
+      Arg.(value & opt (some string) None 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 nameservers =
-  let doc = Key.Arg.info ~doc:"DNS nameserver used to resolve SMTP servers." [ "nameserver" ] in
-  Key.(create "nameservers" Arg.(opt_all string doc))
+let ssh_password =
+  Runtime_arg.create ~pos:__POS__
+    {|let open Cmdliner in
+      let doc = Arg.info ~doc:"The private SSH password." [ "ssh-password" ] in
+      Arg.(value & opt (some string) None doc)|}
 
-let keys =
-  Key.[ v domain
-      ; v postmaster
-      ; v remote ]
+let nameservers = Runtime_arg.create ~pos:__POS__ "Unikernel.K.nameservers"
+let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
   [ package "randomconv"
@@ -40,21 +28,23 @@ let packages =
   ; package "domain-name"
   ; package "dns-mirage" ]
 
+let runtime_args = [ setup ]
+
 let relay =
-  foreign ~keys ~packages "Unikernel.Make" @@
-  random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> git_client @-> job
+  main ~runtime_args ~packages "Unikernel.Make" @@
+  time @-> mclock @-> pclock @-> stackv4v6 @-> dns_client @-> git_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 tcp = tcpv4v6_of_stackv4v6 stack
 let git_client =
-  let happy_eyeballs = mimic_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in
-  git_ssh ~password:ssh_password ~key:ssh_key tcp happy_eyeballs
+  let git = mimic_happy_eyeballs stack he dns in
+  git_ssh ~password:ssh_password ~key:ssh_key ~authenticator:ssh_authenticator tcp git
 
 let () =
   register "relay"
-    [ relay $ random $ time $ mclock $ pclock $ stack $ dns $ git_client ]
+    [ relay $ time $ mclock $ pclock $ stack $ dns $ git_client ]

unikernel/relay/unikernel.ml

@@ -5,14 +5,48 @@ let local_of_string str =
   match Angstrom.parse_string ~consume:All Emile.Parser.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
+
+module K = struct
+  open Cmdliner
+
+  let remote =
+    let doc = Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in
+    Arg.(required & opt (some string) None doc)
+
+  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 nameservers =
+    let doc = Arg.info ~doc:"DNS nameservers." [ "nameserver" ] in
+    Arg.(value & opt_all string [] doc)
+
+  type t =
+    { remote : string
+    ; domain : [ `host ] Domain_name.t
+    ; postmaster : Emile.mailbox }
+
+  let v remote domain postmaster =
+    { remote; domain; postmaster }
+
+  let setup = Term.(const v $ remote $ domain $ postmaster)
+end
+
 module Make
-  (Random : Mirage_random.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)
   (_ : sig end)
 = struct
   module Store = Git_kv.Make (Pclock)
@@ -38,8 +72,7 @@ module Make
       Lwt.return_error (R.msgf "[%s:%s] is not supported" ldh value)
   end
 
-  module Mti_gf =
-    Mti_gf.Make (Random) (Time) (Mclock) (Pclock) (Resolver) (Stack)
+  module Mti_gf = Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Stack)
   module Nss = Ca_certs_nss.Make (Pclock)
 
   let relay_map relay_map ctx remote =
@@ -74,23 +107,17 @@ module Make
               Lwt.return acc in
       Lwt_list.fold_left_s f relay_map values
 
-  let start _random _time _mclock _pclock stack dns ctx =
-    let domain = R.failwith_error_msg
-      (Domain_name.of_string (Key_gen.domain ())) in
-    let domain = Domain_name.host_exn domain in
-    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 start _time _mclock _pclock stack dns ctx { K.remote; domain; postmaster; } =
     let authenticator = R.failwith_error_msg (Nss.authenticator ()) in
-    let tls = Tls.Config.client ~authenticator () in
-    relay_map (Ptt.Relay_map.empty ~postmaster ~domain) ctx (Key_gen.remote ())
+    let tls = Rresult.R.failwith_error_msg (Tls.Config.client ~authenticator ()) in
+    relay_map (Ptt.Relay_map.empty ~postmaster ~domain) 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
-      ; ipaddr= Ipaddr.(V4 (V4.Prefix.address (Key_gen.ipv4 ())))
+      ; ipaddr
       ; tls= None
       ; zone= Mrmime.Date.Zone.GMT
       ; size= 10_000_000L (* 10M *) }