From 25beb78eac6bcc1fc5455b8d89bc6677ab529786 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 16 Sep 2024 16:13:11 +0200 Subject: [PATCH] Upgrade the ptt project with the current ecosystem --- .ocamlformat | 3 +- Dockerfile.relay | 4 +- Dockerfile.signer | 4 +- Dockerfile.spamfilter | 4 +- Dockerfile.submission | 4 +- Dockerfile.verifier | 4 +- bin/adduser.ml | 15 +- bin/dune | 4 +- bin/lipap.ml | 24 +- bin/mti_gf.ml | 22 +- bin/sSH.ml | 15 +- bin/sSH.mli | 11 - bin/spf.ml | 7 +- lib/authentication.ml | 4 +- lib/common.ml | 73 +++--- lib/common.mli | 7 +- lib/hm.ml | 104 +++----- lib/hm.mli | 5 +- lib/lipap.ml | 31 +-- lib/lipap.mli | 3 +- lib/logic.ml | 61 +++-- lib/messaged.ml | 118 ++++----- lib/mti_gf.ml | 34 +-- lib/mti_gf.mli | 1 - lib/nec.ml | 68 ++--- lib/nec.mli | 1 - lib/ptt_transmit.ml | 90 ++++--- lib/ptt_tuyau.ml | 48 ++-- lib/rdwr.ml | 18 +- lib/relay.ml | 9 +- lib/relay.mli | 3 +- lib/relay_map.ml | 29 +-- lib/sMTP.ml | 30 +-- lib/sSMTP.ml | 6 +- lib/sigs.ml | 7 - lib/sigs.mli | 7 - lib/spartacus.ml | 43 +--- lib/spartacus.mli | 1 - lib/submission.ml | 97 ++++--- lib/submission.mli | 5 +- ptt-bin.opam | 2 + ptt.opam | 9 +- test/test.ml | 413 +++++++++++++++--------------- unikernel/relay/config.ml | 58 ++--- unikernel/relay/unikernel.ml | 63 +++-- unikernel/signer/config.ml | 132 +++++----- unikernel/signer/unikernel.ml | 165 ++++++++---- unikernel/spamfilter/config.ml | 26 +- unikernel/spamfilter/unikernel.ml | 52 +++- unikernel/submission/config.ml | 79 ++---- unikernel/submission/unikernel.ml | 100 ++++++-- unikernel/verifier/config.ml | 49 +--- unikernel/verifier/unikernel.ml | 95 +++++-- 53 files changed, 1125 insertions(+), 1142 deletions(-) delete mode 100644 bin/sSH.mli diff --git a/.ocamlformat b/.ocamlformat index c472f64..0085415 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.26.1 +version=0.26.2 module-item-spacing=compact break-struct=natural break-infix=fit-or-vertical @@ -15,7 +15,6 @@ space-around-arrays=false break-cases=fit break-fun-decl=smart cases-exp-indent=2 -sequence-style=before if-then-else=compact field-space=tight indent-after-in=0 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/Dockerfile.signer b/Dockerfile.signer index 00e891a..7cd156a 100644 --- a/Dockerfile.signer +++ b/Dockerfile.signer @@ -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/signer/ /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/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/Dockerfile.submission b/Dockerfile.submission index eb8f654..f8181e3 100644 --- a/Dockerfile.submission +++ b/Dockerfile.submission @@ -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/submission/ /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/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/bin/adduser.ml b/bin/adduser.ml index 3abd81a..a03e966 100644 --- a/bin/adduser.ml +++ b/bin/adduser.ml @@ -16,11 +16,10 @@ let ssh_edn, ssh_protocol = Mimic.register ~name:"ssh" (module SSH) let unix_ctx_with_ssh () = Git_unix.ctx (Happy_eyeballs_lwt.create ()) >|= fun ctx -> let open Mimic in - let k0 scheme user path host port capabilities = + let k0 scheme user path host port mode = match scheme, Unix.gethostbyname host with | `SSH, {Unix.h_addr_list; _} when Array.length h_addr_list > 0 -> - Lwt.return_some - {SSH.user; path; host= h_addr_list.(0); port; capabilities} + Lwt.return_some {SSH.user; path; host= h_addr_list.(0); port; mode} | _ -> Lwt.return_none in ctx |> Mimic.fold Smart_git.git_transmission @@ -121,7 +120,7 @@ let renderer = let reporter ppf = let report src level ~over k msgf = - let k _ = over () ; k () in + let k _ = over (); k () in let with_metadata header _tags k ppf fmt = Fmt.kpf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") @@ -132,10 +131,10 @@ let reporter ppf = {Logs.report} let setup_logs style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer () - ; Logs.set_level level - ; Logs.set_reporter (reporter Fmt.stderr) - ; Option.is_none level + Fmt_tty.setup_std_outputs ?style_renderer (); + Logs.set_level level; + Logs.set_reporter (reporter Fmt.stderr); + Option.is_none level let setup_logs = Term.(const setup_logs $ renderer $ verbosity) diff --git a/bin/dune b/bin/dune index ac561eb..7b3b299 100644 --- a/bin/dune +++ b/bin/dune @@ -19,8 +19,8 @@ (public_name ptt.adduser) (package ptt-bin) (modules adduser sSH) - (libraries logs.cli fmt.tty fmt.cli ca-certs mirage-flow git-unix git-kv - mirage-clock-unix ptt.value cmdliner)) + (libraries logs.cli logs.fmt fmt.tty fmt.cli ca-certs mirage-flow git-unix + git-kv mirage-clock-unix ptt.value cmdliner)) (executable (name spf) diff --git a/bin/lipap.ml b/bin/lipap.ml index 0d88cec..39efa5d 100644 --- a/bin/lipap.ml +++ b/bin/lipap.ml @@ -9,15 +9,6 @@ let () = Logs.set_reporter reporter let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let ( <.> ) f g x = f (g x) -module Random = struct - type g = unit - - let generate ?g:_ len = - let ic = open_in "/dev/urandom" in - let rs = Bytes.create len in - really_input ic rs 0 len ; close_in ic ; Cstruct.of_bytes rs -end - open Rresult module Resolver = struct @@ -39,13 +30,9 @@ module Resolver = struct end module Server = - Lipap.Make (Random) (Time) (Mclock) (Pclock) (Resolver) - (Tcpip_stack_socket.V4V6) + Lipap.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6) -let load_file filename = - let open Rresult in - Bos.OS.File.read filename >>= fun contents -> - R.ok (Cstruct.of_string contents) +let load_file filename = Bos.OS.File.read filename let cert = let open Rresult in @@ -75,7 +62,7 @@ let fiber ~domain locals = ~certificates:(`Single ([cert], private_key)) ~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None) () in - + let tls = Rresult.R.failwith_error_msg tls in TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 -> let info = @@ -86,11 +73,12 @@ let fiber ~domain locals = ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT ; Ptt.SMTP.size= 0x1000000L } in - let resolver = Dns_client_lwt.create () in + let he = Happy_eyeballs_lwt.create () in + let resolver = Dns_client_lwt.create he in let tls = let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in Tls.Config.client ~authenticator () in - + let tls = Rresult.R.failwith_error_msg tls in Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver None Digestif.BLAKE2B info authenticator [Ptt.Mechanism.PLAIN] diff --git a/bin/mti_gf.ml b/bin/mti_gf.ml index 66bea61..4a44ab6 100644 --- a/bin/mti_gf.ml +++ b/bin/mti_gf.ml @@ -9,15 +9,6 @@ let () = Logs.set_reporter reporter let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let ( <.> ) f g x = f (g x) -module Random = struct - type g = unit - - let generate ?g:_ len = - let ic = open_in "/dev/urandom" in - let rs = Bytes.create len in - really_input ic rs 0 len ; close_in ic ; Cstruct.of_bytes rs -end - open Rresult module Resolver = struct @@ -39,13 +30,9 @@ module Resolver = struct end module Server = - Mti_gf.Make (Random) (Time) (Mclock) (Pclock) (Resolver) - (Tcpip_stack_socket.V4V6) + Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6) -let load_file filename = - let open Rresult in - Bos.OS.File.read filename >>= fun contents -> - R.ok (Cstruct.of_string contents) +let load_file filename = Bos.OS.File.read filename let cert = let open Rresult in @@ -61,7 +48,7 @@ let private_key = Rresult.R.get_ok private_key let tls = let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in - Tls.Config.client ~authenticator () + R.failwith_error_msg (Tls.Config.client ~authenticator ()) let fiber ~domain locals = let open Lwt.Infix in @@ -77,7 +64,8 @@ let fiber ~domain locals = ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT ; Ptt.SMTP.size= 0x1000000L } in - let resolver = Dns_client_lwt.create () in + let he = Happy_eyeballs_lwt.create () in + let resolver = Dns_client_lwt.create he in Server.fiber ~port:4242 ~locals ~tls tcpv4v6 resolver info let romain_calascibetta = diff --git a/bin/sSH.ml b/bin/sSH.ml index b439cc3..5f66c60 100644 --- a/bin/sSH.ml +++ b/bin/sSH.ml @@ -17,16 +17,16 @@ type endpoint = { ; path: string ; host: Unix.inet_addr ; port: int - ; capabilities: [ `Wr | `Rd ] + ; mode: [ `Rd | `Wr ] } let pp_inet_addr ppf inet_addr = Fmt.string ppf (Unix.string_of_inet_addr inet_addr) -let connect {user; path; host; port; capabilities} = +let connect {user; path; host; port; mode} = let edn = Fmt.str "%s@%a" user pp_inet_addr host in let cmd = - match capabilities with + match mode with | `Rd -> Fmt.str {sh|git-upload-pack '%s'|sh} path | `Wr -> Fmt.str {sh|git-receive-pack '%s'|sh} path in let cmd = Fmt.str "ssh -p %d %s %a" port edn Fmt.(quote string) cmd in @@ -45,7 +45,7 @@ let read t = let write t cs = let str = Cstruct.to_string cs in - try output_string t.oc str ; flush t.oc ; Lwt.return_ok () + try output_string t.oc str; flush t.oc; Lwt.return_ok () with Unix.Unix_error (err, f, v) -> Lwt.return_error (`Error (err, f, v)) let writev t css = @@ -57,4 +57,9 @@ let writev t css = | Error _ as err -> Lwt.return err) in go t css -let close t = close_in t.ic ; close_out t.oc ; Lwt.return_unit +let close t = close_in t.ic; close_out t.oc; Lwt.return_unit + +let shutdown t = function + | `read -> close_in t.ic; Lwt.return_unit + | `write -> close_out t.oc; Lwt.return_unit + | `read_write -> close t diff --git a/bin/sSH.mli b/bin/sSH.mli deleted file mode 100644 index 8deb6db..0000000 --- a/bin/sSH.mli +++ /dev/null @@ -1,11 +0,0 @@ -include Mirage_flow.S - -type endpoint = { - user: string - ; path: string - ; host: Unix.inet_addr - ; port: int - ; capabilities: [ `Rd | `Wr ] -} - -val connect : endpoint -> (flow, write_error) result Lwt.t diff --git a/bin/spf.ml b/bin/spf.ml index dfe9e32..dfec733 100644 --- a/bin/spf.ml +++ b/bin/spf.ml @@ -17,7 +17,8 @@ let ns_check ~domain spf = let getrrecord dns key domain_name = Dns_client_lwt.get_resource_record dns key domain_name end in - let dns = Dns_client_lwt.create () in + let he = Happy_eyeballs_lwt.create () in + let dns = Dns_client_lwt.create he in Uspf_lwt.get ~domain dns (module DNS) >>= function | Ok spf' when Uspf.Term.equal spf spf' -> Lwt.return `Already_registered | Ok _ -> Lwt.return `Must_be_updated @@ -60,7 +61,7 @@ let ns_update (ipaddr, port) ~dns_key stack ~domain spf = |> R.reword_error (R.msgf "%a" Dns_tsig.pp_s) |> Lwt.return >>? fun (data, mac) -> - DNS.send_tcp flow data + DNS.send_tcp flow (Cstruct.of_string data) >|= R.reword_error (fun _ -> R.msgf "Impossible to send a DNS packet to %a:%d" Ipaddr.pp ipaddr port) @@ -71,7 +72,7 @@ let ns_update (ipaddr, port) ~dns_key stack ~domain spf = ipaddr port) >>? fun data -> Dns_tsig.decode_and_verify (Ptime_clock.now ()) dns_key key_name ~mac - data + (Cstruct.to_string data) |> R.reword_error (R.msgf "%a" Dns_tsig.pp_e) |> Lwt.return >>? fun (packet', _tsig, _mac) -> diff --git a/lib/authentication.ml b/lib/authentication.ml index 4cbf841..966d6da 100644 --- a/lib/authentication.ml +++ b/lib/authentication.ml @@ -15,8 +15,8 @@ let is_zero = ( = ) '\000' let authenticate {return; bind} hash username password t = let ( >>= ) = bind in let p = Digestif.digest_string hash password in - Bytes.fill (Bytes.unsafe_of_string password) 0 (String.length password) '\000' - ; t username p >>= fun v -> return (R.ok v) + Bytes.fill (Bytes.unsafe_of_string password) 0 (String.length password) '\000'; + t username p >>= fun v -> return (R.ok v) let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v = let parser = diff --git a/lib/common.ml b/lib/common.ml index 097802b..ff8611c 100644 --- a/lib/common.ml +++ b/lib/common.ml @@ -11,8 +11,7 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) = + (Resolver : RESOLVER with type 'a io = 'a IO.t) = struct type 'w resolver = { gethostbyname: @@ -29,7 +28,7 @@ struct 'a. 'w -> string -> string -> (Ipaddr.t, ([> R.msg ] as 'a)) result IO.t } - type 'g random = ?g:'g -> bytes -> unit IO.t + type 'g random = ?g:'g -> bytes -> ?off:int -> int -> unit type 'a consumer = 'a option -> unit IO.t let resolver = @@ -43,13 +42,11 @@ struct let ( >>? ) x f = x >>= function Ok x -> f x | Error err -> return (Error err) - let generate ?g buf = - let open Random in - generate ?g buf >>= fun () -> + let generate ?g buf ?off len = + Mirage_crypto_rng.generate_into ?g buf ?off len; for i = 0 to Bytes.length buf - 1 do if Bytes.get buf i = '\000' then Bytes.set buf i '\001' done - ; return () let scheduler = let open Scheduler in @@ -97,21 +94,17 @@ struct let fold m {Dns.Mx.mail_exchange; Dns.Mx.preference} = Log.debug (fun m -> m "Try to resolve %a (MX) as a SMTP recipients box." Domain_name.pp - mail_exchange) - ; resolver.gethostbyname w mail_exchange >>= function - | Ok mx_ipaddr -> - IO.return - (Mxs.add - { - Mxs.preference - ; Mxs.mx_ipaddr - ; Mxs.mx_domain= Some mail_exchange - } - m) - | Error (`Msg err) -> - Log.err (fun m -> - m "Impossible to resolve %a: %s" Domain_name.pp mail_exchange err) - ; IO.return m in + mail_exchange); + resolver.gethostbyname w mail_exchange >>= function + | Ok mx_ipaddr -> + IO.return + (Mxs.add + {Mxs.preference; Mxs.mx_ipaddr; Mxs.mx_domain= Some mail_exchange} + m) + | Error (`Msg err) -> + Log.err (fun m -> + m "Impossible to resolve %a: %s" Domain_name.pp mail_exchange err); + IO.return m in let rec go acc = function | [] -> IO.return acc | Forward_path.Postmaster :: r -> @@ -121,21 +114,19 @@ struct try let domain = Domain_name.(host_exn <.> of_strings_exn) v in Log.debug (fun m -> - m "Try to resolve %a as a recipients box." Domain_name.pp domain) - ; resolver.getmxbyname w domain >>= function - | Ok m -> - Log.debug (fun pf -> - pf "Got %d SMTP recipients box from %a." - (Dns.Rr_map.Mx_set.cardinal m) - Domain_name.pp domain) - ; list_fold_left_s ~f:fold Mxs.empty - (Dns.Rr_map.Mx_set.elements m) - >>= fun s -> go (s :: acc) r - | Error (`Msg err) -> - Log.warn (fun m -> - m "Impossible to resolve MX of %a: %s" Domain_name.pp domain - err) - ; go acc r + m "Try to resolve %a as a recipients box." Domain_name.pp domain); + resolver.getmxbyname w domain >>= function + | Ok m -> + Log.debug (fun pf -> + pf "Got %d SMTP recipients box from %a." + (Dns.Rr_map.Mx_set.cardinal m) + Domain_name.pp domain); + list_fold_left_s ~f:fold Mxs.empty (Dns.Rr_map.Mx_set.elements m) + >>= fun s -> go (s :: acc) r + | Error (`Msg err) -> + Log.warn (fun m -> + m "Impossible to resolve MX of %a: %s" Domain_name.pp domain err); + go acc r with _exn -> go (Mxs.empty :: acc) r) | Forward_path.Forward_path {Path.domain= Domain.IPv4 mx_ipaddr; _} :: r | Forward_path.Domain (Domain.IPv4 mx_ipaddr) :: r -> @@ -207,8 +198,8 @@ struct | Error (`Msg _err) -> Log.err (fun m -> m "%a is unreachable (no MX information)." (pp_recipients ~domain) - recipients) - ; IO.return resolved + recipients); + IO.return resolved | Ok mxs -> ( let fold mxs {Dns.Mx.mail_exchange; Dns.Mx.preference} = resolver.gethostbyname w mail_exchange >>= function @@ -220,8 +211,8 @@ struct | Error (`Msg _err) -> Log.err (fun m -> m "%a as the SMTP service is unreachable." Domain_name.pp - mail_exchange) - ; IO.return mxs in + mail_exchange); + IO.return mxs in list_fold_left_s ~f:fold Mxs.empty (Dns.Rr_map.Mx_set.elements mxs) >>= fun mxs -> if Mxs.is_empty mxs then IO.return resolved diff --git a/lib/common.mli b/lib/common.mli index aae52f1..5915c7a 100644 --- a/lib/common.mli +++ b/lib/common.mli @@ -5,10 +5,9 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) : sig + (Resolver : RESOLVER with type 'a io = 'a IO.t) : sig type 'w resolver - type 'g random = ?g:'g -> bytes -> unit IO.t + type 'g random = ?g:'g -> bytes -> ?off:int -> int -> unit type 'a consumer = 'a option -> unit IO.t val ( >>= ) : 'a IO.t -> ('a -> 'b IO.t) -> 'b IO.t @@ -19,7 +18,7 @@ module Make -> ('b, 'err) result IO.t val resolver : Resolver.t resolver - val generate : Random.g random + val generate : Mirage_crypto_rng.g random val scheduler : Scheduler.t Colombe.Sigs.impl val rdwr : (Flow.t, Scheduler.t) Colombe.Sigs.rdwr diff --git a/lib/hm.ml b/lib/hm.ml index 6f451e6..ed4c4dc 100644 --- a/lib/hm.ml +++ b/lib/hm.ml @@ -7,34 +7,16 @@ let src = Logs.Src.create "ptt.hm" module Log : Logs.LOG = (val Logs.src_log src) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) (Resolver : Ptt.Sigs.RESOLVER with type +'a io = 'a Lwt.t) (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 include Ptt_tuyau.Client (Stack) - - module Random = struct - type g = Random.g - type +'a io = 'a Lwt.t - - let generate ?g buf = - let len = Bytes.length buf in - let raw = Random.generate ?g len in - Cstruct.blit_to_bytes raw 0 buf 0 len - ; Lwt.return () - end - module Flow = Rdwr.Make (Stack.TCP) - - module Verifier = - Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) (Random) - + module Verifier = Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) module Server = Ptt_tuyau.Server (Time) (Stack) include Ptt_transmit.Make (Pclock) (Stack) (Verifier.Md) module Lwt_scheduler = Uspf.Sigs.Make (Lwt) @@ -71,16 +53,16 @@ struct | exn -> Lwt.return (Error (`Exn exn))) >>= function | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port) - ; Lwt.return () + Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); + Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err) - ; Lwt.return () + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err); + Lwt.return () | Error (`Exn exn) -> Log.err (fun m -> m "<%a:%d> raised an unknown exception: %s" Ipaddr.pp ip port - (Printexc.to_string exn)) - ; Lwt.return () in + (Printexc.to_string exn)); + Lwt.return () in let (`Initialized fiber) = Server.serve_when_ready ?stop ~handler:(handler pool) service in fiber @@ -99,8 +81,8 @@ struct match !lst with | [] -> Lwt.return_none | str :: rest -> - lst := rest - ; Lwt.return_some (str, 0, String.length str) + lst := rest; + Lwt.return_some (str, 0, String.length str) let stream_of_field (field_name : Mrmime.Field_name.t) unstrctrd = stream_of_list @@ -117,8 +99,8 @@ struct | None -> if !current == b then Lwt.return_none else ( - current := b - ; next ()) in + current := b; + next ()) in next let smtp_logic ~pool ~info ~tls stack resolver messaged map dns = @@ -127,38 +109,36 @@ struct Verifier.Md.pop messaged >>= function | None -> Lwt.pause () >>= go | Some (key, queue, consumer) -> - Log.debug (fun m -> m "Got an email.") - ; let verify_and_transmit () = - Verifier.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver - map - (List.map fst (Ptt.Messaged.recipients key)) - >>= fun recipients -> - let sender, _ = Ptt.Messaged.from key in - let ctx = - Uspf.empty |> Uspf.with_ip (Ptt.Messaged.ipaddr key) |> fun ctx -> - Option.fold ~none:ctx - ~some:(fun sender -> Uspf.with_sender (`MAILFROM sender) ctx) - sender in - Uspf.get ~ctx state dns (module Uspf_dns) |> Lwt_scheduler.prj - >>= function - | Error (`Msg err) -> - Log.err (fun m -> m "Got an error from the SPF verifier: %s." err) - ; (* TODO(dinosaure): save this result into the incoming email. *) - transmit ~pool ~info ~tls stack (key, queue, consumer) - recipients - | Ok record -> - Uspf.check ~ctx state dns (module Uspf_dns) record - |> Lwt_scheduler.prj - >>= fun res -> - let receiver = - `Domain (Domain_name.to_strings info.Ptt.SSMTP.domain) in - let field_name, unstrctrd = Uspf.to_field ~ctx ~receiver res in - let stream = stream_of_field field_name unstrctrd in - let consumer = concat_stream stream consumer in - transmit ~pool ~info ~tls stack (key, queue, consumer) recipients - in - Lwt.async verify_and_transmit - ; Lwt.pause () >>= go in + Log.debug (fun m -> m "Got an email."); + let verify_and_transmit () = + Verifier.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver map + (List.map fst (Ptt.Messaged.recipients key)) + >>= fun recipients -> + let sender, _ = Ptt.Messaged.from key in + let ctx = + Uspf.empty |> Uspf.with_ip (Ptt.Messaged.ipaddr key) |> fun ctx -> + Option.fold ~none:ctx + ~some:(fun sender -> Uspf.with_sender (`MAILFROM sender) ctx) + sender in + Uspf.get ~ctx state dns (module Uspf_dns) |> Lwt_scheduler.prj + >>= function + | Error (`Msg err) -> + Log.err (fun m -> m "Got an error from the SPF verifier: %s." err); + (* TODO(dinosaure): save this result into the incoming email. *) + transmit ~pool ~info ~tls stack (key, queue, consumer) recipients + | Ok record -> + Uspf.check ~ctx state dns (module Uspf_dns) record + |> Lwt_scheduler.prj + >>= fun res -> + let receiver = + `Domain (Domain_name.to_strings info.Ptt.SSMTP.domain) in + let field_name, unstrctrd = Uspf.to_field ~ctx ~receiver res in + let stream = stream_of_field field_name unstrctrd in + let consumer = concat_stream stream consumer in + transmit ~pool ~info ~tls stack (key, queue, consumer) recipients + in + Lwt.async verify_and_transmit; + Lwt.pause () >>= go in go () let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info dns = diff --git a/lib/hm.mli b/lib/hm.mli index 6ded031..f472519 100644 --- a/lib/hm.mli +++ b/lib/hm.mli @@ -6,15 +6,12 @@ sender allows this IP address. *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) (Resolver : Ptt.Sigs.RESOLVER with type +'a io = 'a Lwt.t) (Stack : Tcpip.Stack.V4V6) - (DNS : Dns_client_mirage.S - with type Transport.stack = Stack.t - and type 'a Transport.io = 'a Lwt.t) : sig + (DNS : Dns_client_mirage.S with type 'a Transport.io = 'a Lwt.t) : sig val fiber : ?limit:int -> ?stop:Lwt_switch.t diff --git a/lib/lipap.ml b/lib/lipap.ml index 78a0947..5879721 100644 --- a/lib/lipap.ml +++ b/lib/lipap.ml @@ -7,7 +7,6 @@ let src = Logs.Src.create "ptt.lipap" module Log : Logs.LOG = (val Logs.src_log src) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -15,23 +14,11 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct include Ptt_tuyau.Client (Stack) - - module Random = struct - type g = Random.g - type +'a io = 'a Lwt.t - - let generate ?g buf = - let len = Bytes.length buf in - let raw = Random.generate ?g len in - Cstruct.blit_to_bytes raw 0 buf 0 len - ; Lwt.return () - end - module Tls = Tls_mirage.Make (Stack.TCP) module Flow = Rdwr.Make (Tls) module Submission = - Ptt.Submission.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) (Random) + Ptt.Submission.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) module Server = Ptt_tuyau.Server (Time) (Stack) include Ptt_transmit.Make (Pclock) (Stack) (Submission.Md) @@ -66,16 +53,16 @@ struct | exn -> Lwt.return (Error (`Exn exn))) >>= function | Ok () -> - Log.info (fun m -> m "<%a:%d> quit properly" Ipaddr.pp ip port) - ; Lwt.return () + Log.info (fun m -> m "<%a:%d> quit properly" Ipaddr.pp ip port); + Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err) - ; Lwt.return () + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err); + Lwt.return () | Error (`Exn exn) -> Log.err (fun m -> m "<%a:%d> raised an unknown exception: %s" Ipaddr.pp ip port - (Printexc.to_string exn)) - ; Lwt.return () in + (Printexc.to_string exn)); + Lwt.return () in let (`Initialized fiber) = Server.serve_when_ready ?stop ~handler:(handler pool) service in fiber @@ -92,8 +79,8 @@ struct (List.map fst (Ptt.Messaged.recipients key)) >>= fun recipients -> transmit ~pool ~info ~tls stack v recipients in - Lwt.async transmit - ; Lwt.pause () >>= go in + Lwt.async transmit; + Lwt.pause () >>= go in go () let fiber diff --git a/lib/lipap.mli b/lib/lipap.mli index 6034fcd..82b20af 100644 --- a/lib/lipap.mli +++ b/lib/lipap.mli @@ -7,7 +7,6 @@ wrap the SMTP protocol with the Transport Security Layer). *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -21,7 +20,7 @@ module Make -> tls:Tls.Config.client -> Stack.TCP.t -> Resolver.t - -> Random.g option + -> Mirage_crypto_rng.g option -> 'k Digestif.hash -> Ptt.Logic.info -> (Ptt_tuyau.Lwt_backend.Lwt_scheduler.t, 'k) Ptt.Authentication.t diff --git a/lib/logic.ml b/lib/logic.ml index 1ef4b39..6052c7d 100644 --- a/lib/logic.ml +++ b/lib/logic.ml @@ -184,15 +184,14 @@ module Make (Monad : MONAD) = struct | Error err -> fail err (* TODO(dinosaure): catch [`Invalid_reverse_path _]. *) | Ok `Reset -> - incr reset - ; send ctx Value.PP_250 ["Yes buddy!"] >>= fun () -> mail_from () + incr reset; + send ctx Value.PP_250 ["Yes buddy!"] >>= fun () -> mail_from () | Ok v -> - incr bad - ; Log.warn (fun m -> - m "%a sended a bad command: %a" Domain.pp domain_from Request.pp - v) - ; send ctx Value.PN_503 ["Command out of sequence"] >>= fun () -> - mail_from () + incr bad; + Log.warn (fun m -> + m "%a sended a bad command: %a" Domain.pp domain_from Request.pp v); + send ctx Value.PN_503 ["Command out of sequence"] >>= fun () -> + mail_from () and recipients ~from acc = if !reset >= 25 || !bad >= 25 then m_properly_close_and_fail ctx ~message:"You reached the limit buddy!" @@ -218,16 +217,15 @@ module Make (Monad : MONAD) = struct send ctx Value.Code (452, ["Too many recipients, buddy! "]) >>= fun () -> fail `Too_many_recipients | `Reset -> - incr reset - ; send ctx Value.PP_250 ["Yes buddy!"] >>= fun () -> mail_from () + incr reset; + send ctx Value.PP_250 ["Yes buddy!"] >>= fun () -> mail_from () | `Quit -> m_politely_close ctx | v -> - incr bad - ; Log.warn (fun m -> - m "%a sended a bad command: %a" Domain.pp domain_from Request.pp - v) - ; send ctx Value.PN_503 ["Command out of sequence"] >>= fun () -> - recipients ~from acc in + incr bad; + Log.warn (fun m -> + m "%a sended a bad command: %a" Domain.pp domain_from Request.pp v); + send ctx Value.PN_503 ["Command out of sequence"] >>= fun () -> + recipients ~from acc in mail_from () exception Unrecognized_authentication @@ -249,8 +247,8 @@ module Make (Monad : MONAD) = struct return (`Authentication (domain_from, mechanism)) else raise Unrecognized_authentication with Invalid_argument _ | Unrecognized_authentication -> - incr bad - ; send ctx Value.PN_504 ["Unrecognized authentication!"] >>= auth_0) + incr bad; + send ctx Value.PN_504 ["Unrecognized authentication!"] >>= auth_0) | `Verb ("AUTH", [mechanism; payload]) -> ( try let mechanism = Mechanism.of_string_exn mechanism in @@ -259,24 +257,23 @@ module Make (Monad : MONAD) = struct (`Authentication_with_payload (domain_from, mechanism, payload)) else raise Unrecognized_authentication with Invalid_argument _ | Unrecognized_authentication -> - incr bad - ; send ctx Value.PN_504 ["Unrecognized authentication!"] >>= auth_0) + incr bad; + send ctx Value.PN_504 ["Unrecognized authentication!"] >>= auth_0) | `Verb ("AUTH", []) -> - incr bad - ; let* () = send ctx Value.PN_555 ["Syntax error, buddy!"] in - auth_0 () + incr bad; + let* () = send ctx Value.PN_555 ["Syntax error, buddy!"] in + auth_0 () | `Reset -> - incr reset - ; send ctx Value.PP_250 ["Yes buddy!"] >>= auth_0 + incr reset; + send ctx Value.PP_250 ["Yes buddy!"] >>= auth_0 | `Quit -> m_politely_close ctx | v -> - incr bad - ; Log.warn (fun m -> - m " %a sended a bad command: %a" Domain.pp domain_from - Request.pp v) - ; let* () = - send ctx Value.PN_530 ["Authentication required, buddy!"] in - auth_0 () in + incr bad; + Log.warn (fun m -> + m " %a sended a bad command: %a" Domain.pp domain_from Request.pp + v); + let* () = send ctx Value.PN_530 ["Authentication required, buddy!"] in + auth_0 () in auth_0 () let m_mail ctx = diff --git a/lib/messaged.ml b/lib/messaged.ml index 7ae447b..579266b 100644 --- a/lib/messaged.ml +++ b/lib/messaged.ml @@ -95,62 +95,62 @@ struct (* XXX(dinosaure): preferred one writer / one reader *) let pipe_of_queue ?(chunk = 0x1000) queue = if chunk <= 0 then - Fmt.invalid_arg "stream_of_queue: chunk must be bigger than 0" - - ; let close = ref false in - let mutex = Mutex.create () in - let condition = Condition.create () in - - let consumer () = + Fmt.invalid_arg "stream_of_queue: chunk must be bigger than 0"; + + let close = ref false in + let mutex = Mutex.create () in + let condition = Condition.create () in + + let consumer () = + Mutex.lock mutex >>= fun () -> + let rec wait () = + if Ke.is_empty queue && not !close then + Condition.wait condition mutex >>= wait + else return () in + wait () >>= fun () -> + let len = min (Ke.length queue) chunk in + + if len = 0 && !close then (Mutex.unlock mutex; return None) + else + let buf = Bytes.create chunk in + Log.debug (fun m -> m "Transmit %d byte(s) from the client." len); + Ke.N.keep_exn queue ~blit:blit_to_bytes ~length:Bytes.length ~off:0 ~len + buf; + Ke.N.shift_exn queue len; + Mutex.unlock mutex; + return (Some (Bytes.unsafe_to_string buf, 0, len)) in + + let rec producer = function + | None -> + Log.debug (fun m -> + m "The client finished the transmission of the message."); Mutex.lock mutex >>= fun () -> - let rec wait () = - if Ke.is_empty queue && not !close then - Condition.wait condition mutex >>= wait - else return () in - wait () >>= fun () -> - let len = min (Ke.length queue) chunk in - - if len = 0 && !close then (Mutex.unlock mutex ; return None) + close := true; + Condition.broadcast condition; + Mutex.unlock mutex; + return () + | Some (buf, off, len) as v -> ( + Mutex.lock mutex >>= fun () -> + if !close then (Mutex.unlock mutex; return ()) else - let buf = Bytes.create chunk in - Log.debug (fun m -> m "Transmit %d byte(s) from the client." len) - ; Ke.N.keep_exn queue ~blit:blit_to_bytes ~length:Bytes.length ~off:0 - ~len buf - ; Ke.N.shift_exn queue len - ; Mutex.unlock mutex - ; return (Some (Bytes.unsafe_to_string buf, 0, len)) in - - let rec producer = function - | None -> - Log.debug (fun m -> - m "The client finished the transmission of the message.") - ; Mutex.lock mutex >>= fun () -> - close := true - ; Condition.broadcast condition - ; Mutex.unlock mutex - ; return () - | Some (buf, off, len) as v -> ( - Mutex.lock mutex >>= fun () -> - if !close then (Mutex.unlock mutex ; return ()) - else - match - Ke.N.push queue ~blit:blit_of_string ~length:String.length ~off - ~len buf - with - | None -> - Condition.signal condition - ; Mutex.unlock mutex - ; Log.debug (fun m -> m "The internal queue is full.") - ; pause () >>= fun () -> producer v - | Some _ -> - Condition.signal condition ; Mutex.unlock mutex ; return ()) in - {q= queue; m= mutex; c= condition; f= close}, producer, consumer + match + Ke.N.push queue ~blit:blit_of_string ~length:String.length ~off ~len + buf + with + | None -> + Condition.signal condition; + Mutex.unlock mutex; + Log.debug (fun m -> m "The internal queue is full."); + pause () >>= fun () -> producer v + | Some _ -> Condition.signal condition; Mutex.unlock mutex; return ()) + in + {q= queue; m= mutex; c= condition; f= close}, producer, consumer let close queue = Mutex.lock queue.m >>= fun () -> - queue.f := true - ; Mutex.unlock queue.m - ; return () + queue.f := true; + Mutex.unlock queue.m; + return () type 'a producer = 'a option -> unit IO.t type 'a consumer = unit -> 'a option IO.t @@ -169,25 +169,25 @@ struct let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in let queue, producer, consumer = pipe_of_queue ?chunk queue in Mutex.lock t.m >>= fun () -> - Queue.push (key, queue, consumer) t.q - ; Condition.signal t.c - ; Mutex.unlock t.m - ; return producer + Queue.push (key, queue, consumer) t.q; + Condition.signal t.c; + Mutex.unlock t.m; + return producer let await t = Mutex.lock t.m >>= fun () -> let rec await () = if Queue.is_empty t.q then Condition.wait t.c t.m >>= await else return () in - await () >>= fun () -> Mutex.unlock t.m ; return () + await () >>= fun () -> Mutex.unlock t.m; return () let pop t = Mutex.lock t.m >>= fun () -> try let key, queue, consumer = Queue.pop t.q in - Mutex.unlock t.m - ; return (Some (key, queue, consumer)) - with _exn -> Mutex.unlock t.m ; return None + Mutex.unlock t.m; + return (Some (key, queue, consumer)) + with _exn -> Mutex.unlock t.m; return None let broadcast t = Condition.broadcast t.c end diff --git a/lib/mti_gf.ml b/lib/mti_gf.ml index a65f092..6599225 100644 --- a/lib/mti_gf.ml +++ b/lib/mti_gf.ml @@ -7,7 +7,6 @@ let src = Logs.Src.create "ptt.mti-gf" module Log : Logs.LOG = (val Logs.src_log src) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -15,23 +14,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct include Ptt_tuyau.Client (Stack) - - module Random = struct - type g = Random.g - type +'a io = 'a Lwt.t - - let generate ?g buf = - let len = Bytes.length buf in - let raw = Random.generate ?g len in - Cstruct.blit_to_bytes raw 0 buf 0 len - ; Lwt.return () - end - module Flow = Rdwr.Make (Stack.TCP) - - module Relay = - Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) (Random) - + module Relay = Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) module Server = Ptt_tuyau.Server (Time) (Stack) include Ptt_transmit.Make (Pclock) (Stack) (Relay.Md) @@ -53,16 +37,16 @@ struct | exn -> Lwt.return (Error (`Exn exn))) >>= function | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port) - ; Lwt.return () + Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); + Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err) - ; Lwt.return () + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err); + Lwt.return () | Error (`Exn exn) -> Log.err (fun m -> m "<%a:%d> raised an unknown exception: %s" Ipaddr.pp ip port - (Printexc.to_string exn)) - ; Lwt.return () in + (Printexc.to_string exn)); + Lwt.return () in let (`Initialized fiber) = Server.serve_when_ready ?stop ~handler:(handler pool) service in fiber @@ -145,8 +129,8 @@ struct (List.map fst recipients) >>= fun recipients -> transmit ~pool ~info ~tls ?emitter stack v recipients in - Lwt.async transmit - ; Lwt.pause () >>= go in + Lwt.async transmit; + Lwt.pause () >>= go in go () let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info = diff --git a/lib/mti_gf.mli b/lib/mti_gf.mli index 58bfb2d..89f6a4d 100644 --- a/lib/mti_gf.mli +++ b/lib/mti_gf.mli @@ -6,7 +6,6 @@ real destination is [foo@gmail.com]. *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) diff --git a/lib/nec.ml b/lib/nec.ml index 852f341..50b38db 100644 --- a/lib/nec.ml +++ b/lib/nec.ml @@ -7,7 +7,6 @@ let src = Logs.Src.create "ptt.nec" module Log : Logs.LOG = (val Logs.src_log src) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -15,24 +14,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct include Ptt_tuyau.Client (Stack) - - module Random = struct - type g = Random.g - type +'a io = 'a Lwt.t - - let generate ?g buf = - let len = Bytes.length buf in - let raw = Random.generate ?g len in - Cstruct.blit_to_bytes raw 0 buf 0 len - ; Lwt.return () - end - module Flow = Rdwr.Make (Stack.TCP) - - module Signer = - Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) (Random) - (* XXX(dinosaure): the [signer] is a simple relay. *) - + module Signer = Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) module Server = Ptt_tuyau.Server (Time) (Stack) include Ptt_transmit.Make (Pclock) (Stack) (Signer.Md) @@ -55,16 +38,16 @@ struct | exn -> Lwt.return (Error (`Exn exn))) >>= function | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port) - ; Lwt.return () + Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); + Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err) - ; Lwt.return () + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err); + Lwt.return () | Error (`Exn exn) -> Log.err (fun m -> m "<%a:%d> raised an unknown exception: %s" Ipaddr.pp ip port - (Printexc.to_string exn)) - ; Lwt.return () in + (Printexc.to_string exn)); + Lwt.return () in let (`Initialized fiber) = Server.serve_when_ready ?stop ~handler:(handler pool) service in fiber @@ -76,26 +59,23 @@ struct Signer.Md.pop messaged >>= function | None -> Lwt.pause () >>= go | Some (key, queue, consumer) -> - Log.debug (fun m -> m "Got an email.") - ; let sign_and_transmit () = - Lwt.catch (fun () -> - Dkim_mirage.sign ~key:private_key ~newline:Dkim.CRLF consumer - dkim - >>= fun (_dkim', consumer') -> - Log.debug (fun m -> m "Incoming email signed.") - ; Signer.resolve_recipients ~domain:info.Ptt.SSMTP.domain - resolver map - (List.map fst (Ptt.Messaged.recipients key)) - >>= fun recipients -> - Log.debug (fun m -> - m "Send the signed email to the destination.") - ; transmit ~pool ~info ~tls stack (key, queue, consumer') - recipients) - @@ fun _exn -> - Log.err (fun m -> m "Impossible to sign the incoming email.") - ; Lwt.return_unit in - Lwt.async sign_and_transmit - ; Lwt.pause () >>= go in + Log.debug (fun m -> m "Got an email."); + let sign_and_transmit () = + Lwt.catch (fun () -> + Dkim_mirage.sign ~key:private_key ~newline:Dkim.CRLF consumer dkim + >>= fun (_dkim', consumer') -> + Log.debug (fun m -> m "Incoming email signed."); + Signer.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver + map + (List.map fst (Ptt.Messaged.recipients key)) + >>= fun recipients -> + Log.debug (fun m -> m "Send the signed email to the destination."); + transmit ~pool ~info ~tls stack (key, queue, consumer') recipients) + @@ fun _exn -> + Log.err (fun m -> m "Impossible to sign the incoming email."); + Lwt.return_unit in + Lwt.async sign_and_transmit; + Lwt.pause () >>= go in go () let fiber diff --git a/lib/nec.mli b/lib/nec.mli index da9f066..98eeba3 100644 --- a/lib/nec.mli +++ b/lib/nec.mli @@ -5,7 +5,6 @@ *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) diff --git a/lib/ptt_transmit.ml b/lib/ptt_transmit.ml index 5170d42..9751581 100644 --- a/lib/ptt_transmit.ml +++ b/lib/ptt_transmit.ml @@ -28,18 +28,16 @@ struct let rec go () = consumer () >>= function | Some ((str, off, len) as v) -> - Log.debug (fun m -> m "Send to %d recipient(s)" (List.length producers)) - ; Log.debug (fun m -> - m "@[%a@]" - (Hxd_string.pp Hxd.default) - (String.sub str off len)) - ; List.iter (fun producer -> producer (Some v)) producers - ; Lwt.pause () >>= go + Log.debug (fun m -> m "Send to %d recipient(s)" (List.length producers)); + Log.debug (fun m -> + m "@[%a@]" (Hxd_string.pp Hxd.default) (String.sub str off len)); + List.iter (fun producer -> producer (Some v)) producers; + Lwt.pause () >>= go | None -> Log.debug (fun m -> - m "Send to %d recipient(s)." (List.length producers)) - ; List.iter (fun producer -> producer None) producers - ; Lwt.return () in + m "Send to %d recipient(s)." (List.length producers)); + List.iter (fun producer -> producer None) producers; + Lwt.return () in go let ( <+> ) s0 s1 = @@ -52,8 +50,8 @@ struct | None -> if !current == s1 then Lwt.return None else ( - current := s1 - ; Lwt_scheduler.prj (next ())) in + current := s1; + Lwt_scheduler.prj (next ())) in Lwt_scheduler.inj res in next @@ -114,36 +112,36 @@ struct let rec go = function | [] -> Log.err (fun m -> - m "Impossible to send an email to %a (no solution found)." pp_key k) - ; Lwt.return () + m "Impossible to send an email to %a (no solution found)." pp_key k); + Lwt.return () | {Ptt.Mxs.mx_ipaddr; _} :: rest -> ( Log.debug (fun m -> m "Transmit the incoming email to %a (%a)." Ipaddr.pp mx_ipaddr - Domain.pp mx_domain) - ; Lwt_pool.use pool (fun (encoder, decoder, queue) -> - sendmail ~encoder:(Fun.const encoder) ~decoder:(Fun.const decoder) - ~queue:(Fun.const queue) ~info ~tls stack mx_ipaddr emitter + Domain.pp mx_domain); + Lwt_pool.use pool (fun (encoder, decoder, queue) -> + sendmail ~encoder:(Fun.const encoder) ~decoder:(Fun.const decoder) + ~queue:(Fun.const queue) ~info ~tls stack mx_ipaddr emitter stream + recipients + >>= function + | Ok () -> Lwt.return_ok () + | Error `STARTTLS_unavailable + (* TODO(dinosaure): when [insecure]. *) -> + Log.warn (fun m -> + m + "The SMTP receiver %a does not implement STARTTLS, restart \ + in clear." + Domain.pp mx_domain); + sendmail_without_tls ~encoder:(Fun.const encoder) + ~decoder:(Fun.const decoder) ~info stack mx_ipaddr emitter stream recipients - >>= function - | Ok () -> Lwt.return_ok () - | Error `STARTTLS_unavailable - (* TODO(dinosaure): when [insecure]. *) -> - Log.warn (fun m -> - m - "The SMTP receiver %a does not implement STARTTLS, \ - restart in clear." - Domain.pp mx_domain) - ; sendmail_without_tls ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~info stack mx_ipaddr emitter - stream recipients - | Error err -> Lwt.return_error err) - >>= function - | Ok () -> Lwt.return_unit - | Error err -> - Log.err (fun m -> - m "Impossible to send the given email to %a: %a." Domain.pp - mx_domain pp_error err) - ; go rest) in + | Error err -> Lwt.return_error err) + >>= function + | Ok () -> Lwt.return_unit + | Error err -> + Log.err (fun m -> + m "Impossible to send the given email to %a: %a." Domain.pp + mx_domain pp_error err); + go rest) in let sort = List.sort (fun {Ptt.Mxs.preference= a; _} {Ptt.Mxs.preference= b; _} -> icompare a b) in @@ -162,12 +160,12 @@ struct let transmit = plug_consumer_to_producers consumer producers in Log.debug (fun m -> m "Start to send the incoming email to %d recipient(s)." - (List.length targets)) - ; Lwt.both (transmit ()) - (Lwt_list.iter_s - (sendmail_to_a_target ~pool ~info ~tls ~key stack emitter) - targets) - >>= fun ((), ()) -> - Log.debug (fun m -> m "Email sended!") - ; Md.close queue + (List.length targets)); + Lwt.both (transmit ()) + (Lwt_list.iter_s + (sendmail_to_a_target ~pool ~info ~tls ~key stack emitter) + targets) + >>= fun ((), ()) -> + Log.debug (fun m -> m "Email sended!"); + Md.close queue end diff --git a/lib/ptt_tuyau.ml b/lib/ptt_tuyau.ml index 486c214..dd3bd0b 100644 --- a/lib/ptt_tuyau.ml +++ b/lib/ptt_tuyau.ml @@ -60,22 +60,22 @@ module Client (Stack : Tcpip.Stack.V4V6) = struct Log.debug (fun m -> m "Email to %a was sent!" Fmt.(Dump.list Colombe.Forward_path.pp) - recipients) - ; Lwt.return (Ok ()) + recipients); + Lwt.return (Ok ()) | Error (`Sendmail `STARTTLS_unavailable) -> Lwt.return_error `STARTTLS_unavailable | Error (`Sendmail err) -> Log.err (fun m -> m "Got a sendmail error when we tried to sent to %a: %a" Fmt.(Dump.list Colombe.Forward_path.pp) - recipients Sendmail_with_starttls.pp_error err) - ; Lwt.return (R.error_msgf "%a" Sendmail_with_starttls.pp_error err) + recipients Sendmail_with_starttls.pp_error err); + Lwt.return (R.error_msgf "%a" Sendmail_with_starttls.pp_error err) | Error (`Msg msg) as err -> Log.err (fun m -> m "Got an error when we tried to sent to %a: %s" Fmt.(Dump.list Colombe.Forward_path.pp) - recipients msg) - ; Lwt.return err + recipients msg); + Lwt.return err | Error (`Exn exn) -> Lwt.return (R.error_msgf "Unknown error: %s" (Printexc.to_string exn)) @@ -131,12 +131,12 @@ module Server (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct let listener flow = Lwt_mutex.lock mutex >>= fun () -> - Queue.push flow queue - ; Lwt_condition.signal condition () - ; Lwt_mutex.unlock mutex - ; Lwt.return_unit in - Stack.TCP.listen ~port stack listener - ; Lwt.return {stack; queue; condition; mutex; closed= false} + Queue.push flow queue; + Lwt_condition.signal condition (); + Lwt_mutex.unlock mutex; + Lwt.return_unit in + Stack.TCP.listen ~port stack listener; + Lwt.return {stack; queue; condition; mutex; closed= false} let rec accept ({queue; condition; mutex; _} as t) = Lwt_mutex.lock mutex >>= fun () -> @@ -146,30 +146,30 @@ module Server (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct else Lwt.return_unit in await () >>= fun () -> match Queue.pop queue with - | flow -> Lwt_mutex.unlock mutex ; Lwt.return_ok flow + | flow -> Lwt_mutex.unlock mutex; Lwt.return_ok flow | exception Queue.Empty -> - if t.closed then (Lwt_mutex.unlock mutex ; Lwt.return_error `Closed) - else (Lwt_mutex.unlock mutex ; accept t) + if t.closed then (Lwt_mutex.unlock mutex; Lwt.return_error `Closed) + else (Lwt_mutex.unlock mutex; accept t) let close ({stack; condition; _} as t) = - t.closed <- true - ; Stack.TCP.disconnect stack >>= fun () -> - Lwt_condition.signal condition () - ; Lwt.return_unit + t.closed <- true; + Stack.TCP.disconnect stack >>= fun () -> + Lwt_condition.signal condition (); + Lwt.return_unit let serve_when_ready ?stop ~handler service = `Initialized (let switched_off = let t, u = Lwt.wait () in Lwt_switch.add_hook stop (fun () -> - Lwt.wakeup_later u (Ok `Stopped) - ; Lwt.return_unit) - ; t in + Lwt.wakeup_later u (Ok `Stopped); + Lwt.return_unit); + t in let rec loop () = accept service >>= function | Ok flow -> - Lwt.async (fun () -> handler flow) - ; loop () + Lwt.async (fun () -> handler flow); + loop () | Error `Closed -> Lwt.return_error `Closed | Error _ -> Lwt.pause () >>= loop in let stop_result = diff --git a/lib/rdwr.ml b/lib/rdwr.ml index a06e75e..2249583 100644 --- a/lib/rdwr.ml +++ b/lib/rdwr.ml @@ -24,18 +24,18 @@ module Make (Flow : Mirage_flow.S) = struct Flow.read flow.flow >>= failwith Flow.pp_error >>= function | `Eof -> Lwt.return 0 | `Data res -> - Ke.Rke.N.push flow.queue ~blit:blit0 ~length:Cstruct.length res - ; let len = min p_len (Ke.Rke.length flow.queue) in - Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Bytes.length - ~off:p_off ~len payload - ; Ke.Rke.N.shift_exn flow.queue len - ; Lwt.return len) + Ke.Rke.N.push flow.queue ~blit:blit0 ~length:Cstruct.length res; + let len = min p_len (Ke.Rke.length flow.queue) in + Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Bytes.length ~off:p_off + ~len payload; + Ke.Rke.N.shift_exn flow.queue len; + Lwt.return len) else let len = min p_len (Ke.Rke.length flow.queue) in Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Bytes.length ~off:p_off - ~len payload - ; Ke.Rke.N.shift_exn flow.queue len - ; Lwt.return len + ~len payload; + Ke.Rke.N.shift_exn flow.queue len; + Lwt.return len let input flow payload p_off p_len = recv flow payload p_off p_len diff --git a/lib/relay.ml b/lib/relay.ml index f20b29e..1b48396 100644 --- a/lib/relay.ml +++ b/lib/relay.ml @@ -9,10 +9,9 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) = + (Resolver : RESOLVER with type 'a io = 'a IO.t) = struct - include Common.Make (Scheduler) (IO) (Flow) (Resolver) (Random) + include Common.Make (Scheduler) (IO) (Flow) (Resolver) module Md = Messaged.Make (Scheduler) (IO) type server = {info: info; messaged: Md.t; mutable count: int64} @@ -31,8 +30,8 @@ struct let succ server = let v = server.count in - server.count <- Int64.succ server.count - ; v + server.count <- Int64.succ server.count; + v type error = [ `Error of SMTP.error | `Too_big_data ] diff --git a/lib/relay.mli b/lib/relay.mli index 81a394d..1b078c3 100644 --- a/lib/relay.mli +++ b/lib/relay.mli @@ -5,8 +5,7 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) : sig + (Resolver : RESOLVER with type 'a io = 'a IO.t) : sig module Md : module type of Messaged.Make (Scheduler) (IO) type server diff --git a/lib/relay_map.ml b/lib/relay_map.ml index 6652712..3f9e5b1 100644 --- a/lib/relay_map.ml +++ b/lib/relay_map.ml @@ -17,15 +17,15 @@ let add ~local mailbox t = | Error (`Msg err) -> invalid_arg err | Ok mailbox -> ( Log.debug (fun m -> - m "Add %a with %a." Emile.pp_local local Colombe.Forward_path.pp mailbox) - ; try - let rest = Hashtbl.find t.map local in - if not (List.exists (Colombe.Forward_path.equal mailbox) rest) then - Hashtbl.add t.map local (mailbox :: rest) - ; t - with Not_found -> - Hashtbl.add t.map local [mailbox] - ; t) + m "Add %a with %a." Emile.pp_local local Colombe.Forward_path.pp mailbox); + try + let rest = Hashtbl.find t.map local in + if not (List.exists (Colombe.Forward_path.equal mailbox) rest) then + Hashtbl.add t.map local (mailbox :: rest); + t + with Not_found -> + Hashtbl.add t.map local [mailbox]; + t) let exists reverse_path t = match reverse_path with @@ -40,8 +40,8 @@ let recipients ~local {map; _} = match Hashtbl.find map local with | recipients -> recipients | exception Not_found -> - Log.err (fun m -> m "%a not found into our local map." Emile.pp_local local) - ; [] + Log.err (fun m -> m "%a not found into our local map." Emile.pp_local local); + [] let all t = Hashtbl.fold (fun _ vs a -> vs @ a) t.map [] let ( <.> ) f g x = f (g x) @@ -94,8 +94,7 @@ let expand t unresolved resolved = Log.debug (fun m -> m "Replace locals %a by their destinations." Fmt.(Dump.list Emile.pp_local) - vs) - ; let vs = - List.fold_left (fun a local -> recipients ~local t @ a) [] vs in - List.fold_left fold (unresolved, resolved) vs in + vs); + let vs = List.fold_left (fun a local -> recipients ~local t @ a) [] vs in + List.fold_left fold (unresolved, resolved) vs in By_domain.fold fold unresolved (By_domain.empty, resolved) diff --git a/lib/sMTP.ml b/lib/sMTP.ml index 129fa16..bacb7bc 100644 --- a/lib/sMTP.ml +++ b/lib/sMTP.ml @@ -117,16 +117,15 @@ let m_relay_init ctx info = |> reword_error tls_error >>= fun () -> m_relay_init ctx info | `Reset -> - incr reset - ; let* () = send ctx Value.PP_250 ["Yes buddy!"] in - go () + incr reset; + let* () = send ctx Value.PP_250 ["Yes buddy!"] in + go () | `Quit -> m_politely_close ctx | _ -> - incr bad - ; let* () = - send ctx Value.PN_530 ["Must issue a STARTTLS command first."] - in - go () in + incr bad; + let* () = + send ctx Value.PN_530 ["Must issue a STARTTLS command first."] in + go () in go () let m_submission_init ctx info ms = @@ -164,14 +163,13 @@ let m_submission_init ctx info ms = |> reword_error tls_error >>= fun () -> m_submission_init ctx info ms | `Reset -> - incr reset - ; let* () = send ctx Value.PP_250 ["Yes, buddy!"] in - go () + incr reset; + let* () = send ctx Value.PP_250 ["Yes, buddy!"] in + go () | `Quit -> m_politely_close ctx | _ -> - incr bad - ; let* () = - send ctx Value.PN_530 ["Must issue a STARTTLS command first."] - in - go () in + incr bad; + let* () = + send ctx Value.PN_530 ["Must issue a STARTTLS command first."] in + go () in go () diff --git a/lib/sSMTP.ml b/lib/sSMTP.ml index 31929af..fd48d90 100644 --- a/lib/sSMTP.ml +++ b/lib/sSMTP.ml @@ -14,9 +14,9 @@ module Value = struct let fiber : a send -> [> Encoder.error ] Encoder.state = function | Payload -> let k encoder = - Encoder.write v encoder - ; Encoder.write "\r\n" encoder - ; Encoder.flush (fun _ -> Encoder.Done) encoder in + Encoder.write v encoder; + Encoder.write "\r\n" encoder; + Encoder.flush (fun _ -> Encoder.Done) encoder in Encoder.safe k encoder | PP_220 -> Reply.Encoder.response (`PP_220 v) encoder | PP_221 -> Reply.Encoder.response (`PP_221 v) encoder diff --git a/lib/sigs.ml b/lib/sigs.ml index 8cde6fa..971a208 100644 --- a/lib/sigs.ml +++ b/lib/sigs.ml @@ -51,13 +51,6 @@ module type RESOLVER = sig t -> string -> string -> (Ipaddr.t, [> Rresult.R.msg ]) result io end -module type RANDOM = sig - type g - type +'a io - - val generate : ?g:g -> bytes -> unit io -end - module type FLOW = sig type t type +'a io diff --git a/lib/sigs.mli b/lib/sigs.mli index 8cde6fa..971a208 100644 --- a/lib/sigs.mli +++ b/lib/sigs.mli @@ -51,13 +51,6 @@ module type RESOLVER = sig t -> string -> string -> (Ipaddr.t, [> Rresult.R.msg ]) result io end -module type RANDOM = sig - type g - type +'a io - - val generate : ?g:g -> bytes -> unit io -end - module type FLOW = sig type t type +'a io diff --git a/lib/spartacus.ml b/lib/spartacus.ml index e77f7eb..527ec54 100644 --- a/lib/spartacus.ml +++ b/lib/spartacus.ml @@ -7,7 +7,6 @@ let src = Logs.Src.create "ptt.spartacus" module Log : Logs.LOG = (val Logs.src_log src) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) @@ -15,24 +14,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct include Ptt_tuyau.Client (Stack) - - module Random = struct - type g = Random.g - type +'a io = 'a Lwt.t - - let generate ?g buf = - let len = Bytes.length buf in - let raw = Random.generate ?g len in - Cstruct.blit_to_bytes raw 0 buf 0 len - ; Lwt.return () - end - module Flow = Rdwr.Make (Stack.TCP) - - module Filter = - Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) (Random) - (* XXX(dinosaure): the [filter] is a simple relay. *) - + module Filter = Ptt.Relay.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) module Server = Ptt_tuyau.Server (Time) (Stack) include Ptt_transmit.Make (Pclock) (Stack) (Filter.Md) @@ -55,16 +38,16 @@ struct | exn -> Lwt.return (Error (`Exn exn))) >>= function | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port) - ; Lwt.return () + Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); + Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err) - ; Lwt.return () + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ip port err); + Lwt.return () | Error (`Exn exn) -> Log.err (fun m -> m "<%a:%d> raised an unknown exception: %s" Ipaddr.pp ip port - (Printexc.to_string exn)) - ; Lwt.return () in + (Printexc.to_string exn)); + Lwt.return () in let (`Initialized fiber) = Server.serve_when_ready ?stop ~handler:(handler pool) service in fiber @@ -83,8 +66,8 @@ struct | None -> None in Spamtacus_mirage.rank consumer >>= function | Error (`Msg err) -> - Log.err (fun m -> m "Got an error from the incoming email: %s." err) - ; Lwt.return_unit + Log.err (fun m -> m "Got an error from the incoming email: %s." err); + Lwt.return_unit | Ok (_label, consumer') -> Filter.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver map (List.map fst (Ptt.Messaged.recipients key)) @@ -93,11 +76,11 @@ struct Lwt_stream.get consumer' >|= function | Some str -> Some (str, 0, String.length str) | None -> None in - Log.debug (fun m -> m "Send the labelled email to the destination.") - ; transmit ~pool ~info ~tls stack (key, queue, consumer') recipients + Log.debug (fun m -> m "Send the labelled email to the destination."); + transmit ~pool ~info ~tls stack (key, queue, consumer') recipients in - Lwt.async label_and_transmit - ; Lwt.pause () >>= go in + Lwt.async label_and_transmit; + Lwt.pause () >>= go in go () let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info = diff --git a/lib/spartacus.mli b/lib/spartacus.mli index 09d1d6e..fc9aeab 100644 --- a/lib/spartacus.mli +++ b/lib/spartacus.mli @@ -5,7 +5,6 @@ field then. *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) diff --git a/lib/submission.ml b/lib/submission.ml index fb53efa..55f03a8 100644 --- a/lib/submission.ml +++ b/lib/submission.ml @@ -9,10 +9,9 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) = + (Resolver : RESOLVER with type 'a io = 'a IO.t) = struct - include Common.Make (Scheduler) (IO) (Flow) (Resolver) (Random) + include Common.Make (Scheduler) (IO) (Flow) (Resolver) module Md = Messaged.Make (Scheduler) (IO) type 'k server = { @@ -40,8 +39,8 @@ struct let succ server = let v = server.count in - server.count <- Int64.succ server.count - ; v + server.count <- Int64.succ server.count; + v type error = [ `Error of [ SSMTP.error | `Invalid_recipients | `Too_many_tries ] @@ -92,44 +91,42 @@ struct go (limit + 1) ~payload m)) | Mechanism.PLAIN, None -> ( let stamp = Bytes.create 0x10 in - generate ?g:random stamp >>= fun () -> + generate ?g:random stamp 0x10; let stamp = Bytes.unsafe_to_string stamp in - Log.debug (fun m -> m "Generate the stamp %S." stamp) - ; let m = + Log.debug (fun m -> m "Generate the stamp %S." stamp); + let m = + let open SSMTP in + let open Monad in + send ctx Value.TP_334 [Base64.encode_string ~pad:true stamp] + >>= fun () -> recv ctx Value.Payload in + run flow m >>? fun v -> + Log.debug (fun m -> m "Got a payload while authentication: %S" v); + Authentication.decode_authentication scheduler hash + (Authentication.PLAIN (Some stamp)) server.authenticator v + |> Scheduler.prj + >>= function + | Ok true -> + let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in + run flow m >>? fun () -> IO.return (Ok `Authenticated) + | (Error _ | Ok false) as res -> ( + let () = + match res with + | Error (`Msg err) -> + Log.err (fun m -> m "Got an authentication error: %s" err) + | _ -> () in + let m = let open SSMTP in let open Monad in - send ctx Value.TP_334 [Base64.encode_string ~pad:true stamp] - >>= fun () -> recv ctx Value.Payload in - run flow m >>? fun v -> - Log.debug (fun m -> m "Got a payload while authentication: %S" v) - ; Authentication.decode_authentication scheduler hash - (Authentication.PLAIN (Some stamp)) server.authenticator v - |> Scheduler.prj - >>= function - | Ok true -> - let m = - SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in - run flow m >>? fun () -> IO.return (Ok `Authenticated) - | (Error _ | Ok false) as res -> ( - let () = - match res with - | Error (`Msg err) -> - Log.err (fun m -> m "Got an authentication error: %s" err) - | _ -> () in - let m = - let open SSMTP in - let open Monad in - let* () = - send ctx Value.PN_535 ["Bad authentication, buddy!"] in - SSMTP.m_submission ctx ~domain_from server.mechanisms in - run flow m >>? function - | `Quit -> IO.return (Ok `Quit) - | `Authentication (_domain_from, m) -> - (* assert (_domain_from = domain_from) ; *) - go (limit + 1) m - | `Authentication_with_payload (_domain_from, m, payload) -> - (* assert (_domain_from = domain_from) ; *) - go (limit + 1) ~payload m)) in + let* () = send ctx Value.PN_535 ["Bad authentication, buddy!"] in + SSMTP.m_submission ctx ~domain_from server.mechanisms in + run flow m >>? function + | `Quit -> IO.return (Ok `Quit) + | `Authentication (_domain_from, m) -> + (* assert (_domain_from = domain_from) ; *) + go (limit + 1) m + | `Authentication_with_payload (_domain_from, m, payload) -> + (* assert (_domain_from = domain_from) ; *) + go (limit + 1) ~payload m)) in go 1 ?payload mechanism type authentication = @@ -142,7 +139,7 @@ struct -> ipaddr:Ipaddr.t -> Flow.t -> Resolver.t - -> Random.g option + -> Mirage_crypto_rng.g option -> 'k Digestif.hash -> 'k server -> (unit, error) result IO.t = @@ -174,15 +171,15 @@ struct Md.push server.messaged key >>= fun producer -> let m = SSMTP.m_mail ctx in run flow m >>? fun () -> - Log.debug (fun m -> m "Start to receive the incoming email.") - ; receive_mail - ~limit:(Int64.to_int server.info.size) - flow ctx - SSMTP.(fun ctx -> Monad.recv ctx Value.Payload) - producer - >>? fun () -> - let m = SSMTP.m_end ctx in - run flow m >>? fun `Quit -> IO.return (Ok ()) + Log.debug (fun m -> m "Start to receive the incoming email."); + receive_mail + ~limit:(Int64.to_int server.info.size) + flow ctx + SSMTP.(fun ctx -> Monad.recv ctx Value.Payload) + producer + >>? fun () -> + let m = SSMTP.m_end ctx in + run flow m >>? fun `Quit -> IO.return (Ok ()) | false -> let e = `Invalid_recipients in let m = diff --git a/lib/submission.mli b/lib/submission.mli index dc8aeb7..b287790 100644 --- a/lib/submission.mli +++ b/lib/submission.mli @@ -5,8 +5,7 @@ module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) (Flow : FLOW with type 'a io = 'a IO.t) - (Resolver : RESOLVER with type 'a io = 'a IO.t) - (Random : RANDOM with type 'a io = 'a IO.t) : sig + (Resolver : RESOLVER with type 'a io = 'a IO.t) : sig module Md : module type of Messaged.Make (Scheduler) (IO) type 'k server @@ -49,7 +48,7 @@ module Make -> ipaddr:Ipaddr.t -> Flow.t -> Resolver.t - -> Random.g option + -> Mirage_crypto_rng.g option -> 'k Digestif.hash -> 'k server -> (unit, error) result IO.t diff --git a/ptt-bin.opam b/ptt-bin.opam index 5189711..8789f43 100644 --- a/ptt-bin.opam +++ b/ptt-bin.opam @@ -15,6 +15,8 @@ depends: [ "dune" "ptt" {= version} "bos" + "dns-client" + "dns-client-lwt" "git-kv" {>= "0.0.2"} "git-unix" {>= "3.10.0"} "ca-certs" diff --git a/ptt.opam b/ptt.opam index 875c21b..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"} @@ -29,6 +29,7 @@ depends: [ "ke" {>= "0.6"} "hxd" "bigstringaf" + "mirage-crypto-rng" {>= "1.1.0"} "ocaml-syntax-shims" "dkim-mirage" {>= "0.4.0"} "mirage-kv" {>= "4.0.1"} @@ -50,7 +51,7 @@ build: ["dune" "build" "-p" name "-j" jobs] run-test: ["dune" "runtest" "-p" name "-j" jobs] dev-repo: "git+https://github.com/mirage/ptt.git" pin-depends: [ - [ "spamtacus-bayesian.dev" "git+https://github.com/mirage/spamtacus.git#25dbb19afc8344f6933652ab8f6c590d887583bc" ] - [ "spamtacus.dev" "git+https://github.com/mirage/spamtacus.git#25dbb19afc8344f6933652ab8f6c590d887583bc" ] - [ "spamtacus-mirage.dev" "git+https://github.com/mirage/spamtacus.git#25dbb19afc8344f6933652ab8f6c590d887583bc" ] + [ "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" ] ] diff --git a/test/test.ml b/test/test.ml index c690c30..7f986be 100644 --- a/test/test.ml +++ b/test/test.ml @@ -31,18 +31,18 @@ let mechanism_test_0 = Alcotest.(check mechanism) "plain" (Ptt.Mechanism.of_string_exn "plain") - Ptt.Mechanism.PLAIN - ; Alcotest.(check mechanism) - "PLAIN" - (Ptt.Mechanism.of_string_exn "PLAIN") - Ptt.Mechanism.PLAIN - ; Alcotest.(check mechanism) - "PlAiN" - (Ptt.Mechanism.of_string_exn "PlAiN") - Ptt.Mechanism.PLAIN - ; Alcotest.check_raises "PLAIZ" (Invalid_argument "Invalid mechanism: PLAIZ") - (fun () -> ignore @@ Ptt.Mechanism.of_string_exn "PLAIZ") - ; Lwt.return_unit + Ptt.Mechanism.PLAIN; + Alcotest.(check mechanism) + "PLAIN" + (Ptt.Mechanism.of_string_exn "PLAIN") + Ptt.Mechanism.PLAIN; + Alcotest.(check mechanism) + "PlAiN" + (Ptt.Mechanism.of_string_exn "PlAiN") + Ptt.Mechanism.PLAIN; + Alcotest.check_raises "PLAIZ" (Invalid_argument "Invalid mechanism: PLAIZ") + (fun () -> ignore @@ Ptt.Mechanism.of_string_exn "PLAIZ"); + Lwt.return_unit let auth0 = let module Map = Map.Make (struct @@ -81,54 +81,51 @@ let authentication_test_0 = auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" "toto" >>= fun romain -> - Alcotest.(check (result bool msg)) "romain" (Ok true) romain - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "thomas" "tata" - >>= fun thomas -> - Alcotest.(check (result bool msg)) "thomas" (Ok true) thomas - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "anil" "tutu" - >>= fun anil -> - Alcotest.(check (result bool msg)) "anil" (Ok true) anil - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "hannes" "titi" - >>= fun hannes -> - Alcotest.(check (result bool msg)) "hannes" (Ok true) hannes - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "gemma" "" - >>= fun gemma -> - Alcotest.(check (result bool msg)) "gemma" (Ok true) gemma - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" - "romain.calascibetta" "titi" - >>= fun wrong -> - Alcotest.(check (result bool msg)) "romain (wrong)" (Ok false) wrong - ; auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" - "pierre.caillou" "toto" - >>= fun pierre -> - Alcotest.(check (result bool msg)) "pierre" (Ok false) pierre - ; auth Digestif.SHA1 plain_none auth0 "stamp\000%s\000%s" - "romain.calascibetta" "toto" - >>= fun bad_stamp -> - Alcotest.(check (result bool msg)) - "bad stamp" - (Error (`Msg "Unexpected stamp")) - bad_stamp - ; auth Digestif.SHA1 plain_none auth0 "salut les copains" - >>= fun malformed -> - Alcotest.(check (result bool msg)) - "malformed" - (Error (`Msg "Invalid input")) - malformed - ; auth Digestif.SHA1 (Ptt.Authentication.PLAIN (Some "stamp")) - auth0 "\000%s\000%s" "anil" "tutu" - >>= fun invalid_stamp -> - Alcotest.(check (result bool msg)) - "no stamp" - (Error (`Msg "Invalid stamp")) - invalid_stamp - ; auth Digestif.SHA1 plain_none auth0 "\000\000%s" "tutu" - >>= fun invalid_username -> - Alcotest.(check (result bool msg)) - "invalid username" - (Error (`Msg "Invalid username: \"\"")) - invalid_username - ; Lwt.return_unit + Alcotest.(check (result bool msg)) "romain" (Ok true) romain; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "thomas" "tata" + >>= fun thomas -> + Alcotest.(check (result bool msg)) "thomas" (Ok true) thomas; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "anil" "tutu" + >>= fun anil -> + Alcotest.(check (result bool msg)) "anil" (Ok true) anil; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "hannes" "titi" + >>= fun hannes -> + Alcotest.(check (result bool msg)) "hannes" (Ok true) hannes; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "gemma" "" >>= fun gemma -> + Alcotest.(check (result bool msg)) "gemma" (Ok true) gemma; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" + "titi" + >>= fun wrong -> + Alcotest.(check (result bool msg)) "romain (wrong)" (Ok false) wrong; + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "pierre.caillou" "toto" + >>= fun pierre -> + Alcotest.(check (result bool msg)) "pierre" (Ok false) pierre; + auth Digestif.SHA1 plain_none auth0 "stamp\000%s\000%s" "romain.calascibetta" + "toto" + >>= fun bad_stamp -> + Alcotest.(check (result bool msg)) + "bad stamp" + (Error (`Msg "Unexpected stamp")) + bad_stamp; + auth Digestif.SHA1 plain_none auth0 "salut les copains" >>= fun malformed -> + Alcotest.(check (result bool msg)) + "malformed" + (Error (`Msg "Invalid input")) + malformed; + auth Digestif.SHA1 (Ptt.Authentication.PLAIN (Some "stamp")) auth0 + "\000%s\000%s" "anil" "tutu" + >>= fun invalid_stamp -> + Alcotest.(check (result bool msg)) + "no stamp" + (Error (`Msg "Invalid stamp")) + invalid_stamp; + auth Digestif.SHA1 plain_none auth0 "\000\000%s" "tutu" + >>= fun invalid_username -> + Alcotest.(check (result bool msg)) + "invalid username" + (Error (`Msg "Invalid username: \"\"")) + invalid_username; + Lwt.return_unit let x25519 = Domain_name.(host_exn <.> of_string_exn) "x25519.net" let gmail = Domain_name.(host_exn <.> of_string_exn) "gmail.com" @@ -177,27 +174,27 @@ let aggregate_test_0 = let u, r = Ptt.Aggregate.aggregate_by_domains ~domain:x25519 ms in Alcotest.(check bool) "resolved is empty" true - (Ptt.Aggregate.By_ipaddr.is_empty r) - ; Alcotest.(check unresolved) - "unresolved gmail.com" - (`Local - [ - Local.(v [w "romain"; w "calascibetta"]) - ; Local.(v [w "gemma"; w "d"; w "gordon"]) - ]) - (Ptt.Aggregate.By_domain.find gmail u) - ; Alcotest.(check unresolved) - "unresolved recoil.org" - (`Local [Local.(v [w "anil"])]) - (Ptt.Aggregate.By_domain.find recoil u) - ; Alcotest.(check unresolved) - "unresolved gazagnaire.org" - (`Local [Local.(v [w "thomas"])]) - (Ptt.Aggregate.By_domain.find gazagnaire u) - ; Alcotest.(check unresolved) - "unresolved nqsb.io" `All - (Ptt.Aggregate.By_domain.find nqsb u) - ; Lwt.return_unit + (Ptt.Aggregate.By_ipaddr.is_empty r); + Alcotest.(check unresolved) + "unresolved gmail.com" + (`Local + [ + Local.(v [w "romain"; w "calascibetta"]) + ; Local.(v [w "gemma"; w "d"; w "gordon"]) + ]) + (Ptt.Aggregate.By_domain.find gmail u); + Alcotest.(check unresolved) + "unresolved recoil.org" + (`Local [Local.(v [w "anil"])]) + (Ptt.Aggregate.By_domain.find recoil u); + Alcotest.(check unresolved) + "unresolved gazagnaire.org" + (`Local [Local.(v [w "thomas"])]) + (Ptt.Aggregate.By_domain.find gazagnaire u); + Alcotest.(check unresolved) + "unresolved nqsb.io" `All + (Ptt.Aggregate.By_domain.find nqsb u); + Lwt.return_unit module Lwt_io = struct include Lwt @@ -228,8 +225,8 @@ let stream_of_string_list l = match !l with | [] -> Lwt.return None | x :: r -> - l := r - ; Lwt.return (Some x) in + l := r; + Lwt.return (Some x) in stream let stream_is_empty s = @@ -273,11 +270,11 @@ let messaged_test_0 = let rec consume () = v () >>= function | Some (str, off, len) -> - Buffer.add_substring buf str off len - ; consume () + Buffer.add_substring buf str off len; + consume () | None -> - contents := Buffer.contents buf - ; Lwt.return_unit in + contents := Buffer.contents buf; + Lwt.return_unit in consume () | None -> assert false in let domain_from = Mrmime.Mailbox.Domain.(v domain [a "x25519"; a "net"]) in @@ -288,14 +285,13 @@ let messaged_test_0 = let open Lwt.Infix in Lwt.both (do0 ~domain_from ~from hello_world) (do1 ()) >>= fun _ -> - Alcotest.(check string) "(random schedule) payload" !contents "Hello World!" - ; Lwt.both (do1 ()) (do0 ~domain_from ~from hello_buddy) >>= fun _ -> - Alcotest.(check string) - "(consumer & producer) payload" !contents "Hello buddy!" - ; Lwt.both (do0 ~domain_from ~from hello_guy) (do1 ()) >>= fun _ -> - Alcotest.(check string) - "(producer & consumer) payload" !contents "Hello guy!" - ; Lwt.return_unit + Alcotest.(check string) "(random schedule) payload" !contents "Hello World!"; + Lwt.both (do1 ()) (do0 ~domain_from ~from hello_buddy) >>= fun _ -> + Alcotest.(check string) + "(consumer & producer) payload" !contents "Hello buddy!"; + Lwt.both (do0 ~domain_from ~from hello_guy) (do1 ()) >>= fun _ -> + Alcotest.(check string) "(producer & consumer) payload" !contents "Hello guy!"; + Lwt.return_unit let messaged_test_1 = Alcotest_lwt.test_case "messaged 1" `Quick @@ fun _sw () -> @@ -303,27 +299,27 @@ let messaged_test_1 = let last = ref 0 in let do0 ~domain_from ~from v = let open Lwt.Infix in - last := 0 - ; let key = - Ptt.Messaged.v - ~domain_from: - ((Rresult.R.get_ok <.> Colombe_emile.to_domain) domain_from) - ~from:((Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) from, []) - ~recipients:[] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L in - Md.push md key >>= fun producer -> - let rec consume () = - v () >>= function - | Some chunk -> producer (Some chunk) >>= fun () -> consume () - | None -> producer None in - consume () in + last := 0; + let key = + Ptt.Messaged.v + ~domain_from: + ((Rresult.R.get_ok <.> Colombe_emile.to_domain) domain_from) + ~from:((Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) from, []) + ~recipients:[] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L in + Md.push md key >>= fun producer -> + let rec consume () = + v () >>= function + | Some chunk -> producer (Some chunk) >>= fun () -> consume () + | None -> producer None in + consume () in let do1 () = let open Lwt.Infix in - last := 1 - ; Md.await md >>= fun () -> - (* XXX(dinosaure): schedule [do1] __after__ [do0]. *) - Md.pop md >>= function - | Some (_, q, _) -> Md.close q (* XXX(dinosaure): unlock [do0]. *) - | None -> assert false in + last := 1; + Md.await md >>= fun () -> + (* XXX(dinosaure): schedule [do1] __after__ [do0]. *) + Md.pop md >>= function + | Some (_, q, _) -> Md.close q (* XXX(dinosaure): unlock [do0]. *) + | None -> assert false in let domain_from = Mrmime.Mailbox.Domain.(v domain [a "x25519"; a "net"]) in let from = let open Mrmime.Mailbox in @@ -333,22 +329,22 @@ let messaged_test_1 = let stream = hello_world () in Lwt.both (do0 ~domain_from ~from stream) (do1 ()) >>= fun _ -> stream_is_empty stream >>= fun res0 -> - Alcotest.(check bool) "stream consumed" res0 true - ; Alcotest.(check pass) "random schedule" () () - ; let stream = hello_buddy () in - Lwt.both (do1 ()) - (Lwt_unix.sleep 0.5 >>= fun () -> do0 ~domain_from ~from stream) - >>= fun _ -> - stream_is_empty stream >>= fun res1 -> - Alcotest.(check bool) "stream consumed" res1 true - ; Alcotest.(check int) "(consumer & producer)" !last 0 - ; let stream = hello_guy () in - Lwt.both (do0 ~domain_from ~from stream) (Lwt_unix.sleep 0.5 >>= do1) - >>= fun _ -> - stream_is_empty stream >>= fun res2 -> - Alcotest.(check bool) "stream consumed" res2 true - ; Alcotest.(check int) "(producer & consumer)" !last 1 - ; Lwt.return_unit + Alcotest.(check bool) "stream consumed" res0 true; + Alcotest.(check pass) "random schedule" () (); + let stream = hello_buddy () in + Lwt.both (do1 ()) + (Lwt_unix.sleep 0.5 >>= fun () -> do0 ~domain_from ~from stream) + >>= fun _ -> + stream_is_empty stream >>= fun res1 -> + Alcotest.(check bool) "stream consumed" res1 true; + Alcotest.(check int) "(consumer & producer)" !last 0; + let stream = hello_guy () in + Lwt.both (do0 ~domain_from ~from stream) (Lwt_unix.sleep 0.5 >>= do1) + >>= fun _ -> + stream_is_empty stream >>= fun res2 -> + Alcotest.(check bool) "stream consumed" res2 true; + Alcotest.(check int) "(producer & consumer)" !last 1; + Lwt.return_unit let put_crlf x = x ^ "\r\n" @@ -361,10 +357,10 @@ let rdwr_from_flows inputs outputs = | [] -> inj (Lwt.return `End) | x :: r -> let len = min (String.length x) len in - Bytes.blit_string x 0 bytes off len - ; if len = String.length x then inputs := r - else inputs := String.sub x len (String.length x - len) :: r - ; inj (Lwt.return (`Len len)) in + Bytes.blit_string x 0 bytes off len; + if len = String.length x then inputs := r + else inputs := String.sub x len (String.length x - len) :: r; + inj (Lwt.return (`Len len)) in let rec wr () bytes off len = match !outputs with | [] -> Fmt.failwith "Unexpected output: %S" (String.sub bytes off len) @@ -373,11 +369,11 @@ let rdwr_from_flows inputs outputs = let len = min (String.length x) len in if String.sub x 0 len <> String.sub bytes off len then Fmt.failwith "Expected %S, have %S" (String.sub x 0 len) - (String.sub bytes off len) - ; if String.length x = len then outputs := r - else outputs := String.sub x len (String.length x - len) :: r - ; if len < max then wr () bytes (off + len) (max - len) - else inj (Lwt.return ()) in + (String.sub bytes off len); + if String.length x = len then outputs := r + else outputs := String.sub x len (String.length x - len) :: r; + if len < max then wr () bytes (off + len) (max - len) + else inj (Lwt.return ()) in ( {Colombe.Sigs.rd; Colombe.Sigs.wr} , fun () -> match !inputs, !outputs with @@ -419,9 +415,9 @@ let smtp_test_0 = run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function | Ok _ -> Alcotest.fail "Unexpected good result" | Error (`Error (`Protocol `End_of_input)) -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "connection close" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "connection close" () (); + Lwt.return_unit | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err @@ -445,9 +441,9 @@ let smtp_test_1 = let open Lwt.Infix in run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function | Ok `Quit -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "quit" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "quit" () (); + Lwt.return_unit | Ok (`Submission _) -> Alcotest.fail "Unexpected submission" | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err @@ -475,9 +471,9 @@ let smtp_test_2 = let open Lwt.Infix in run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function | Ok `Quit -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "quit" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "quit" () (); + Lwt.return_unit | Ok (`Submission _) -> Alcotest.fail "Unexpected submission" | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err @@ -516,9 +512,9 @@ let smtp_test_3 = run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function | Ok (`Quit | `Submission _) -> Alcotest.fail "Unexpected quit or submission" | Error (`Error `Too_many_bad_commands) -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "too many bad commands" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "too many bad commands" () (); + Lwt.return_unit | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err | Error `Connection_close -> Alcotest.fail "Unexpected connection close" @@ -546,9 +542,9 @@ let smtp_test_4 = run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function | Ok _ -> Alcotest.fail "Unexpected quit or submission" | Error (`Error `No_recipients) -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "no recipients" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "no recipients" () (); + Lwt.return_unit | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err | Error `Connection_close -> Alcotest.fail "Unexpected connection close" @@ -600,16 +596,16 @@ let smtp_test_5 = Domain.(v domain [a "gmail"; a "com"]) in Alcotest.(check reverse_path) "from" (fst from) - ((Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) romain_calascibetta) - ; Alcotest.(check (list forward_path)) - "recipients" (List.map fst recipients) - [(Rresult.R.get_ok <.> Colombe_emile.to_forward_path) anil] - ; Alcotest.(check domain) - "domain" domain_from - ((Rresult.R.get_ok <.> Colombe_emile.to_domain) gmail) - ; Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "submission" () () - ; Lwt.return_unit + ((Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) romain_calascibetta); + Alcotest.(check (list forward_path)) + "recipients" (List.map fst recipients) + [(Rresult.R.get_ok <.> Colombe_emile.to_forward_path) anil]; + Alcotest.(check domain) + "domain" domain_from + ((Rresult.R.get_ok <.> Colombe_emile.to_domain) gmail); + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "submission" () (); + Lwt.return_unit | Ok `Quit -> Alcotest.fail "Unexpected quit" | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err @@ -638,9 +634,9 @@ let smtp_test_6 = run_state (Ptt.SSMTP.m_submission_init ctx info [Ptt.Mechanism.PLAIN]) rdwr >>= function | Ok `Quit -> - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check pass) "quit" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check pass) "quit" () (); + Lwt.return_unit | Ok (`Authentication _ | `Authentication_with_payload _) -> Alcotest.failf "Unexpected authentication" | Ok (`Submission _) -> Alcotest.failf "Unexpected submission" @@ -673,13 +669,13 @@ let smtp_test_7 = let gmail = let open Mrmime.Mailbox in Domain.(v domain [a "gmail"; a "com"]) in - Alcotest.(check unit) "empty stream" (check ()) () - ; Alcotest.(check mechanism) "mechanism" m Ptt.Mechanism.PLAIN - ; Alcotest.(check domain) - "domain" v - ((Rresult.R.get_ok <.> Colombe_emile.to_domain) gmail) - ; Alcotest.(check pass) "authentication" () () - ; Lwt.return_unit + Alcotest.(check unit) "empty stream" (check ()) (); + Alcotest.(check mechanism) "mechanism" m Ptt.Mechanism.PLAIN; + Alcotest.(check domain) + "domain" v + ((Rresult.R.get_ok <.> Colombe_emile.to_domain) gmail); + Alcotest.(check pass) "authentication" () (); + Lwt.return_unit | Ok `Quit | Ok (`Submission _) -> Alcotest.failf "Unexpected quit or submission" | Error (`Error err) -> @@ -748,8 +744,8 @@ module Flow = struct (fun () -> Lwt_unix.read socket buf off len) (fun exn -> Logs.err (fun m -> - m "[recv] Got an exception: %S." (Printexc.to_string exn)) - ; Lwt.fail exn) + m "[recv] Got an exception: %S." (Printexc.to_string exn)); + Lwt.fail exn) let send socket buf off len = let open Lwt.Infix in @@ -761,8 +757,8 @@ module Flow = struct go socket buf (off + res) (len - res)) (fun exn -> Logs.err (fun m -> - m "[send] Got an exception: %S." (Printexc.to_string exn)) - ; Lwt.fail exn) + m "[send] Got an exception: %S." (Printexc.to_string exn)); + Lwt.fail exn) else Lwt.return_unit in go socket (Bytes.unsafe_of_string buf) off len end @@ -773,24 +769,22 @@ let serve_when_ready ?stop ~handler socket = (let switched_off = let t, u = Lwt.wait () in Lwt_switch.add_hook stop (fun () -> - Lwt.wakeup_later u `Stopped - ; Lwt.return_unit) - ; t in + Lwt.wakeup_later u `Stopped; + Lwt.return_unit); + t in let rec loop () = Lwt_unix.accept socket >>= fun (flow, _) -> let[@warning "-8"] (Unix.ADDR_INET (inet_addr, _)) = Lwt_unix.getpeername flow in - Lwt.async (fun () -> handler (Ipaddr_unix.of_inet_addr inet_addr) flow) - ; Lwt.pause () >>= loop in + Lwt.async (fun () -> handler (Ipaddr_unix.of_inet_addr inet_addr) flow); + Lwt.pause () >>= loop in let stop = Lwt.pick [switched_off; loop ()] >>= fun `Stopped -> Lwt_unix.close socket in stop) let make_relay_smtp_server ?stop ~port info = - let module SMTP = - Ptt.Relay.Make (Scheduler) (Lwt_io) (Flow) (Resolver) (Random) - in + let module SMTP = Ptt.Relay.Make (Scheduler) (Lwt_io) (Flow) (Resolver) in let conf_server = SMTP.create ~info in let messaged = SMTP.messaged conf_server in let smtp_relay_server conf_server = @@ -799,32 +793,31 @@ let make_relay_smtp_server ?stop ~port info = let sockaddr = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr info.SMTP.ipaddr, port) in Lwt_unix.bind socket sockaddr >|= fun () -> - Lwt_unix.listen socket 40 - - ; let handler ipaddr flow = - let open Lwt.Infix in - Logs.debug (fun m -> m "Got a new connection. Start to process it!") - ; SMTP.accept ~ipaddr flow () conf_server >>= fun res -> - Lwt_unix.close flow >>= fun () -> - match res with Ok _ -> Lwt.return () | Error _err -> Lwt.return () - in - serve_when_ready ?stop ~handler socket in + Lwt_unix.listen socket 40; + + let handler ipaddr flow = + let open Lwt.Infix in + Logs.debug (fun m -> m "Got a new connection. Start to process it!"); + SMTP.accept ~ipaddr flow () conf_server >>= fun res -> + Lwt_unix.close flow >>= fun () -> + match res with Ok _ -> Lwt.return () | Error _err -> Lwt.return () in + serve_when_ready ?stop ~handler socket in let smtp_logic messaged ms = let open Lwt.Infix in Lwt.return (`Queue (let th, u = Lwt.wait () in Lwt_switch.add_hook stop (fun () -> - Lwt.wakeup_later u `Stopped - ; Lwt.return_unit) - ; let rec loop () = - SMTP.Md.await messaged >>= fun () -> - SMTP.Md.pop messaged >>= function - | Some (key, queue, _) -> - SMTP.Md.close queue >>= fun () -> Queue.push key ms ; loop () - | None -> loop () in - Lwt.pick [th; loop ()] >|= fun `Stopped -> - Queue.fold (rev List.cons) [] ms)) in + Lwt.wakeup_later u `Stopped; + Lwt.return_unit); + let rec loop () = + SMTP.Md.await messaged >>= fun () -> + SMTP.Md.pop messaged >>= function + | Some (key, queue, _) -> + SMTP.Md.close queue >>= fun () -> Queue.push key ms; loop () + | None -> loop () in + Lwt.pick [th; loop ()] >|= fun `Stopped -> + Queue.fold (rev List.cons) [] ms)) in Lwt.both (smtp_relay_server conf_server) (smtp_logic messaged (Queue.create ())) @@ -914,8 +907,8 @@ let full_test_0 = Ptt.Messaged.v ~domain_from:recoil ~from:(anil, []) ~recipients:[romain_calascibetta, []] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L - ] - ; Lwt.return_unit + ]; + Lwt.return_unit let full_test_1 = Alcotest_lwt.test_case "Receive emails from Anil and Thomas" `Quick @@ -977,8 +970,8 @@ let full_test_1 = ; Ptt.Messaged.v ~domain_from:recoil ~from:(anil, []) ~recipients:[romain_calascibetta, []] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L - ] - ; Lwt.return_unit + ]; + Lwt.return_unit let fiber = Alcotest_lwt.run "ptt" 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 *) } diff --git a/unikernel/signer/config.ml b/unikernel/signer/config.ml index be4a414..f822406 100644 --- a/unikernel/signer/config.ml +++ b/unikernel/signer/config.ml @@ -1,61 +1,71 @@ open Mirage -let fields = - let doc = Key.Arg.info ~doc:"List of fields to sign (separated by a colon)." [ "fields" ] in - Key.(create "fields" Arg.(opt (some string) None doc)) - -let dns_server = - let doc = Key.Arg.info ~doc:"DNS server IP." [ "dns-server" ] in - Key.(create "dns-server" Arg.(required ip_address doc)) - -let dns_port = - let doc = Key.Arg.info ~doc:"DNS server port." [ "dns-port" ] in - Key.(create "dns-port" Arg.(opt int 53 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 selector = - let doc = Key.Arg.info ~doc:"DKIM selector." [ "selector" ] in - Key.(create "selector" Arg.(required string doc)) - -let domain = - let doc = Key.Arg.info ~doc:"DKIM 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 timestamp = - let doc = Key.Arg.info ~doc:"The epoch time that the private key was created." [ "timestamp" ] in - Key.(create "timestamp" Arg.(opt (some int) None doc)) - -let expiration = - let doc = Key.Arg.info ~doc:"The signature expiration (epoch time)." [ "expiration" ] in - Key.(create "expiration" Arg.(opt (some int) None doc)) - -let private_key = - let doc = Key.Arg.info ~doc:"The seed (in base64) of the private RSA key." [ "private-key" ] in - Key.(create "private-key" Arg.(required string 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 fields - ; v dns_server - ; v dns_port - ; v dns_key - ; v selector - ; v domain - ; v destination - ; v timestamp - ; v expiration - ; v private_key - ; v postmaster ] +(* 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 open Functoria.DSL in + let pp_label name ppf = function + | None -> () + | Some key -> Fmt.pf ppf "@ ~%s:%s" name key in + let pp_opt name ppf = function + | None -> () + | Some key -> Fmt.pf ppf "@ ?%s:%s" name key in + let pop ~err x rest = + match (rest, x) with + | h :: t, Some _ -> (Some h, t) + | _, 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 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 connect _info modname = function + | _random + :: _time + :: _mclock + :: _pclock + :: stackv4v6 + :: happy_eyeballs + :: rest -> + let[@warning "-8"] Some dns_server, rest = pop ~err (Some dns_server) rest in + let[@warning "-8"] Some dns_port, rest = pop ~err (Some dns_port) rest in + let timeout, rest = pop ~err timeout rest in + let () = match rest with [] -> () | _ -> err () in + code ~pos:__POS__ {ocaml|%s.connect @[%a%a@ (%s, %s)@]|ocaml} modname + pp_nameserver (dns_server, dns_port) (pp_opt "timeout") timeout stackv4v6 + happy_eyeballs + | _ -> err () + in + impl ~runtime_args ~packages ~connect "Dns_client_mirage.Make" + (random + @-> time + @-> mclock + @-> pclock + @-> stackv4v6 + @-> happy_eyeballs + @-> dns_client) + +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 + $ 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 = [ package "randomconv" @@ -68,16 +78,20 @@ let packages = ; package "dns-mirage" ; package "ca-certs-nss" ] +let runtime_args = [ setup ] + let signer = - foreign ~keys ~packages "Unikernel.Make" @@ - random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> job + main ~runtime_args ~packages "Unikernel.Make" @@ + random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> dns_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 he = generic_happy_eyeballs stack +let dns = generic_dns_client ~dns_server ~dns_port stack he let () = register "signer" - [ signer $ random $ time $ mclock $ pclock $ stack ] + [ signer $ random $ time $ mclock $ pclock $ stack $ dns ] diff --git a/unikernel/signer/unikernel.ml b/unikernel/signer/unikernel.ml index 8e65f12..5df0eba 100644 --- a/unikernel/signer/unikernel.ml +++ b/unikernel/signer/unikernel.ml @@ -5,12 +5,96 @@ exception Invalid_certificate let ( >>? ) = Lwt_result.bind +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 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 dns_port = + 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 + 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 + let field = Arg.conv Mrmime.Field_name.(of_string, pp) in + Arg.(value & opt (some (list ~sep:',' field)) None doc) + + let selector = + let doc = Arg.info [ "selector" ] ~doc:"The DKIM selector." in + let part = Arg.conv Domain_name.(of_string, pp) in + Arg.(required & opt (some part) None doc) + + let timestamp = + let doc = Arg.info [ "timestamp" ] ~doc:"The epoch time that the private key was created." in + Arg.(value & opt (some int64) None doc) + + let expiration = + let doc = Arg.info [ "expiration" ] ~doc:"The signature expiration (epoch time)." in + Arg.(value & opt (some int64) None doc) + + let seed = + let doc = Arg.info [ "seed" ] ~doc:"The seed (in base64) of the private RSA key." in + let parser str = Base64.decode str in + let pp ppf str = Fmt.string ppf (Base64.encode_exn str) in + let b64 = Arg.conv (parser, pp) in + Arg.(required & opt (some b64) None 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 + ; dns_port : int + ; fields : Mrmime.Field_name.t list option + ; selector : [ `raw ] Domain_name.t + ; timestamp : int64 option + ; 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 setup = + Term.(const v $ domain $ postmaster $ destination + $ dns_key $ dns_server $ dns_port + $ fields $ selector $ timestamp $ expiration $ seed) +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) = struct (* XXX(dinosaure): this is a fake resolver which enforce the [signer] to * transmit **any** emails to only one and unique SMTP server. *) @@ -24,46 +108,43 @@ module Make let extension ipaddr _ldh _value = Lwt.return_ok ipaddr end - module Nec = Nec.Make (Random) (Time) (Mclock) (Pclock) (Resolver) (Stack) - module DKIM = Dkim_mirage.Make (Random) (Time) (Mclock) (Pclock) (Stack) - module DNS = Dns_mirage.Make (Stack) + module Nec = Nec.Make (Time) (Mclock) (Pclock) (Resolver) (Stack) + module DKIM = Dkim_mirage.Make (Pclock) (DNS) module Nss = Ca_certs_nss.Make (Pclock) let private_rsa_key_from_seed seed = - let g = - let seed = Cstruct.of_string seed in - Mirage_crypto_rng.(create ~seed (module Fortuna)) in + let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in Mirage_crypto_pk.Rsa.generate ~g ~bits:2048 () - let ns_check dkim server stack = - DKIM.server ~nameservers:(`Tcp, [ `Plaintext (Key_gen.dns_server (), Key_gen.dns_port ()) ]) - stack dkim >>= function - | Ok server' -> + let ns_check dkim value dns = + DKIM.server dns dkim >>= function + | Ok value'-> Logs.info (fun m -> m "The DNS server already has a DKIM public key: %a (expected: %a)." - Dkim.pp_server server' Dkim.pp_server server) ; - if Dkim.equal_server server server' + Dkim.pp_server value' Dkim.pp_server value) ; + if Dkim.equal_server value value' then Lwt.return `Already_registered else Lwt.return `Must_be_updated | Error _ -> Logs.info (fun m -> m "The DNS server does not have the DKIM public key.") ; Lwt.return `Not_found - let ns_update dkim server stack = - ns_check dkim server stack >>= function + module DNS = Dns_mirage.Make (Stack) + + let ns_update (key_name, dns_key) dkim value stack dns { K.dns_server; dns_port; _ } = + ns_check dkim value dns >>= function | `Already_registered -> Lwt.return_ok () | `Must_be_updated | `Not_found -> let dkim_domain = R.failwith_error_msg (Dkim.domain_name dkim) in let key_name, key_zone, dns_key = - let key_name, dns_key = R.failwith_error_msg (Dns.Dnskey.name_key_of_string (Key_gen.dns_key ())) in match Domain_name.find_label key_name (function "_update" -> true | _ -> false) with | None -> Fmt.failwith "The given DNS key is not an update key" | Some idx -> let amount = succ idx in let zone = Domain_name.(host_exn (drop_label_exn ~amount key_name)) in key_name, zone, dns_key in - Stack.TCP.create_connection (Stack.tcp stack) (Key_gen.dns_server (), Key_gen.dns_port ()) + Stack.TCP.create_connection (Stack.tcp stack) (dns_server, dns_port) >|= R.reword_error (R.msgf "%a" Stack.TCP.pp_error) >>? fun flow -> let v = Dns.Packet.Update.Add - Dns.Rr_map.(B (Txt, (3600l, Txt_set.singleton (Dkim.server_to_string server)))) in + Dns.Rr_map.(B (Txt, (3600l, Txt_set.singleton (Dkim.server_to_string value)))) in let packet = let header = (Randomconv.int16 Random.generate, Dns.Packet.Flags.empty) in let zone = Dns.Packet.Question.create key_zone Dns.Rr_map.Soa in @@ -72,13 +153,12 @@ module Make begin Dns_tsig.encode_and_sign ~proto:`Tcp packet (Ptime.v (Pclock.now_d_ps ())) dns_key key_name |> R.reword_error (R.msgf "%a" Dns_tsig.pp_s) |> Lwt.return >>? fun (data, mac) -> - DNS.send_tcp flow data + DNS.send_tcp flow (Cstruct.of_string data) >|= R.reword_error (fun _ -> R.msgf "Impossible to send a DNS packet to %a:%d" - Ipaddr.pp (Key_gen.dns_server ()) - (Key_gen.dns_port ())) >>? fun () -> DNS.read_tcp (DNS.of_flow flow) + Ipaddr.pp dns_server dns_port) >>? fun () -> DNS.read_tcp (DNS.of_flow flow) >|= R.reword_error (fun _ -> R.msgf "Impossible to read a DNS packet from %a:%d" - Ipaddr.pp (Key_gen.dns_server ()) - (Key_gen.dns_port ())) >>? fun data -> + Ipaddr.pp dns_server dns_port) >>? fun data -> + let data = Cstruct.to_string data in Dns_tsig.decode_and_verify (Ptime.v (Pclock.now_d_ps ())) dns_key key_name ~mac data |> R.reword_error (R.msgf "%a" Dns_tsig.pp_e) |> Lwt.return >>? fun (packet', _tsig, _mac) -> @@ -87,39 +167,26 @@ module Make | Error _ -> assert false end @@ fun res -> Stack.TCP.close flow >>= fun () -> Lwt.return res - let start _random _time _mclock _pclock stack = - let fields = match Key_gen.fields () with - | None -> None - | Some fields -> - let fields = String.split_on_char ':' fields in - let f acc x = match acc with Error _ as err -> err | Ok acc -> - match Mrmime.Field_name.of_string x with - | Ok x -> Ok (x :: acc) - | Error _ -> R.error_msgf "Invalid field-name: %S" x in - let fields = R.failwith_error_msg (List.fold_left f (Ok []) fields) in - Some fields 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 selector = R.failwith_error_msg (Domain_name.of_string (Key_gen.selector ())) in - let domain = R.failwith_error_msg (Domain_name.of_string (Key_gen.domain ())) in + let start _random _time _mclock _pclock stack dns + ({ K.domain; postmaster; destination; dns_key; fields; selector; seed; timestamp; expiration; _ } as cfg) = let dkim = Dkim.v ~version:1 ?fields ~selector ~algorithm:`RSA ~query:(`DNS (`TXT)) - ?timestamp:(Option.map Int64.of_int (Key_gen.timestamp ())) - ?expiration:(Option.map Int64.of_int (Key_gen.expiration ())) - domain in - let private_key = private_rsa_key_from_seed (Base64.decode_exn (Key_gen.private_key ())) in - let server = Dkim.server_of_dkim ~key:private_key dkim in + ?timestamp + ?expiration + (Domain_name.raw domain) in + let private_key = private_rsa_key_from_seed seed in + let value = Dkim.server_of_dkim ~key:private_key dkim in let authenticator = R.failwith_error_msg (Nss.authenticator ()) in - let tls = Tls.Config.client ~authenticator () in - ns_update dkim server stack >|= R.failwith_error_msg >>= fun () -> - let domain = Domain_name.host_exn domain in - Nec.fiber ~port:25 ~tls (Stack.tcp stack) (Key_gen.destination ()) (private_key, dkim) + let tls = R.failwith_error_msg (Tls.Config.client ~authenticator ()) in + ns_update dns_key dkim value stack dns cfg >|= R.failwith_error_msg >>= fun () -> + let ip = Stack.ip stack in + let ipaddr = List.hd (Stack.IP.configured_ips ip) in + let ipaddr = Ipaddr.Prefix.address ipaddr in + Nec.fiber ~port:25 ~tls (Stack.tcp stack) destination (private_key, dkim) { Ptt.Logic.domain - ; ipaddr= Ipaddr.(V4 (V4.Prefix.address (Key_gen.ipv4 ()))) + ; ipaddr ; tls= None ; zone= Mrmime.Date.Zone.GMT ; size= 10_000_000L } 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 *) } diff --git a/unikernel/submission/config.ml b/unikernel/submission/config.ml index 5937258..f823f88 100644 --- a/unikernel/submission/config.ml +++ b/unikernel/submission/config.ml @@ -1,63 +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 destination = - let doc = Key.Arg.info ~doc:"SMTP server destination." [ "destination" ] in - Key.(create "destination" Arg.(required ip_address doc)) - -let domain = - let doc = Key.Arg.info ~doc:"SMTP domain-name." [ "domain" ] in - Key.(create "domain" Arg.(required string doc)) - -let postmaster = - let doc = Key.Arg.info ~doc:"The postmaster of the SMTP service." [ "postmaster" ] in - Key.(create "postmaster" 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 submission_domain = - let doc = Key.Arg.info ~doc:"domain-name of the submission SMTP service." [ "submission-domain" ] in - Key.(create "submission-domain" 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 key_seed = - let doc = Key.Arg.info ~doc:"Key seed used to generate TLS certificate." ["key-seed"] in - Key.(create "key-seed" Arg.(required 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 - ; v destination - ; v submission_domain - ; v dns_server - ; v dns_port - ; v dns_key - ; v key_seed ] +let nameservers = Runtime_arg.create ~pos:__POS__ "Unikernel.K.nameservers" +let setup = runtime_arg ~pos:__POS__ "Unikernel.K.setup" let packages = [ package "randomconv" @@ -69,8 +31,10 @@ let packages = ; package "ca-certs-nss" ; package "emile" ] +let runtime_args = [ setup ] + let submission = - foreign ~keys ~packages "Unikernel.Make" @@ + main ~runtime_args ~packages "Unikernel.Make" @@ random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> git_client @-> job let random = default_random @@ -78,11 +42,12 @@ 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 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 "submission" diff --git a/unikernel/submission/unikernel.ml b/unikernel/submission/unikernel.ml index d38fc7b..3957837 100644 --- a/unikernel/submission/unikernel.ml +++ b/unikernel/submission/unikernel.ml @@ -1,12 +1,75 @@ 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 + 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) +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 hostname = + let doc = Arg.info ~doc:"Hostname of the SMTP submission server." [ "hostname" ] 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 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 = + { remote : string + ; domain : [ `host ] Domain_name.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 setup = Term.(const v $ remote $ domain $ hostname $ 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) @@ -29,7 +92,7 @@ module Make let extension ipaddr _ldh _value = Lwt.return_ok ipaddr end - module Lipap = Lipap.Make (Random) (Time) (Mclock) (Pclock) (Resolver) (Stack) + module Lipap = Lipap.Make (Time) (Mclock) (Pclock) (Resolver) (Stack) let authentication ctx remote = Git_kv.connect ctx remote >>= fun t -> @@ -76,11 +139,9 @@ module Make (fun local v -> inj (authentication local v)) in Lwt.return authentication - let retrieve_certs stack = - let domain = Key_gen.submission_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.hostname; 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 dns_server 53 >>= function | Error (`Msg err) -> failwith err | Ok certificates -> let now = Ptime.v (Pclock.now_d_ps ()) in @@ -95,32 +156,29 @@ 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 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 _random _time _mclock _pclock stack ctx ({ K.remote; domain; postmaster; destination; _ } as cfg) = let authenticator = R.failwith_error_msg (Nss.authenticator ()) in - let tls = Tls.Config.client ~authenticator () in - authentication ctx (Key_gen.remote ()) >>= fun authentication -> + 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 + authentication ctx remote >>= fun authentication -> 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 () = - Lipap.fiber ~port:465 ~tls (Stack.tcp stack) (Key_gen.destination ()) None Digestif.BLAKE2B + Lipap.fiber ~port:465 ~tls (Stack.tcp stack) destination None Digestif.BLAKE2B { Ptt.Logic.domain - ; ipaddr= Ipaddr.(V4 (V4.Prefix.address (Key_gen.ipv4 ()))) (* XXX(dinosaure): or public IP address? *) - ; 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 *) } authentication [ Ptt.Mechanism.PLAIN ] in Lwt.both (server ()) (wait_and_stop ()) >>= fun ((), result) -> loop result in - retrieve_certs stack >>= loop + retrieve_certs stack cfg >>= loop end 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