diff --git a/bin/lipap.ml b/bin/lipap.ml index 39efa5d..c0c2c0b 100644 --- a/bin/lipap.ml +++ b/bin/lipap.ml @@ -11,26 +11,16 @@ let ( <.> ) f g x = f (g x) open Rresult -module Resolver = struct - type +'a io = 'a Lwt.t - type t = Dns_client_lwt.t +module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make + (Time) (Mclock) (Tcpip_stack_socket.V4V6) - let gethostbyname t v = - let open Lwt.Infix in - Dns_client_lwt.gethostbyname t v >|= function - | Ok v -> Ok (Ipaddr.V4 v) - | Error _ as err -> err - - let getmxbyname t v = - let open Lwt_result in - Dns_client_lwt.getaddrinfo t Dns.Rr_map.Mx v >|= fun (_, mxs) -> mxs - - let extension _t _ldh _v = - Lwt.return (R.error_msgf "Impossible to resolve [%s:%s]" _ldh _v) -end +module Dns_client = Dns_client_mirage.Make + (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) + (Happy_eyeballs_daemon) module Server = - Lipap.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6) + Lipap.Make (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) + (Dns_client) (Happy_eyeballs_daemon) let load_file filename = Bos.OS.File.read filename @@ -48,12 +38,11 @@ let private_key = let private_key = Rresult.R.get_ok private_key -let authenticator _username _password = - Ptt_tuyau.Lwt_backend.Lwt_scheduler.inj (Lwt.return true) +let authenticator _username _password = Lwt.return true let authenticator = Ptt.Authentication.v authenticator -let fiber ~domain locals = +let job ~domain locals = let open Lwt.Infix in let open Tcpip_stack_socket.V4V6 in let ipv4_only = false and ipv6_only = false in @@ -63,8 +52,9 @@ let fiber ~domain locals = ~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 -> + TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 -> + UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + connect udpv4v6 tcpv4v6 >>= fun stack -> let info = { Ptt.SMTP.domain @@ -73,25 +63,23 @@ let fiber ~domain locals = ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT ; Ptt.SMTP.size= 0x1000000L } in - let he = Happy_eyeballs_lwt.create () in - let resolver = Dns_client_lwt.create he in + Happy_eyeballs_daemon.connect_device stack >>= fun he -> + let dns = Dns_client.create (stack, 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] + Server.job ~port:4242 ~locals ~tls ~info None Digestif.BLAKE2B tcpv4v6 dns he + authenticator [Ptt.Mechanism.PLAIN] let romain_calascibetta = let open Mrmime.Mailbox in Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"]) let () = - let domain = Domain_name.(host_exn <.> of_string_exn) "x25519.net" in - let locals = Ptt.Relay_map.empty ~postmaster:romain_calascibetta ~domain in - let locals = - let open Mrmime.Mailbox in - Ptt.Relay_map.add - ~local:Local.(v [w "romain"; w "calascibetta"]) - romain_calascibetta locals in - Lwt_main.run (fiber ~domain locals) + let locals = Ptt_map.empty ~postmaster:romain_calascibetta in + let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in + Ptt_map.add + ~local:(`Dot_string [ "romain"; "calascibetta" ]) + romain_calascibetta locals; + Lwt_main.run (job ~domain locals) diff --git a/bin/mti_gf.ml b/bin/mti_gf.ml index 4a44ab6..b1c325b 100644 --- a/bin/mti_gf.ml +++ b/bin/mti_gf.ml @@ -11,26 +11,16 @@ let ( <.> ) f g x = f (g x) open Rresult -module Resolver = struct - type +'a io = 'a Lwt.t - type t = Dns_client_lwt.t +module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make + (Time) (Mclock) (Tcpip_stack_socket.V4V6) - let gethostbyname t v = - let open Lwt.Infix in - Dns_client_lwt.gethostbyname t v >|= function - | Ok v -> Ok (Ipaddr.V4 v) - | Error _ as err -> err +module Dns_client = Dns_client_mirage.Make + (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) + (Happy_eyeballs_daemon) - let getmxbyname t v = - let open Lwt_result in - Dns_client_lwt.getaddrinfo t Dns.Rr_map.Mx v >|= fun (_, mxs) -> mxs - - let extension _t _ldh _v = - Lwt.return (R.error_msgf "Impossible to resolve [%s:%s]" _ldh _v) -end - -module Server = - Mti_gf.Make (Time) (Mclock) (Pclock) (Resolver) (Tcpip_stack_socket.V4V6) +module Server = Mti_gf.Make + (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) + (Dns_client) (Happy_eyeballs_daemon) let load_file filename = Bos.OS.File.read filename @@ -50,12 +40,13 @@ let tls = let authenticator = R.failwith_error_msg (Ca_certs.authenticator ()) in R.failwith_error_msg (Tls.Config.client ~authenticator ()) -let fiber ~domain locals = +let job ~domain locals = let open Lwt.Infix in let open Tcpip_stack_socket.V4V6 in let ipv4_only = false and ipv6_only = false in - TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None - >>= fun tcpv4v6 -> + TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 -> + UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + connect udpv4v6 tcpv4v6 >>= fun stack -> let info = { Ptt.SMTP.domain @@ -64,20 +55,18 @@ let fiber ~domain locals = ; Ptt.SMTP.zone= Mrmime.Date.Zone.GMT ; Ptt.SMTP.size= 0x1000000L } 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 + Happy_eyeballs_daemon.connect_device stack >>= fun he -> + let dns = Dns_client.create (stack, he) in + Server.job ~port:4242 ~locals ~tls ~info tcpv4v6 dns he let romain_calascibetta = let open Mrmime.Mailbox in Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"]) let () = - let domain = Domain_name.(host_exn <.> of_string_exn) "x25519.net" in - let locals = Ptt.Relay_map.empty ~postmaster:romain_calascibetta ~domain in - let locals = - let open Mrmime.Mailbox in - Ptt.Relay_map.add - ~local:Local.(v [w "romain"; w "calascibetta"]) - romain_calascibetta locals in - Lwt_main.run (fiber ~domain locals) + let locals = Ptt_map.empty ~postmaster:romain_calascibetta in + let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in + Ptt_map.add + ~local:(`Dot_string [ "romain"; "calascibetta" ]) + romain_calascibetta locals; + Lwt_main.run (job ~domain locals) diff --git a/lib/aggregate.ml b/lib/aggregate.ml deleted file mode 100644 index f0822a2..0000000 --- a/lib/aggregate.ml +++ /dev/null @@ -1,67 +0,0 @@ -let ( <.> ) f g x = f (g x) - -module By_domain = Map.Make (struct - type t = [ `host ] Domain_name.t - - let compare = Domain_name.compare -end) - -module By_ipaddr = Map.Make (Ipaddr) - -type unresolved_elt = [ `All | `Postmaster | `Local of Emile.local list ] -type resolved_elt = [ `All | `Local of Emile.local list ] - -let postmaster = [`Atom "Postmaster"] -let equal_local = Emile.equal_local ~case_sensitive:true - -let add_unresolved ~domain elt unresolved = - match elt, By_domain.find_opt domain unresolved with - | `All, _ -> By_domain.add domain `All unresolved - | _, Some `All | `Postmaster, Some `Postmaster -> unresolved - | `Postmaster, Some (`Local vs) -> - if List.exists (equal_local postmaster) vs then unresolved - else By_domain.add domain (`Local (postmaster :: vs)) unresolved - | `Local v, Some (`Local vs) -> - if List.exists (equal_local v) vs then unresolved - else By_domain.add domain (`Local (v :: vs)) unresolved - | `Local v, Some `Postmaster -> - By_domain.add domain (`Local [v; postmaster]) unresolved - | `Postmaster, None -> By_domain.add domain `Postmaster unresolved - | `Local v, None -> By_domain.add domain (`Local [v]) unresolved - -let add_resolved ipaddr elt resolved = - match elt, By_ipaddr.find_opt ipaddr resolved with - | `All, _ -> By_ipaddr.add ipaddr `All resolved - | _, Some `All -> resolved - | `Local v, Some (`Local vs) -> - if List.exists (equal_local v) vs then resolved - else By_ipaddr.add ipaddr (`Local (v :: vs)) resolved - | `Local v, None -> By_ipaddr.add ipaddr (`Local [v]) resolved - -let aggregate_by_domains ~domain = - let open Colombe in - let open Forward_path in - let fold (unresolved, resolved) = function - | Postmaster -> add_unresolved ~domain `Postmaster unresolved, resolved - | Forward_path {Path.domain= Domain.Domain v; Path.local; _} -> - let domain = Domain_name.(host_exn <.> of_strings_exn) v in - let local = Colombe_emile.of_local local in - add_unresolved ~domain (`Local local) unresolved, resolved - | Domain (Domain.Domain v) -> - let domain = Domain_name.(host_exn <.> of_strings_exn) v in - add_unresolved ~domain `All unresolved, resolved - | Domain (Domain.IPv4 v4) -> - unresolved, add_resolved (Ipaddr.V4 v4) `All resolved - | Domain (Domain.IPv6 v6) -> - unresolved, add_resolved (Ipaddr.V6 v6) `All resolved - | Forward_path {Path.domain= Domain.IPv4 v4; Path.local; _} -> - let local = Colombe_emile.of_local local in - unresolved, add_resolved (Ipaddr.V4 v4) (`Local local) resolved - | Forward_path {Path.domain= Domain.IPv6 v6; Path.local; _} -> - let local = Colombe_emile.of_local local in - unresolved, add_resolved (Ipaddr.V6 v6) (`Local local) resolved - | Domain (Domain.Extension _) - | Forward_path {Path.domain= Domain.Extension _; _} -> - unresolved, resolved in - (* TODO *) - List.fold_left fold (By_domain.empty, By_ipaddr.empty) diff --git a/lib/aggregate.mli b/lib/aggregate.mli deleted file mode 100644 index 82ec2c8..0000000 --- a/lib/aggregate.mli +++ /dev/null @@ -1,32 +0,0 @@ -(** Aggregate module. - - The goal of this module is to split recipients into 2 sets: - - - [By_domain] which contains recipients with domains. - - [By_ipaddr] which contains recipients with [Ipaddr.t] as a domain. - - This module is relevant when you look into [Relay_map] which is able to - translate recipients with domains to others recipients. *) - -module By_domain : Map.S with type key = [ `host ] Domain_name.t -module By_ipaddr : Map.S with type key = Ipaddr.t - -type unresolved_elt = [ `All | `Postmaster | `Local of Emile.local list ] -type resolved_elt = [ `All | `Local of Emile.local list ] - -val add_unresolved : - domain:[ `host ] Domain_name.t - -> [ `All | `Postmaster | `Local of Emile.local ] - -> unresolved_elt By_domain.t - -> unresolved_elt By_domain.t - -val add_resolved : - Ipaddr.t - -> [ `All | `Local of Emile.local ] - -> resolved_elt By_ipaddr.t - -> resolved_elt By_ipaddr.t - -val aggregate_by_domains : - domain:[ `host ] Domain_name.t - -> Colombe.Forward_path.t list - -> unresolved_elt By_domain.t * resolved_elt By_ipaddr.t diff --git a/lib/authentication.ml b/lib/authentication.ml index 966d6da..54a8df0 100644 --- a/lib/authentication.ml +++ b/lib/authentication.ml @@ -1,24 +1,24 @@ -open Colombe.Sigs open Rresult +open Lwt.Infix let ( <.> ) f g x = f (g x) -type ('s, 'k) t = username -> 'k password -> (bool, 's) io +type 'k t = username -> 'k password -> bool Lwt.t and username = Emile.local and 'k password = 'k Digestif.t -external v : (username -> 'k password -> (bool, 's) io) -> ('s, 'k) t +external v : (username -> 'k password -> bool Lwt.t) -> 'k t = "%identity" let is_zero = ( = ) '\000' -let authenticate {return; bind} hash username password t = - let ( >>= ) = bind in +let authenticate hash username password t = 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) + t username p >>= fun v -> Lwt.return_ok (username, v) -let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v = +let decode_plain_authentication hash ?stamp t v = + let ( >>= ) = Result.bind in let parser = let open Angstrom in take_till is_zero >>= fun v0 -> @@ -33,18 +33,18 @@ let decode_plain_authentication ({return; _} as scheduler) hash ?stamp t v = | Some stamp, Ok (v0, v1, v2) -> if Eqaf.equal stamp v0 then match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with - | Ok username -> authenticate scheduler hash username v2 t - | Error _ -> return (R.error_msgf "Invalid username: %S" v1) - else return (R.error_msgf "Invalid stamp") + | Ok username -> authenticate hash username v2 t + | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1) + else Lwt.return (R.error_msgf "Invalid stamp") | None, Ok ("", v1, v2) -> ( match Angstrom.parse_string ~consume:All Emile.Parser.local_part v1 with - | Ok username -> authenticate scheduler hash username v2 t - | Error _ -> return (R.error_msgf "Invalid username: %S" v1)) - | None, Ok (_, _, _) -> return (R.error_msgf "Unexpected stamp") - | _, (Error _ as err) -> return err + | Ok username -> authenticate hash username v2 t + | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1)) + | None, Ok (_, _, _) -> Lwt.return (R.error_msgf "Unexpected stamp") + | _, (Error _ as err) -> Lwt.return err type mechanism = PLAIN of string option -let decode_authentication scheduler hash m t v = +let decode_authentication hash m t v = match m with - | PLAIN stamp -> decode_plain_authentication scheduler hash ?stamp t v + | PLAIN stamp -> decode_plain_authentication hash ?stamp t v diff --git a/lib/authentication.mli b/lib/authentication.mli index c81624e..72e39e8 100644 --- a/lib/authentication.mli +++ b/lib/authentication.mli @@ -1,25 +1,23 @@ -open Colombe.Sigs open Rresult -type ('s, 'k) t +type 'k t (** The {i authenticator} type. *) type username = Emile.local type 'k password = 'k Digestif.t -val v : (username -> 'k password -> (bool, 's) io) -> ('s, 'k) t +val v : (username -> 'k password -> bool Lwt.t) -> 'k t (** [v authenticator] makes an {i authenticator}. *) type mechanism = | PLAIN of string option (** Type of mechanism used by the client. *) val decode_authentication : - 's impl - -> 'k Digestif.hash + 'k Digestif.hash -> mechanism - -> ('s, 'k) t + -> 'k t -> string - -> ((bool, [> R.msg ]) result, 's) io + -> (Emile.local * bool, [> R.msg ]) result Lwt.t (** [decode_authentication scheduler hash mechanism t payload] tries to decode [payload] according [mechanism] used. Then, it applies the {i authenticator} [t] with decoded value. [hash] is used as a {i witness} of which hash diff --git a/lib/common.ml b/lib/common.ml deleted file mode 100644 index ff8611c..0000000 --- a/lib/common.ml +++ /dev/null @@ -1,270 +0,0 @@ -open Colombe.Sigs -open Sigs -open Rresult - -let ( <.> ) f g x = f (g x) -let src = Logs.Src.create "ptt.common" - -module Log = (val Logs.src_log src) - -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) = -struct - type 'w resolver = { - gethostbyname: - 'a. - 'w - -> [ `host ] Domain_name.t - -> (Ipaddr.t, ([> R.msg ] as 'a)) result IO.t - ; getmxbyname: - 'a. - 'w - -> [ `host ] Domain_name.t - -> (Dns.Rr_map.Mx_set.t, ([> R.msg ] as 'a)) result IO.t - ; extension: - 'a. 'w -> string -> string -> (Ipaddr.t, ([> R.msg ] as 'a)) result IO.t - } - - type 'g random = ?g:'g -> bytes -> ?off:int -> int -> unit - type 'a consumer = 'a option -> unit IO.t - - let resolver = - let open Resolver in - {gethostbyname; getmxbyname; extension} - - let return = IO.return - let ( >>= ) = IO.bind - let ( >|= ) x f = x >>= fun x -> return (f x) - - let ( >>? ) x f = - x >>= function Ok x -> f x | Error err -> return (Error err) - - 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 - - let scheduler = - let open Scheduler in - { - bind= (fun x f -> inj (prj x >>= fun x -> prj (f x))) - ; return= (fun x -> inj (return x)) - } - - let rdwr = - let open Scheduler in - let rd flow buf off len = - inj - @@ (Flow.recv flow buf off len >>= function - | 0 -> IO.return `End - | len -> IO.return (`Len len)) in - { - Colombe.Sigs.rd - ; Colombe.Sigs.wr= - (fun flow buf off len -> inj (Flow.send flow buf off len)) - } - - let run : - Flow.t - -> ('a, 'err) Colombe.State.t - -> ('a, [> `Error of 'err ]) result IO.t = - fun flow m -> - let rec go = function - | Colombe.State.Read {buffer; off; len; k} -> - rdwr.rd flow buffer off len |> Scheduler.prj >>= fun res -> - (go <.> k) res - | Colombe.State.Write {buffer; off; len; k} -> - rdwr.wr flow buffer off len |> Scheduler.prj >>= fun () -> go (k len) - | Colombe.State.Return v -> IO.return (Ok v) - | Colombe.State.Error err -> IO.return (Error (`Error err)) in - go m - - let list_fold_left_s ~f a l = - let rec go a = function - | [] -> IO.return a - | x :: r -> f a x >>= fun a -> go a r in - go a l - - let recipients_are_reachable ~ipaddr w recipients = - let open Colombe in - 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 - let rec go acc = function - | [] -> IO.return acc - | Forward_path.Postmaster :: r -> - go (Mxs.(singleton (v ~preference:0 ipaddr)) :: acc) r - | Forward_path.Forward_path {Path.domain= Domain.Domain v; _} :: r - | Forward_path.Domain (Domain.Domain v) :: r -> ( - 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 - 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 -> - go (Mxs.(singleton (v ~preference:0 (Ipaddr.V4 mx_ipaddr))) :: acc) r - | Forward_path.Forward_path {Path.domain= Domain.IPv6 _; _} :: r - | Forward_path.Domain (Domain.IPv6 _) :: r -> - go acc r - | Forward_path.Forward_path {Path.domain= Domain.Extension (ldh, v); _} - :: r - | Forward_path.Domain (Domain.Extension (ldh, v)) :: r -> ( - resolver.extension w ldh v >>= function - | Ok mx_ipaddr -> - go (Mxs.(singleton (v ~preference:0 mx_ipaddr)) :: acc) r - | Error (`Msg _err) -> go acc r) in - go [] recipients - >>= (IO.return <.> List.for_all (fun m -> not (Mxs.is_empty m))) - - let dot = Some (".\r\n", 0, 3) - - let receive_mail ?(limit = 0x100000) flow ctx m producer = - let rec go count () = - if count >= limit then return (Error `Too_big_data) - else - run flow (m ctx) >>? function - | ".." -> producer dot >>= go (count + 3) - | "." -> producer None >>= fun () -> return (Ok ()) - | v -> - let len = String.length v in - producer (Some (v ^ "\r\n", 0, len + 2)) >>= go (count + len + 2) - in - go 0 () - - let pp_recipients ~domain ppf = function - | `All -> Fmt.pf ppf "*@%a" Domain_name.pp domain - | `Local vs -> - Fmt.pf ppf "@[%a@]@%a" - Fmt.(Dump.list Emile.pp_local) - vs Domain_name.pp domain - | `Postmaster -> Fmt.pf ppf "Postmaster@%a" Domain_name.pp domain - - let resolve_recipients ~domain w relay_map recipients = - let module Resolved = Map.Make (struct - type t = - [ `Ipaddr of Ipaddr.t | `Domain of [ `host ] Domain_name.t * Mxs.t ] - - let compare a b = - match a, b with - | `Ipaddr a, `Ipaddr b -> Ipaddr.compare a b - | `Domain (_, mxs_a), `Domain (_, mxs_b) -> - let {Mxs.mx_ipaddr= a; _} = Mxs.choose mxs_a in - let {Mxs.mx_ipaddr= b; _} = Mxs.choose mxs_b in - Ipaddr.compare a b - | `Ipaddr a, `Domain (_, mxs) -> - let {Mxs.mx_ipaddr= b; _} = Mxs.choose mxs in - Ipaddr.compare a b - | `Domain (_, mxs), `Ipaddr b -> - let {Mxs.mx_ipaddr= a; _} = Mxs.choose mxs in - Ipaddr.compare a b - end) in - let postmaster = [`Atom "Postmaster"] in - let unresolved, resolved = - Aggregate.aggregate_by_domains ~domain recipients in - let unresolved, resolved = - match relay_map with - | Some relay_map -> Relay_map.expand relay_map unresolved resolved - | None -> unresolved, resolved in - let fold resolved (domain, recipients) = - resolver.getmxbyname w domain >>= function - | Error (`Msg _err) -> - Log.err (fun m -> - m "%a is unreachable (no MX information)." (pp_recipients ~domain) - recipients); - IO.return resolved - | Ok mxs -> ( - let fold mxs {Dns.Mx.mail_exchange; Dns.Mx.preference} = - resolver.gethostbyname w mail_exchange >>= function - | Ok mx_ipaddr -> - let mxs = - Mxs.(add (v ~preference ~domain:mail_exchange mx_ipaddr) mxs) - in - IO.return mxs - | Error (`Msg _err) -> - Log.err (fun m -> - m "%a as the SMTP service is unreachable." Domain_name.pp - 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 - else - let {Mxs.mx_ipaddr; _} = Mxs.choose mxs in - match recipients with - | `All -> - IO.return (Resolved.add (`Domain (domain, mxs)) `All resolved) - | `Local l0 -> ( - match Resolved.find_opt (`Ipaddr mx_ipaddr) resolved with - | None -> - IO.return - (Resolved.add (`Domain (domain, mxs)) (`Local l0) resolved) - | Some `All -> IO.return resolved - | Some (`Local l1) -> - let vs = - List.sort_uniq - (Emile.compare_local ~case_sensitive:true) - (l0 @ l1) in - IO.return - (Resolved.add (`Domain (domain, mxs)) (`Local vs) resolved) - | Some `Postmaster -> - IO.return - (Resolved.add - (`Domain (domain, mxs)) - (`Local (postmaster :: l0)) - resolved)) - | `Postmaster -> ( - match Resolved.find_opt (`Ipaddr mx_ipaddr) resolved with - | Some `Postmaster | Some `All -> IO.return resolved - | Some (`Local l0) -> - if - List.exists - (Emile.equal_local ~case_sensitive:true postmaster) - l0 - then IO.return resolved - else - IO.return - (Resolved.add - (`Domain (domain, mxs)) - (`Local (postmaster :: l0)) - resolved) - | None -> - IO.return - (Resolved.add - (`Domain (domain, mxs)) - (`Local [postmaster]) resolved))) in - let open Aggregate in - let resolved = - By_ipaddr.fold - (fun k v m -> Resolved.add (`Ipaddr k) v m) - resolved Resolved.empty in - list_fold_left_s ~f:fold resolved (By_domain.bindings unresolved) - >|= Resolved.bindings -end diff --git a/lib/common.mli b/lib/common.mli deleted file mode 100644 index 5915c7a..0000000 --- a/lib/common.mli +++ /dev/null @@ -1,72 +0,0 @@ -open Sigs -open Rresult - -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) : sig - type 'w resolver - 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 - - val ( >>? ) : - ('a, 'err) result IO.t - -> ('a -> ('b, 'err) result IO.t) - -> ('b, 'err) result IO.t - - val resolver : Resolver.t resolver - val generate : Mirage_crypto_rng.g random - val scheduler : Scheduler.t Colombe.Sigs.impl - val rdwr : (Flow.t, Scheduler.t) Colombe.Sigs.rdwr - - val run : - Flow.t - -> ('a, 'err) Colombe.State.t - -> ('a, [> `Error of 'err ]) result IO.t - (** [run flow m] runs [m] on [flow]. [m] is a description of what we will send - and receive. [flow] is a representation of the {i socket}. *) - - val recipients_are_reachable : - ipaddr:Ipaddr.t -> Resolver.t -> Colombe.Forward_path.t list -> bool IO.t - (** [recipients_are_reachable ~ipv4 resolver recipients] tries to resolve - {i MX} record for any domains of recipients. [ipaddr] is the {b public} IP - of the current SMTP server to resolve [Postmaster]. *) - - val receive_mail : - ?limit:int - -> Flow.t - -> 'ctx - -> ('ctx -> (string, 'err) Colombe.State.t) - -> (string * int * int) consumer - -> (unit, [> `Error of 'err | `Too_big_data ]) result IO.t - (** [receive_mail ?limit flow ctx m consumer] runs [m] which gives to us a - {i payload} from a given [ctx] (with [STARTTLS] or not) and a [flow]. - Then, it transmits these {i payloads} to the [consumer]. - - [limit] can protect us to an infinite filler. If we reach the limit, - [`Too_big_data] is returned. *) - - val resolve_recipients : - domain:[ `host ] Domain_name.t - -> Resolver.t - -> Relay_map.t option - -> Colombe.Forward_path.t list - -> ([ `Domain of [ `host ] Domain_name.t * Mxs.t | `Ipaddr of Ipaddr.t ] - * Aggregate.resolved_elt) - list - IO.t - (** [resolve_recipients ~domain resolver map recipients] tries to resolve - [recipients] with [resolver] and rightly translates recipients found into - [map] to expected recipients. - - The result is a list of: - - - [`Domain (domain, mxs)] which is an aggregation of all recipients with - the same [domain]. [mxs] is a set of Mail eXchange services (priority - and IP address) of the [domain]. - - [`Ipaddr ip] is an aggregation of all recipients with the same IP as a - domain. *) -end diff --git a/lib/dune b/lib/dune index af8988c..0998e64 100644 --- a/lib/dune +++ b/lib/dune @@ -1,48 +1,78 @@ +(library + (name ptt_common) + (public_name ptt.common) + (modules ptt_common mxs) + (libraries lwt logs cstruct mirage-flow colombe tls mrmime dns)) + +(library + (name ptt_sendmail) + (public_name ptt.sendmail) + (modules ptt_sendmail) + (libraries emile colombe.emile mrmime sendmail-mirage ptt.common)) + +(library + (name ptt_aggregate) + (public_name ptt.aggregate) + (modules ptt_aggregate) + (libraries ptt.common ptt.sendmail)) + +(library + (name ptt_flow) + (public_name ptt.flow) + (modules ptt_flow) + (libraries ke colombe tcpip)) + +(library + (name ptt_map) + (public_name ptt.map) + (modules ptt_map) + (libraries ptt.common colombe.emile)) + (library (name ptt) (public_name ptt) - (modules ptt aggregate authentication common logic mechanism messaged mxs - relay_map relay sigs sMTP sSMTP submission) - (libraries digestif mrmime colombe.emile domain-name dns sendmail.starttls + (modules ptt authentication logic mechanism messaged + relay sigs sMTP sSMTP submission) + (libraries ptt.common ptt.flow ptt.aggregate digestif mrmime colombe.emile domain-name dns sendmail.starttls logs ipaddr) (preprocess future_syntax)) (library - (name ptt_tuyau) - (public_name ptt.tuyau) - (modules ptt_tuyau lwt_backend) + (name ptt_server) + (public_name ptt.server) + (modules ptt_server) (libraries lwt tls-mirage bigstringaf mirage-time mirage-flow tcpip mimic ptt.rdwr ptt)) -(library - (name ptt_transmit) - (public_name ptt.transmit) - (modules ptt_transmit) - (libraries hxd.core hxd.string ptt.tuyau mirage-clock received)) +; (library +; (name ptt_transmit) +; (public_name ptt.transmit) +; (modules ptt_transmit) +; (libraries hxd.core hxd.string ptt.tuyau mirage-clock received)) (library (name lipap) (public_name ptt.lipap) (modules lipap) - (libraries tls ptt.transmit mirage-random tls-mirage)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dns-client-mirage)) (library (name mti_gf) (public_name ptt.mti-gf) (modules mti_gf) - (libraries mirage-random ptt.transmit)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dns-client-mirage)) (library (name nec) (public_name ptt.nec) (modules nec) - (libraries dkim-mirage mirage-random ptt.transmit)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dkim-mirage dns-client-mirage)) (library (name hm) (public_name ptt.hm) (modules hm) - (libraries dns-client-mirage uspf mirage-random ptt.transmit)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server uspf-mirage)) (library (name ptt_value) @@ -54,7 +84,7 @@ (name spartacus) (public_name ptt.spartacus) (modules spartacus) - (libraries spamtacus-mirage mirage-random ptt.transmit)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server spamtacus-mirage dns-client-mirage)) (library (name rdwr) diff --git a/lib/hm.ml b/lib/hm.ml index 59763c5..037a4ea 100644 --- a/lib/hm.ml +++ b/lib/hm.ml @@ -1,149 +1,118 @@ open Rresult -open Ptt_tuyau.Lwt_backend open Lwt.Infix let src = Logs.Src.create "ptt.hm" module Log : Logs.LOG = (val Logs.src_log src) +let ( $ ) f g = fun x -> f (g x) + module Make (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 'a Transport.io = 'a Lwt.t) = + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) = struct - include Ptt_tuyau.Client (Stack) - module Flow = Rdwr.Make (Stack.TCP) - 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) - - module Uspf_dns = struct - type t = DNS.t - type backend = Lwt_scheduler.t - - type error = - [ `Msg of string - | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t - | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] + module Verifier = Ptt.Relay.Make (Stack) + module Server = Ptt_server.Make (Time) (Stack) + module Sendmail = Ptt_sendmail.Make (Pclock) (Stack) (Happy_eyeballs) + module Uspf_client = Uspf_mirage.Make (Dns_client) - let getrrecord dns key domain_name = - Lwt_scheduler.inj @@ DNS.get_resource_record dns key domain_name - end + let resolver = + let open Ptt_common in + let getmxbyname dns domain_name = + Dns_client.getaddrinfo dns Dns.Rr_map.Mx domain_name + >|= Result.map snd in + let gethostbyname dns domain_name = + let ipv4 = + Dns_client.gethostbyname dns domain_name + >|= Result.map (fun ipv4 -> Ipaddr.V4 ipv4) in + let ipv6 = + Dns_client.gethostbyname6 dns domain_name + >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in + Lwt.all [ ipv4; ipv6 ] >|= function + | [ _; (Ok _ as ipv6) ] -> ipv6 + | [ (Ok _ as ipv4); Error _ ] -> ipv4 + | [ (Error _ as err); _ ] -> err + | [] | [_] | _ :: _ :: _ -> assert false in + { getmxbyname; gethostbyname } - let smtp_verifier_service ~pool ?stop ~port stack resolver conf_server = - Server.init ~port stack >>= fun service -> - let handler pool flow = - let ip, port = Stack.TCP.dst flow in - let v = Flow.make flow in - Lwt.catch + let server_job ~pool ?stop ~port stack dns server close = + let handler flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, queue) -> Verifier.accept ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr:ip v - resolver conf_server + ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr flow + dns resolver server >|= R.reword_error (R.msgf "%a" Verifier.pp_error) >>= fun res -> Stack.TCP.close flow >>= fun () -> Lwt.return res) - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) + (fun () -> Stack.TCP.close flow) >>= function - | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); - Lwt.return () + | Ok () -> Lwt.return () | Error (`Msg err) -> - 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)); + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in - let (`Initialized fiber) = - Server.serve_when_ready ?stop ~handler:(handler pool) service in - fiber - - let state = - let open Uspf.Sigs in - let open Lwt_scheduler in - { - return= (fun x -> inj (Lwt.return x)) - ; bind= (fun x f -> inj (prj x >>= fun x -> prj (f x))) - } - - let stream_of_list lst = - let lst = ref lst in - fun () -> - match !lst with - | [] -> Lwt.return_none - | str :: rest -> - lst := rest; - Lwt.return_some (str, 0, String.length str) + Server.init ~port stack >>= fun service -> + Server.serve_when_ready ?stop ~handler service + |> fun (`Initialized job) -> + let job = job >|= close in job let stream_of_field (field_name : Mrmime.Field_name.t) unstrctrd = - stream_of_list - [ - (field_name :> string); ": "; Unstrctrd.to_utf_8_string unstrctrd; "\r\n" - ] + Lwt_stream.of_list + [ (field_name :> string) + ; ": " + ; Unstrctrd.to_utf_8_string unstrctrd; "\r\n" ] - let concat_stream a b = - let current = ref a in - let rec next () = - let v = !current () in - v >>= function - | Some _ -> v - | None -> - if !current == b then Lwt.return_none - else ( - current := b; - next ()) in - next - - let smtp_logic ~pool ~info ~tls stack resolver messaged map dns = + let logic_job ~info map (ic, oc) dns = let rec go () = - Verifier.Md.await messaged >>= fun () -> - 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 + Lwt_stream.get ic >>= function + | None -> oc None; Lwt.return_unit + | Some (key, stream) -> + 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 + let verify () = + Uspf_client.get ~ctx dns >>= function + | Error (`Msg msg) -> + Log.err (fun m -> m "Got an error from SPF: %s" msg); + (* TODO(dinosaure): add a new field into the incoming email. *) + Lwt.return stream | 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; + Uspf_client.check ~ctx dns record >>= fun result -> + let receiver = match info.Ptt_common.domain with + | Colombe.Domain.Domain ds -> `Domain ds + | IPv4 ipv4 -> `Addr (Emile.IPv4 ipv4) + | IPv6 ipv6 -> `Addr (Emile.IPv6 ipv6) + | Extension (k, v) -> `Addr (Emile.Ext (k, v)) in + let field_name, unstrctrd = Uspf.to_field ~ctx ~receiver result in + let stream = Lwt_stream.append (stream_of_field field_name unstrctrd) stream in + Lwt.return stream in + verify () >>= fun stream -> + let recipients = Ptt.Messaged.recipients key in + let recipients = List.map fst recipients in + let recipients = Ptt_map.expand ~info map recipients in + let recipients = Ptt_aggregate.to_recipients ~info recipients in + let id = Ptt_common.id_to_messageID ~info (Ptt.Messaged.id key) in + let elts = List.map (fun recipients -> + { Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id }) recipients in + List.iter (oc $ Option.some) elts; Lwt.pause () >>= go in go () - let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info dns = - let conf_server = Verifier.create ~info in - let messaged = Verifier.messaged conf_server in + let job ?(limit = 20) ?stop ~locals ~port ~tls ~info stack dns he = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create Colombe.Encoder.io_buffer_size in @@ -156,10 +125,12 @@ struct let decoder = Bytes.create Colombe.Decoder.io_buffer_size in let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in Lwt.return (encoder, decoder, queue) in + let pool1 = + { Ptt_sendmail.pool= fun fn -> Lwt_pool.use pool1 fn } in + let ic_server, stream0, close0 = Verifier.create ~info in + let oc_server, push0 = Sendmail.v ~resolver ~pool:pool1 ~info tls in Lwt.join - [ - smtp_verifier_service ~pool:pool0 ?stop ~port stack resolver conf_server - ; smtp_logic ~pool:pool1 ~info ~tls stack resolver messaged locals dns - ; smtp_send_emails ... - ] + [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0) dns + ; Sendmail.job dns he oc_server ] end diff --git a/lib/hm.mli b/lib/hm.mli index f472519..7981db3 100644 --- a/lib/hm.mli +++ b/lib/hm.mli @@ -9,18 +9,18 @@ module Make (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 'a Transport.io = 'a Lwt.t) : sig - val fiber : + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig + val job : ?limit:int -> ?stop:Lwt_switch.t - -> ?locals:Ptt.Relay_map.t + -> locals:Ptt_map.t -> port:int -> tls:Tls.Config.client + -> info:Ptt_common.info -> Stack.TCP.t - -> Resolver.t - -> Ptt.Logic.info - -> DNS.t + -> Dns_client.t + -> Happy_eyeballs.t -> unit Lwt.t end diff --git a/lib/lexicon.ml b/lib/lexicon.ml new file mode 100644 index 0000000..2c6634a --- /dev/null +++ b/lib/lexicon.ml @@ -0,0 +1,24 @@ +let pp_recipients ppf { Sendmail.domain; locals; } = + let pp_domain ppf = function + | `Ipaddr (Ipaddr.V4 v4) -> Fmt.pf ppf "[%a]" Ipaddr.V4.pp v4 + | `Ipaddr (Ipaddr.V6 v6) -> Fmt.pf ppf "[IPv6:%a]" Ipaddr.V6.pp v6 + | `Domain domain -> Domain_name.pp ppf domain in + let pp_local ppf local = + let pp_elt ppf = function + | `Atom x -> Fmt.string ppf x + | `String x -> Fmt.pf ppf "%S" x in + Fmt.(list ~sep:(any ".") pp_elt) ppf local in + match locals with + | `All -> Fmt.pf ppf "- <%a>\n" pp_domain domain + | `Some locals -> + let pp_elt local = Fmt.pf ppf "- %a@%a\n" pp_local local pp_domain domain in + List.iter pp_elt locals + +let impossible_to_send_an_email_to ~recipients mxs = + Fmt.str {text|It's impossible to send an email to: + %a + + We tried to send the email %a at %a to: + %a + + All of them are unavailable.|text} diff --git a/lib/lipap.ml b/lib/lipap.ml index 5879721..0d7420c 100644 --- a/lib/lipap.ml +++ b/lib/lipap.ml @@ -1,103 +1,93 @@ open Rresult -open Ptt_tuyau.Lwt_backend open Lwt.Infix let src = Logs.Src.create "ptt.lipap" module Log : Logs.LOG = (val Logs.src_log src) +let ( $ ) f g = fun x -> f (g x) + module Make (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) = + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) = struct - include Ptt_tuyau.Client (Stack) - module Tls = Tls_mirage.Make (Stack.TCP) - module Flow = Rdwr.Make (Tls) - - module Submission = - Ptt.Submission.Make (Lwt_scheduler) (Lwt_io) (Flow) (Resolver) + module Submission = Ptt.Submission.Make (Stack) + module Server = Ptt_server.Make (Time) (Stack) + module Sendmail = Ptt_sendmail.Make (Pclock) (Stack) (Happy_eyeballs) - module Server = Ptt_tuyau.Server (Time) (Stack) - include Ptt_transmit.Make (Pclock) (Stack) (Submission.Md) + let resolver = + let open Ptt_common in + let getmxbyname dns domain_name = + Dns_client.getaddrinfo dns Dns.Rr_map.Mx domain_name + >|= Result.map snd in + let gethostbyname dns domain_name = + let ipv4 = + Dns_client.gethostbyname dns domain_name + >|= Result.map (fun ipv4 -> Ipaddr.V4 ipv4) in + let ipv6 = + Dns_client.gethostbyname6 dns domain_name + >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in + Lwt.all [ ipv4; ipv6 ] >|= function + | [ _; (Ok _ as ipv6) ] -> ipv6 + | [ (Ok _ as ipv4); Error _ ] -> ipv4 + | [ (Error _ as err); _ ] -> err + | [] | [_] | _ :: _ :: _ -> assert false in + { getmxbyname; gethostbyname } - let smtp_submission_service - ~pool ?stop ~port stack resolver random hash conf_server = - let tls = - match (Submission.info conf_server).Ptt.SSMTP.tls with - | Some tls -> tls - | None -> - Fmt.invalid_arg "Impossible to launch a submission server without TLS" - in - Server.init ~port stack >>= fun service -> - let handler pool flow = - let ip, port = Stack.TCP.dst flow in - Lwt.catch + let server_job ~pool ?stop ~port random hash stack dns server close = + let handler flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, _) -> - Tls.server_of_flow tls flow >>= function - | Error err -> - Stack.TCP.close flow >>= fun () -> - Lwt.return_error (R.msgf "%a" Tls.pp_write_error err) - | Ok flow -> - Submission.accept ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~ipaddr:ip (Flow.make flow) resolver - random hash conf_server - >|= R.reword_error (R.msgf "%a" Submission.pp_error) - >>= fun res -> - Tls.close flow >>= fun () -> Lwt.return res) - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) + Submission.accept ~encoder:(Fun.const encoder) + ~decoder:(Fun.const decoder) ~ipaddr flow dns resolver + random hash server + >|= R.reword_error (R.msgf "%a" Submission.pp_error)) + (fun () -> Stack.TCP.close flow) >>= function - | Ok () -> - Log.info (fun m -> m "<%a:%d> quit properly" Ipaddr.pp ip port); - Lwt.return () + | Ok () -> Lwt.return () | Error (`Msg err) -> - 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)); + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in - let (`Initialized fiber) = - Server.serve_when_ready ?stop ~handler:(handler pool) service in - fiber + Server.init ~port stack >>= fun service -> + Server.serve_when_ready ?stop ~handler service + |> fun (`Initialized job) -> + let job = job >|= close in job - let smtp_logic ~pool ~info ~tls stack resolver messaged map = + let logic_job ~info map (ic, oc) = let rec go () = - Submission.Md.await messaged >>= fun () -> - Submission.Md.pop messaged >>= function - | None -> Lwt.pause () >>= go - | Some ((key, _, _) as v) -> - let transmit () = - Submission.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver - map - (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_stream.get ic >>= function + | None -> oc None; Lwt.return_unit + | Some (key, stream) -> + let sender = fst (Ptt.Messaged.from key) in + let recipients = Ptt.Messaged.recipients key in + let recipients = List.map fst recipients in + let recipients = Ptt_map.expand ~info map recipients in + let recipients = Ptt_aggregate.to_recipients ~info recipients in + let id = Ptt_common.id_to_messageID ~info (Ptt.Messaged.id key) in + let elts = List.map (fun recipients -> + (* TODO(dinosaure): Can we use multiple MAIL FROM to keep the original + sender? We actually force to be + SPF-valid in front of SMTP servers even if we are not the original + author of the email. The original author is kept into the [Sender] + field of the email which is unchanged. *) + { Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id }) recipients in + List.iter (oc $ Option.some) elts; + Lwt.pause () >>= go in go () - let fiber - ?(limit = 20) - ?stop - ?locals - ~port - ~tls - stack - resolver - random - hash - info - authenticator - mechanisms = - let conf_server = Submission.create ~info ~authenticator mechanisms in - let messaged = Submission.messaged conf_server in + let job ?(limit = 20) ?stop ~locals ~port ~tls ~info + random hash stack dns he + authenticator mechanisms = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create Colombe.Encoder.io_buffer_size in @@ -110,10 +100,12 @@ struct let decoder = Bytes.create Colombe.Decoder.io_buffer_size in let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in Lwt.return (encoder, decoder, queue) in + let pool1 = + { Ptt_sendmail.pool= fun fn -> Lwt_pool.use pool1 fn } in + let ic_server, stream0, close0 = Submission.create ~info ~authenticator mechanisms in + let oc_server, push0 = Sendmail.v ~resolver ~pool:pool1 ~info tls in Lwt.join - [ - smtp_submission_service ~pool:pool0 ?stop ~port stack resolver random - hash conf_server - ; smtp_logic ~pool:pool1 ~info ~tls stack resolver messaged locals - ] + [ server_job ~pool:pool0 ?stop ~port random hash stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0) + ; Sendmail.job dns he oc_server ] end diff --git a/lib/lipap.mli b/lib/lipap.mli index 82b20af..32c79bc 100644 --- a/lib/lipap.mli +++ b/lib/lipap.mli @@ -10,20 +10,23 @@ module Make (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) : sig - val fiber : + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : +sig + val job : ?limit:int -> ?stop:Lwt_switch.t - -> ?locals:Ptt.Relay_map.t + -> locals:Ptt_map.t -> port:int -> tls:Tls.Config.client - -> Stack.TCP.t - -> Resolver.t + -> info:Ptt_common.info -> Mirage_crypto_rng.g option -> 'k Digestif.hash - -> Ptt.Logic.info - -> (Ptt_tuyau.Lwt_backend.Lwt_scheduler.t, 'k) Ptt.Authentication.t + -> Stack.TCP.t + -> Dns_client.t + -> Happy_eyeballs.t + -> 'k Ptt.Authentication.t -> Ptt.Mechanism.t list -> unit Lwt.t end diff --git a/lib/logic.ml b/lib/logic.ml index 6052c7d..9990909 100644 --- a/lib/logic.ml +++ b/lib/logic.ml @@ -54,8 +54,7 @@ module Value = struct | Reply.Encoder.error | `Too_many_bad_commands | `No_recipients - | `Too_many_recipients - | `Invalid_recipients ] + | `Too_many_recipients ] let pp_error ppf = function | #Reply.Encoder.error as err -> Reply.Encoder.pp_error ppf err @@ -63,7 +62,6 @@ module Value = struct | `Too_many_bad_commands -> Fmt.string ppf "Too many bad commands" | `No_recipients -> Fmt.string ppf "No recipients" | `Too_many_recipients -> Fmt.string ppf "Too many recipients" - | `Invalid_recipients -> Fmt.string ppf "Invalid recipients" end module type MONAD = sig @@ -100,19 +98,19 @@ module type MONAD = sig val decode : context -> 'a Value.recv - -> ( context - -> 'a - -> ('b, ([> `Protocol of error ] as 'err)) Colombe.State.t) + -> (context -> 'a -> ('b, ([> `Protocol of error ] as 'err)) Colombe.State.t) -> ('b, 'err) Colombe.State.t val send : context -> 'a Value.send -> 'a - -> (unit, [> `Protocol of error ]) Colombe.State.t + -> (unit, ([> `Protocol of error ] as 'err)) Colombe.State.t val recv : - context -> 'a Value.recv -> ('a, [> `Protocol of error ]) Colombe.State.t + context + -> 'a Value.recv + -> ('a, ([> `Protocol of error ] as 'err)) Colombe.State.t val return : 'a -> ('a, 'err) Colombe.State.t val fail : 'err -> ('a, 'err) Colombe.State.t @@ -129,17 +127,7 @@ end let () = Colombe.Request.Decoder.add_extension "STARTTLS" let () = Colombe.Request.Decoder.add_extension "AUTH" -(* XXX(dinosaure): shoud be ok! *) - -type info = { - domain: [ `host ] Domain_name.t - ; ipaddr: Ipaddr.t - ; tls: Tls.Config.server option - ; zone: Mrmime.Date.Zone.t - ; size: int64 -} - -type submission = { +type email = { from: Messaged.from ; recipients: (Forward_path.t * (string * string option) list) list ; domain_from: Domain.t @@ -151,7 +139,7 @@ module Log = (val Logs.src_log src : Logs.LOG) module Make (Monad : MONAD) = struct let politely ~domain ~ipaddr = - Fmt.str "%a at your service, [%s]" Domain_name.pp domain + Fmt.str "%a at your service, [%s]" Domain.pp domain (Ipaddr.to_string ipaddr) let m_properly_close_and_fail ctx ?(code = 554) ~message err = @@ -206,7 +194,7 @@ module Make (Monad : MONAD) = struct `No_recipients | acc -> let recipients = List.rev acc in - return (`Submission {from; recipients; domain_from})) + return (`Send {from; recipients; domain_from})) | `Recipient v -> (* XXX(dinosaure): the minimum number of recipients that MUST be buffered is 100 recipients. *) @@ -292,8 +280,8 @@ module Make (Monad : MONAD) = struct let* () = send ctx Value.PP_250 [ - politely ~domain:info.domain ~ipaddr:info.ipaddr; "8BITMIME" - ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.size + politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" + ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.Ptt_common.size ] in m_relay ctx ~domain_from @@ -303,8 +291,8 @@ module Make (Monad : MONAD) = struct let* () = send ctx Value.PP_250 [ - politely ~domain:info.domain ~ipaddr:info.ipaddr; "8BITMIME" - ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.size + politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" + ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.Ptt_common.size ; Fmt.str "AUTH %a" Fmt.(list ~sep:(const string " ") Mechanism.pp) ms ] in m_submission ctx ~domain_from ms diff --git a/lib/lwt_backend.ml b/lib/lwt_backend.ml deleted file mode 100644 index 8c75309..0000000 --- a/lib/lwt_backend.ml +++ /dev/null @@ -1,47 +0,0 @@ -module Mutex = struct - type 'a fiber = 'a Lwt.t - type t = Lwt_mutex.t - - let create () = Lwt_mutex.create () - let lock t = Lwt_mutex.lock t - let unlock t = Lwt_mutex.unlock t -end - -module Condition = struct - type 'a fiber = 'a Lwt.t - type mutex = Mutex.t - type t = unit Lwt_condition.t - - (* XXX(dinosaure): unix backend does not give to us a chance - to pass a value. *) - - let create () = Lwt_condition.create () - let wait t mutex = Lwt_condition.wait ~mutex t - let signal t = Lwt_condition.signal t () - let broadcast t = Lwt_condition.broadcast t () -end - -module Lwt_scheduler = Colombe.Sigs.Make (struct type +'a t = 'a Lwt.t end) - -module Lwt_io = struct - type +'a t = 'a Lwt.t - - module Mutex = Mutex - module Condition = Condition - - let bind = Lwt.bind - let return = Lwt.return - let pause = Lwt.pause -end - -let lwt = - let open Lwt.Infix in - let open Lwt_scheduler in - { - Colombe.Sigs.bind= (fun x f -> inj (prj x >>= fun x -> prj (f x))) - ; Colombe.Sigs.return= (fun x -> inj (Lwt.return x)) - } - -let ( >>? ) x f = - let open Lwt.Infix in - x >>= function Ok x -> f x | Error err -> Lwt.return (Error err) diff --git a/lib/messaged.ml b/lib/messaged.ml index 579266b..02a8ef5 100644 --- a/lib/messaged.ml +++ b/lib/messaged.ml @@ -1,17 +1,14 @@ -open Sigs open Colombe -module Ke = Ke.Rke.Weighted type from = Reverse_path.t * (string * string option) list type recipient = Forward_path.t * (string * string option) list -type key = { - domain_from: Domain.t +type key = + { domain_from: Domain.t ; from: from ; recipients: recipient list ; id: int64 - ; ip: Ipaddr.t -} + ; ip: Ipaddr.t } let domain_from {domain_from; _} = domain_from let from {from; _} = from @@ -19,7 +16,7 @@ let recipients {recipients; _} = recipients let id {id; _} = id let ipaddr {ip; _} = ip -let v ~domain_from ~from ~recipients ~ipaddr:ip id = +let key ~domain_from ~from ~recipients ~ipaddr:ip id = {domain_from; from; recipients; id; ip} let pp ppf key = @@ -51,6 +48,7 @@ let equal a b = && a.id = b.id && Ipaddr.compare a.ip b.ip = 0 +(* module type S = sig type +'a s type queue @@ -66,128 +64,117 @@ module type S = sig val pop : t -> (key * queue * chunk consumer) option s val broadcast : t -> unit end +*) let src = Logs.Src.create "ptt.messaged" module Log = (val Logs.src_log src) -module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) = -struct - type +'a s = 'a IO.t - - open IO - - let ( >>= ) = bind - - type queue = { - q: (char, Bigarray.int8_unsigned_elt) Ke.t - ; m: Mutex.t - ; c: Condition.t - ; f: bool ref - } - - let blit_to_bytes src src_off dst dst_off len = - Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len - - let blit_of_string src src_off dst dst_off len = - Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len - - (* 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 () = - 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 () -> - 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 ()) +type t = (key * string Lwt_stream.t) Lwt_stream.t + +(* +let blit_to_bytes src src_off dst dst_off len = + Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len + +let blit_of_string src src_off dst dst_off len = + Bigstringaf.blit_from_string src ~src_off dst ~dst_off ~len + +(* 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 () = + let rec wait () = + if Ke.is_empty queue && not !close + then Lwt_condition.wait ~mutex condition >>= wait + else Lwt.return_unit in + Lwt_mutex.with_lock mutex @@ fun () -> + let* () = wait () in + let len = min (Ke.length queue) chunk in + + if len = 0 && !close then Lwt.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; + Lwt.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."); + Lwt_mutex.with_lock mutex @@ fun () -> + close := true; + Condition.broadcast condition (); + Lwt.return_unit + | Some (buf, off, len) as v -> + let* next = Lwt_mutex.with_lock mutex @@ fun () -> + if !close then Lwt.return_unit else - match - Ke.N.push queue ~blit:blit_of_string ~length:String.length ~off ~len - buf - with + let length = String.length in + match Ke.N.push queue ~blit:blit_of_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 () - - type 'a producer = 'a option -> unit IO.t - type 'a consumer = unit -> 'a option IO.t - type chunk = string * int * int - - type t = { - q: (key * queue * chunk consumer) Queue.t - ; m: Mutex.t - ; c: Condition.t - } - - let create () = - {q= Queue.create (); m= Mutex.create (); c= Condition.create ()} - - let push ?chunk t key = - let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in - let queue, producer, consumer = pipe_of_queue ?chunk queue in - Mutex.lock t.m >>= fun () -> + Lwt_condition.signal condition (); + Lwt.pause () >>= fun () -> Lwt.return `Retry + | Some _ -> + Lwt_condition.signal condition (); + Lwt.return `Stop in + match next with + | `Retry -> producer v + | `Stop -> Lwt.return_unit + 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 () + +type 'a producer = 'a option -> unit IO.t +type 'a consumer = unit -> 'a option IO.t +type chunk = string * int * int + +type t = + { q: (key * queue * chunk consumer) Queue.t + ; m: Lwt_mutex.t + ; c: unit Lwt_condition.t } + +let create () = + {q= Queue.create (); m= Lwt_mutex.create (); c= Lwt_condition.create ()} + +let push ?chunk t key = + let queue, _ = Ke.create ~capacity:0x1000 Bigarray.Char in + let queue, producer, consumer = pipe_of_queue ?chunk queue in + let ( let* ) = Lwt.bind in + let* () = Lwt_mutex.with_lock t.m @@ fun () -> 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 () - - 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 - - let broadcast t = Condition.broadcast t.c -end + Lwt_condition.signal t.c (); + Lwt.return_unit in + return producer + +let await t = + let rec await () = + if Queue.is_empty t.q + then Lwt_condition.wait ~mutex:t.m t.c >>= await + else Lwt.return_unit in + Lwt_mutex.lock t.m await + +let pop t = + Lwt_mutex.with_lock t.m @@ fun () -> + match Queue.pop t.q with + | key, queue, consumer -> Lwt.return_some (key, queue, consumer) + | exception _ -> Lwt.return_none + +let broadcast t = + Lwt_mutex.with_lock t.m @@ fun () -> + Lwt_condition.broadcast t.c (); + Lwt.return_unit +*) diff --git a/lib/messaged.mli b/lib/messaged.mli index d25fcc0..03439ea 100644 --- a/lib/messaged.mli +++ b/lib/messaged.mli @@ -1,4 +1,3 @@ -open Sigs open Colombe type from = Reverse_path.t * (string * string option) list @@ -13,7 +12,7 @@ val ipaddr : key -> Ipaddr.t val pp : key Fmt.t val equal : key -> key -> bool -val v : +val key : domain_from:Domain.t -> from:from -> recipients:recipient list @@ -21,6 +20,9 @@ val v : -> int64 -> key +type t = (key * string Lwt_stream.t) Lwt_stream.t + +(* module type S = sig type +'a s type queue @@ -59,3 +61,4 @@ end module Make (Scheduler : SCHEDULER) (IO : IO with type 'a t = 'a Scheduler.s) : S with type +'a s = 'a IO.t +*) diff --git a/lib/mti_gf.ml b/lib/mti_gf.ml index 6599225..6c06547 100644 --- a/lib/mti_gf.ml +++ b/lib/mti_gf.ml @@ -1,156 +1,110 @@ open Rresult -open Ptt_tuyau.Lwt_backend open Lwt.Infix let src = Logs.Src.create "ptt.mti-gf" module Log : Logs.LOG = (val Logs.src_log src) +let ( $ ) f g = fun x -> f (g x) + module Make (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) = + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) = struct - include Ptt_tuyau.Client (Stack) - module Flow = Rdwr.Make (Stack.TCP) - 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) + module Relay = Ptt.Relay.Make (Stack) + module Server = Ptt_server.Make (Time) (Stack) + module Sendmail = Ptt_sendmail.Make (Pclock) (Stack) (Happy_eyeballs) - let smtp_relay_service ~pool ?stop ~port stack resolver conf_server = - Server.init ~port stack >>= fun service -> - let handler pool flow = - let ip, port = Stack.TCP.dst flow in - let v = Flow.make flow in - Lwt.catch + let resolver = + let open Ptt_common in + let getmxbyname dns domain_name = + Dns_client.getaddrinfo dns Dns.Rr_map.Mx domain_name + >|= Result.map snd in + let gethostbyname dns domain_name = + let ipv4 = + Dns_client.gethostbyname dns domain_name + >|= Result.map (fun ipv4 -> Ipaddr.V4 ipv4) in + let ipv6 = + Dns_client.gethostbyname6 dns domain_name + >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in + Lwt.all [ ipv4; ipv6 ] >|= function + | [ _; (Ok _ as ipv6) ] -> ipv6 + | [ (Ok _ as ipv4); Error _ ] -> ipv4 + | [ (Error _ as err); _ ] -> err + | [] | [_] | _ :: _ :: _ -> assert false in + { getmxbyname; gethostbyname } + + let server_job ~pool ?stop ~port stack dns server close = + let handler flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, queue) -> Relay.accept ~encoder:(Fun.const encoder) ~decoder:(Fun.const decoder) - ~queue:(Fun.const queue) ~ipaddr:ip v resolver conf_server - >|= R.reword_error (R.msgf "%a" Relay.pp_error) - >>= fun res -> - Stack.TCP.close flow >>= fun () -> Lwt.return res) - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) + ~queue:(Fun.const queue) ~ipaddr flow dns resolver server + >|= R.reword_error (R.msgf "%a" Relay.pp_error)) + (fun () -> Stack.TCP.close flow) >>= function - | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); - Lwt.return () + | Ok () -> Lwt.return () | Error (`Msg err) -> - 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)); + Log.err (fun m -> m "<%a:%d> raised an error: %s" Ipaddr.pp ipaddr port err); Lwt.return () in - let (`Initialized fiber) = - Server.serve_when_ready ?stop ~handler:(handler pool) service in - fiber - - let filter_on_domain ~domain fwd_path = - match fwd_path with - | Colombe.Forward_path.Postmaster -> true - | Domain (Domain vs) | Forward_path {Colombe.Path.domain= Domain vs; _} -> - let domain' = Domain_name.(host_exn (of_strings_exn vs)) in - Domain_name.equal domain domain' - | Domain _ | Forward_path _ -> false - - let to_reverse_path ~domain = function - | Colombe.Forward_path.Postmaster -> - Some - (Some - { - Colombe.Path.local= `String "postmaster" - ; domain= Domain (Domain_name.to_strings domain) - ; rest= [] - }) - | Domain _ -> None - | Forward_path path -> Some (Some path) - - (* NOTE(dinosaure): as the relay, we disturb the route of the email and the - receiver can fail on the SPF check. Imagine a relay with this association: - [foo@bar.com] -> [foo@gmail.com]. If a sender ([bar@foo.com]) sends an - email to [foo@bar.com], our [verifier] will be able to do a SPF - verification. Afterthat, the [verifier] will send back the incoming email - (with a new [Received-SPF] field) to our relay. The relay will find that - the real destination of the email is [foo@gmail.com]. In such situation, - we will talk to [gmail.com:25] which will do another SPF verification. - - In such situation, the [MAIL FROM] given to [gmail.com:25] must have the - [bar.com] domain (our domain) to allow [gmail.com:25] to really check SPF - metadata. However, the initial [MAIL FROM] was [bar@foo.com]! - - We must do a translation of the [MAIL FROM] which must correspond to the - initial destination ([foo@bar.com]) when we talk to [gmail.com:25]. It - complexify a bit the situation when: - 1) we must verify that the initial destination ([foo@bar.com]) exists as - a user into our database - 2) currently, we handles only one case: when we have **one** recipient with - our domain [bar.com] - mainly because we can have only one sender - - If someone wants to send to [foo@bar.com] and [bar@bar.com], which - [MAIL FROM] we should use for real destinations? We obviously can associate - the [MAIL FROM] per destinations ([foo@bar.com] will be the [MAIL FROM] of - its destination, and the same appear for [bar@bar.com]). However, - [bar@bar.com] can be associate to [foo@gmail.com]... In that case, we have - 2 users with the same destination and we fallback on the situation where - we can not really choose between [foo@bar.com] and [bar@bar.com] as the - expected [MAIL FROM] for [gmail.com:25]... - - So currently, we handle the basic case where someone wants to send an email - to only one [@bar.com]. *) + Server.init ~port stack >>= fun service -> + Server.serve_when_ready ?stop ~handler service + |> fun (`Initialized job) -> + let job = job >|= close in job - let smtp_logic ~pool ~info ~tls stack resolver messaged map = + let logic_job ~info map (ic, oc) = + let sender = + let local = `Dot_string [ "ptt"; "mti-gf" ] in + Some (Colombe.Path.{ local; domain= info.Ptt_common.domain; rest= [] }) in let rec go () = - Relay.Md.await messaged >>= fun () -> - Relay.Md.pop messaged >>= function - | None -> Lwt.pause () >>= go - | Some ((key, _, _) as v) -> - let transmit () = - let recipients = Ptt.Messaged.recipients key in - let translated_emitters = - List.map fst recipients - |> List.find_all (filter_on_domain ~domain:info.Ptt.SSMTP.domain) - |> List.filter_map (to_reverse_path ~domain:info.Ptt.SSMTP.domain) - in - let emitter = - match translated_emitters, map with - | [_emitter], None -> None - | [emitter], Some map -> - if Ptt.Relay_map.exists emitter map then Some emitter else None - | [], _ -> None - | _ :: _, _ -> - None (* TODO(dinosaure): see the huge comment above. *) in - Relay.resolve_recipients ~domain:info.Ptt.SSMTP.domain resolver map - (List.map fst recipients) - >>= fun recipients -> - transmit ~pool ~info ~tls ?emitter stack v recipients in - Lwt.async transmit; + Lwt_stream.get ic >>= function + | None -> oc None; Lwt.return_unit + | Some (key, stream) -> + let recipients = Ptt.Messaged.recipients key in + let recipients = List.map fst recipients in + let recipients = Ptt_map.expand ~info map recipients in + let recipients = Ptt_aggregate.to_recipients ~info recipients in + let id = Ptt_common.id_to_messageID ~info (Ptt.Messaged.id key) in + let elts = List.map (fun recipients -> + (* TODO(dinosaure): Can we use multiple MAIL FROM to keep the original + sender? We actually force to be + SPF-valid in front of SMTP servers even if we are not the original + author of the email. The original author is kept into the [Sender] + field of the email which is unchanged. *) + { Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id }) recipients in + List.iter (oc $ Option.some) elts; Lwt.pause () >>= go in go () - let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info = - let conf_server = Relay.create ~info in - let messaged = Relay.messaged conf_server in + let job ?(limit = 20) ?stop ~locals ~port ~tls ~info stack dns he = let pool0 = Lwt_pool.create limit @@ fun () -> - let encoder = Bytes.create Colombe.Encoder.io_buffer_size in - let decoder = Bytes.create Colombe.Decoder.io_buffer_size in - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let encoder = Bytes.create 0x7ff in + let decoder = Bytes.create 0x7ff in + let queue = Ke.Rke.create ~capacity:0x800 Bigarray.char in Lwt.return (encoder, decoder, queue) in let pool1 = Lwt_pool.create limit @@ fun () -> - let encoder = Bytes.create Colombe.Encoder.io_buffer_size in - let decoder = Bytes.create Colombe.Decoder.io_buffer_size in - let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in + let encoder = Bytes.create 0x7ff in + let decoder = Bytes.create 0x7ff in + let queue = Ke.Rke.create ~capacity:0x800 Bigarray.char in Lwt.return (encoder, decoder, queue) in + let pool1 = + { Ptt_sendmail.pool= fun fn -> Lwt_pool.use pool1 fn } in + let ic_server, stream0, close0 = Relay.create ~info in + let oc_server, push0 = Sendmail.v ~resolver ~pool:pool1 ~info tls in Lwt.join - [ - smtp_relay_service ~pool:pool0 ?stop ~port stack resolver conf_server - ; smtp_logic ~pool:pool1 ~info ~tls stack resolver messaged locals - ] + [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0) + ; Sendmail.job dns he oc_server ] end diff --git a/lib/mti_gf.mli b/lib/mti_gf.mli index 89f6a4d..7f57950 100644 --- a/lib/mti_gf.mli +++ b/lib/mti_gf.mli @@ -9,16 +9,18 @@ module Make (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) : sig - val fiber : + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig + val job : ?limit:int -> ?stop:Lwt_switch.t - -> ?locals:Ptt.Relay_map.t + -> locals:Ptt_map.t -> port:int -> tls:Tls.Config.client + -> info:Ptt_common.info -> Stack.TCP.t - -> Resolver.t - -> Ptt.Logic.info + -> Dns_client.t + -> Happy_eyeballs.t -> unit Lwt.t end diff --git a/lib/nec.ml b/lib/nec.ml index 50b38db..a64a644 100644 --- a/lib/nec.ml +++ b/lib/nec.ml @@ -1,95 +1,100 @@ open Rresult -open Ptt_tuyau.Lwt_backend open Lwt.Infix let src = Logs.Src.create "ptt.nec" module Log : Logs.LOG = (val Logs.src_log src) +let ( $ ) f g = fun x -> f (g x) + module Make (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) = + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) = struct - include Ptt_tuyau.Client (Stack) - module Flow = Rdwr.Make (Stack.TCP) - 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) + module Signer = Ptt.Relay.Make (Stack) + module Server = Ptt_server.Make (Time) (Stack) + module Sendmail = Ptt_sendmail.Make (Pclock) (Stack) (Happy_eyeballs) - let smtp_signer_service ~pool ?stop ~port stack resolver conf_server = - Server.init ~port stack >>= fun service -> - let handler pool flow = - let ip, port = Stack.TCP.dst flow in - let v = Flow.make flow in - Lwt.catch + let resolver = + let open Ptt_common in + let getmxbyname dns domain_name = + Dns_client.getaddrinfo dns Dns.Rr_map.Mx domain_name + >|= Result.map snd in + let gethostbyname dns domain_name = + let ipv4 = + Dns_client.gethostbyname dns domain_name + >|= Result.map (fun ipv4 -> Ipaddr.V4 ipv4) in + let ipv6 = + Dns_client.gethostbyname6 dns domain_name + >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in + Lwt.all [ ipv4; ipv6 ] >|= function + | [ _; (Ok _ as ipv6) ] -> ipv6 + | [ (Ok _ as ipv4); Error _ ] -> ipv4 + | [ (Error _ as err); _ ] -> err + | [] | [_] | _ :: _ :: _ -> assert false in + { getmxbyname; gethostbyname } + + let server_job ~pool ?stop ~port stack dns server close = + let handler flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, queue) -> Signer.accept ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr:ip v - resolver conf_server - >|= R.reword_error (R.msgf "%a" Signer.pp_error) - >>= fun res -> - Stack.TCP.close flow >>= fun () -> Lwt.return res) - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) + ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr flow + dns resolver server + >|= R.reword_error (R.msgf "%a" Signer.pp_error)) + (fun () -> Stack.TCP.close flow) >>= function - | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); - Lwt.return () + | Ok () -> Lwt.return () | Error (`Msg err) -> - 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)); + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in - let (`Initialized fiber) = - Server.serve_when_ready ?stop ~handler:(handler pool) service in - fiber + Server.init ~port stack >>= fun service -> + Server.serve_when_ready ?stop ~handler service + |> fun (`Initialized job) -> + let job = job >|= close in job - let smtp_logic - ~pool ~info ~tls stack resolver messaged (private_key, dkim) map = + let logic_job ~info map (ic, oc) (private_key, dkim) = let rec go () = - Signer.Md.await messaged >>= fun () -> - Signer.Md.pop messaged >>= function - | None -> Lwt.pause () >>= go - | Some (key, queue, consumer) -> - Log.debug (fun m -> m "Got an email."); + Lwt_stream.get ic >>= function + | None -> oc None; Lwt.return_unit + | Some (key, stream) -> let sign_and_transmit () = Lwt.catch (fun () -> + let consumer = + let stream = Lwt_stream.map (fun str -> str, 0, String.length str) stream in + fun () -> Lwt_stream.get stream in 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."); + >>= fun (_signed, consumer) -> + let stream = Lwt_stream.from consumer in + let stream = Lwt_stream.map (fun (str, off, len) -> String.sub str off len) stream in + let sender, _ = Ptt.Messaged.from key in + let recipients = Ptt.Messaged.recipients key in + let recipients = List.map fst recipients in + let recipients = Ptt_map.expand ~info map recipients in + let recipients = Ptt_aggregate.to_recipients ~info recipients in + let id = Ptt_common.id_to_messageID ~info (Ptt.Messaged.id key) in + let elts = List.map (fun recipients -> + { Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id }) recipients in + List.iter (oc $ Option.some) elts; + Lwt.return_unit) + @@ fun exn -> + Log.err (fun m -> m "Impossible to sign the incoming email: %S" (Printexc.to_string exn)); Lwt.return_unit in - Lwt.async sign_and_transmit; - Lwt.pause () >>= go in + sign_and_transmit () >>= Lwt.pause >>= go in go () - let fiber - ?(limit = 20) - ?stop - ?locals - ~port - ~tls - stack - resolver - (private_key, dkim) - info = - let conf_server = Signer.create ~info in - let messaged = Signer.messaged conf_server in + let job ?(limit = 20) ?stop ~locals ~port ~tls ~info + stack dns he (private_key, dkim) = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create Colombe.Encoder.io_buffer_size in @@ -102,10 +107,12 @@ struct let decoder = Bytes.create Colombe.Decoder.io_buffer_size in let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in Lwt.return (encoder, decoder, queue) in + let pool1 = + { Ptt_sendmail.pool= fun fn -> Lwt_pool.use pool1 fn } in + let ic_server, stream0, close0 = Signer.create ~info in + let oc_server, push0 = Sendmail.v ~resolver ~pool:pool1 ~info tls in Lwt.join - [ - smtp_signer_service ~pool:pool0 ?stop ~port stack resolver conf_server - ; smtp_logic ~pool:pool1 ~info ~tls stack resolver messaged - (private_key, dkim) locals - ] + [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0) (private_key, dkim) + ; Sendmail.job dns he oc_server ] end diff --git a/lib/nec.mli b/lib/nec.mli index 98eeba3..fa95e39 100644 --- a/lib/nec.mli +++ b/lib/nec.mli @@ -8,17 +8,19 @@ module Make (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) : sig - val fiber : + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig + val job : ?limit:int -> ?stop:Lwt_switch.t - -> ?locals:Ptt.Relay_map.t + -> locals:Ptt_map.t -> port:int -> tls:Tls.Config.client + -> info:Ptt_common.info -> Stack.TCP.t - -> Resolver.t + -> Dns_client.t + -> Happy_eyeballs.t -> Mirage_crypto_pk.Rsa.priv * Dkim.unsigned Dkim.dkim - -> Ptt.Logic.info -> unit Lwt.t end diff --git a/lib/ptt.ml b/lib/ptt.ml index 6f08140..fb04bfb 100644 --- a/lib/ptt.ml +++ b/lib/ptt.ml @@ -2,10 +2,7 @@ module SMTP = SMTP module SSMTP = SSMTP module Submission = Submission module Relay = Relay -module Relay_map = Relay_map module Messaged = Messaged -module Mxs = Mxs -module Aggregate = Aggregate module Authentication = Authentication module Mechanism = Mechanism module Sigs = Sigs diff --git a/lib/ptt_aggregate.ml b/lib/ptt_aggregate.ml new file mode 100644 index 0000000..61acf3d --- /dev/null +++ b/lib/ptt_aggregate.ml @@ -0,0 +1,97 @@ +let src = Logs.Src.create "ptt.aggregate" + +module Log = (val Logs.src_log src) + +let ( <$> ) f g = fun x -> match g x with + | Ok x -> f x | Error _ as err -> err + +module By_domain = Map.Make (struct + type t = [ `host ] Domain_name.t + + let compare = Domain_name.compare +end) + +module By_ipaddr = Map.Make (Ipaddr) + +let postmaster = [`Atom "Postmaster"] +let equal_local = Emile.equal_local ~case_sensitive:true + +let add_by_domain ~domain elt by_domains = + match elt, By_domain.find_opt domain by_domains with + | `All, _ -> By_domain.add domain `All by_domains + | _, Some `All | `Postmaster, Some `Postmaster -> by_domains + | `Postmaster, Some (`Some vs) -> + if List.exists (equal_local postmaster) vs then by_domains + else By_domain.add domain (`Some (postmaster :: vs)) by_domains + | `Some v, Some (`Some vs) -> + if List.exists (equal_local v) vs then by_domains + else By_domain.add domain (`Some (v :: vs)) by_domains + | `Some v, Some `Postmaster -> + By_domain.add domain (`Some [v; postmaster]) by_domains + | `Postmaster, None -> By_domain.add domain `Postmaster by_domains + | `Some v, None -> By_domain.add domain (`Some [v]) by_domains + +let add_by_ipaddr ipaddr elt by_ipaddrs = + match elt, By_ipaddr.find_opt ipaddr by_ipaddrs with + | `All, _ -> By_ipaddr.add ipaddr `All by_ipaddrs + | _, Some `All -> by_ipaddrs + | `Some v, Some (`Some vs) -> + if List.exists (equal_local v) vs then by_ipaddrs + else By_ipaddr.add ipaddr (`Some (v :: vs)) by_ipaddrs + | `Some v, None -> By_ipaddr.add ipaddr (`Some [v]) by_ipaddrs + +let aggregate_by_domains ~info = + let open Colombe in + let open Forward_path in + let fold (by_domains, by_ipaddrs) = function + | Postmaster -> + begin match info.Ptt_common.domain with + | Colombe.Domain.(IPv4 _ | IPv6 _ | Extension _) -> + Log.err (fun m -> m "The SMTP server domain is not a domain-name, impossible to add the postmaster as a recipient"); + by_domains, by_ipaddrs + | Colombe.Domain.Domain ds -> + match Domain_name.(host <$> of_strings) ds with + | Ok domain -> add_by_domain ~domain `Postmaster by_domains, by_ipaddrs + | Error (`Msg _) -> + Log.err (fun m -> m "Invalid SMTP server domain, impossible to add the postmaster as a recipient"); + by_domains, by_ipaddrs end + | Forward_path {Path.domain= Domain.Domain v; Path.local; _} as recipient -> + begin match Domain_name.(host <$> of_strings) v with + | Ok domain -> + let local = Colombe_emile.of_local local in + add_by_domain ~domain (`Some local) by_domains, by_ipaddrs + | Error (`Msg msg) -> + Log.warn (fun m -> m "Invalid domain for %a, ignore it: %s" Forward_path.pp recipient msg); + by_domains, by_ipaddrs end + | Domain (Domain.Domain v) as recipient -> + begin match Domain_name.(host <$> of_strings) v with + | Ok domain -> add_by_domain ~domain `All by_domains, by_ipaddrs + | Error (`Msg msg) -> + Log.warn (fun m -> m "Invalid domain for %a, ignore it: %s" Forward_path.pp recipient msg); + by_domains, by_ipaddrs end + | Domain (Domain.IPv4 v4) -> + by_domains, add_by_ipaddr (Ipaddr.V4 v4) `All by_ipaddrs + | Domain (Domain.IPv6 v6) -> + by_domains, add_by_ipaddr (Ipaddr.V6 v6) `All by_ipaddrs + | Forward_path {Path.domain= Domain.IPv4 v4; Path.local; _} -> + let local = Colombe_emile.of_local local in + by_domains, add_by_ipaddr (Ipaddr.V4 v4) (`Some local) by_ipaddrs + | Forward_path {Path.domain= Domain.IPv6 v6; Path.local; _} -> + let local = Colombe_emile.of_local local in + by_domains, add_by_ipaddr (Ipaddr.V6 v6) (`Some local) by_ipaddrs + | Domain (Domain.Extension _) + | Forward_path {Path.domain= Domain.Extension _; _} as recipient -> + Log.warn (fun m -> m "We don't support domain extension, ignore %a" Forward_path.pp recipient); + by_domains, by_ipaddrs in + List.fold_left fold (By_domain.empty, By_ipaddr.empty) + +let to_recipients ~info recipients = + let by_domains, by_ipaddrs = aggregate_by_domains ~info recipients in + let by_domains = List.map (fun (domain, locals) -> + let domain = `Domain domain in + Ptt_sendmail.{ domain; locals }) (By_domain.to_list by_domains) in + let by_ipaddrs = List.map (fun (ipaddr, locals) -> + let domain = `Ipaddr ipaddr in + let locals = (locals :> [ `Some of Emile.local list | `Postmaster | `All]) in + Ptt_sendmail.{ domain; locals }) (By_ipaddr.to_list by_ipaddrs) in + List.rev_append by_domains by_ipaddrs diff --git a/lib/ptt_aggregate.mli b/lib/ptt_aggregate.mli new file mode 100644 index 0000000..ca2e477 --- /dev/null +++ b/lib/ptt_aggregate.mli @@ -0,0 +1 @@ +val to_recipients : info:Ptt_common.info -> Colombe.Forward_path.t list -> Ptt_sendmail.recipients list diff --git a/lib/ptt_common.ml b/lib/ptt_common.ml new file mode 100644 index 0000000..2620505 --- /dev/null +++ b/lib/ptt_common.ml @@ -0,0 +1,98 @@ +let src = Logs.Src.create "ptt.common" + +module Log = (val Logs.src_log src) + +let ( <$> ) f g = fun x -> match g x with + | Ok x -> f x | Error _ as err -> err + +type mxs = Dns.Rr_map.Mx_set.t + +type ('dns, 'a) getmxbyname = + 'dns + -> [ `host ] Domain_name.t + -> (mxs, [> `Msg of string ] as 'a) result Lwt.t + +type ('dns, 'a) gethostbyname = + 'dns + -> [ `host ] Domain_name.t + -> (Ipaddr.t, [> `Msg of string ] as 'a) result Lwt.t + +type 'dns resolver = + { getmxbyname : 'a. ('dns, 'a) getmxbyname + ; gethostbyname : 'a. ('dns, 'a) gethostbyname } + +type info = + { domain: Colombe.Domain.t + ; ipaddr: Ipaddr.t + ; tls: Tls.Config.server option + ; zone: Mrmime.Date.Zone.t + ; size: int64 } + +module Mxs = Mxs + +exception Extension_is_not_available of Colombe.Forward_path.t +exception Invalid_recipients of Colombe.Forward_path.t + +module Set = Set.Make (struct type t = [ `host ] Domain_name.t let compare = Domain_name.compare end) + +let recipients_are_reachable ~info dns resolver recipients = + let domains = + let open Colombe in + List.fold_left (fun acc -> function + | Forward_path.Postmaster -> acc (* NOTE(dinosaure): we ourselves should be available *) + | Domain (Domain.IPv4 _ | Domain.IPv6 _) + | Forward_path { Path.domain= (Domain.IPv4 _ | Domain.IPv6 _); _ } -> acc + | Domain (Domain.Extension _) + | Forward_path { Path.domain= Domain.Extension _; _ } as value -> + raise (Extension_is_not_available value) + | Domain (Domain.Domain domain) + | Forward_path { Path.domain= Domain.Domain domain; _ } as value -> + if Domain.equal (Domain.Domain domain) info.domain + then acc (* NOTE(dinosaure): we ourselves should be available *) + else match Domain_name.(host <$> of_strings) domain with + | Ok domain_name -> Set.add domain_name acc + | Error _ -> raise (Invalid_recipients value)) + Set.empty recipients + |> Set.to_list in + let ( let* ) = Lwt.bind in + let mail_exchange_are_reachable { Dns.Mx.mail_exchange; _ } = + let* result = resolver.gethostbyname dns mail_exchange in + match result with + | Ok _ -> Lwt.return true + | Error _ -> Lwt.return false in + let domain_are_reachable domain = + let* result = resolver.getmxbyname dns domain in + match result with + | Ok mxs -> + let lst = Dns.Rr_map.Mx_set.to_list mxs in + let lst = List.sort Dns.Mx.compare lst in + Lwt_list.exists_p mail_exchange_are_reachable lst + | Error _ -> Lwt.return false in + Lwt_list.for_all_p domain_are_reachable domains + +let recipients_are_reachable ~info dns resolver recipients = + Lwt.catch (fun () -> recipients_are_reachable ~info dns resolver recipients) + @@ function + | Extension_is_not_available recipient -> + Log.warn (fun m -> m "Someone tries to send an email to an \ + extension: %a" Colombe.Forward_path.pp recipient); + Lwt.return false + | Invalid_recipients recipient -> + Log.warn (fun m -> m "%a's destination is unreachable" + Colombe.Forward_path.pp recipient); + Lwt.return false + | exn -> Lwt.reraise exn + +let id_to_messageID ~info id = + let local = [ `Atom (Fmt.str "%016Lx" id) ] in + let open Colombe in + let domain = match info.domain with + | Domain.Domain ds -> `Domain ds + | Domain.IPv4 v4 -> + let domain_name = Ipaddr.V4.to_domain_name v4 in + `Domain (Domain_name.to_strings domain_name) + | Domain.IPv6 v6 -> + let domain_name = Ipaddr.V6.to_domain_name v6 in + `Domain (Domain_name.to_strings domain_name) + | Domain.Extension _ -> failwith "The SMTP server domain must not be an extension" in + local, domain diff --git a/lib/ptt_flow.ml b/lib/ptt_flow.ml new file mode 100644 index 0000000..076a2ea --- /dev/null +++ b/lib/ptt_flow.ml @@ -0,0 +1,102 @@ +open Colombe.Sigs +open Colombe.State +open Colombe +open Lwt.Infix + +let ( <.> ) f g = fun x -> f (g x) + +module Lwt_scheduler = Sigs.Make (Lwt) + +let lwt_bind x f = + let open Lwt_scheduler in + inj (prj x >>= (prj <.> f)) + +let lwt = + { Sigs.bind = lwt_bind; return = (fun x -> Lwt_scheduler.inj (Lwt.return x)) } + +exception Rdwr of string + +module Rdwr (Flow : Mirage_flow.S) = struct + let blit0 src src_off dst dst_off len = + let dst = Cstruct.of_bigarray ~off:dst_off ~len dst in + Cstruct.blit src src_off dst 0 len + + let blit1 src src_off dst dst_off len = + Bigstringaf.blit_to_bytes src ~src_off dst ~dst_off ~len + + let failwith pp = function + | Ok v -> Lwt.return v + | Error err -> Lwt.fail (Rdwr (Fmt.str "%a" pp err)) + + type t = + { queue : (char, Bigarray.int8_unsigned_elt) Ke.Rke.t + ; flow : Flow.flow } + + let make flow = { flow; queue = Ke.Rke.create ~capacity:0x800 Bigarray.char } + + let recv flow payload p_off p_len = + if Ke.Rke.is_empty flow.queue + then ( + 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) + 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 + + let send flow payload p_off p_len = + let cs = Cstruct.of_string payload ~off:p_off ~len:p_len in + Flow.write flow.flow cs >>= failwith Flow.pp_write_error +end + +module Make (Flow : Mirage_flow.S) = struct + module Flow' = Rdwr (Flow) + + type flow = Flow'.t + + let rdwr = + let open Lwt_scheduler in + let rd flow buf off len = + Flow'.recv flow buf off len >>= function + | 0 -> Lwt.return `End + | len -> Lwt.return (`Len len) in + let rd flow buf off len = inj (rd flow buf off len) + and wr flow buf off len = inj (Flow'.send flow buf off len) in + { Colombe.Sigs.rd; wr } + + let run : + type s flow. + s impl -> + (flow, s) rdwr -> + flow -> + ('a, 'err) t -> + (('a, 'err) result, s) io = + fun { bind; return } rdwr flow m -> + let ( >>= ) = bind in + + let rec go = function + | Read { buffer; off; len; k } -> + rdwr.rd flow buffer off len >>= fun v -> go (k v) + | Write { buffer; off; len; k } -> + rdwr.wr flow buffer off len >>= fun () -> go (k len) + | Return v -> return (Ok v) + | Error err -> return (Error err : ('a, 'err) result) in + go m + + let make = Flow'.make + + let run flow m = + Lwt.catch (fun () -> Lwt_scheduler.prj (run lwt rdwr flow m)) + @@ function + | Rdwr msg -> Lwt.return_error (`Flow msg) + | exn -> Lwt.reraise exn +end diff --git a/lib/ptt_flow.mli b/lib/ptt_flow.mli new file mode 100644 index 0000000..7ee427d --- /dev/null +++ b/lib/ptt_flow.mli @@ -0,0 +1,10 @@ +module Make (Flow : Mirage_flow.S) : sig + type flow + + val make : Flow.flow -> flow + + val run : + flow + -> ('a, ([> `Flow of string ] as 'err)) Colombe.State.t + -> ('a, 'err) result Lwt.t +end diff --git a/lib/ptt_map.ml b/lib/ptt_map.ml new file mode 100644 index 0000000..95edbac --- /dev/null +++ b/lib/ptt_map.ml @@ -0,0 +1,65 @@ +let src = Logs.Src.create "ptt.map" + +module Log = (val Logs.src_log src) + +module By_domain = Map.Make (struct + type t = [ `host ] Domain_name.t + + let compare = Domain_name.compare +end) + +type t = + { postmaster: Emile.mailbox + ; map: (local, Colombe.Forward_path.t list) Hashtbl.t } +and local = [ `Dot_string of string list | `String of string ] + +let postmaster {postmaster; _} = postmaster +let empty ~postmaster = {postmaster; map= Hashtbl.create 256} + +let add ~local destination t = + match Colombe_emile.to_forward_path destination with + | Error (`Msg err) -> invalid_arg err + | Ok destination -> + match Hashtbl.find_opt t.map local with + | Some vs -> + if not (List.exists (Colombe.Forward_path.equal destination) vs) + then Hashtbl.replace t.map local (destination :: vs) + | None -> Hashtbl.add t.map local [ destination ] + +let exists_as_sender sender ~info t = + match sender with + | None -> false + | Some {Colombe.Path.local; domain; _} -> + Colombe.Domain.equal domain info.Ptt_common.domain + && Hashtbl.mem t.map local + +let recipients ~local {map; _} = + Hashtbl.find_opt map local + |> Option.value ~default:[] + +let all t = Hashtbl.fold (fun _ -> List.rev_append) t.map [] + +let ( $ ) f g x = f (g x) + +module Set = Set.Make (Colombe.Forward_path) + +let expand ~info t recipients = + let open Colombe in + let open Forward_path in + List.map (function + | Postmaster -> + (Result.to_option $ Colombe_emile.to_forward_path) t.postmaster + |> Option.value ~default:Postmaster + |> (Fun.flip List.cons []) + | Domain domain as recipient -> + if Domain.equal domain info.Ptt_common.domain + then all t + else [ recipient ] + | Forward_path { Path.local; domain; _ } as recipient -> + if Domain.equal domain info.Ptt_common.domain + then match Hashtbl.find_opt t.map local with + | Some recipients -> recipients + | None -> [] + else [ recipient ]) recipients + |> List.concat + |> Set.of_list |> Set.to_list diff --git a/lib/ptt_map.mli b/lib/ptt_map.mli new file mode 100644 index 0000000..8918807 --- /dev/null +++ b/lib/ptt_map.mli @@ -0,0 +1,15 @@ +type t +type local = [ `Dot_string of string list | `String of string ] + +val postmaster : t -> Emile.mailbox +val empty : postmaster:Emile.mailbox -> t +val add : local:local -> Emile.mailbox -> t -> unit +val exists_as_sender : Colombe.Reverse_path.t -> info:Ptt_common.info -> t -> bool +val recipients : local:local -> t -> Colombe.Forward_path.t list +val all : t -> Colombe.Forward_path.t list + +val expand : + info:Ptt_common.info + -> t + -> Colombe.Forward_path.t list + -> Colombe.Forward_path.t list diff --git a/lib/ptt_sendmail.ml b/lib/ptt_sendmail.ml new file mode 100644 index 0000000..33de642 --- /dev/null +++ b/lib/ptt_sendmail.ml @@ -0,0 +1,214 @@ +let src = Logs.Src.create "ptt.sendmail" + +module Log = (val Logs.src_log src) + +open Lwt.Infix + +let ( <$> ) f g = fun x -> match g x with + | Ok x -> f x | Error _ as err -> err + +[@@@warning "-30"] + +type recipients = + { domain : [ `Ipaddr of Ipaddr.t | `Domain of [ `host ] Domain_name.t ] + ; locals : [ `All | `Some of Emile.local list | `Postmaster ] } +and 'dns t = + { stream : elt Lwt_stream.t + ; push : elt push + ; info : Ptt_common.info + ; resolver : 'dns Ptt_common.resolver + ; tls : Tls.Config.client + ; pool : pool option } +and elt = + { sender : Colombe.Reverse_path.t + ; recipients : recipients + ; data : string Lwt_stream.t + ; policies : policy list + ; id : Mrmime.MessageID.t } +and pool = { pool : 'a. (resource -> 'a Lwt.t) -> 'a Lwt.t } +and resource = bytes * bytes * (char, Bigarray.int8_unsigned_elt) Ke.Rke.t +and 'a push = 'a option -> unit +and policy = [ `Ignore ] + +[@@@warning "+30"] + +let warn_about_an_unreachable_mail_exchange ~domain ~mail_exchange msg = + Log.warn @@ fun m -> m "Impossible to resolve %a, a mail exchange server for %a: %s" + Domain_name.pp mail_exchange Domain_name.pp domain msg + +(* recipients -> Colombe.Forward_path.t list *) +let recipients_to_forward_paths recipients = + let open Colombe in + let open Forward_path in + let domain = match recipients.domain with + | `Ipaddr (Ipaddr.V4 v4) -> Domain.IPv4 v4 + | `Ipaddr (Ipaddr.V6 v6) -> Domain.IPv6 v6 + | `Domain domain -> Domain.Domain (Domain_name.to_strings domain) in + let local_to_forward_path local = + let local = List.map (function `Atom x -> x | `String x -> x) local in + Forward_path { Path.local= `Dot_string local; domain; rest= [] } in + match recipients.locals with + | `All -> [ Domain domain ] + | `Some locals -> List.map local_to_forward_path locals + | `Postmaster -> [ Postmaster ] + +let guess_return_path stream = + let open Mrmime in + let decoder = Hd.decoder Field_name.Map.empty in + let extract_return_path + : type a. a Field.t -> a -> Colombe.Forward_path.t option Lwt.t + = fun w v -> match w with + | Unstructured -> + let str = Unstructured.to_string v in + begin match (Colombe_emile.to_forward_path <$> Emile.of_string) str with + | Ok recipient -> Lwt.return_some recipient + | Error _ -> Lwt.return_none end + | _ -> Lwt.return_none in + let rec go decoder = match Hd.decode decoder with + | `End _ | `Malformed _ -> Lwt.return_none + | `Field field -> + let Field.Field (field_name, w, v) = Location.without_location field in + if Field_name.equal field_name Field_name.return_path + then extract_return_path w v + else go decoder + | `Await -> + Lwt_stream.get stream >>= function + | Some str -> Hd.src decoder str 0 (String.length str); go decoder + | None -> Lwt.return_none in + go decoder + +module Make + (Clock : Mirage_clock.PCLOCK) + (Stack : Tcpip.Stack.V4V6) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) += struct + module Sendmail = Sendmail_mirage.Make (Clock) (Stack.TCP) (Happy_eyeballs) + + let to_stream stream = + let stream = Lwt_stream.map (fun str -> str, 0, String.length str) stream in + let consumed = ref false in + consumed, (fun () -> consumed := true; Lwt_stream.get stream) + + let sendmail ?(last_option= false) he t ~ipaddr elt = + let ( let* ) = Lwt.bind in + let destination = Ipaddr.to_string ipaddr in + let backup = Lwt_stream.clone elt.data in + let consumed, stream = to_stream elt.data in + let recipients = recipients_to_forward_paths elt.recipients in + let* result = match t.pool with + | Some { pool } -> + pool @@ fun (encoder, decoder, queue) -> + let encoder = Fun.const encoder in + let decoder = Fun.const decoder in + let queue = Fun.const queue in + Sendmail.sendmail ~encoder ~decoder ~queue he ~destination + ~cfg:t.tls ~domain:t.info.Ptt_common.domain elt.sender recipients stream + | None -> + Sendmail.sendmail he ~destination ~cfg:t.tls + ~domain:t.info.Ptt_common.domain elt.sender recipients stream in + if not last_option + then match result, !consumed with + | Ok (), _ -> Lwt.return `Ok + | Error _, false -> Lwt.return `Retry + | Error err, true -> + let* forward_path = guess_return_path backup in + Lwt.return (`Errored (forward_path, err)) + else match result with + | Ok () -> Lwt.return `Ok + | Error _ when List.exists ((=) `Ignore) elt.policies -> Lwt.return `Ok + | Error err -> + let* forward_path = guess_return_path backup in + Lwt.return (`Errored (forward_path, err)) + + let no_mail_exchange_service elt = + let ( let* ) = Lwt.bind in + let* forward_path = guess_return_path (Lwt_stream.clone elt.data) in + match forward_path with + | None -> + let recipients = recipients_to_forward_paths elt.recipients in + Log.err (fun m -> m "Impossible to send the email %a to @[%a@] \ + and impossible to find a return-path to notify the sender %a" + Mrmime.MessageID.pp elt.id + Fmt.(list ~sep:(any ",") Colombe.Forward_path.pp) recipients + Colombe.Reverse_path.pp elt.sender); + Lwt.return_unit + | Some _forward_path -> assert false (* TODO *) + + let pp_error ppf = function + | #Sendmail_with_starttls.error as err -> + Sendmail_with_starttls.pp_error ppf err + | `Msg msg -> Fmt.string ppf msg + + let error_while_sending_email elt (forward_path, err) = + match forward_path with + | None -> + let recipients = recipients_to_forward_paths elt.recipients in + Log.err (fun m -> m "Got an error while sending email %a to \ + @[%a@] and impossible to find a return-path to notify the + sender %a: %a" Mrmime.MessageID.pp elt.id + Fmt.(list ~sep:(any ",") Colombe.Forward_path.pp) recipients + Colombe.Reverse_path.pp elt.sender + pp_error err); + Lwt.return_unit + | Some _forward_path -> assert false (* TODO *) + + let sendmail dns he t elt = + let ( let* ) = Lwt.bind in + let open Ptt_common in + begin match elt.recipients.domain with + | `Ipaddr ipaddr -> + let domain = Ipaddr.to_domain_name ipaddr in + Lwt.return_ok Mxs.(v ~preference:0 ~domain ipaddr) + | `Domain domain -> + let* r = t.resolver.getmxbyname dns domain in + match r with + | Ok mxs -> + let resolve = (Fun.flip Lwt_list.fold_left_s [] ) + begin fun acc ({ Dns.Mx.mail_exchange; _ } as mx) -> + let* r = t.resolver.gethostbyname dns mail_exchange in + match r with + | Ok ipaddr -> Lwt.return ((mx, ipaddr) :: acc) + | Error (`Msg msg) -> + warn_about_an_unreachable_mail_exchange ~domain ~mail_exchange msg; + Lwt.return acc end in + resolve (Dns.Rr_map.Mx_set.to_list mxs) >|= Mxs.vs >|= Result.ok + | Error _ as err -> Lwt.return err end >>= function + | Error _ -> no_mail_exchange_service elt + | Ok mxs -> + if Mxs.is_empty mxs + then no_mail_exchange_service elt + else + let mxs = Mxs.to_list mxs in + let rec go = function + | [] -> + (* NOTE(dinosaure): we verified that [mxs] contains at least one + field and we catch up the case when we have the last element + of [mxs] which does not do the recursion. This case should + never occur. *) + assert false + | [ _mx, ipaddr ] -> + let* result = sendmail ~last_option:true he t ~ipaddr elt in + begin match result with + | `Retry | `Ok -> Lwt.return_unit + | `Errored value -> error_while_sending_email elt value end + | (_mx, ipaddr) :: mxs -> + let* result = sendmail he t ~ipaddr elt in + match result with + | `Ok -> Lwt.return_unit + | `Retry -> go mxs + | `Errored value -> error_while_sending_email elt value in + go mxs + + let rec job dns he t = + Lwt_stream.get t.stream >>= function + | Some elt -> + sendmail dns he t elt >>= fun () -> + job dns he t + | None -> Lwt.return_unit + + let v + : type a. resolver:_ -> ?pool:pool -> info:Ptt_common.info -> Tls.Config.client -> _ + = fun ~resolver ?pool ~info tls -> + let stream, push = Lwt_stream.create () in + { stream; push; info; resolver; tls; pool }, push +end diff --git a/lib/ptt_sendmail.mli b/lib/ptt_sendmail.mli new file mode 100644 index 0000000..c920110 --- /dev/null +++ b/lib/ptt_sendmail.mli @@ -0,0 +1,51 @@ +(** The purpose of this module is to launch a ‘job’ which will send the emails + it obtains (and which are transmitted by the push function returned by + {!val:v}). + + To do this, we need a DNS resolver (to resolve the [MX] field of a domain), + server information (so that it can identify itself to other SMTP servers), + a TLS client configuration (to initiate encrypted communication with + STARTTLS) and a happy-eyeballs instance to initiate a TCP/IP connection + with the SMTP servers. + + An email that you want to send is described in such a way that it contains + the sender, the recipients, the content, a unique ID and an error + management policy. + + It can happen that the email cannot be sent (unavailable SMTP server, + non-existent domain name, etc.). In this specific case, we need an error + management policy so that we know if we need to send an error message back + to the [Return-Path] announced by the email. + + Receivers must be aggregated according to the domain name and/or IP + corresponding to the email exchange server. The idea is to send one email + per domain listed in the receivers (and not one email per receiver). +*) + +type recipients = + { domain : [ `Ipaddr of Ipaddr.t | `Domain of [ `host ] Domain_name.t ] + ; locals : [ `All | `Postmaster | `Some of Emile.local list ] } +and 'dns t and elt = + { sender : Colombe.Reverse_path.t + ; recipients : recipients + ; data : string Lwt_stream.t + ; policies : policy list + ; id : Mrmime.MessageID.t } +and pool = { pool : 'a. (resource -> 'a Lwt.t) -> 'a Lwt.t } +and resource = bytes * bytes * (char, Bigarray.int8_unsigned_elt) Ke.Rke.t +and 'a push = 'a option -> unit +and policy = [ `Ignore ] + +module Make + (Clock : Mirage_clock.PCLOCK) + (Stack : Tcpip.Stack.V4V6) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig + val v : + resolver:'dns Ptt_common.resolver + -> ?pool:pool + -> info:Ptt_common.info + -> Tls.Config.client + -> 'dns t * elt push + + val job : 'dns -> Happy_eyeballs.t -> 'dns t -> unit Lwt.t +end diff --git a/lib/ptt_server.ml b/lib/ptt_server.ml new file mode 100644 index 0000000..1f7a67a --- /dev/null +++ b/lib/ptt_server.ml @@ -0,0 +1,85 @@ +let src = Logs.Src.create "ptt.server" + +module Log = (val Logs.src_log src) + +module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct + open Lwt.Infix + + type service = { + stack: Stack.TCP.t + ; queue: Stack.TCP.flow Queue.t + ; condition: unit Lwt_condition.t + ; mutex: Lwt_mutex.t + ; mutable closed: bool + } + + let init ~port stack = + let queue = Queue.create () in + let condition = Lwt_condition.create () in + let mutex = Lwt_mutex.create () in + + let listener flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt_mutex.with_lock mutex @@ fun () -> + Log.debug (fun m -> m "A new incoming connection: %a:%d" Ipaddr.pp ipaddr port); + Queue.push flow queue; + Lwt_condition.signal condition (); + 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) = + let rec await () = + if Queue.is_empty queue && not t.closed then + Lwt_condition.wait condition ~mutex >>= Lwt.pause >>= await + else Lwt.return (Queue.take_opt queue, t.closed) in + Lwt_mutex.with_lock mutex await >>= function + | Some flow, _ -> Lwt.return (`Flow flow) + | None, false -> accept t + | None, true -> Lwt.return `Closed + + let close ({stack; condition; mutex; _} as t) = + Lwt_mutex.with_lock mutex @@ fun () -> + Log.debug (fun m -> m "Close the server"); + t.closed <- true; + Stack.TCP.disconnect stack >>= fun () -> + Lwt_condition.broadcast condition (); + Lwt.return_unit + + let rec clean acc = function + | [] -> acc + | th :: ths -> + match Lwt.state th with + | Return () -> clean acc ths + | Fail exn -> + Log.err (fun m -> m "A spawned thread failed with: %S" (Printexc.to_string exn)); + clean acc ths + | Sleep -> clean (th :: acc) ths + + let rec terminate = function + | [] -> + Log.debug (fun m -> m "The server is cleaned"); + Lwt.return_unit + | th :: ths -> + Log.debug (fun m -> m "Unterminated tasks"); + match Lwt.state th with + | Return () -> terminate ths + | Fail exn -> + Log.err (fun m -> m "A spawned thread failed with: %S" (Printexc.to_string exn)); + terminate ths + | Sleep -> Lwt.pause () >>= fun () -> terminate (th :: ths) + + let serve_when_ready ?stop ~handler service = + `Initialized + (Lwt_switch.add_hook stop (fun () -> close service); + let rec loop ths = + let ths = clean [] ths in + accept service >>= function + | `Flow flow -> + let th = handler flow in + loop (th :: ths) + | `Closed -> + Log.debug (fun m -> m "Terminate the server"); + Lwt.return (clean [] ths) in + loop [] >>= terminate) +end diff --git a/lib/ptt_server.mli b/lib/ptt_server.mli new file mode 100644 index 0000000..8eb2dfa --- /dev/null +++ b/lib/ptt_server.mli @@ -0,0 +1,11 @@ +module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) : sig + type service + + val init : port:int -> Stack.TCP.t -> service Lwt.t + + val serve_when_ready : + ?stop:Lwt_switch.t + -> handler:(Stack.TCP.flow -> unit Lwt.t) + -> service + -> [ `Initialized of unit Lwt.t ] +end diff --git a/lib/ptt_tuyau.ml b/lib/ptt_tuyau.ml deleted file mode 100644 index 83134c1..0000000 --- a/lib/ptt_tuyau.ml +++ /dev/null @@ -1,141 +0,0 @@ -module Lwt_backend = Lwt_backend - -let src = Logs.Src.create "ptt.tuyau" - -module Log = (val Logs.src_log src) - -module type FLOW = Ptt.Sigs.FLOW with type +'a io = 'a Lwt.t - -module Client (Stack : Tcpip.Stack.V4V6) = struct - open Rresult - open Lwt.Infix - open Lwt_backend - module Flow = Rdwr.Make (Stack.TCP) - - let rdwr : (Flow.t, Lwt_scheduler.t) Colombe.Sigs.rdwr = - let rd flow buf off len = - Lwt_scheduler.inj - @@ (Flow.recv flow buf off len >>= function - | 0 -> Lwt.return `End - | len -> Lwt.return (`Len len)) in - let wr flow buf off len = Lwt_scheduler.inj (Flow.send flow buf off len) in - {Colombe.Sigs.rd; Colombe.Sigs.wr} - - let sendmail - ?encoder - ?decoder - ?queue - ~info - ~tls - stack - ipaddr - sender - recipients - stream = - Stack.TCP.create_connection stack (ipaddr, 25) - >|= R.reword_error (fun err -> `Flow err) - >>? fun flow -> - let flow' = Flow.make flow in - let ctx = - Sendmail_with_starttls.Context_with_tls.make ?encoder ?decoder ?queue () - in - let domain = - let vs = Domain_name.to_strings info.Ptt.Logic.domain in (* the domain of our SMTP stack => ptt *) - Colombe.Domain.Domain vs in - Lwt.catch - (fun () -> - Sendmail_with_starttls.sendmail lwt rdwr flow' ctx tls ~domain sender - recipients stream - |> Lwt_scheduler.prj - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) - >>= fun res -> - Stack.TCP.close flow >|= fun () -> res - - let sendmail_without_tls - ?encoder ?decoder ~info stack ipaddr sender recipients stream = - Stack.TCP.create_connection stack (mx_ipaddr, 25) - >|= R.reword_error (fun err -> `Flow err) - >>? fun flow -> - let flow' = Flow.make flow in - let ctx = Colombe.State.Context.make ?encoder ?decoder () in - let domain = - let vs = Domain_name.to_strings info.Ptt.Logic.domain in - Colombe.Domain.Domain vs in - Lwt.catch - (fun () -> - Sendmail.sendmail lwt rdwr flow' ctx ~domain emitter recipients producer - |> Lwt_scheduler.prj - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) - >>= fun res -> - Stack.TCP.close flow >|= fun () -> res -end - -module Server (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct - open Lwt.Infix - - type service = { - stack: Stack.TCP.t - ; queue: Stack.TCP.flow Queue.t - ; condition: unit Lwt_condition.t - ; mutex: Lwt_mutex.t - ; mutable closed: bool - } - - let init ~port stack = - let queue = Queue.create () in - let condition = Lwt_condition.create () in - let mutex = Lwt_mutex.create () in - - 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} - - let rec accept ({queue; condition; mutex; _} as t) = - Lwt_mutex.lock mutex >>= fun () -> - let rec await () = - if Queue.is_empty queue && not t.closed then - Lwt_condition.wait condition ~mutex >>= await - else Lwt.return_unit in - await () >>= fun () -> - match Queue.pop queue with - | 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) - - let close ({stack; condition; _} as t) = - 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 - let rec loop () = - accept service >>= function - | Ok flow -> - Lwt.async (fun () -> handler flow); - loop () - | Error `Closed -> Lwt.return_error `Closed - | Error _ -> Lwt.pause () >>= loop in - let stop_result = - Lwt.pick [switched_off; loop ()] >>= function - | Ok `Stopped -> close service >>= fun () -> Lwt.return_ok () - | Error _ as err -> close service >>= fun () -> Lwt.return err in - stop_result >>= function Ok () | Error `Closed -> Lwt.return_unit) -end diff --git a/lib/ptt_tuyau.mli b/lib/ptt_tuyau.mli deleted file mode 100644 index e6f1289..0000000 --- a/lib/ptt_tuyau.mli +++ /dev/null @@ -1,49 +0,0 @@ -module Lwt_backend : module type of Lwt_backend -open Lwt_backend - -module type FLOW = Ptt.Sigs.FLOW with type +'a io = 'a Lwt.t - -module Client (Stack : Tcpip.Stack.V4V6) : sig - val sendmail : - ?encoder:(unit -> bytes) - -> ?decoder:(unit -> bytes) - -> ?queue:(unit -> (char, Bigarray.int8_unsigned_elt) Ke.Rke.t) - -> info:Ptt.Logic.info - -> tls:Tls.Config.client - -> Stack.TCP.t - -> Ipaddr.t - -> Colombe.Reverse_path.t - -> (string * int * int, Lwt_scheduler.t) Sendmail.stream - -> Colombe.Forward_path.t list - -> ( unit - , [> `Flow of Stack.TCP.error | `STARTTLS_unavailable | `Msg of string ] - ) - result - Lwt.t - - val sendmail_without_tls : - ?encoder:(unit -> bytes) - -> ?decoder:(unit -> bytes) - -> info:Ptt.Logic.info - -> Stack.TCP.t - -> Ipaddr.t - -> Colombe.Reverse_path.t - -> (string * int * int, Lwt_scheduler.t) Sendmail.stream - -> Colombe.Forward_path.t list - -> (unit, [> `Flow of Stack.TCP.error | `Msg of string ]) result Lwt.t - - val pp_error : - [ `Flow of Stack.TCP.error | `Msg of string | `STARTTLS_unavailable ] Fmt.t -end - -module Server (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) : sig - type service - - val init : port:int -> Stack.TCP.t -> service Lwt.t - - val serve_when_ready : - ?stop:Lwt_switch.t - -> handler:(Stack.TCP.flow -> unit Lwt.t) - -> service - -> [ `Initialized of unit Lwt.t ] -end diff --git a/lib/relay.ml b/lib/relay.ml index 1b48396..fd652d9 100644 --- a/lib/relay.ml +++ b/lib/relay.ml @@ -1,91 +1,110 @@ -open Sigs open Rresult +open Lwt.Infix + +let ( >>? ) = Lwt_result.bind let src = Logs.Src.create "ptt.relay" module Log = (val Logs.src_log src : Logs.LOG) -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) = -struct - include Common.Make (Scheduler) (IO) (Flow) (Resolver) - module Md = Messaged.Make (Scheduler) (IO) - - type server = {info: info; messaged: Md.t; mutable count: int64} +module Make (Stack : Tcpip.Stack.V4V6) = struct + include Ptt_flow.Make (Stack.TCP) - and info = SMTP.info = { - domain: [ `host ] Domain_name.t + type server = + { info: info + ; messaged: Messaged.t + ; push: ((Messaged.key * string Lwt_stream.t) option -> unit) + ; mutable count: int64} + + and info = Ptt_common.info = + { domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t - ; size: int64 - } - + ; size: int64 } + let info {info; _} = info - let create ~info = {info; messaged= Md.create (); count= 0L} - let messaged {messaged; _} = messaged + let create ~info = + let messaged, push = Lwt_stream.create () in + let close () = push None in + {info; messaged; push; count= 0L}, messaged, close + let succ server = let v = server.count in server.count <- Int64.succ server.count; v - - type error = [ `Error of SMTP.error | `Too_big_data ] - + + type error = [ SMTP.error | `Too_big_data | `Flow of string | `Invalid_recipients ] + let pp_error ppf = function - | `Error err -> SMTP.pp_error ppf err + | #SMTP.error as err -> SMTP.pp_error ppf err | `Too_big_data -> Fmt.pf ppf "Too big data" - + | `Flow msg -> Fmt.pf ppf "Error at the protocol level: %s" msg + | `Invalid_recipients -> Fmt.string ppf "Invalid recipients" + let properly_close_tls flow ctx = let encoder = Sendmail_with_starttls.Context_with_tls.encoder ctx in - let tls_error err = `Tls err in let m = - SMTP.Value_with_tls.close encoder |> SMTP.Monad.reword_error tls_error - in + SMTP.Value_with_tls.close encoder + |> SMTP.Monad.reword_error (fun err -> `Tls err) in run flow m + let dot = ".\r\n" + + let receive_mail ?(limit = 0x100000) flow ctx m bounded_stream = + let rec go count () = + if count >= limit then Lwt.return_error `Too_big_data + else + run flow (m ctx) >>? function + | ".." -> bounded_stream#push dot >>= go (count + 3) + | "." -> bounded_stream#close; Lwt.return_ok () + | str -> + let len = String.length str in + let str = str ^ "\r\n" in + bounded_stream#push str >>= + go (count + len + 2) + in + go 0 () + let accept : ?encoder:(unit -> bytes) -> ?decoder:(unit -> bytes) -> ?queue:(unit -> (char, Bigarray.int8_unsigned_elt) Ke.Rke.t) -> ipaddr:Ipaddr.t - -> Flow.t - -> Resolver.t + -> Stack.TCP.flow + -> 'dns + -> 'dns Ptt_common.resolver -> server - -> (unit, error) result IO.t = - fun ?encoder ?decoder ?queue ~ipaddr flow resolver server -> - let ctx = - Sendmail_with_starttls.Context_with_tls.make ?encoder ?decoder ?queue () - in + -> (unit, error) result Lwt.t = + fun ?encoder ?decoder ?queue ~ipaddr flow dns resolver server -> + let ctx = Sendmail_with_starttls.Context_with_tls.make ?encoder ?decoder ?queue () in let m = SMTP.m_relay_init ctx server.info in + let flow = make flow in run flow m >>? function - | `Quit -> properly_close_tls flow ctx >>? fun () -> IO.return (Ok ()) - | `Submission {SMTP.domain_from; from; recipients; _} -> ( - recipients_are_reachable ~ipaddr:server.info.ipaddr resolver + | `Quit -> properly_close_tls flow ctx >>? fun () -> Lwt.return_ok () + | `Send {SMTP.domain_from; from; recipients; _} -> + Ptt_common.recipients_are_reachable ~info:server.info dns resolver (List.map fst recipients) >>= function | true -> let id = succ server in - let key = Messaged.v ~domain_from ~from ~recipients ~ipaddr id in - Md.push server.messaged key >>= fun producer -> + let key = Messaged.key ~domain_from ~from ~recipients ~ipaddr id in + let stream, bounded_stream = Lwt_stream.create_bounded 0x7ff in + server.push (Some (key, stream)); let m = SMTP.m_mail ctx in run flow m >>? fun () -> receive_mail ~limit:(Int64.to_int server.info.size) flow ctx SMTP.(fun ctx -> Monad.recv ctx Value.Payload) - producer + bounded_stream >>? fun () -> let m = SMTP.m_end ctx in run flow m >>? fun `Quit -> - properly_close_tls flow ctx >>? fun () -> IO.return (Ok ()) + properly_close_tls flow ctx >>? fun () -> Lwt.return_ok () | false -> let e = `Invalid_recipients in - let m = - SMTP.m_properly_close_and_fail ctx ~message:"No valid recipients" e - in - run flow m) + let m = SMTP.m_properly_close_and_fail ctx ~message:"No valid recipients" e in + run flow m end diff --git a/lib/relay.mli b/lib/relay.mli index 1b078c3..4ab99b0 100644 --- a/lib/relay.mli +++ b/lib/relay.mli @@ -1,22 +1,15 @@ open Rresult -open Sigs 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) : sig - module Md : module type of Messaged.Make (Scheduler) (IO) - + (Stack : Tcpip.Stack.V4V6) : sig type server - type info = SMTP.info = { - domain: [ `host ] Domain_name.t + type info = SMTP.info = + { domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t - ; size: int64 - } + ; size: int64 } val info : server -> info @@ -24,26 +17,18 @@ module Make val pp_error : error Fmt.t - val resolve_recipients : - domain:[ `host ] Domain_name.t - -> Resolver.t - -> Relay_map.t option - -> Colombe.Forward_path.t list - -> ([ `Domain of [ `host ] Domain_name.t * Mxs.t | `Ipaddr of Ipaddr.t ] - * Aggregate.resolved_elt) - list - IO.t - - val create : info:info -> server - val messaged : server -> Md.t + val create : + info:info + -> server * (Messaged.key * string Lwt_stream.t) Lwt_stream.t * (unit -> unit) val accept : ?encoder:(unit -> bytes) -> ?decoder:(unit -> bytes) -> ?queue:(unit -> (char, Bigarray.int8_unsigned_elt) Ke.Rke.t) -> ipaddr:Ipaddr.t - -> Flow.t - -> Resolver.t + -> Stack.TCP.flow + -> 'dns + -> 'dns Ptt_common.resolver -> server - -> (unit, error) result IO.t + -> (unit, error) result Lwt.t end diff --git a/lib/relay_map.ml b/lib/relay_map.ml deleted file mode 100644 index 3f9e5b1..0000000 --- a/lib/relay_map.ml +++ /dev/null @@ -1,100 +0,0 @@ -let src = Logs.Src.create "ptt.relay-map" - -module Log = (val Logs.src_log src) - -type t = { - postmaster: Emile.mailbox - ; domain: [ `host ] Domain_name.t - ; map: (Emile.local, Colombe.Forward_path.t list) Hashtbl.t -} - -let postmaster {postmaster; _} = postmaster -let domain {domain; _} = domain -let empty ~postmaster ~domain = {postmaster; domain; map= Hashtbl.create 256} - -let add ~local mailbox t = - match Colombe_emile.to_forward_path mailbox with - | 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) - -let exists reverse_path t = - match reverse_path with - | None -> false - | Some {Colombe.Path.local; domain= Domain vs; _} -> - let domain' = Domain_name.(host_exn (of_strings_exn vs)) in - Domain_name.equal t.domain domain' - && Hashtbl.mem t.map (Colombe_emile.of_local local) - | _ -> false - -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); - [] - -let all t = Hashtbl.fold (fun _ vs a -> vs @ a) t.map [] -let ( <.> ) f g x = f (g x) - -let expand t unresolved resolved = - let open Aggregate in - let fold domain elt (unresolved, resolved) = - if not (Domain_name.equal domain t.domain) then - By_domain.add domain elt unresolved, resolved - else - let open Colombe in - let open Forward_path in - let fold (unresolved, resolved) = function - | Postmaster -> ( - let local = t.postmaster.Emile.local in - let domain, _ = t.postmaster.Emile.domain in - match domain with - | `Domain vs -> - let domain = Domain_name.(host_exn <.> of_strings_exn) vs in - add_unresolved ~domain `Postmaster unresolved, resolved - | `Addr (Emile.IPv4 v4) -> - unresolved, add_resolved (Ipaddr.V4 v4) (`Local local) resolved - | `Addr (Emile.IPv6 v6) -> - unresolved, add_resolved (Ipaddr.V6 v6) (`Local local) resolved - | `Addr (Emile.Ext _) | `Literal _ -> unresolved, resolved) - | Domain (Domain.Domain v) -> - let domain = Domain_name.(host_exn <.> of_strings_exn) v in - add_unresolved ~domain `All unresolved, resolved - | Forward_path {Path.domain= Domain.Domain v; Path.local; _} -> - let domain = Domain_name.(host_exn <.> of_strings_exn) v in - let local = Colombe_emile.of_local local in - add_unresolved ~domain (`Local local) unresolved, resolved - | Forward_path {Path.domain= Domain.IPv4 v4; Path.local; _} -> - let local = Colombe_emile.of_local local in - unresolved, add_resolved (Ipaddr.V4 v4) (`Local local) resolved - | Forward_path {Path.domain= Domain.IPv6 v6; Path.local; _} -> - let local = Colombe_emile.of_local local in - unresolved, add_resolved (Ipaddr.V6 v6) (`Local local) resolved - | Domain (Domain.IPv4 v4) -> - unresolved, add_resolved (Ipaddr.V4 v4) `All resolved - | Domain (Domain.IPv6 v6) -> - unresolved, add_resolved (Ipaddr.V6 v6) `All resolved - | Forward_path {Path.domain= Domain.Extension _; _} -> - unresolved, resolved - | Domain (Domain.Extension _) -> unresolved, resolved in - match elt with - | `Postmaster -> List.fold_left fold (unresolved, resolved) [Postmaster] - | `All -> List.fold_left fold (unresolved, resolved) (all t) - | `Local vs -> - 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 - By_domain.fold fold unresolved (By_domain.empty, resolved) diff --git a/lib/relay_map.mli b/lib/relay_map.mli deleted file mode 100644 index 478f9d0..0000000 --- a/lib/relay_map.mli +++ /dev/null @@ -1,43 +0,0 @@ -(** The {i relay-map} allows the user to map an user from a specific domain to - some others mailboxes. Like: - - Any incoming emails to john\@doe.org will be send to: - - - john\@gmail.com - - john\@wanadoo.fr - - To be able to do that, the user must create a {i relay-map} with {!empty}: - [empty ~postmaster ~domain:"doe.org"] and fills the map with - [add ~local:"john" "john@gmail.com" |> add ~local:"john" "john@wanadoo.fr"]. *) - -type t -(** The type of the map. *) - -val postmaster : t -> Emile.mailbox -(** [postmaster m] returns the {i postmaster} of the map which {b is} the - postmaster of {!domain}'s [m]. *) - -val domain : t -> [ `host ] Domain_name.t -(** [domain m] returns the domain handled by [m]. *) - -val empty : postmaster:Emile.mailbox -> domain:[ `host ] Domain_name.t -> t -(** [empty ~postmaster ~domain] creates a map which handles the given [domain]. *) - -val add : local:Emile.local -> Emile.mailbox -> t -> t -(** [add ~local mailbox m] appends a new deliver mailbox to [local] into [m]. *) - -val exists : Colombe.Reverse_path.t -> t -> bool -(** [exists addr t] checks if [addr] exists into the given [t]. *) - -val recipients : local:Emile.local -> t -> Colombe.Forward_path.t list -(** [recipients ~local m] returns all associated mailboxes to [local] in [m]. *) - -val all : t -> Colombe.Forward_path.t list -(** [all m] returns all deliver mailboxes registered into [m]. *) - -val expand : - t - -> Aggregate.unresolved_elt Aggregate.By_domain.t - -> Aggregate.resolved_elt Aggregate.By_ipaddr.t - -> Aggregate.unresolved_elt Aggregate.By_domain.t - * Aggregate.resolved_elt Aggregate.By_ipaddr.t diff --git a/lib/sMTP.ml b/lib/sMTP.ml index bacb7bc..86eb4e9 100644 --- a/lib/sMTP.ml +++ b/lib/sMTP.ml @@ -12,7 +12,7 @@ module Value = struct | Colombe.State.Write {k; buffer; off; len} -> Colombe.State.Write {k= go <.> k; buffer; off; len} | Colombe.State.Return v -> Return v - | Colombe.State.Error err -> Error (`Protocol err) in + | Colombe.State.Error err -> Error err in go (SSMTP.Value.encode ctx v w) let decode_without_tls ctx w = @@ -22,61 +22,57 @@ module Value = struct | Colombe.State.Write {k; buffer; off; len} -> Colombe.State.Write {k= go <.> k; buffer; off; len} | Colombe.State.Return v -> Return v - | Colombe.State.Error err -> Error (`Protocol err) in + | Colombe.State.Error err -> Error err in go (SSMTP.Value.decode ctx w) end module Value_with_tls = Sendmail_with_starttls.Make_with_tls (Value) -module Monad = struct +module Monad + : Logic.MONAD + with type context = Sendmail_with_starttls.Context_with_tls.t + and type error = Value_with_tls.error += struct type context = Sendmail_with_starttls.Context_with_tls.t - include - State.Scheduler (Sendmail_with_starttls.Context_with_tls) (Value_with_tls) + include State.Scheduler (Sendmail_with_starttls.Context_with_tls) (Value_with_tls) end type context = Sendmail_with_starttls.Context_with_tls.t type error = - [ `Protocol of - [ `Protocol of Value.error - | `Tls_alert of Tls.Packet.alert_type - | `Tls_failure of Tls.Engine.failure - | `Tls_closed ] - | `Tls of - [ `Protocol of Value.error - | `Tls_alert of Tls.Packet.alert_type - | `Tls_failure of Tls.Engine.failure - | `Tls_closed ] - | `No_recipients - | `Invalid_recipients + [ `No_recipients + | `Protocol of Value_with_tls.error | `Too_many_bad_commands - | `Too_many_recipients ] + | `Too_many_recipients + | `Tls of Value_with_tls.error ] -let pp_error ppf = function - | `Tls (`Protocol (#Value.error as err)) - | `Protocol (`Protocol (#Value.error as err)) -> - Value.pp_error ppf err - | `Protocol (`Tls_alert alert) | `Tls (`Tls_alert alert) -> +let pp_value_with_tls_error ppf = function + | `Tls_alert alert -> Fmt.pf ppf "TLS alert: %s" (Tls.Packet.alert_type_to_string alert) - | `Protocol (`Tls_failure failure) | `Tls (`Tls_failure failure) -> + | `Tls_failure failure -> Fmt.pf ppf "TLS failure: %s" (Tls.Engine.string_of_failure failure) - | `Tls `Tls_closed | `Protocol `Tls_closed -> + | `Tls_closed -> Fmt.string ppf "TLS connection closed by peer" + | `Value (#Value.error as err) -> Value.pp_error ppf err + +let pp_error ppf = function + | `Tls (#Value_with_tls.error as err) + | `Protocol (#Value_with_tls.error as err) -> + pp_value_with_tls_error ppf err | `No_recipients -> Fmt.string ppf "No recipients" - | `Invalid_recipients -> Fmt.string ppf "Invalid recipients" | `Too_many_bad_commands -> Fmt.string ppf "Too many bad commands" | `Too_many_recipients -> Fmt.string ppf "Too many recipients" -type info = Logic.info = { - domain: [ `host ] Domain_name.t +type info = Ptt_common.info = { + domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t ; size: int64 } -type submission = Logic.submission = { +type email = Logic.email = { from: Messaged.from ; recipients: (Forward_path.t * (string * string option) list) list ; domain_from: Domain.t @@ -88,17 +84,17 @@ let m_relay_init ctx info = match info.tls with | None -> let open Monad in - send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] + send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] >>= fun () -> m_relay_init ctx info | Some tls -> let open Monad in let* _from_domain = - send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] + send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] >>= fun () -> recv ctx Value.Helo in let capabilities = [ - politely ~domain:info.Logic.domain ~ipaddr:info.Logic.ipaddr; "8BITMIME" - ; "SMTPUTF8"; "STARTTLS"; Fmt.str "SIZE %Ld" info.Logic.size + politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" + ; "SMTPUTF8"; "STARTTLS"; Fmt.str "SIZE %Ld" info.Ptt_common.size ] in let* () = send ctx Value.PP_250 capabilities in let reset = ref 0 and bad = ref 0 in @@ -132,19 +128,19 @@ let m_submission_init ctx info ms = match info.tls with | None -> let open Monad in - send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] + send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] >>= fun () -> m_submission_init ctx info ms | Some tls -> let open Monad in let* _from_domain = - send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] + send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] >>= fun () -> recv ctx Value.Helo in let capabilities = [ - politely ~domain:info.Logic.domain ~ipaddr:info.Logic.ipaddr; "8BITMIME" + politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" ; "SMTPUTF8"; "STARTTLS" ; Fmt.str "AUTH %a" Fmt.(list ~sep:(const string " ") Mechanism.pp) ms - ; Fmt.str "SIZE %Ld" info.Logic.size + ; Fmt.str "SIZE %Ld" info.Ptt_common.size ] in let* () = send ctx Value.PP_250 capabilities in let reset = ref 0 and bad = ref 0 in diff --git a/lib/sMTP.mli b/lib/sMTP.mli index b6b1200..73c2b03 100644 --- a/lib/sMTP.mli +++ b/lib/sMTP.mli @@ -8,48 +8,39 @@ module Value : sig Encoder.encoder -> 'x send -> 'x - -> (unit, [> `Protocol of SSMTP.Value.error ]) t + -> (unit, error) t val decode_without_tls : - Decoder.decoder -> 'x recv -> ('x, [> `Protocol of SSMTP.Value.error ]) t + Decoder.decoder -> 'x recv -> ('x, error) t end module Value_with_tls : - module type of Sendmail_with_starttls.Make_with_tls (Value) + module type of Sendmail_with_starttls.Make_with_tls (Value) -module Monad : - module type of - State.Scheduler (Sendmail_with_starttls.Context_with_tls) (Value_with_tls) +module Monad : Logic.MONAD + with type context = Sendmail_with_starttls.Context_with_tls.t + and type error = Value_with_tls.error type context = Sendmail_with_starttls.Context_with_tls.t type error = - [ `Tls of - [ `Protocol of Value.error - | `Tls_alert of Tls.Packet.alert_type - | `Tls_failure of Tls.Engine.failure - | `Tls_closed ] - | `Protocol of - [ `Protocol of Value.error - | `Tls_alert of Tls.Packet.alert_type - | `Tls_failure of Tls.Engine.failure - | `Tls_closed ] - | `No_recipients - | `Invalid_recipients + [ `No_recipients + | `Protocol of Value_with_tls.error | `Too_many_bad_commands - | `Too_many_recipients ] + | `Too_many_recipients + | `Tls of Value_with_tls.error ] val pp_error : error Fmt.t -type info = Logic.info = { - domain: [ `host ] Domain_name.t +type info = Ptt_common.info = { + domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t ; size: int64 } -type submission = Logic.submission = { +type email = Logic.email = { from: Messaged.from ; recipients: (Forward_path.t * (string * string option) list) list ; domain_from: Domain.t @@ -71,13 +62,13 @@ val m_submission : -> ( [> `Quit | `Authentication of Domain.t * Mechanism.t | `Authentication_with_payload of Domain.t * Mechanism.t * string ] - , [> error ] ) + , [> error ]) Colombe.State.t val m_relay : context -> domain_from:Domain.t - -> ([> `Quit | `Submission of submission ], [> error ]) Colombe.State.t + -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_mail : context -> (unit, [> error ]) Colombe.State.t val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t @@ -85,7 +76,7 @@ val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t val m_relay_init : context -> info - -> ([> `Quit | `Submission of submission ], [> error ]) Colombe.State.t + -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_submission_init : context @@ -94,5 +85,5 @@ val m_submission_init : -> ( [> `Quit | `Authentication of Domain.t * Mechanism.t | `Authentication_with_payload of Domain.t * Mechanism.t * string ] - , [> error ] ) + , [> error ]) Colombe.State.t diff --git a/lib/sSMTP.ml b/lib/sSMTP.ml index fd48d90..2b46868 100644 --- a/lib/sSMTP.ml +++ b/lib/sSMTP.ml @@ -89,15 +89,15 @@ let pp_error ppf = function | `No_recipients -> Fmt.string ppf "No recipients" | `Too_many_recipients -> Fmt.string ppf "Too many recipients" -type info = Logic.info = { - domain: [ `host ] Domain_name.t +type info = Ptt_common.info = { + domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t ; size: int64 } -type submission = Logic.submission = { +type email = Logic.email = { from: Messaged.from ; recipients: (Forward_path.t * (string * string option) list) list ; domain_from: Domain.t @@ -107,10 +107,10 @@ include Logic.Make (Monad) let m_submission_init ctx info ms = let open Monad in - let* () = send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] in + let* () = send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] in m_submission_init ctx info ms let m_relay_init ctx info = let open Monad in - let* () = send ctx Value.PP_220 [Domain_name.to_string info.Logic.domain] in + let* () = send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] in m_relay_init ctx info diff --git a/lib/sSMTP.mli b/lib/sSMTP.mli index bdfbef7..4c8f0d4 100644 --- a/lib/sSMTP.mli +++ b/lib/sSMTP.mli @@ -23,15 +23,15 @@ type error = val pp_error : error Fmt.t -type info = Logic.info = { - domain: [ `host ] Domain_name.t +type info = Ptt_common.info = { + domain: Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t ; size: int64 } -type submission = Logic.submission = { +type email = Logic.email = { from: Messaged.from ; recipients: (Forward_path.t * (string * string option) list) list ; domain_from: Domain.t @@ -59,7 +59,7 @@ val m_submission : val m_relay : context -> domain_from:Domain.t - -> ([> `Quit | `Submission of submission ], [> error ]) Colombe.State.t + -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_mail : context -> (unit, [> error ]) Colombe.State.t val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t @@ -67,7 +67,7 @@ val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t val m_relay_init : context -> info - -> ([> `Quit | `Submission of submission ], [> error ]) Colombe.State.t + -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_submission_init : context diff --git a/lib/sendmail.ml b/lib/sendmail.ml deleted file mode 100644 index b70b360..0000000 --- a/lib/sendmail.ml +++ /dev/null @@ -1,115 +0,0 @@ -type recipients = - { domain : [ `Ipaddr of Ipaddr.t | `Domain of [ `host ] Domain_name.t ] - ; locals : [ `All | `Some of Emile.local list ] } - -(* 1: recipients - * | domain: robur.coop - * | locals: `Some [ reynir; dinosaure ] *) - -let warn_about_an_unreachable_mail_exchange ~domain ~mail_exchange msg = - Log.warn @@ fun m -> m "Impossible to resolve %a, a mail exchange server for %a: %s" - Domain_name.pp mail_exchange Domain_name.pp domain msg - -let warn_that_starttls_is_unavailable ~domain ~ipaddr = - Log.warn @@ fun m -> m "STARTTLS is unavailable for %a (%a)" Domain_name.pp domain Ipaddr.pp ipaddr - -type error = - [ `No_mail_exchange_servers_for of [ `host ] Domain_name.t ] - -(* recipients -> Colombe.Forward_path.t list *) -let recipients_to_forward_paths ~domain recipients = - let open Colombe in - let open Forward_path in - let local_to_forward_path local = - let local = List.map (function `Atom x -> x | `String x -> x) local in - { Path.local= `Dot_string local; domain; rest= [] } in - match recipients.locals with - | `All -> [ Domain domain ] - | `Some locals -> Lust.map local_to_forward_path locals - -let single_sendmail t stack ipaddr sender recipients stream = - sendmail stack ipaddr sender recipients stream >>= function - | Error `STARTTLS_unavailable -> - warn_that_starttls_is_unavailable ipaddr; - sendmail_without_tls stack ipaddr sender recipients stream - | Ok () -> Lwt.return_ok () - | Error err -> Lwt.return_error err - -(* example: - * To: reynir@robur.coop, dinosaure@robur.coop, romain.calascibetta@gmail.com - * - * Hello World! - * - * -> incoming email with one stream with "Hello World!" - * -> signing - * -> our ((stream of DKIM-fieldi) ^ (incoming stream "Hello World")) + recipients - * | reynir@robur.coop, dinosaure@robur.coop, romain.calascibetta@gmail.com - * -> aggregate - * | { domain= robur.coop; locals= [ reynir; dinosaure ] } - * | { domain= gmail.com; locals= [ romain.calascibetta ] } - * -> multiplex the incoming stream to multiple streams (in our example, 2) - * -> Lwt_list.iter push_to_send [ recipients with robur.coop, copied incoming stream - * ; recipients with gmail.com, copied incoming stream ] - * - * another thread is: get_emails_to_send - * -> Lwt_stream.get incoming_emails_to_send : (recipients * string Lwt_stream.t) Lwt_stream.t - * -> Some (recipients, stream) - * -> sendmail recipients stream - * - * MX gmail.com - * gmail-smtp-in.l.google.com => A: 108.177.15.27 - * alt2.gmail-smtp-in.l.google.com => A: 142.251.9.26 - *) - -type t = - { stream : _ Lwt_stream.t - ; info : Ptt.info } - -let sendmail t resolver dns sender (recipients : recipients) (data : string Lwt_stream.t) = - let ( let** ) = Lwt_result.bind in - let ( let* ) = Lwt.bind in - let domain = recipients.domain in - let** mx_domain, mxs = - match recipients.domain with - | `Ipaddr (Ipaddr.V4 v4 as mx_ipaddr) -> - Lwt.return_ok (Domain.IPv4 v4, Ptt.Mxs.(v ~preference:0 mx_ipaddr)) - | `Ipaddr (Ipaddr.V6 v6 as mx_ipaddr) -> - Lwt.return_ok (Domain.IPv6 v6, Ptt.Mxs.(v ~preference:0 mx_ipaddr)) - | `Domain domain -> - let* result = resolver.getmxbyname dns host in - match result with - | Ok mxs -> - let mxs = (Fun.flip Lwt_list.fold_left_s (Dns.Mx_set.to_list mxs)) - begin fun acc ({ Dns.Mx.mail_exchange; _ } as mx) -> - resolver.getabyname dns mail_exchange >>= function - | Ok ipaddr -> Lwt.return ((mx, ipaddr) :: acc) - | Error (`Msg err) -> - warn_about_an_unreachable_mail_exchange ~domain ~mail_exchange msg; - Lwt.return acc end |> Mxs.vs in - Domain.Domain (Domain_name.to_strings domain), mxs in - | Error (`Msg err) -> - Lwt.return_error (`No_mail_exchange_servers_for domain) - let** () = - if Mxs.is_empty mxs - then Lwt.return_error (`No_mail_exchange_servers_for recipients.domain) - else Lwt.return_ok () in - let recipients = recipients_to_forward_paths recipients in - let mxs = Mxs.to_list mxs in - let rec go = function - | [] -> - let recipients = recipients_of_sender sender in - Lwt_stream.push t.stream (recipients, error_sendmail); - Lwt.return_unit - | ((mx : Dns.Mx.t), ipaddr) :: mxs -> - let* result = single_sendmail t stack ~domain ipaddr sender recipients stream in - match result with - | Ok () -> Lwt.return_ok () - | Error err -> go mxs in - go None mxs - -let rec smtp_send_emails t resolver dns = - Lwt_stream.get t.stream >>= function - | Some (sender, recipients, data) -> - sendmail t resolver dns sender recipients data >>= fun () -> - smtp_send_emails t resolver dns - | None -> Lwt.return_unit diff --git a/lib/spartacus.ml b/lib/spartacus.ml index 527ec54..983adba 100644 --- a/lib/spartacus.ml +++ b/lib/spartacus.ml @@ -1,91 +1,97 @@ open Rresult -open Ptt_tuyau.Lwt_backend open Lwt.Infix let src = Logs.Src.create "ptt.spartacus" module Log : Logs.LOG = (val Logs.src_log src) +let ( $ ) f g = fun x -> f (g x) + module Make (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) = + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) = struct - include Ptt_tuyau.Client (Stack) - module Flow = Rdwr.Make (Stack.TCP) - 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) + module Filter = Ptt.Relay.Make (Stack) + module Server = Ptt_server.Make (Time) (Stack) + module Sendmail = Ptt_sendmail.Make (Pclock) (Stack) (Happy_eyeballs) - let smtp_filter_service ~pool ?stop ~port stack resolver conf_server = - Server.init ~port stack >>= fun service -> - let handler pool flow = - let ip, port = Stack.TCP.dst flow in - let v = Flow.make flow in - Lwt.catch + let resolver = + let open Ptt_common in + let getmxbyname dns domain_name = + Dns_client.getaddrinfo dns Dns.Rr_map.Mx domain_name + >|= Result.map snd in + let gethostbyname dns domain_name = + let ipv4 = + Dns_client.gethostbyname dns domain_name + >|= Result.map (fun ipv4 -> Ipaddr.V4 ipv4) in + let ipv6 = + Dns_client.gethostbyname6 dns domain_name + >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in + Lwt.all [ ipv4; ipv6 ] >|= function + | [ _; (Ok _ as ipv6) ] -> ipv6 + | [ (Ok _ as ipv4); Error _ ] -> ipv4 + | [ (Error _ as err); _ ] -> err + | [] | [_] | _ :: _ :: _ -> assert false in + { getmxbyname; gethostbyname } + + let server_job ~pool ?stop ~port stack dns server close = + let handler flow = + let ipaddr, port = Stack.TCP.dst flow in + Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, queue) -> Filter.accept ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr:ip v - resolver conf_server + ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr flow + dns resolver server >|= R.reword_error (R.msgf "%a" Filter.pp_error) >>= fun res -> Stack.TCP.close flow >>= fun () -> Lwt.return res) - (function - | Failure err -> Lwt.return (R.error_msg err) - | exn -> Lwt.return (Error (`Exn exn))) + (fun () -> Stack.TCP.close flow) >>= function - | Ok () -> - Log.info (fun m -> m "<%a:%d> submitted a message" Ipaddr.pp ip port); - Lwt.return () + | Ok () -> Lwt.return () | Error (`Msg err) -> - 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)); + Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in - let (`Initialized fiber) = - Server.serve_when_ready ?stop ~handler:(handler pool) service in - fiber + Server.init ~port stack >>= fun service -> + Server.serve_when_ready ?stop ~handler service + |> fun (`Initialized job) -> + let job = job >|= close in job - let smtp_logic ~pool ~info ~tls stack resolver messaged map = + let logic_job ~info map (ic, oc) = let rec go () = - Filter.Md.await messaged >>= fun () -> - Filter.Md.pop messaged >>= function - | None -> Lwt.pause () >>= go - | Some (key, queue, consumer) -> - let label_and_transmit () = - let consumer = - Lwt_stream.from @@ fun () -> - consumer () >|= function - | Some (str, off, len) -> Some (String.sub str off len) - | None -> None in - Spamtacus_mirage.rank consumer >>= function + Lwt_stream.get ic >>= function + | None -> oc None; Lwt.return_unit + | Some (key, stream) -> + let filter () = + let backup = Lwt_stream.clone stream in + Spamtacus_mirage.rank stream >>= function | Error (`Msg err) -> 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)) - >>= fun recipients -> - let consumer' () = - 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 - in - Lwt.async label_and_transmit; + Lwt.return backup + | Ok (_label, stream) -> + Lwt.return stream in + filter () >>= fun stream -> + let sender, _ = Ptt.Messaged.from key in + let recipients = Ptt.Messaged.recipients key in + let recipients = List.map fst recipients in + let recipients = Ptt_map.expand ~info map recipients in + let recipients = Ptt_aggregate.to_recipients ~info recipients in + let id = Ptt_common.id_to_messageID ~info (Ptt.Messaged.id key) in + let elts = List.map (fun recipients -> + { Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id }) recipients in + List.iter (oc $ Option.some) elts; Lwt.pause () >>= go in go () - let fiber ?(limit = 20) ?stop ?locals ~port ~tls stack resolver info = - let conf_server = Filter.create ~info in - let messaged = Filter.messaged conf_server in + let job ?(limit = 20) ?stop ~locals ~port ~tls ~info stack dns he = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create Colombe.Encoder.io_buffer_size in @@ -98,9 +104,12 @@ struct let decoder = Bytes.create Colombe.Decoder.io_buffer_size in let queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char in Lwt.return (encoder, decoder, queue) in + let pool1 = + { Ptt_sendmail.pool= fun fn -> Lwt_pool.use pool1 fn } in + let ic_server, stream0, close0 = Filter.create ~info in + let oc_server, push0 = Sendmail.v ~resolver ~pool:pool1 ~info tls in Lwt.join - [ - smtp_filter_service ~pool:pool0 ?stop ~port stack resolver conf_server - ; smtp_logic ~pool:pool1 ~info ~tls stack resolver messaged locals - ] + [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0) + ; Sendmail.job dns he oc_server ] end diff --git a/lib/spartacus.mli b/lib/spartacus.mli index fc9aeab..e0046ad 100644 --- a/lib/spartacus.mli +++ b/lib/spartacus.mli @@ -8,16 +8,18 @@ module Make (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) : sig - val fiber : + (Stack : Tcpip.Stack.V4V6) + (Dns_client : Dns_client_mirage.S) + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig + val job : ?limit:int -> ?stop:Lwt_switch.t - -> ?locals:Ptt.Relay_map.t + -> locals:Ptt_map.t -> port:int -> tls:Tls.Config.client + -> info:Ptt_common.info -> Stack.TCP.t - -> Resolver.t - -> Ptt.Logic.info + -> Dns_client.t + -> Happy_eyeballs.t -> unit Lwt.t end diff --git a/lib/submission.ml b/lib/submission.ml index 55f03a8..da22806 100644 --- a/lib/submission.ml +++ b/lib/submission.ml @@ -1,41 +1,38 @@ -open Sigs open Rresult +open Lwt.Infix + +let ( >>? ) = Lwt_result.bind let src = Logs.Src.create "ptt.submission" module Log = (val Logs.src_log src : Logs.LOG) -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) = -struct - include Common.Make (Scheduler) (IO) (Flow) (Resolver) - module Md = Messaged.Make (Scheduler) (IO) - - type 'k server = { - info: info - ; messaged: Md.t +module Make (Stack : Tcpip.Stack.V4V6) = struct + module Tls_flow = Tls_mirage.Make (Stack.TCP) + module TLS = Ptt_flow.Make (Tls_flow) + module TCP = Ptt_flow.Make (Stack.TCP) + + type 'k server = + { info: info + ; messaged: Messaged.t + ; push: ((Messaged.key * string Lwt_stream.t) option -> unit) ; mechanisms: Mechanism.t list - ; authenticator: (Scheduler.t, 'k) Authentication.t - ; mutable count: int64 - } + ; authenticator: 'k Authentication.t + ; mutable count: int64 } - and info = SSMTP.info = { - domain: [ `host ] Domain_name.t + and info = SSMTP.info = + { domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t - ; size: int64 - } + ; size: int64 } let info {info; _} = info let create ~info ~authenticator mechanisms = - {info; messaged= Md.create (); mechanisms; authenticator; count= 0L} - - let messaged {messaged; _} = messaged + let messaged, push = Lwt_stream.create () in + let close () = push None in + {info; messaged; push; mechanisms; authenticator; count= 0L}, messaged, close let succ server = let v = server.count in @@ -43,34 +40,54 @@ struct v type error = - [ `Error of [ SSMTP.error | `Invalid_recipients | `Too_many_tries ] - | `Too_big_data ] + [ SSMTP.error + | `Too_big_data + | `Too_many_tries + | `Flow of string + | `Invalid_recipients ] + + type 'err runner = Runner : + { run : 'a. 'flow -> ('a, 'err) Colombe.State.t -> ('a, 'err) result Lwt.t + ; flow : 'flow } -> 'err runner + + let flowf fmt = Fmt.kstr (fun str -> `Flow str) fmt let pp_error ppf = function - | `Error (#SSMTP.error as err) -> SSMTP.pp_error ppf err - | `Error `Invalid_recipients -> Fmt.pf ppf "Invalid recipients" - | `Error `Too_many_tries -> Fmt.pf ppf "Too many tries" + | #SSMTP.error as err -> SSMTP.pp_error ppf err | `Too_big_data -> Fmt.pf ppf "Too big data" + | `Too_many_tries -> Fmt.pf ppf "Too many tries" + | `Flow msg -> Fmt.pf ppf "Error at the protocol level: %s" msg + | `Invalid_recipients -> Fmt.string ppf "Invalid recipients" + + let to_local local = + if List.exists (function `String _ -> true | _ -> false) local + then + let sstr = List.map (function `Atom str -> str | `String str -> str) local in + let str = String.concat "." sstr in + `String str + else + let ws, _ = (Fun.flip List.partition_map local) @@ function + | `Atom str -> Either.left str + | _ -> Either.right () in + `Dot_string ws - let authentication ctx ~domain_from flow random hash server ?payload mechanism - = + let authentication ctx ~domain_from (Runner { run; flow; }) + random hash server ?payload mechanism = let rec go limit ?payload m = if limit >= 3 then let e = `Too_many_tries in - let m = - SSMTP.m_properly_close_and_fail ctx ~message:"Too many tries" e in + let m = SSMTP.m_properly_close_and_fail ctx ~message:"Too many tries" e in run flow m else match m, payload with - | Mechanism.PLAIN, Some v -> ( - Authentication.decode_authentication scheduler hash + | Mechanism.PLAIN, Some v -> begin + Authentication.decode_authentication hash (Authentication.PLAIN None) server.authenticator v - |> Scheduler.prj >>= function - | Ok true -> + | Ok (user, 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 -> ( + run flow m >>? fun () -> Lwt.return_ok (`Authenticated (to_local user)) + | (Error _ | Ok (_, false)) as res -> begin let () = match res with | Error (`Msg err) -> @@ -82,16 +99,16 @@ struct 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) + | `Quit -> Lwt.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)) - | Mechanism.PLAIN, None -> ( + go (limit + 1) ~payload m end end + | Mechanism.PLAIN, None -> begin let stamp = Bytes.create 0x10 in - generate ?g:random stamp 0x10; + Mirage_crypto_rng.generate_into ?g:random stamp 0x10; let stamp = Bytes.unsafe_to_string stamp in Log.debug (fun m -> m "Generate the stamp %S." stamp); let m = @@ -101,14 +118,14 @@ struct >>= 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.decode_authentication hash (Authentication.PLAIN (Some stamp)) server.authenticator v - |> Scheduler.prj >>= function - | Ok true -> + | Ok (user, 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 -> ( + run flow m >>? fun () -> + Lwt.return_ok (`Authenticated (to_local user)) + | (Error _ | Ok (_, false)) as res -> let () = match res with | Error (`Msg err) -> @@ -120,70 +137,98 @@ struct 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) + | `Quit -> Lwt.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 (limit + 1) ~payload m end in go 1 ?payload mechanism type authentication = [ `Authentication_with_payload of Colombe.Domain.t * Mechanism.t * string | `Authentication of Colombe.Domain.t * Mechanism.t ] + let dot = ".\r\n" + + let receive_mail ?(limit = 0x100000) (Runner { run; flow}) ctx m bounded_stream = + let rec go count () = + if count >= limit then Lwt.return_error `Too_big_data + else + run flow (m ctx) >>? function + | ".." -> bounded_stream#push dot >>= go (count + 3) + | "." -> bounded_stream#close; Lwt.return_ok () + | str -> + let len = String.length str in + let str = str ^ "\r\n" in + bounded_stream#push str >>= + go (count + len + 2) + in + go 0 () + let accept : ?encoder:(unit -> bytes) -> ?decoder:(unit -> bytes) -> ipaddr:Ipaddr.t - -> Flow.t - -> Resolver.t + -> Stack.TCP.flow + -> 'dns + -> 'dns Ptt_common.resolver -> Mirage_crypto_rng.g option -> 'k Digestif.hash -> 'k server - -> (unit, error) result IO.t = - fun ?encoder ?decoder ~ipaddr flow resolver random hash server -> + -> (unit, error) result Lwt.t = + fun ?encoder ?decoder ~ipaddr flow dns resolver random hash server -> let ctx = Colombe.State.Context.make ?encoder ?decoder () in let m = SSMTP.m_submission_init ctx server.info server.mechanisms in + begin match server.info.SSMTP.tls with + | None -> Lwt.return_ok (Runner { run= TCP.run; flow= TCP.make flow }) + | Some tls -> + Tls_flow.server_of_flow tls flow + >|= Result.map_error (flowf "%a" Tls_flow.pp_write_error) + >>? fun flow -> + Lwt.return_ok (Runner { run= TLS.run; flow= TLS.make flow }) end + >>? fun (Runner { run; flow} as runner) -> run flow m >>? function - | `Quit -> IO.return (Ok ()) - | #authentication as auth -> ( + | `Quit -> Lwt.return_ok () + | #authentication as auth -> let domain_from, m, payload = match auth with | `Authentication_with_payload (domain_from, m, v) -> domain_from, m, Some v | `Authentication (domain_from, m) -> domain_from, m, None in - authentication ctx ~domain_from flow random hash server ?payload m + authentication ctx ~domain_from runner random hash server ?payload m >>? function - | `Quit -> IO.return (Ok ()) - | `Authenticated -> ( + | `Quit -> Lwt.return_ok () + | `Authenticated user -> let m = SSMTP.m_relay ctx ~domain_from in run flow m >>? function - | `Quit -> IO.return (Ok ()) - | `Submission {domain_from; from; recipients; _} -> ( - recipients_are_reachable ~ipaddr:server.info.ipaddr resolver + | `Quit -> Lwt.return_ok () + | `Send {SSMTP.domain_from; recipients; from; _} -> + Ptt_common.recipients_are_reachable ~info:server.info dns resolver (List.map fst recipients) >>= function - | true -> + | true -> begin let id = succ server in - let key = Messaged.v ~domain_from ~from ~recipients ~ipaddr id in - Md.push server.messaged key >>= fun producer -> + let from = + let sender = Colombe.Path.{ local= user; domain= server.info.SSMTP.domain; rest= [] } in + Some sender, snd from in + let key = Messaged.key ~domain_from ~from ~recipients ~ipaddr id in + let stream, bounded_stream = Lwt_stream.create_bounded 0x7ff in + server.push (Some (key, stream)); 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 + runner ctx SSMTP.(fun ctx -> Monad.recv ctx Value.Payload) - producer + bounded_stream >>? fun () -> let m = SSMTP.m_end ctx in - run flow m >>? fun `Quit -> IO.return (Ok ()) + run flow m >>? fun `Quit -> Lwt.return_ok () end | false -> let e = `Invalid_recipients in - let m = - SSMTP.m_properly_close_and_fail ctx ~message:"No valid recipients" - e in - run flow m))) + let m = SSMTP.m_properly_close_and_fail ctx ~message:"No valid recipients" e in + run flow m end diff --git a/lib/submission.mli b/lib/submission.mli index b287790..ccb9716 100644 --- a/lib/submission.mli +++ b/lib/submission.mli @@ -1,22 +1,14 @@ open Rresult -open Sigs - -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) : sig - module Md : module type of Messaged.Make (Scheduler) (IO) +module Make (Stack : Tcpip.Stack.V4V6) : sig type 'k server - type info = SSMTP.info = { - domain: [ `host ] Domain_name.t + type info = SSMTP.info = + { domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t - ; size: int64 - } + ; size: int64 } val info : 'k server -> info @@ -24,34 +16,23 @@ module Make val pp_error : error Fmt.t - val resolve_recipients : - domain:[ `host ] Domain_name.t - -> Resolver.t - -> Relay_map.t option - -> Colombe.Forward_path.t list - -> ([ `Domain of [ `host ] Domain_name.t * Mxs.t | `Ipaddr of Ipaddr.t ] - * Aggregate.resolved_elt) - list - IO.t - val create : info:info - -> authenticator:(Scheduler.t, 'k) Authentication.t + -> authenticator:'k Authentication.t -> Mechanism.t list - -> 'k server - - val messaged : 'k server -> Md.t + -> 'k server * (Messaged.key * string Lwt_stream.t) Lwt_stream.t * (unit -> unit) val accept : ?encoder:(unit -> bytes) -> ?decoder:(unit -> bytes) -> ipaddr:Ipaddr.t - -> Flow.t - -> Resolver.t + -> Stack.TCP.flow + -> 'dns + -> 'dns Ptt_common.resolver -> Mirage_crypto_rng.g option -> 'k Digestif.hash -> 'k server - -> (unit, error) result IO.t + -> (unit, error) result Lwt.t (** [accept flow resolver random alg server] is a simple SMTP process which accepts an incoming email iff the client is authentified. The method to safely check the password uses the hash algorithm [alg] and private diff --git a/test/dune b/test/dune index 6d83800..0618a48 100644 --- a/test/dune +++ b/test/dune @@ -2,7 +2,7 @@ (name test) (modules test) (libraries logs.fmt mirage-crypto-rng.unix ipaddr.unix bos threads mrmime - ptt ptt.tuyau alcotest-lwt)) + mirage-time-unix mirage-clock-unix ptt ptt.server alcotest-lwt tcpip.stack-socket)) (rule (alias runtest) diff --git a/test/test.ml b/test/test.ml index 7f986be..bc793b9 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,11 +1,25 @@ let () = Printexc.record_backtrace true -let reporter = Logs_fmt.reporter () let () = Fmt.set_utf_8 Fmt.stdout true let () = Fmt.set_utf_8 Fmt.stderr true let () = Fmt.set_style_renderer Fmt.stdout `Ansi_tty let () = Fmt.set_style_renderer Fmt.stderr `Ansi_tty let () = Logs.set_level ~all:true (Some Logs.Debug) -let () = Logs.set_reporter reporter + +let reporter ppf = + let report src level ~over k msgf = + let k _ = + over () ; + k () in + let with_metadata header _tags k ppf fmt = + Format.kfprintf k ppf + ("%a[%a]: " ^^ fmt ^^ "\n%!") + Logs_fmt.pp_header (level, header) + Fmt.(styled `Magenta string) + (Logs.Src.name src) in + msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in + { Logs.report } + +let () = Logs.set_reporter (reporter Fmt.stderr) let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore @@ -62,77 +76,63 @@ let auth0 = |> Map.add Local.(v [w "gemma"]) Digestif.(digest_string SHA1 "") in let f username password = match Map.find username m with - | v -> Scheduler.inj (Lwt.return Digestif.(equal SHA1 password v)) - | exception Not_found -> Scheduler.inj (Lwt.return false) in + | v -> Lwt.return Digestif.(equal SHA1 password v) + | exception Not_found -> Lwt.return false in Ptt.Authentication.v f let authentication_test_0 = Alcotest_lwt.test_case "authentication 0" `Quick @@ fun _sw () -> + let open Lwt.Infix in let auth hash mechanism authenticator fmt = Fmt.kstr (fun payload -> - Ptt.Authentication.decode_authentication lwt hash mechanism + Ptt.Authentication.decode_authentication hash mechanism authenticator - (Base64.encode_exn payload) - |> Scheduler.prj) + (Base64.encode_exn payload)) fmt in let plain_none = Ptt.Authentication.PLAIN None in - let open Lwt.Infix in - auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" - "toto" - >>= fun romain -> + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" "toto" + >|= Result.map snd >>= 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 -> + >|= Result.map snd >>= 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 -> + >|= Result.map snd >>= 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 -> + >|= Result.map snd >>= fun hannes -> Alcotest.(check (result bool msg)) "hannes" (Ok true) hannes; - auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "gemma" "" >>= fun gemma -> + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "gemma" "" + >|= Result.map snd >>= 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 -> + auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" "titi" + >|= Result.map snd >>= 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 -> + >|= Result.map snd >>= 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 "stamp\000%s\000%s" "romain.calascibetta" "toto" + >|= Result.map snd >>= 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" + >|= Result.map snd >>= 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" + >|= Result.map snd >>= 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; + >|= Result.map snd >>= 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" +let x25519 = Colombe.Domain.(Domain [ "x25519"; "net" ]) +let gmail = Colombe.Domain.(Domain [ "gmail"; "com" ]) let recoil = Domain_name.(host_exn <.> of_string_exn) "recoil.org" let nqsb = Domain_name.(host_exn <.> of_string_exn) "nqsb.io" let gazagnaire = Domain_name.(host_exn <.> of_string_exn) "gazagnaire.org" +(* let pp_unresolved ppf = function | `All -> Fmt.string ppf "" | `Postmaster -> Fmt.string ppf "" @@ -154,14 +154,10 @@ let unresolved = Alcotest.testable pp_unresolved equal_unresolved let aggregate_test_0 = Alcotest_lwt.test_case "aggregate 0" `Quick @@ fun _sw () -> let open Mrmime.Mailbox in - let m0 = - Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"]) - in + let m0 = Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"]) in let m1 = Local.[w "thomas"] @ Domain.(domain, [a "gazagnaire"; a "org"]) in let m2 = Local.[w "anil"] @ Domain.(domain, [a "recoil"; a "org"]) in - let m3 = - Local.[w "gemma"; w "d"; w "gordon"] @ Domain.(domain, [a "gmail"; a "com"]) - in + let m3 = Local.[w "gemma"; w "d"; w "gordon"] @ Domain.(domain, [a "gmail"; a "com"]) in let ms = List.map (Rresult.R.get_ok <.> Colombe_emile.to_forward_path) @@ -345,6 +341,7 @@ let messaged_test_1 = Alcotest.(check bool) "stream consumed" res2 true; Alcotest.(check int) "(producer & consumer)" !last 1; Lwt.return_unit +*) let put_crlf x = x ^ "\r\n" @@ -424,11 +421,14 @@ let smtp_test_0 = let smtp_test_1 = Alcotest_lwt.test_case "SMTP (relay) 1" `Quick @@ fun _sw () -> let rdwr, check = - rdwr_from_flows ["EHLO gmail.com"; "QUIT"] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "221 Bye, buddy!" - ] in + rdwr_from_flows + [ "EHLO gmail.com"; "QUIT" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250 SIZE 16777216" + ; "221 Bye, buddy!" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -444,7 +444,7 @@ let smtp_test_1 = Alcotest.(check unit) "empty stream" (check ()) (); Alcotest.(check pass) "quit" () (); Lwt.return_unit - | Ok (`Submission _) -> Alcotest.fail "Unexpected submission" + | Ok (`Send _) -> Alcotest.fail "Unexpected submission" | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err | Error `Connection_close -> Alcotest.fail "Unexpected connection close" @@ -453,12 +453,16 @@ let smtp_test_2 = Alcotest_lwt.test_case "SMTP (relay) 2" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - ["EHLO gmail.com"; "RSET"; "QUIT"] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "250 Yes buddy!" - ; "221 Bye, buddy!" - ] in + [ "EHLO gmail.com" + ; "RSET" + ; "QUIT" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250 SIZE 16777216" + ; "250 Yes buddy!" + ; "221 Bye, buddy!" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -474,7 +478,7 @@ let smtp_test_2 = Alcotest.(check unit) "empty stream" (check ()) (); Alcotest.(check pass) "quit" () (); Lwt.return_unit - | Ok (`Submission _) -> Alcotest.fail "Unexpected submission" + | Ok (`Send _) -> Alcotest.fail "Unexpected submission" | Error (`Error err) -> Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err | Error `Connection_close -> Alcotest.fail "Unexpected connection close" @@ -483,22 +487,23 @@ let smtp_test_3 = Alcotest_lwt.test_case "SMTP (relay) 3" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - [ - "EHLO gmail.com"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET" + [ "EHLO gmail.com" ; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET" ; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET" - ] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "250 Yes buddy!" + ; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250 SIZE 16777216" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" ; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!"; "250 Yes buddy!" - ; "554 You reached the limit buddy!" - ] in + ; "250 Yes buddy!" + ; "554 You reached the limit buddy!" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -510,7 +515,7 @@ let smtp_test_3 = } in let open Lwt.Infix in run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function - | Ok (`Quit | `Submission _) -> Alcotest.fail "Unexpected quit or submission" + | Ok (`Quit | `Send _) -> 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" () (); @@ -523,12 +528,16 @@ let smtp_test_4 = Alcotest_lwt.test_case "SMTP (relay) 4" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - ["EHLO gmail.com"; "MAIL FROM:"; "DATA"] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "250 Ok, buddy!" - ; "554 No recipients" - ] in + [ "EHLO gmail.com" + ; "MAIL FROM:" + ; "DATA"] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250 SIZE 16777216" + ; "250 Ok, buddy!" + ; "554 No recipients" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -561,15 +570,16 @@ let smtp_test_5 = Alcotest_lwt.test_case "SMTP (relay) 5" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - [ - "EHLO gmail.com"; "MAIL FROM:" - ; "RCPT TO:"; "DATA" - ] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "250 Ok, buddy!" + [ "EHLO gmail.com" + ; "MAIL FROM:" + ; "RCPT TO:"; "DATA" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250 SIZE 16777216" ; "250 Ok, buddy!" - ] in + ; "250 Ok, buddy!" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -581,9 +591,7 @@ let smtp_test_5 = } in let open Lwt.Infix in run_state (Ptt.SSMTP.m_relay_init ctx info) rdwr >>= function - | Ok - (`Submission - {Ptt.SSMTP.from; Ptt.SSMTP.recipients; Ptt.SSMTP.domain_from}) -> + | Ok (`Send {Ptt.SSMTP.from; Ptt.SSMTP.recipients; Ptt.SSMTP.domain_from}) -> let romain_calascibetta = let open Mrmime.Mailbox in Local.[w "romain"; w "calascibetta"] @@ -615,12 +623,17 @@ let smtp_test_6 = Alcotest_lwt.test_case "SMTP (submission) 6" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - ["EHLO gmail.com"; "MAIL FROM:"; "QUIT"] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250-SIZE 16777216"; "250 AUTH PLAIN" - ; "530 Authentication required, buddy!"; "221 Bye, buddy!" - ] in + [ "EHLO gmail.com" + ; "MAIL FROM:" + ; "QUIT" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250-SIZE 16777216" + ; "250 AUTH PLAIN" + ; "530 Authentication required, buddy!" + ; "221 Bye, buddy!" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -648,11 +661,14 @@ let smtp_test_7 = Alcotest_lwt.test_case "SMTP (submission) 7" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - ["EHLO gmail.com"; "AUTH PLAIN"] - [ - "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME"; "250-SMTPUTF8"; "250-SIZE 16777216"; "250 AUTH PLAIN" - ] in + [ "EHLO gmail.com" + ; "AUTH PLAIN" ] + [ "220 x25519.net" + ; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME" + ; "250-SMTPUTF8" + ; "250-SIZE 16777216" + ; "250 AUTH PLAIN" ] in let ctx = Colombe.State.Context.make () in let info = { @@ -682,6 +698,7 @@ let smtp_test_7 = Alcotest.failf "Unexpected protocol error: %a" Ptt.SSMTP.pp_error err | Error `Connection_close -> Alcotest.failf "Unexpected connection close" +(* module Random = struct type g = unit type +'a io = 'a Lwt.t @@ -721,88 +738,51 @@ module Resolver = struct let err = Rresult.R.error_msgf "Extension are not available" in Lwt.return err end +*) -module Flow = struct - type t = Lwt_unix.file_descr - type +'a io = 'a Lwt.t +module Server = Ptt_server.Make (Time) (Tcpip_stack_socket.V4V6) - let flow endpoint = - let sockaddr = - match endpoint with - | Unix.ADDR_UNIX _ -> endpoint - | Unix.ADDR_INET (fake_inet_addr, _) -> - let fake_inet_addr = Ipaddr_unix.of_inet_addr fake_inet_addr in - Unix.ADDR_INET - ( Unix.inet_addr_loopback - , Hashtbl.find fake_smtp_servers fake_inet_addr ) in - let open Lwt.Infix in - let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Lwt_unix.connect socket sockaddr >>= fun () -> Lwt.return socket - - let recv socket buf off len = - Lwt.catch - (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) - - let send socket buf off len = - let open Lwt.Infix in - let rec go socket buf off len = - if len > 0 then - Lwt.catch - (fun () -> - Lwt_unix.write socket buf off len >>= fun res -> - 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) - else Lwt.return_unit in - go socket (Bytes.unsafe_of_string buf) off len -end +let resolver = + let open Ptt_common in + let getmxbyname _ domain_name = + let mxs = + Dns.Rr_map.Mx_set.add + {Dns.Mx.preference= 0; mail_exchange= domain_name} + Dns.Rr_map.Mx_set.empty in + Lwt.return (Ok mxs) in + let gethostbyname tbl domain_name = + match Hashtbl.find_opt tbl domain_name with + | Some v -> Lwt.return (Ok v) + | None -> + let err = Rresult.R.error_msgf "%a not found" Domain_name.pp domain_name in + Lwt.return err in + { getmxbyname; gethostbyname } -let serve_when_ready ?stop ~handler socket = +let make_smtp_server ?stop ~port tbl info stack = let open Lwt.Infix in - `Initialized - (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 - 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 - 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) in - let conf_server = SMTP.create ~info in - let messaged = SMTP.messaged conf_server in - let smtp_relay_server conf_server = - let open Lwt.Infix in - let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - 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 - let smtp_logic messaged ms = + let module SMTP = Ptt.Relay.Make (Tcpip_stack_socket.V4V6) in + let ic_server, stream0, close = SMTP.create ~info in + let job_server server = + let handler flow = + let ipaddr, port = Tcpip_stack_socket.V4V6.TCP.dst flow in + Lwt.finalize + (fun () -> + SMTP.accept ~ipaddr flow tbl resolver server + >|= Result.map_error (Rresult.R.msgf "%a" SMTP.pp_error)) + (fun () -> Tcpip_stack_socket.V4V6.TCP.close flow) + >>= function + | Ok () -> Lwt.return () + | Error (`Msg err) -> + Logs.err (fun m -> m "<%a:%d> raised an error: %s" Ipaddr.pp ipaddr port err); + Lwt.return () in + Server.init ~port stack >|= fun service -> + Server.serve_when_ready ?stop ~handler service in + job_server ic_server >|= fun (`Initialized th) -> + let th = th >|= close in + `Initialized th, stream0 + +(* + let job_logic messaged ms = let open Lwt.Infix in Lwt.return (`Queue @@ -821,8 +801,31 @@ let make_relay_smtp_server ?stop ~port info = Lwt.both (smtp_relay_server conf_server) (smtp_logic messaged (Queue.create ())) +*) + +module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make + (Time) (Mclock) (Tcpip_stack_socket.V4V6) + +module Sendmail = Sendmail_mirage.Make + (Pclock) (Tcpip_stack_socket.V4V6.TCP) (Happy_eyeballs_daemon) -let sendmail ipaddr port ~domain sender recipients contents = +let sendmail he ipaddr port ~domain sender recipients contents = + let open Lwt.Infix in + let destination = Fmt.str "%a" Ipaddr.pp ipaddr in + let stream = Lwt_stream.of_list contents in + let stream = Lwt_stream.map (fun str -> str ^ "\r\n") stream in + let mail () = + Lwt_stream.get stream >|= function + | Some str -> Some (str, 0, String.length str) + | None -> None in + Sendmail.sendmail he ~destination ~port ~domain + sender recipients mail >>= function + | Ok () -> Lwt.return_unit + | Error (`Msg msg) -> Fmt.failwith "%s" msg + | Error (#Sendmail_with_starttls.error as err) -> + Fmt.failwith "%a" Sendmail_with_starttls.pp_error err + +(* let stream = stream_of_string_list contents in let stream () = let open Lwt.Infix in @@ -860,130 +863,132 @@ let sendmail ipaddr port ~domain sender recipients contents = Scheduler.prj res >>= function | Ok () -> Lwt_unix.close socket | Error err -> Fmt.failwith "%a" Sendmail.pp_error err +*) let key = Alcotest.testable Ptt.Messaged.pp Ptt.Messaged.equal let full_test_0 = Alcotest_lwt.test_case "Receive one email from Anil" `Quick @@ fun _sw () -> let romain_calascibetta = + let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_forward_path) - (let open Mrmime.Mailbox in - Local.[w "romain"; w "calascibetta"] - @ Domain.(domain, [a "gmail"; a "com"])) in + (Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"])) in let anil = + let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) - (let open Mrmime.Mailbox in - Local.[w "anil"] @ Domain.(domain, [a "recoil"; a "org"])) in + (Local.[w "anil"] @ Domain.(domain, [a "recoil"; a "org"])) in let recoil = (Colombe.Domain.of_string_exn <.> Domain_name.to_string) recoil in + let ipv4_only = false and ipv6_only = false in + let open Lwt.Infix in + let open Tcpip_stack_socket.V4V6 in + TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 -> + UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + connect udpv4v6 tcpv4v6 >>= fun stack -> + let he = Happy_eyeballs_daemon.create stack in let sendmail contents = - sendmail + sendmail he Ipaddr.(V4 V4.localhost) 8888 ~domain:recoil anil [romain_calascibetta] contents in let stop = Lwt_switch.create () in let open Lwt.Infix in - make_relay_smtp_server ~stop ~port:8888 - { - Ptt.SMTP.domain= gmail + let tbl = Hashtbl.create 0 in + make_smtp_server ~stop ~port:8888 tbl + { Ptt.SMTP.domain= gmail ; ipaddr= Ipaddr.(V4 V4.localhost) ; tls= None ; zone= Mrmime.Date.Zone.GMT - ; size= 0x1000000L - } - >>= fun (`Initialized th0, `Queue th1) -> - Lwt.join - [ - ( sendmail - [ - "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; "" - ; "Hello World!" - ] - >>= fun () -> Lwt_switch.turn_off stop ); th0 - ] - >>= fun () -> - th1 >>= fun contents -> - Alcotest.(check (list key)) - "inbox" contents - [ - Ptt.Messaged.v ~domain_from:recoil ~from:(anil, []) + ; size= 0x1000000L } tcpv4v6 + >>= fun (`Initialized th, stream) -> + let sendmail = + sendmail + [ "From: anil@recoil.org" + ; "Subject: SMTP server, PLZ!" + ; "" + ; "Hello World!" ] >>= fun () -> + Logs.debug (fun m -> m "Close the SMTP server"); + Lwt_switch.turn_off stop in + Lwt.join [ sendmail; th ] >>= fun () -> + Lwt_stream.to_list stream >|= List.map fst >>= fun inbox -> + Alcotest.(check (list key)) "inbox" inbox + [ Ptt.Messaged.key ~domain_from:recoil ~from:(anil, []) ~recipients:[romain_calascibetta, []] - ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L - ]; + ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L ]; Lwt.return_unit let full_test_1 = Alcotest_lwt.test_case "Receive emails from Anil and Thomas" `Quick @@ fun _sw () -> let romain_calascibetta = + let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_forward_path) - (let open Mrmime.Mailbox in - Local.[w "romain"; w "calascibetta"] - @ Domain.(domain, [a "gmail"; a "com"])) in + (Local.[w "romain"; w "calascibetta"] @ Domain.(domain, [a "gmail"; a "com"])) in let anil = + let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) - (let open Mrmime.Mailbox in - Local.[w "anil"] @ Domain.(domain, [a "recoil"; a "org"])) in + (Local.[w "anil"] @ Domain.(domain, [a "recoil"; a "org"])) in let thomas = + let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) - (let open Mrmime.Mailbox in - Local.[w "thomas"] @ Domain.(domain, [a "gazagnaire"; a "org"])) in + (Local.[w "thomas"] @ Domain.(domain, [a "gazagnaire"; a "org"])) in let recoil = (Colombe.Domain.of_string_exn <.> Domain_name.to_string) recoil in - let gazagnaire = - (Colombe.Domain.of_string_exn <.> Domain_name.to_string) gazagnaire in + let gazagnaire = (Colombe.Domain.of_string_exn <.> Domain_name.to_string) gazagnaire in + let ipv4_only = false and ipv6_only = false in + let open Lwt.Infix in + let open Tcpip_stack_socket.V4V6 in + TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 -> + UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + connect udpv4v6 tcpv4v6 >>= fun stack -> + let he = Happy_eyeballs_daemon.create stack in let stop = Lwt_switch.create () in let open Lwt.Infix in - make_relay_smtp_server ~stop ~port:4444 - { - Ptt.SMTP.domain= gmail + let tbl = Hashtbl.create 0 in + make_smtp_server ~stop ~port:4444 tbl + { Ptt.SMTP.domain= gmail ; ipaddr= Ipaddr.(V4 V4.localhost) ; tls= None ; zone= Mrmime.Date.Zone.GMT - ; size= 0x1000000L - } - >>= fun (`Initialized th0, `Queue th1) -> + ; size= 0x1000000L } tcpv4v6 + >>= fun (`Initialized th, stream) -> let sendmail ~domain sender contents = - sendmail - Ipaddr.(V4 V4.localhost) + sendmail he Ipaddr.(V4 V4.localhost) 4444 ~domain sender [romain_calascibetta] contents in - Lwt.join - [ - ( sendmail ~domain:recoil anil - [ - "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; "" - ; "Hello World!" - ] - >>= fun () -> - sendmail ~domain:gazagnaire thomas - [ - "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; "" - ; "Hello World!" - ] - >>= fun () -> Lwt_switch.turn_off stop ); th0 - ] - >>= fun () -> - th1 >>= fun contents -> + let sendmail = + sendmail ~domain:recoil anil + [ "From: anil@recoil.org" + ; "Subject: SMTP server, PLZ!" + ; "" + ; "Hello World!" ] + >>= fun () -> + sendmail ~domain:gazagnaire thomas + [ "From: anil@recoil.org" + ; "Subject: SMTP server, PLZ!" + ; "" + ; "Hello World!" ] + >>= fun () -> Lwt_switch.turn_off stop in + Lwt.join [ sendmail; th ] >>= fun () -> + Lwt_stream.to_list stream >|= List.map fst >|= List.rev >>= fun inbox -> Alcotest.(check (list key)) - "inbox" contents - [ - Ptt.Messaged.v ~domain_from:gazagnaire ~from:(thomas, []) + "inbox" inbox + [ Ptt.Messaged.key ~domain_from:gazagnaire ~from:(thomas, []) ~recipients:[romain_calascibetta, []] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 1L - ; Ptt.Messaged.v ~domain_from:recoil ~from:(anil, []) + ; Ptt.Messaged.key ~domain_from:recoil ~from:(anil, []) ~recipients:[romain_calascibetta, []] - ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L - ]; + ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 0L ]; Lwt.return_unit let fiber = Alcotest_lwt.run "ptt" - [ - "mechanism", [mechanism_test_0]; "authentication", [authentication_test_0] - ; "aggregate", [aggregate_test_0] - ; "messaged", [messaged_test_0; messaged_test_1] - ; ( "SMTP" - , [ - smtp_test_0; smtp_test_1; smtp_test_2; smtp_test_3; smtp_test_4 - ; smtp_test_5; smtp_test_6; smtp_test_7 - ] ); "Server", [full_test_0; full_test_1] - ] + [ "mechanism", [mechanism_test_0] + ; "authentication", [authentication_test_0] + ; "SMTP", [ smtp_test_0 + ; smtp_test_1 + ; smtp_test_2 + ; smtp_test_3 + ; smtp_test_4 + ; smtp_test_5 + ; smtp_test_6 + ; smtp_test_7 ] + ; "server", [full_test_0; full_test_1] ] let () = Lwt_main.run fiber