From 4f70f6860b7ee05e2f33df115cc7c9d397bd8497 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 20 Sep 2024 17:18:06 +0200 Subject: [PATCH] . --- Dockerfile.spamfilter | 4 +-- unikernel/signer/unikernel.ml | 10 +++--- unikernel/spamfilter/config.ml | 26 ++++------------ unikernel/spamfilter/unikernel.ml | 52 ++++++++++++++++++++++++------- 4 files changed, 52 insertions(+), 40 deletions(-) diff --git a/Dockerfile.spamfilter b/Dockerfile.spamfilter index a845c8b..8a225cc 100644 --- a/Dockerfile.spamfilter +++ b/Dockerfile.spamfilter @@ -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/spamfilter/ /home/opam/src RUN opam pin add ptt -ny git+https://github.com/mirage/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/signer/unikernel.ml b/unikernel/signer/unikernel.ml index 96001a6..5df0eba 100644 --- a/unikernel/signer/unikernel.ml +++ b/unikernel/signer/unikernel.ml @@ -23,20 +23,20 @@ module K = struct Arg.(required & opt (some mailbox) None doc) let dns_key = - let doc = Arg.info ~doc:"nsupdate key" ["dns-key"] in + 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 + let doc = Arg.info ~doc:"dns server IP" [ "dns-server" ] in Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc) let dns_port = - let doc = Arg.info ~doc:"dns server port" ["dns-port"] in + let doc = Arg.info ~doc:"dns server port" [ "dns-port" ] in Arg.(value & opt int 53 doc) let destination = - let doc = Arg.info ~doc:"Next SMTP server IP" ["destination"] in + let doc = Arg.info ~doc:"Next SMTP server IP" [ "destination" ] in Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc) let fields = @@ -88,8 +88,6 @@ module K = struct $ fields $ selector $ timestamp $ expiration $ seed) end - - module Make (Random : Mirage_random.S) (Time : Mirage_time.S) diff --git a/unikernel/spamfilter/config.ml b/unikernel/spamfilter/config.ml index a7a77bf..d2c0480 100644 --- a/unikernel/spamfilter/config.ml +++ b/unikernel/spamfilter/config.ml @@ -1,21 +1,6 @@ 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 keys = - Key.[ v domain - ; v destination - ; v postmaster ] +let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup" let packages = [ package "ptt" ~sublibs:[ "spartacus" ] @@ -23,11 +8,12 @@ let packages = ; package "domain-name" ; package "ca-certs-nss" ] +let runtime_args = [ setup ] + let spamfilter = - foreign ~keys ~packages "Unikernel.Make" @@ - random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> job + main ~runtime_args ~packages "Unikernel.Make" @@ + time @-> mclock @-> pclock @-> stackv4v6 @-> job -let random = default_random let time = default_time let mclock = default_monotonic_clock let pclock = default_posix_clock @@ -35,4 +21,4 @@ let stack = generic_stackv4v6 default_network let () = register "spamfilter" - [ spamfilter $ random $ time $ mclock $ pclock $ stack ] + [ spamfilter $ time $ mclock $ pclock $ stack ] diff --git a/unikernel/spamfilter/unikernel.ml b/unikernel/spamfilter/unikernel.ml index 502a22e..b3f5af4 100644 --- a/unikernel/spamfilter/unikernel.ml +++ b/unikernel/spamfilter/unikernel.ml @@ -1,8 +1,39 @@ 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 + +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 destination = + let doc = Arg.info ~doc:"Next SMTP server IP" [ "destination" ] in + Arg.(required & opt (some Mirage_runtime_network.Arg.ip_address) None doc) + + type t = + { domain : [ `host ] Domain_name.t + ; postmaster : Emile.mailbox + ; destination : Ipaddr.t } + + let v domain postmaster destination = + { domain; postmaster; destination } + + let setup = Term.(const v $ domain $ postmaster $ destination) +end + module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -20,21 +51,18 @@ module Make let extension ipaddr _ldh _value = Lwt.return_ok ipaddr end - module SpamFilter = Spartacus.Make (Random) (Time) (Mclock) (Pclock) (Resolver) (Stack) + module SpamFilter = Spartacus.Make (Time) (Mclock) (Pclock) (Resolver) (Stack) module Nss = Ca_certs_nss.Make (Pclock) - let start _random _time _mclock _pclock stack = - 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 start _time _mclock _pclock stack { K.domain; postmaster; destination }= let authenticator = R.failwith_error_msg (Nss.authenticator ()) in - let tls = Tls.Config.client ~authenticator () in - let domain = Domain_name.host_exn domain in - SpamFilter.fiber ~port:25 ~tls (Stack.tcp stack) (Key_gen.destination ()) + 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 + SpamFilter.fiber ~port:25 ~tls (Stack.tcp stack) destination { Ptt.Logic.domain - ; ipaddr= Ipaddr.(V4 (V4.Prefix.address (Key_gen.ipv4 ()))) + ; ipaddr ; tls= None ; zone= Mrmime.Date.Zone.GMT (* XXX(dinosaure): any MirageOS use GMT. *) ; size= 10_000_000L (* 10M *) }