From 16fd043ff130c20ad0d1da68fd504b50ad1de998 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 20 Sep 2024 17:33:49 +0200 Subject: [PATCH] . --- Dockerfile.verifier | 4 +- unikernel/verifier/config.ml | 49 +++-------------- unikernel/verifier/unikernel.ml | 95 +++++++++++++++++++++++++-------- 3 files changed, 81 insertions(+), 67 deletions(-) diff --git a/Dockerfile.verifier b/Dockerfile.verifier index 3c5228d..79f4890 100644 --- a/Dockerfile.verifier +++ b/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 diff --git a/unikernel/verifier/config.ml b/unikernel/verifier/config.ml index 3cbb616..33b54b0 100644 --- a/unikernel/verifier/config.ml +++ b/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,8 +12,10 @@ 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 @@ -59,7 +23,8 @@ 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" diff --git a/unikernel/verifier/unikernel.ml b/unikernel/verifier/unikernel.ml index eee0af9..7245af5 100644 --- a/unikernel/verifier/unikernel.ml +++ b/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