From 03aa2807f6cbbe7e5e0ddbb488bb287d1f26daf2 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Fri, 20 Sep 2024 10:50:23 +0200 Subject: [PATCH] . --- Dockerfile.relay | 4 +-- ptt.opam | 7 +--- unikernel/relay/config.ml | 58 ++++++++++++++------------------- unikernel/relay/unikernel.ml | 63 +++++++++++++++++++++++++----------- 4 files changed, 72 insertions(+), 60 deletions(-) diff --git a/Dockerfile.relay b/Dockerfile.relay index 4c0d431..dc603db 100644 --- a/Dockerfile.relay +++ b/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 diff --git a/ptt.opam b/ptt.opam index 0fcbde8..36e696f 100644 --- a/ptt.opam +++ b/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" ] ] diff --git a/unikernel/relay/config.ml b/unikernel/relay/config.ml index 2896968..656aeac 100644 --- a/unikernel/relay/config.ml +++ b/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: or ed25519:)." ["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 ] diff --git a/unikernel/relay/unikernel.ml b/unikernel/relay/unikernel.ml index ff36724..d624a68 100644 --- a/unikernel/relay/unikernel.ml +++ b/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 *) }