From 9b783fac7077e909a422db48ec5f295de8a4ac16 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 16 Sep 2024 16:13:11 +0200 Subject: [PATCH] . --- .ocamlformat | 3 +- bin/adduser.ml | 10 ++-- bin/lipap.ml | 24 +++------ bin/mti_gf.ml | 22 ++------ bin/sSH.ml | 4 +- bin/spf.ml | 3 +- lib/authentication.ml | 4 +- lib/common.ml | 73 ++++++++++++-------------- lib/common.mli | 7 ++- lib/hm.ml | 100 +++++++++++++++-------------------- lib/hm.mli | 1 - 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 +- 33 files changed, 405 insertions(+), 556 deletions(-) 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/bin/adduser.ml b/bin/adduser.ml index 3abd81a..289b84c 100644 --- a/bin/adduser.ml +++ b/bin/adduser.ml @@ -121,7 +121,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 +132,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/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..cbc5dfa 100644 --- a/bin/sSH.ml +++ b/bin/sSH.ml @@ -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,4 @@ 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 diff --git a/bin/spf.ml b/bin/spf.ml index dfe9e32..dbf7dc4 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 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..e232ab5 100644 --- a/lib/hm.ml +++ b/lib/hm.ml @@ -7,7 +7,6 @@ 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) @@ -18,23 +17,8 @@ module Make and 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 +55,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 +83,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 +101,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 +111,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..546cb74 100644 --- a/lib/hm.mli +++ b/lib/hm.mli @@ -6,7 +6,6 @@ sender allows this IP address. *) module Make - (Random : Mirage_random.S) (Time : Mirage_time.S) (Mclock : Mirage_clock.MCLOCK) (Pclock : Mirage_clock.PCLOCK) 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