Update unikernels with mirage.4.8.0

mirage · Oct 15, 2024 · 2bd7e5e · 2bd7e5e
1 parent d8ad094
commit 2bd7e5e
Show file tree

Hide file tree

Showing 8 changed files with 66 additions and 79 deletions.
diff --git a/unikernel/relay/config.ml b/unikernel/relay/config.ml
@@ -1,24 +1,7 @@
-open Mirage
-
-let ssh_key =
-  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)|}
+(* mirage >= 4.8.0 & < 4.9.0 *)
 
-let ssh_authenticator =
-  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 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)|}
+open Mirage
 
-let nameservers = Runtime_arg.create ~pos:__POS__ "Unikernel.K.nameservers"
 let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
@@ -39,11 +22,11 @@ let mclock = default_monotonic_clock
 let pclock = default_posix_clock
 let stack = generic_stackv4v6 default_network
 let he = generic_happy_eyeballs stack
-let dns = generic_dns_client ~nameservers stack he
+let dns = generic_dns_client stack he
 let tcp = tcpv4v6_of_stackv4v6 stack
 let git_client =
   let git = mimic_happy_eyeballs stack he dns in
-  git_ssh ~password:ssh_password ~key:ssh_key ~authenticator:ssh_authenticator tcp git
+  git_ssh tcp git
 
 let () =
   register "relay"

diff --git a/unikernel/signer/config.ml b/unikernel/signer/config.ml
@@ -1,9 +1,11 @@
+(* mirage >= 4.8.0 & < 4.9.0 *)
+
 open Mirage
 
 (* NOTE(dinosaure): it's like a DNS client but it uses the primary DNS server to
    get the possible DKIM public key if it exists (like a client) or [nsupdate]
    the primary DNS server with what we got from the command-line. *)
-let generic_dns_client timeout dns_server dns_port =
+let generic_dns_client timeout =
   let open Functoria.DSL in
   let pp_label name ppf = function
     | None -> ()
@@ -17,15 +19,17 @@ let generic_dns_client timeout dns_server dns_port =
     | _, None -> (None, rest)
     | _ -> err () in 
   let packages = [ package "dns-client-mirage" ~min:"9.0.0" ~max:"10.0.0" ] in
-  let runtime_args = [ Runtime_arg.v dns_server; Runtime_arg.v dns_port; ] in
+  let dns_server = Runtime_arg.create ~pos:__POS__ "Unikernel.K.dns_server" in
+  let dns_port = Runtime_arg.create ~pos:__POS__ "Unikernel.K.dns_port" in
+  let runtime_args = Runtime_arg.[ v dns_server; v dns_port; ] in
   let runtime_args = match timeout with
     | Some timeout -> runtime_args @ [ Runtime_arg.v timeout ]
     | None -> runtime_args in
   let pp_nameserver ppf (dns_server, dns_port) =
     let nameserver = Fmt.str "[\"tcp:%s:%s\"]" dns_server dns_port in
     pp_label "nameservers" ppf (Some nameserver)
   in
-  let err () = connect_err "generic_dns_client" 6 ~max:9 in
+  let err () = connect_err "generic_dns_client" 6 in
   let connect _info modname = function
     | _random
       :: _time
@@ -54,17 +58,15 @@ let generic_dns_client timeout dns_server dns_port =
 
 let generic_dns_client ?timeout ?(random = default_random)
     ?(time = default_time) ?(mclock = default_monotonic_clock)
-    ?(pclock = default_posix_clock) ~dns_server ~dns_port stackv4v6 happy_eyeballs =
-  generic_dns_client timeout dns_server dns_port
+    ?(pclock = default_posix_clock) stackv4v6 happy_eyeballs =
+  generic_dns_client timeout
   $ random
   $ time
   $ mclock
   $ pclock
   $ stackv4v6
   $ happy_eyeballs
 
-let dns_server : Ipaddr.t Runtime_arg.arg = Runtime_arg.create ~pos:__POS__ "Unikernel.K.dns_server"
-let dns_port : int Runtime_arg.arg = Runtime_arg.create ~pos:__POS__ "Unikernel.K.dns_port"
 let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
@@ -90,7 +92,7 @@ let mclock = default_monotonic_clock
 let pclock = default_posix_clock
 let stack = generic_stackv4v6 default_network
 let he = generic_happy_eyeballs stack
-let dns = generic_dns_client ~dns_server ~dns_port stack he
+let dns = generic_dns_client stack he
 
 let () =
   register "signer"

diff --git a/unikernel/signer/unikernel.ml b/unikernel/signer/unikernel.ml
@@ -37,7 +37,7 @@ module K = struct
 
   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)
+    Mirage_runtime.register_arg Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc)
 
   let fields =
     let doc = Arg.info [ "fields" ] ~doc:"List of fields to sign" in
@@ -67,7 +67,6 @@ module K = struct
   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
     ; dns_port : int
@@ -77,15 +76,31 @@ module K = struct
     ; expiration : int64 option
     ; seed : string }
 
-  let v domain postmaster destination
-    dns_key dns_server dns_port
-    fields selector timestamp expiration seed =
-    { domain; postmaster; destination; dns_key; dns_server; dns_port; fields; selector; timestamp; expiration; seed }
+  let v domain postmaster  dns_key dns_server dns_port fields selector timestamp expiration seed =
+    { domain
+    ; postmaster
+    ; dns_key
+    ; dns_server
+    ; dns_port
+    ; fields
+    ; selector
+    ; timestamp
+    ; expiration
+    ; seed }
 
   let setup =
-    Term.(const v $ domain $ postmaster $ destination
-    $ dns_key $ dns_server $ dns_port
-    $ fields $ selector $ timestamp $ expiration $ seed)
+    let open Term in
+    const v
+    $ domain
+    $ postmaster
+    $ dns_key
+    $ dns_server
+    $ dns_port
+    $ fields
+    $ selector
+    $ timestamp
+    $ expiration
+    $ seed
 end
 
 module Make
@@ -158,8 +173,11 @@ module Make
           | Error _ -> assert false
         end @@ fun res -> Stack.TCP.close flow >>= fun () -> Lwt.return res
 
+  module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = K.destination () end)
+  module Nec = Nec.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs)
+
   let start _random _time _mclock _pclock stack dns he
-    ({ K.domain; postmaster; destination; dns_key; fields; selector; seed; timestamp; expiration; _ } as cfg) =
+    ({ K.domain; postmaster; dns_key; fields; selector; seed; timestamp; expiration; _ } as cfg) =
     let dkim = Dkim.v
       ~version:1 ?fields ~selector
       ~algorithm:`RSA
@@ -176,8 +194,6 @@ module Make
     let ipaddr = List.hd (Stack.IP.configured_ips ip) in
     let ipaddr = Ipaddr.Prefix.address ipaddr in
     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

diff --git a/unikernel/spamfilter/config.ml b/unikernel/spamfilter/config.ml
@@ -1,3 +1,5 @@
+(* mirage >= 4.8.0 & < 4.9.0 *)
+
 open Mirage
 
 let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"

diff --git a/unikernel/spamfilter/unikernel.ml b/unikernel/spamfilter/unikernel.ml
@@ -20,17 +20,16 @@ module K = struct
 
   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)
+    Mirage_runtime.register_arg Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc)
 
   type t =
     { domain : Colombe.Domain.t
-    ; postmaster : Emile.mailbox
-    ; destination : Ipaddr.t }
+    ; postmaster : Emile.mailbox }
 
-  let v domain postmaster destination =
-    { domain; postmaster; destination }
+  let v domain postmaster =
+    { domain; postmaster }
 
-  let setup = Term.(const v $ domain $ postmaster $ destination)
+  let setup = Term.(const v $ domain $ postmaster)
 end
 
 module Make
@@ -42,8 +41,10 @@ module Make
 = struct
 
   module Nss = Ca_certs_nss.Make (Pclock)
+  module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = K.destination () end)
+  module Spam_filter = Spartacus.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs)
 
-  let start _time _mclock _pclock stack he { K.domain; postmaster; destination }=
+  let start _time _mclock _pclock stack he { K.domain; postmaster }=
     let authenticator = R.failwith_error_msg (Nss.authenticator ()) in
     let tls = R.failwith_error_msg (Tls.Config.client ~authenticator ()) in
     let ip = Stack.ip stack in
@@ -56,8 +57,6 @@ module Make
       ; zone= Mrmime.Date.Zone.GMT
       ; size= 10_000_000L (* 10M *) } in
     let locals = Ptt_map.empty ~postmaster in
-    let module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = destination end) in
-    let module Spam_filter = Spartacus.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs) in
     Fake_dns.connect () >>= fun dns ->
     Spam_filter.job ~locals ~port:25 ~tls ~info (Stack.tcp stack) dns he
 end
diff --git a/unikernel/submission/config.ml b/unikernel/submission/config.ml
@@ -1,24 +1,7 @@
-open Mirage
-
-let ssh_key =
-  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)|}
+(* mirage >= 4.8.0 & < 4.9.0 *)
 
-let ssh_authenticator =
-  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 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)|}
+open Mirage
 
-let nameservers = Runtime_arg.create ~pos:__POS__ "Unikernel.K.nameservers"
 let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"
 
 let packages =
@@ -43,11 +26,11 @@ let mclock = default_monotonic_clock
 let pclock = default_posix_clock
 let stack = generic_stackv4v6 default_network
 let he = generic_happy_eyeballs stack
-let dns = generic_dns_client ~nameservers stack he
+let dns = generic_dns_client stack he
 let tcp = tcpv4v6_of_stackv4v6 stack
 let git_client =
   let git = mimic_happy_eyeballs stack he dns in
-  git_ssh ~password:ssh_password ~key:ssh_key ~authenticator:ssh_authenticator tcp git
+  git_ssh tcp git
 
 let () =
   register "submission"

diff --git a/unikernel/submission/unikernel.ml b/unikernel/submission/unikernel.ml
@@ -42,7 +42,7 @@ module K = struct
 
   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)
+    Mirage_runtime.register_arg 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
@@ -57,15 +57,14 @@ module K = struct
     ; domain : Colombe.Domain.t
     ; hostname : [ `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 remote domain hostname postmaster destination dns_key dns_server key_seed =
-    { remote; domain; hostname; postmaster; destination; dns_key; dns_server; key_seed }
+  let v remote domain hostname postmaster dns_key dns_server key_seed =
+    { remote; domain; hostname; postmaster; dns_key; dns_server; key_seed }
 
-  let setup = Term.(const v $ remote $ domain $ hostname $ postmaster $ destination $ dns_key $ dns_server $ key_seed)
+  let setup = Term.(const v $ remote $ domain $ hostname $ postmaster $ dns_key $ dns_server $ key_seed)
 end
 
 module Make
@@ -136,16 +135,17 @@ 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 he ctx ({ K.remote; domain; postmaster; destination; _ } as cfg) =
+  module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = K.destination () end)
+  module Lipap = Lipap.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs)
+
+  let start _random _time _mclock _pclock stack he ctx ({ K.remote; domain; postmaster; _ } as cfg) =
     let authenticator = R.failwith_error_msg (Nss.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 locals = Ptt_map.empty ~postmaster in
     authentication ctx remote >>= fun authentication ->
-    let module Fake_dns = Ptt_fake_dns.Make (struct let ipaddr = destination end) in
-    let module Lipap = Lipap.Make (Time) (Mclock) (Pclock) (Stack) (Fake_dns) (Happy_eyeballs) in
     Fake_dns.connect () >>= fun dns ->
     let rec loop (certificates, expiration) =
       let info =

diff --git a/unikernel/verifier/config.ml b/unikernel/verifier/config.ml
@@ -1,3 +1,5 @@
+(* mirage >= 4.8.0 & < 4.9.0 *)
+
 open Mirage
 
 let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup"