2024-10-11 12:32.43: New job: test mirage/ptt https://github.com/mirage/ptt.git#refs/heads/master (a43a52ee306659de1e9fc267167a5970df0aa1ee) (linux-x86_64:(lint-fmt)) Base: ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612 ocamlformat version: version 0.26.2 (from opam) To reproduce locally: git clone --recursive "https://github.com/mirage/ptt.git" -b "master" && cd "ptt" && git reset --hard a43a52ee cat > Dockerfile <<'END-OF-DOCKERFILE' FROM ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612 USER 1000:1000 RUN cd ~/opam-repository && (git cat-file -e 525e9f91783f83939e57ae00eb12498294707461 || git fetch origin master) && git reset -q --hard 525e9f91783f83939e57ae00eb12498294707461 && git log --no-decorate -n1 --oneline && opam update -u RUN opam depext -i dune WORKDIR /src RUN opam depext -i ocamlformat=0.26.2 COPY --chown=1000:1000 . /src/ RUN opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2) END-OF-DOCKERFILE docker build . END-REPRO-BLOCK 2024-10-11 12:32.43: Using cache hint "mirage/ptt-ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612-debian-12-4.08_opam-2.2-ocamlformat-525e9f91783f83939e57ae00eb12498294707461" 2024-10-11 12:32.43: Using OBuilder spec: ((from ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612) (user (uid 1000) (gid 1000)) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "cd ~/opam-repository && (git cat-file -e 525e9f91783f83939e57ae00eb12498294707461 || git fetch origin master) && git reset -q --hard 525e9f91783f83939e57ae00eb12498294707461 && git log --no-decorate -n1 --oneline && opam update -u")) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i dune")) (workdir /src) (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i ocamlformat=0.26.2")) (copy (src .) (dst /src/)) (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)")) ) 2024-10-11 12:32.43: Waiting for resource in pool OCluster 2024-10-11 12:32.43: Waiting for worker… 2024-10-11 12:32.44: Got resource from pool OCluster Building on x86-bm-c19.sw.ocaml.org All commits already cached HEAD is now at a43a52e Merge pull request #47 from mirage/ng (from ocaml/opam:debian-12-ocaml-4.08@sha256:313659e036d93aad64e3d503c7a2aa6326e0a2c7426087b094ccca6aed7d1612) 2024-10-11 12:32.44 ---> using "8ac68bced7188653db7b81863dbdd05e2bdaccde05c724cc4b90798d2e42b237" from cache /: (user (uid 1000) (gid 1000)) /: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "cd ~/opam-repository && (git cat-file -e 525e9f91783f83939e57ae00eb12498294707461 || git fetch origin master) && git reset -q --hard 525e9f91783f83939e57ae00eb12498294707461 && git log --no-decorate -n1 --oneline && opam update -u")) From https://github.com/ocaml/opam-repository * branch master -> FETCH_HEAD 75006f8c5e..1a07d7f3b0 master -> origin/master 525e9f9178 Merge pull request #26639 from mtelvers/opam-publish-ocaml-version.3.6.9 <><> Updating package repositories ><><><><><><><><><><><><><><><><><><><><><><> [default] synchronised from file:///home/opam/opam-repository default (at file:///home/opam/opam-repository): [INFO] opam 2.1 and 2.2 include many performance and security improvements over 2.0; please consider upgrading (https://opam.ocaml.org/doc/Install.html) Everything as up-to-date as possible (run with --verbose to show unavailable upgrades). However, you may "opam upgrade" these packages explicitly, which will ask permission to downgrade or uninstall the conflicting packages. Nothing to do. # Run eval $(opam env) to update the current shell environment 2024-10-11 12:32.44 ---> using "a21bd7513dcf5833d662789450c6f33572a4c1a9f3b46154afd115a32f751142" from cache /: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i dune")) # Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian # No extra OS packages requirements found. # All required OS packages found. # Now letting opam install the packages The following actions will be performed: - install dune 3.16.0 <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [dune.3.16.0] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> installed dune.3.16.0 Done. # Run eval $(opam env) to update the current shell environment 2024-10-11 12:32.44 ---> using "1c0aa1ffcd30b30e93efe5f8f110da1163e6dbc8e3b92fd8a8595449e53f7d11" from cache /: (workdir /src) /src: (run (cache (opam-archives (target /home/opam/.opam/download-cache))) (network host) (shell "opam depext -i ocamlformat=0.26.2")) # Detecting depexts using vars: arch=x86_64, os=linux, os-distribution=debian, os-family=debian # No extra OS packages requirements found. # All required OS packages found. # Now letting opam install the packages The following actions will be performed: - install sexplib0 v0.14.0 [required by base] - install ocaml-version 3.6.9 [required by ocamlformat-lib] - install menhirLib 20240715 [required by ocamlformat-lib] - install menhirCST 20240715 [required by menhir] - install menhirSdk 20240715 [required by ocamlformat-lib] - install ocamlbuild 0.15.0 [required by fpath, astring, uuseg] - install either 1.0.0 [required by ocamlformat-lib] - install ocamlfind 1.9.6 [required by ocp-indent, astring, fpath, uuseg] - install cmdliner 1.3.0 [required by ocamlformat] - install result 1.5 [required by ocamlformat-lib] - install seq base [required by re] - install csexp 1.5.2 [required by ocamlformat-lib] - install camlp-streams 5.0.1 [required by ocamlformat-lib] - install dune-build-info 3.16.0 [required by ocamlformat-lib] - install fix 20230505 [required by ocamlformat-lib] - install menhir 20240715 [required by ocamlformat-lib] - install topkg 1.0.7 [required by fpath, astring, uuseg] - install base-bytes base [required by ocp-indent] - install re 1.11.0 [required by ocamlformat] - install dune-configurator 3.16.0 [required by base] - install uutf 1.0.3 [required by ocamlformat-lib] - install astring 0.8.5 [required by ocamlformat-lib] - install ocp-indent 1.8.1 [required by ocamlformat-lib] - install base v0.14.3 [required by ocamlformat-lib] - install uucp 15.0.0 [required by uuseg] - install fpath 0.7.3 [required by ocamlformat-lib] - install stdio v0.14.0 [required by ocamlformat-lib] - install uuseg 15.0.0 [required by ocamlformat-lib] - install ocamlformat-lib 0.26.2 [required by ocamlformat] - install ocamlformat 0.26.2 ===== 30 to install ===== <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [astring.0.8.5] found in cache [base.v0.14.3] found in cache [camlp-streams.5.0.1] found in cache [cmdliner.1.3.0] found in cache [csexp.1.5.2] found in cache [dune-build-info.3.16.0] found in cache [dune-configurator.3.16.0] found in cache [either.1.0.0] found in cache [fix.20230505] found in cache [fpath.0.7.3] found in cache [menhir.20240715] found in cache [menhirCST.20240715] found in cache [menhirLib.20240715] found in cache [menhirSdk.20240715] found in cache [ocaml-version.3.6.9] found in cache [ocamlbuild.0.15.0] found in cache [ocamlfind.1.9.6] found in cache [ocamlformat.0.26.2] found in cache [ocamlformat-lib.0.26.2] found in cache [ocp-indent.1.8.1] found in cache [re.1.11.0] found in cache [result.1.5] found in cache [sexplib0.v0.14.0] found in cache [stdio.v0.14.0] found in cache [topkg.1.0.7] found in cache [uucp.15.0.0] found in cache [uuseg.15.0.0] found in cache [uutf.1.0.3] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> installed seq.base -> installed camlp-streams.5.0.1 -> installed csexp.1.5.2 -> installed cmdliner.1.3.0 -> installed either.1.0.0 -> installed fix.20230505 -> installed menhirCST.20240715 -> installed menhirLib.20240715 -> installed menhirSdk.20240715 -> installed ocaml-version.3.6.9 -> installed result.1.5 -> installed sexplib0.v0.14.0 -> installed re.1.11.0 -> installed dune-build-info.3.16.0 -> installed dune-configurator.3.16.0 -> installed ocamlfind.1.9.6 -> installed base-bytes.base -> installed ocamlbuild.0.15.0 -> installed ocp-indent.1.8.1 -> installed base.v0.14.3 -> installed stdio.v0.14.0 -> installed topkg.1.0.7 -> installed uutf.1.0.3 -> installed astring.0.8.5 -> installed fpath.0.7.3 -> installed menhir.20240715 -> installed uucp.15.0.0 -> installed uuseg.15.0.0 -> installed ocamlformat-lib.0.26.2 -> installed ocamlformat.0.26.2 Done. <><> ocp-indent.1.8.1 installed successfully ><><><><><><><><><><><><><><><><><> => This package requires additional configuration for use in editors. Install package 'user-setup', or manually: * for Emacs, add these lines to ~/.emacs: (add-to-list 'load-path "/home/opam/.opam/4.08/share/emacs/site-lisp") (require 'ocp-indent) * for Vim, add this line to ~/.vimrc: set rtp^="/home/opam/.opam/4.08/share/ocp-indent/vim" # Run eval $(opam env) to update the current shell environment 2024-10-11 12:32.44 ---> using "a988629b13740c3a147799fe4edea7ee5600efc089ba4cfa6fcf9fb2e5da4fc1" from cache /src: (copy (src .) (dst /src/)) 2024-10-11 12:32.44 ---> using "bc8828c18ab51f287005b0a930b652dcb92bd083a4b3855202fc7723855b47dc" from cache /src: (run (shell "opam exec -- dune build @fmt --ignore-promoted-rules || (echo \"dune build @fmt failed\"; exit 2)")) File "lib/dune", line 1, characters 0-0: diff --git a/_build/default/lib/dune b/_build/default/lib/.formatted/dune index 0998e64..0930b14 100644 --- a/_build/default/lib/dune +++ b/_build/default/lib/.formatted/dune @@ -31,10 +31,10 @@ (library (name ptt) (public_name ptt) - (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) + (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 @@ -54,25 +54,29 @@ (name lipap) (public_name ptt.lipap) (modules lipap) - (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dns-client-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-time mirage-clock mirage-random ptt ptt.map ptt.server dns-client-mirage)) + (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 mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dkim-mirage dns-client-mirage)) + (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 mirage-time mirage-clock mirage-random ptt ptt.map ptt.server uspf-mirage)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server + uspf-mirage)) (library (name ptt_value) @@ -84,7 +88,8 @@ (name spartacus) (public_name ptt.spartacus) (modules spartacus) - (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server spamtacus-mirage dns-client-mirage)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server + spamtacus-mirage dns-client-mirage)) (library (name rdwr) File "lib/lipap.mli", line 1, characters 0-0: diff --git a/_build/default/lib/lipap.mli b/_build/default/lib/.formatted/lipap.mli index 32c79bc..ca26d9c 100644 --- a/_build/default/lib/lipap.mli +++ b/_build/default/lib/.formatted/lipap.mli @@ -12,8 +12,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) (Stack : Tcpip.Stack.V4V6) (Dns_client : Dns_client_mirage.S) - (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : -sig + (Happy_eyeballs : Happy_eyeballs_mirage.S with type flow = Stack.TCP.flow) : sig val job : ?limit:int -> ?stop:Lwt_switch.t File "lib/mxs.mli", line 1, characters 0-0: diff --git a/_build/default/lib/mxs.mli b/_build/default/lib/.formatted/mxs.mli index 809ca8b..4a07a96 100644 --- a/_build/default/lib/mxs.mli +++ b/_build/default/lib/.formatted/mxs.mli @@ -4,5 +4,7 @@ val pp_key : key Fmt.t include Map.S with type key := key -val v : preference:int -> domain:[ `host ] Domain_name.t -> Ipaddr.t -> Ipaddr.t t +val v : + preference:int -> domain:[ `host ] Domain_name.t -> Ipaddr.t -> Ipaddr.t t + val vs : (Dns.Mx.t * Ipaddr.t) list -> Ipaddr.t t File "lib/lexicon.ml", line 1, characters 0-0: diff --git a/_build/default/lib/lexicon.ml b/_build/default/lib/.formatted/lexicon.ml index 2c6634a..9f8a647 100644 --- a/_build/default/lib/lexicon.ml +++ b/_build/default/lib/.formatted/lexicon.ml @@ -1,4 +1,4 @@ -let pp_recipients ppf { Sendmail.domain; locals; } = +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 @@ -15,7 +15,8 @@ let pp_recipients ppf { Sendmail.domain; locals; } = 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: + Fmt.str + {text|It's impossible to send an email to: %a We tried to send the email %a at %a to: File "lib/ptt_aggregate.mli", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_aggregate.mli b/_build/default/lib/.formatted/ptt_aggregate.mli index ca2e477..14ee1c7 100644 --- a/_build/default/lib/ptt_aggregate.mli +++ b/_build/default/lib/.formatted/ptt_aggregate.mli @@ -1 +1,4 @@ -val to_recipients : info:Ptt_common.info -> Colombe.Forward_path.t list -> Ptt_sendmail.recipients list +val to_recipients : + info:Ptt_common.info + -> Colombe.Forward_path.t list + -> Ptt_sendmail.recipients list File "lib/mxs.ml", line 1, characters 0-0: diff --git a/_build/default/lib/mxs.ml b/_build/default/lib/.formatted/mxs.ml index 624a0c5..31e1d84 100644 --- a/_build/default/lib/mxs.ml +++ b/_build/default/lib/.formatted/mxs.ml @@ -3,20 +3,22 @@ type key = Dns.Mx.t let pp_key : key Fmt.t = fun ppf elt -> Fmt.pf ppf "{ @[<hov>preference= %d;@ mail_exchange= %a;@] }" - elt.Dns.Mx.preference Domain_name.pp - elt.Dns.Mx.mail_exchange + elt.Dns.Mx.preference Domain_name.pp elt.Dns.Mx.mail_exchange module Key = struct type t = key - let compare {Dns.Mx.preference= a; _} {Dns.Mx.preference= b; _} = Int.compare a b + let compare {Dns.Mx.preference= a; _} {Dns.Mx.preference= b; _} = + Int.compare a b end include (Map.Make (Key) : Map.S with type key := key) let v ~preference ~domain:mail_exchange ipaddr = - singleton { preference; mail_exchange } ipaddr + singleton {preference; mail_exchange} ipaddr let vs = - (Fun.flip List.fold_left empty) begin fun acc (mx, ipaddr) -> - add mx ipaddr acc end + (Fun.flip List.fold_left empty) + begin + fun acc (mx, ipaddr) -> add mx ipaddr acc + end File "lib/ptt_map.mli", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_map.mli b/_build/default/lib/.formatted/ptt_map.mli index 8918807..b5c9bdd 100644 --- a/_build/default/lib/ptt_map.mli +++ b/_build/default/lib/.formatted/ptt_map.mli @@ -4,7 +4,10 @@ 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 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 File "lib/authentication.ml", line 1, characters 0-0: diff --git a/_build/default/lib/authentication.ml b/_build/default/lib/.formatted/authentication.ml index 54a8df0..9bcab73 100644 --- a/_build/default/lib/authentication.ml +++ b/_build/default/lib/.formatted/authentication.ml @@ -7,8 +7,7 @@ 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 Lwt.t) -> 'k t - = "%identity" +external v : (username -> 'k password -> bool Lwt.t) -> 'k t = "%identity" let is_zero = ( = ) '\000' @@ -46,5 +45,4 @@ let decode_plain_authentication hash ?stamp t v = type mechanism = PLAIN of string option let decode_authentication hash m t v = - match m with - | PLAIN stamp -> decode_plain_authentication hash ?stamp t v + match m with PLAIN stamp -> decode_plain_authentication hash ?stamp t v File "lib/messaged.ml", line 1, characters 0-0: diff --git a/_build/default/lib/messaged.ml b/_build/default/lib/.formatted/messaged.ml index 02a8ef5..af21617 100644 --- a/_build/default/lib/messaged.ml +++ b/_build/default/lib/.formatted/messaged.ml @@ -3,12 +3,13 @@ open Colombe 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 File "lib/ptt_map.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_map.ml b/_build/default/lib/.formatted/ptt_map.ml index 2a7e2be..8aa36a6 100644 --- a/_build/default/lib/ptt_map.ml +++ b/_build/default/lib/.formatted/ptt_map.ml @@ -8,9 +8,11 @@ module By_domain = Map.Make (struct let compare = Domain_name.compare end) -type t = - { postmaster: Emile.mailbox - ; map: (local, Colombe.Forward_path.t list) Hashtbl.t } +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 @@ -19,12 +21,12 @@ 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 -> + | 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 ] + 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 @@ -34,11 +36,9 @@ let exists_as_sender sender ~info t = && Hashtbl.mem t.map local let recipients ~local {map; _} = - Hashtbl.find_opt map local - |> Option.value ~default:[] + 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) @@ -46,20 +46,22 @@ 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.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.elements + |> Set.of_list + |> Set.elements File "lib/lipap.ml", line 1, characters 0-0: diff --git a/_build/default/lib/lipap.ml b/_build/default/lib/.formatted/lipap.ml index 0d7420c..b5fc119 100644 --- a/_build/default/lib/lipap.ml +++ b/_build/default/lib/.formatted/lipap.ml @@ -5,7 +5,7 @@ let src = Logs.Src.create "ptt.lipap" module Log : Logs.LOG = (val Logs.src_log src) -let ( $ ) f g = fun x -> f (g x) +let ( $ ) f g x = f (g x) module Make (Time : Mirage_time.S) @@ -22,8 +22,8 @@ struct 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 + 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 @@ -31,12 +31,12 @@ struct 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 + Lwt.all [ipv4; ipv6] >|= function + | [_; (Ok _ as ipv6)] -> ipv6 + | [(Ok _ as ipv4); Error _] -> ipv4 + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port random hash stack dns server close = let handler flow = @@ -45,8 +45,8 @@ struct (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, _) -> Submission.accept ~encoder:(Fun.const encoder) - ~decoder:(Fun.const decoder) ~ipaddr flow dns resolver - random hash server + ~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 @@ -55,9 +55,9 @@ struct Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in Server.init ~port stack >>= fun service -> - Server.serve_when_ready ?stop ~handler service - |> fun (`Initialized job) -> - let job = job >|= close in job + Server.serve_when_ready ?stop ~handler service |> fun (`Initialized job) -> + let job = job >|= close in + job let logic_job ~info map (ic, oc) = let rec go () = @@ -70,24 +70,40 @@ struct 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 <ptt.mti-gf@info.Ptt_common.domain> 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 + let elts = + List.map + (fun recipients -> + (* TODO(dinosaure): Can we use multiple MAIL FROM to keep the original + sender? We actually force <ptt.mti-gf@info.Ptt_common.domain> 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 + Lwt.pause () >>= go in go () - let job ?(limit = 20) ?stop ~locals ~port ~tls ~info - random hash stack dns he - authenticator mechanisms = + 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 @@ -100,12 +116,13 @@ 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 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 - [ 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 ] + [ + 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 File "lib/ptt_sendmail.mli", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_sendmail.mli b/_build/default/lib/.formatted/ptt_sendmail.mli index c920110..065b300 100644 --- a/_build/default/lib/ptt_sendmail.mli +++ b/_build/default/lib/.formatted/ptt_sendmail.mli @@ -22,24 +22,30 @@ 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 } +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 + (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 File "lib/ptt_flow.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_flow.ml b/_build/default/lib/.formatted/ptt_flow.ml index 076a2ea..1bc0137 100644 --- a/_build/default/lib/ptt_flow.ml +++ b/_build/default/lib/.formatted/ptt_flow.ml @@ -3,7 +3,7 @@ open Colombe.State open Colombe open Lwt.Infix -let ( <.> ) f g = fun x -> f (g x) +let ( <.> ) f g x = f (g x) module Lwt_scheduler = Sigs.Make (Lwt) @@ -12,7 +12,7 @@ let lwt_bind x f = inj (prj x >>= (prj <.> f)) let lwt = - { Sigs.bind = lwt_bind; return = (fun x -> Lwt_scheduler.inj (Lwt.return x)) } + {Sigs.bind= lwt_bind; return= (fun x -> Lwt_scheduler.inj (Lwt.return x))} exception Rdwr of string @@ -28,29 +28,26 @@ module Rdwr (Flow : Mirage_flow.S) = struct | 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 } + 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 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 ( + 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) + 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 ; + ~len payload; + Ke.Rke.N.shift_exn flow.queue len; Lwt.return len let send flow payload p_off p_len = @@ -71,23 +68,23 @@ module Make (Flow : Mirage_flow.S) = struct | 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 } + {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 -> + 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) + | 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 @@ -95,8 +92,7 @@ module Make (Flow : Mirage_flow.S) = struct 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 + Lwt.catch (fun () -> Lwt_scheduler.prj (run lwt rdwr flow m)) @@ function + | Rdwr msg -> Lwt.return_error (`Flow msg) + | exn -> Lwt.reraise exn end File "lib/relay.mli", line 1, characters 0-0: diff --git a/_build/default/lib/relay.mli b/_build/default/lib/.formatted/relay.mli index 4ab99b0..1508112 100644 --- a/_build/default/lib/relay.mli +++ b/_build/default/lib/.formatted/relay.mli @@ -1,15 +1,15 @@ open Rresult -module Make - (Stack : Tcpip.Stack.V4V6) : sig +module Make (Stack : Tcpip.Stack.V4V6) : sig type server - type info = SMTP.info = - { domain: Colombe.Domain.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 @@ -19,7 +19,9 @@ module Make val create : info:info - -> server * (Messaged.key * string Lwt_stream.t) Lwt_stream.t * (unit -> unit) + -> server + * (Messaged.key * string Lwt_stream.t) Lwt_stream.t + * (unit -> unit) val accept : ?encoder:(unit -> bytes) File "lib/nec.ml", line 1, characters 0-0: diff --git a/_build/default/lib/nec.ml b/_build/default/lib/.formatted/nec.ml index a64a644..47f76c0 100644 --- a/_build/default/lib/nec.ml +++ b/_build/default/lib/.formatted/nec.ml @@ -5,7 +5,7 @@ let src = Logs.Src.create "ptt.nec" module Log : Logs.LOG = (val Logs.src_log src) -let ( $ ) f g = fun x -> f (g x) +let ( $ ) f g x = f (g x) module Make (Time : Mirage_time.S) @@ -22,8 +22,8 @@ struct 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 + 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 @@ -31,12 +31,12 @@ struct 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 + Lwt.all [ipv4; ipv6] >|= function + | [_; (Ok _ as ipv6)] -> ipv6 + | [(Ok _ as ipv4); Error _] -> ipv4 + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -55,9 +55,9 @@ struct Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in Server.init ~port stack >>= fun service -> - Server.serve_when_ready ?stop ~handler service - |> fun (`Initialized job) -> - let job = job >|= close in job + Server.serve_when_ready ?stop ~handler service |> fun (`Initialized job) -> + let job = job >|= close in + job let logic_job ~info map (ic, oc) (private_key, dkim) = let rec go () = @@ -67,34 +67,55 @@ struct let sign_and_transmit () = Lwt.catch (fun () -> let consumer = - let stream = Lwt_stream.map (fun str -> str, 0, String.length str) stream in + 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 (_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 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 + 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)); + Log.err (fun m -> + m "Impossible to sign the incoming email: %S" + (Printexc.to_string exn)); Lwt.return_unit in sign_and_transmit () >>= Lwt.pause >>= go in go () - let job ?(limit = 20) ?stop ~locals ~port ~tls ~info - stack dns he (private_key, dkim) = + 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 @@ -107,12 +128,13 @@ 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 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 - [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + [ + 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 ] + ; Sendmail.job dns he oc_server + ] end File "lib/ptt_aggregate.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_aggregate.ml b/_build/default/lib/.formatted/ptt_aggregate.ml index 2a55301..955fc4a 100644 --- a/_build/default/lib/ptt_aggregate.ml +++ b/_build/default/lib/.formatted/ptt_aggregate.ml @@ -2,8 +2,7 @@ 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 +let ( <$> ) f g 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 @@ -44,31 +43,45 @@ 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 + | 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"); + 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 -> + | 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 + 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 + 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 + 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 + 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) -> @@ -79,19 +92,28 @@ let aggregate_by_domains ~info = | 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); + | ( 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.bindings 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.bindings by_ipaddrs) in + let by_domains = + List.map + (fun (domain, locals) -> + let domain = `Domain domain in + Ptt_sendmail.{domain; locals}) + (By_domain.bindings 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.bindings by_ipaddrs) in List.rev_append by_domains by_ipaddrs File "lib/hm.ml", line 1, characters 0-0: diff --git a/_build/default/lib/hm.ml b/_build/default/lib/.formatted/hm.ml index 037a4ea..457b124 100644 --- a/_build/default/lib/hm.ml +++ b/_build/default/lib/.formatted/hm.ml @@ -5,7 +5,7 @@ let src = Logs.Src.create "ptt.hm" module Log : Logs.LOG = (val Logs.src_log src) -let ( $ ) f g = fun x -> f (g x) +let ( $ ) f g x = f (g x) module Make (Time : Mirage_time.S) @@ -23,8 +23,8 @@ struct 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 + 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 @@ -32,12 +32,12 @@ struct 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 + Lwt.all [ipv4; ipv6] >|= function + | [_; (Ok _ as ipv6)] -> ipv6 + | [(Ok _ as ipv4); Error _] -> ipv4 + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -58,15 +58,15 @@ struct Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in Server.init ~port stack >>= fun service -> - Server.serve_when_ready ?stop ~handler service - |> fun (`Initialized job) -> - let job = job >|= close in job + 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 = Lwt_stream.of_list - [ (field_name :> string) - ; ": " - ; Unstrctrd.to_utf_8_string unstrctrd; "\r\n" ] + [ + (field_name :> string); ": "; Unstrctrd.to_utf_8_string unstrctrd; "\r\n" + ] let logic_job ~info map (ic, oc) dns = let rec go () = @@ -75,9 +75,8 @@ struct | 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 + 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 () = @@ -88,13 +87,16 @@ struct Lwt.return stream | Ok record -> Uspf_client.check ~ctx dns record >>= fun result -> - let receiver = match info.Ptt_common.domain with + 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 + 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 @@ -102,12 +104,17 @@ struct 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 + 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 () @@ -125,12 +132,13 @@ 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 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 - [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + [ + server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 ; logic_job ~info locals (stream0, push0) dns - ; Sendmail.job dns he oc_server ] + ; Sendmail.job dns he oc_server + ] end File "lib/mti_gf.ml", line 1, characters 0-0: diff --git a/_build/default/lib/mti_gf.ml b/_build/default/lib/.formatted/mti_gf.ml index 6c06547..dfa064e 100644 --- a/_build/default/lib/mti_gf.ml +++ b/_build/default/lib/.formatted/mti_gf.ml @@ -5,7 +5,7 @@ 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) +let ( $ ) f g x = f (g x) module Make (Time : Mirage_time.S) @@ -22,8 +22,8 @@ struct 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 + 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 @@ -31,12 +31,12 @@ struct 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 + Lwt.all [ipv4; ipv6] >|= function + | [_; (Ok _ as ipv6)] -> ipv6 + | [(Ok _ as ipv4); Error _] -> ipv4 + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -51,17 +51,18 @@ struct >>= function | Ok () -> Lwt.return () | Error (`Msg err) -> - Log.err (fun m -> m "<%a:%d> raised an error: %s" Ipaddr.pp ipaddr port err); + Log.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 - |> fun (`Initialized job) -> - let job = job >|= close in job + Server.serve_when_ready ?stop ~handler service |> fun (`Initialized job) -> + let job = job >|= close in + job 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 local = `Dot_string ["ptt"; "mti-gf"] in + Some Colombe.Path.{local; domain= info.Ptt_common.domain; rest= []} in let rec go () = Lwt_stream.get ic >>= function | None -> oc None; Lwt.return_unit @@ -71,17 +72,22 @@ struct 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 <ptt.mti-gf@info.Ptt_common.domain> 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 + let elts = + List.map + (fun recipients -> + (* TODO(dinosaure): Can we use multiple MAIL FROM to keep the original + sender? We actually force <ptt.mti-gf@info.Ptt_common.domain> 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 () @@ -99,12 +105,12 @@ struct 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 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 - [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 - ; logic_job ~info locals (stream0, push0) - ; Sendmail.job dns he oc_server ] + [ + server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0); Sendmail.job dns he oc_server + ] end File "lib/ptt_common.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_common.ml b/_build/default/lib/.formatted/ptt_common.ml index 0e3598c..5ae40f2 100644 --- a/_build/default/lib/ptt_common.ml +++ b/_build/default/lib/.formatted/ptt_common.ml @@ -2,91 +2,101 @@ 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 +let ( <$> ) f g 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 + -> (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 + -> (Ipaddr.t, ([> `Msg of string ] as 'a)) result Lwt.t -type 'dns resolver = - { getmxbyname : 'a. ('dns, 'a) getmxbyname - ; gethostbyname : 'a. ('dns, 'a) gethostbyname } +type 'dns resolver = { + getmxbyname: 'a. ('dns, 'a) getmxbyname + ; gethostbyname: 'a. ('dns, 'a) gethostbyname +} -type info = - { domain: Colombe.Domain.t +type info = { + domain: Colombe.Domain.t ; ipaddr: Ipaddr.t ; tls: Tls.Config.server option ; zone: Mrmime.Date.Zone.t - ; size: int64 } + ; 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) +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 -> + 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)) + | ( 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.elements in let ( let* ) = Lwt.bind in - let mail_exchange_are_reachable { Dns.Mx.mail_exchange; _ } = + 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 + 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.elements mxs in - let lst = List.sort Dns.Mx.compare lst in - Lwt_list.exists_p mail_exchange_are_reachable lst + let lst = Dns.Rr_map.Mx_set.elements 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" + | 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 - | exn -> Lwt.reraise exn + 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 local = [`Atom (Fmt.str "%016Lx" id)] in let open Colombe in - let domain = match info.domain with + let domain = + match info.domain with | Domain.Domain ds -> `Domain ds | Domain.IPv4 v4 -> let domain_name = Ipaddr.V4.to_domain_name v4 in @@ -94,5 +104,6 @@ let id_to_messageID ~info id = | 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 + | Domain.Extension _ -> + failwith "The SMTP server domain must not be an extension" in local, domain File "lib/ptt_server.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_server.ml b/_build/default/lib/.formatted/ptt_server.ml index 1f7a67a..fb9c638 100644 --- a/_build/default/lib/ptt_server.ml +++ b/_build/default/lib/.formatted/ptt_server.ml @@ -21,7 +21,8 @@ module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct 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); + 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 @@ -48,26 +49,28 @@ module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) = struct 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 + | 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) + 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 File "lib/relay.ml", line 1, characters 0-0: diff --git a/_build/default/lib/relay.ml b/_build/default/lib/.formatted/relay.ml index fd652d9..4c83806 100644 --- a/_build/default/lib/relay.ml +++ b/_build/default/lib/.formatted/relay.ml @@ -2,7 +2,6 @@ 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) @@ -10,39 +9,42 @@ module Log = (val Logs.src_log src : Logs.LOG) module Make (Stack : Tcpip.Stack.V4V6) = struct include Ptt_flow.Make (Stack.TCP) - type server = - { info: info + 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 + ; 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 = 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 = [ SMTP.error | `Too_big_data | `Flow of string | `Invalid_recipients ] - + + type error = + [ SMTP.error | `Too_big_data | `Flow of string | `Invalid_recipients ] + let pp_error ppf = function | #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 m = @@ -62,11 +64,9 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | str -> let len = String.length str in let str = str ^ "\r\n" in - bounded_stream#push str >>= - go (count + len + 2) - in + bounded_stream#push str >>= go (count + len + 2) in go 0 () - + let accept : ?encoder:(unit -> bytes) -> ?decoder:(unit -> bytes) @@ -78,12 +78,14 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct -> server -> (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 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 () -> Lwt.return_ok () - | `Send {SMTP.domain_from; from; recipients; _} -> + | `Send {SMTP.domain_from; from; recipients; _} -> ( Ptt_common.recipients_are_reachable ~info:server.info dns resolver (List.map fst recipients) >>= function @@ -105,6 +107,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct 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 File "lib/sMTP.mli", line 1, characters 0-0: diff --git a/_build/default/lib/sMTP.mli b/_build/default/lib/.formatted/sMTP.mli index 73c2b03..8b37159 100644 --- a/_build/default/lib/sMTP.mli +++ b/_build/default/lib/.formatted/sMTP.mli @@ -4,22 +4,17 @@ open Colombe module Value : sig include module type of Logic.Value - val encode_without_tls : - Encoder.encoder - -> 'x send - -> 'x - -> (unit, error) t - - val decode_without_tls : - Decoder.decoder -> 'x recv -> ('x, error) t + val encode_without_tls : Encoder.encoder -> 'x send -> 'x -> (unit, error) t + val decode_without_tls : 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 : Logic.MONAD - with type context = Sendmail_with_starttls.Context_with_tls.t - and type error = Value_with_tls.error +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 @@ -62,7 +57,7 @@ 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 : @@ -74,9 +69,7 @@ val m_mail : context -> (unit, [> error ]) Colombe.State.t val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t val m_relay_init : - context - -> info - -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t + context -> info -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_submission_init : context @@ -85,5 +78,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 File "lib/sSMTP.mli", line 1, characters 0-0: diff --git a/_build/default/lib/sSMTP.mli b/_build/default/lib/.formatted/sSMTP.mli index 4c8f0d4..f337f4c 100644 --- a/_build/default/lib/sSMTP.mli +++ b/_build/default/lib/.formatted/sSMTP.mli @@ -65,9 +65,7 @@ val m_mail : context -> (unit, [> error ]) Colombe.State.t val m_end : context -> ([> `Quit ], [> error ]) Colombe.State.t val m_relay_init : - context - -> info - -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t + context -> info -> ([> `Quit | `Send of email ], [> error ]) Colombe.State.t val m_submission_init : context File "lib/submission.mli", line 1, characters 0-0: diff --git a/_build/default/lib/submission.mli b/_build/default/lib/.formatted/submission.mli index ccb9716..6973b1d 100644 --- a/_build/default/lib/submission.mli +++ b/_build/default/lib/.formatted/submission.mli @@ -3,12 +3,13 @@ open Rresult module Make (Stack : Tcpip.Stack.V4V6) : sig type 'k server - type info = SSMTP.info = - { domain: Colombe.Domain.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 @@ -20,7 +21,9 @@ module Make (Stack : Tcpip.Stack.V4V6) : sig info:info -> authenticator:'k Authentication.t -> Mechanism.t list - -> 'k server * (Messaged.key * string Lwt_stream.t) Lwt_stream.t * (unit -> unit) + -> 'k server + * (Messaged.key * string Lwt_stream.t) Lwt_stream.t + * (unit -> unit) val accept : ?encoder:(unit -> bytes) File "test/dune", line 1, characters 0-0: diff --git a/_build/default/test/dune b/_build/default/test/.formatted/dune index 0618a48..4e93efb 100644 --- a/_build/default/test/dune +++ b/_build/default/test/.formatted/dune @@ -2,7 +2,8 @@ (name test) (modules test) (libraries logs.fmt mirage-crypto-rng.unix ipaddr.unix bos threads mrmime - mirage-time-unix mirage-clock-unix ptt ptt.server alcotest-lwt tcpip.stack-socket)) + mirage-time-unix mirage-clock-unix ptt ptt.server alcotest-lwt + tcpip.stack-socket)) (rule (alias runtest) File "lib/logic.ml", line 1, characters 0-0: diff --git a/_build/default/lib/logic.ml b/_build/default/lib/.formatted/logic.ml index 9990909..32aa761 100644 --- a/_build/default/lib/logic.ml +++ b/_build/default/lib/.formatted/logic.ml @@ -98,7 +98,9 @@ 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 : @@ -280,8 +282,8 @@ module Make (Monad : MONAD) = struct let* () = send ctx Value.PP_250 [ - politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" - ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.Ptt_common.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 @@ -291,8 +293,8 @@ module Make (Monad : MONAD) = struct let* () = send ctx Value.PP_250 [ - politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" - ; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.Ptt_common.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 File "lib/sSMTP.ml", line 1, characters 0-0: diff --git a/_build/default/lib/sSMTP.ml b/_build/default/lib/.formatted/sSMTP.ml index 2b46868..31762c9 100644 --- a/_build/default/lib/sSMTP.ml +++ b/_build/default/lib/.formatted/sSMTP.ml @@ -107,10 +107,14 @@ include Logic.Make (Monad) let m_submission_init ctx info ms = let open Monad in - let* () = send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.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 [Colombe.Domain.to_string info.Ptt_common.domain] in + let* () = + send ctx Value.PP_220 [Colombe.Domain.to_string info.Ptt_common.domain] + in m_relay_init ctx info File "lib/ptt_sendmail.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_sendmail.ml b/_build/default/lib/.formatted/ptt_sendmail.ml index b0d334c..b8e4b4f 100644 --- a/_build/default/lib/ptt_sendmail.ml +++ b/_build/default/lib/.formatted/ptt_sendmail.ml @@ -1,31 +1,35 @@ 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 +let ( <$> ) f g 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 } +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 ] @@ -33,105 +37,120 @@ 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 + 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 + 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 + Forward_path {Path.local= `Dot_string local; domain; rest= []} in match recipients.locals with - | `All -> [ Domain domain ] + | `All -> [Domain domain] | `Some locals -> List.map local_to_forward_path locals - | `Postmaster -> [ Postmaster ] + | `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 + 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 + 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 + 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 + 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 -> + | `Await -> ( Lwt_stream.get stream >>= function - | Some str -> Hd.src decoder str 0 (String.length str); go decoder - | None -> Lwt.return_none in + | 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 + (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) + ( consumed + , fun () -> + consumed := true; + Lwt_stream.get stream ) - let sendmail ?(last_option= false) he t ~ipaddr elt = + 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 } -> + 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 + 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 + 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 + 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 _ 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* 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 @[<hov>%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 + let recipients = recipients_to_forward_paths elt.recipients in + Log.err (fun m -> + m + "Impossible to send the email %a to @[<hov>%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 @@ -142,73 +161,81 @@ module Make 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 \ - @[<hov>%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 + let recipients = recipients_to_forward_paths elt.recipients in + Log.err (fun m -> + m + "Got an error while sending email %a to @[<hov>%a@] and impossible \ + to find a return-path to notify the \n\ + \ 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 + 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 -> + | `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.elements mxs) >|= Mxs.vs >|= Result.ok - | Error _ as err -> Lwt.return err end >>= function + 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.elements 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 + if Mxs.is_empty mxs then no_mail_exchange_service elt else let mxs = Mxs.bindings 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 ] -> + (* 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 -> + 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 + | `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 + | Some elt -> sendmail dns he t elt >>= fun () -> job dns he t | None -> Lwt.return_unit - let v - : resolver:_ -> ?pool:pool -> info:Ptt_common.info -> Tls.Config.client -> _ - = fun ~resolver ?pool ~info tls -> + let v : + 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 + {stream; push; info; resolver; tls; pool}, push end File "lib/spartacus.ml", line 1, characters 0-0: diff --git a/_build/default/lib/spartacus.ml b/_build/default/lib/.formatted/spartacus.ml index 983adba..f69fe0c 100644 --- a/_build/default/lib/spartacus.ml +++ b/_build/default/lib/.formatted/spartacus.ml @@ -5,7 +5,7 @@ let src = Logs.Src.create "ptt.spartacus" module Log : Logs.LOG = (val Logs.src_log src) -let ( $ ) f g = fun x -> f (g x) +let ( $ ) f g x = f (g x) module Make (Time : Mirage_time.S) @@ -22,8 +22,8 @@ struct 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 + 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 @@ -31,12 +31,12 @@ struct 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 + Lwt.all [ipv4; ipv6] >|= function + | [_; (Ok _ as ipv6)] -> ipv6 + | [(Ok _ as ipv4); Error _] -> ipv4 + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -57,9 +57,9 @@ struct Log.err (fun m -> m "<%a:%d> %s" Ipaddr.pp ipaddr port err); Lwt.return () in Server.init ~port stack >>= fun service -> - Server.serve_when_ready ?stop ~handler service - |> fun (`Initialized job) -> - let job = job >|= close in job + Server.serve_when_ready ?stop ~handler service |> fun (`Initialized job) -> + let job = job >|= close in + job let logic_job ~info map (ic, oc) = let rec go () = @@ -72,8 +72,7 @@ struct | Error (`Msg err) -> Log.err (fun m -> m "Got an error from the incoming email: %s." err); Lwt.return backup - | Ok (_label, stream) -> - Lwt.return stream in + | Ok (_label, stream) -> Lwt.return stream in filter () >>= fun stream -> let sender, _ = Ptt.Messaged.from key in let recipients = Ptt.Messaged.recipients key in @@ -81,12 +80,17 @@ struct 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 + 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 () @@ -104,12 +108,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 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 - [ server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 - ; logic_job ~info locals (stream0, push0) - ; Sendmail.job dns he oc_server ] + [ + server_job ~pool:pool0 ?stop ~port stack dns ic_server close0 + ; logic_job ~info locals (stream0, push0); Sendmail.job dns he oc_server + ] end File "lib/sMTP.ml", line 1, characters 0-0: diff --git a/_build/default/lib/sMTP.ml b/_build/default/lib/.formatted/sMTP.ml index 86eb4e9..659b32d 100644 --- a/_build/default/lib/sMTP.ml +++ b/_build/default/lib/.formatted/sMTP.ml @@ -28,14 +28,14 @@ end module Value_with_tls = Sendmail_with_starttls.Make_with_tls (Value) -module Monad - : Logic.MONAD +module Monad : + Logic.MONAD with type context = Sendmail_with_starttls.Context_with_tls.t - and type error = Value_with_tls.error -= struct + 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 @@ -52,14 +52,13 @@ let pp_value_with_tls_error ppf = function Fmt.pf ppf "TLS alert: %s" (Tls.Packet.alert_type_to_string alert) | `Tls_failure failure -> Fmt.pf ppf "TLS failure: %s" (Tls.Engine.string_of_failure failure) - | `Tls_closed -> - Fmt.string ppf "TLS connection closed by peer" + | `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 + pp_value_with_tls_error ppf err | `No_recipients -> Fmt.string ppf "No recipients" | `Too_many_bad_commands -> Fmt.string ppf "Too many bad commands" | `Too_many_recipients -> Fmt.string ppf "Too many recipients" @@ -93,8 +92,9 @@ let m_relay_init ctx info = >>= fun () -> recv ctx Value.Helo in let capabilities = [ - politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" - ; "SMTPUTF8"; "STARTTLS"; Fmt.str "SIZE %Ld" info.Ptt_common.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 @@ -137,8 +137,8 @@ let m_submission_init ctx info ms = >>= fun () -> recv ctx Value.Helo in let capabilities = [ - politely ~domain:info.Ptt_common.domain ~ipaddr:info.Ptt_common.ipaddr; "8BITMIME" - ; "SMTPUTF8"; "STARTTLS" + 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.Ptt_common.size ] in File "bin/mti_gf.ml", line 1, characters 0-0: diff --git a/_build/default/bin/mti_gf.ml b/_build/default/bin/.formatted/mti_gf.ml index b1c325b..5c16c35 100644 --- a/_build/default/bin/mti_gf.ml +++ b/_build/default/bin/.formatted/mti_gf.ml @@ -11,16 +11,17 @@ let ( <.> ) f g x = f (g x) open Rresult -module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make - (Time) (Mclock) (Tcpip_stack_socket.V4V6) +module Happy_eyeballs_daemon = + Happy_eyeballs_mirage.Make (Time) (Mclock) (Tcpip_stack_socket.V4V6) -module Dns_client = Dns_client_mirage.Make - (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) - (Happy_eyeballs_daemon) +module Dns_client = + Dns_client_mirage.Make (Mirage_crypto_rng) (Time) (Mclock) (Pclock) + (Tcpip_stack_socket.V4V6) + (Happy_eyeballs_daemon) -module Server = Mti_gf.Make - (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) - (Dns_client) (Happy_eyeballs_daemon) +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 @@ -44,8 +45,10 @@ 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 -> - UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + 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 = { @@ -65,8 +68,8 @@ let romain_calascibetta = let () = let locals = Ptt_map.empty ~postmaster:romain_calascibetta in - let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in + let domain = Colombe.Domain.Domain ["ptt"; "fr"] in Ptt_map.add - ~local:(`Dot_string [ "romain"; "calascibetta" ]) + ~local:(`Dot_string ["romain"; "calascibetta"]) romain_calascibetta locals; Lwt_main.run (job ~domain locals) File "bin/lipap.ml", line 1, characters 0-0: diff --git a/_build/default/bin/lipap.ml b/_build/default/bin/.formatted/lipap.ml index c0c2c0b..71de88c 100644 --- a/_build/default/bin/lipap.ml +++ b/_build/default/bin/.formatted/lipap.ml @@ -11,16 +11,17 @@ let ( <.> ) f g x = f (g x) open Rresult -module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make - (Time) (Mclock) (Tcpip_stack_socket.V4V6) +module Happy_eyeballs_daemon = + Happy_eyeballs_mirage.Make (Time) (Mclock) (Tcpip_stack_socket.V4V6) -module Dns_client = Dns_client_mirage.Make - (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) - (Happy_eyeballs_daemon) +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) (Tcpip_stack_socket.V4V6) - (Dns_client) (Happy_eyeballs_daemon) + Lipap.Make (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) (Dns_client) + (Happy_eyeballs_daemon) let load_file filename = Bos.OS.File.read filename @@ -37,9 +38,7 @@ let private_key = X509.Private_key.decode_pem raw let private_key = Rresult.R.get_ok private_key - let authenticator _username _password = Lwt.return true - let authenticator = Ptt.Authentication.v authenticator let job ~domain locals = @@ -52,8 +51,10 @@ let job ~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 -> - UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 -> + 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 = { @@ -78,8 +79,8 @@ let romain_calascibetta = let () = let locals = Ptt_map.empty ~postmaster:romain_calascibetta in - let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in + let domain = Colombe.Domain.Domain ["ptt"; "fr"] in Ptt_map.add - ~local:(`Dot_string [ "romain"; "calascibetta" ]) + ~local:(`Dot_string ["romain"; "calascibetta"]) romain_calascibetta locals; Lwt_main.run (job ~domain locals) File "lib/submission.ml", line 1, characters 0-0: diff --git a/_build/default/lib/submission.ml b/_build/default/lib/.formatted/submission.ml index da22806..dccac5c 100644 --- a/_build/default/lib/submission.ml +++ b/_build/default/lib/.formatted/submission.ml @@ -2,7 +2,6 @@ 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) @@ -12,27 +11,31 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct module TLS = Ptt_flow.Make (Tls_flow) module TCP = Ptt_flow.Make (Stack.TCP) - type 'k server = - { info: info + type 'k server = { + info: info ; messaged: Messaged.t - ; push: ((Messaged.key * string Lwt_stream.t) option -> unit) + ; push: (Messaged.key * string Lwt_stream.t) option -> unit ; mechanisms: Mechanism.t list ; authenticator: 'k Authentication.t - ; mutable count: int64 } + ; mutable count: int64 + } - and info = SSMTP.info = - { domain: Colombe.Domain.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 = let messaged, push = Lwt_stream.create () in let close () = push None in - {info; messaged; push; mechanisms; authenticator; count= 0L}, messaged, close + ( {info; messaged; push; mechanisms; authenticator; count= 0L} + , messaged + , close ) let succ server = let v = server.count in @@ -46,9 +49,13 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | `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 + 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 @@ -60,33 +67,43 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | `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 + 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 + 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 (Runner { run; 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 -> begin - Authentication.decode_authentication hash - (Authentication.PLAIN None) server.authenticator v + Authentication.decode_authentication hash (Authentication.PLAIN None) + server.authenticator v >>= function | Ok (user, true) -> let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in - run flow m >>? fun () -> Lwt.return_ok (`Authenticated (to_local user)) + run flow m >>? fun () -> + Lwt.return_ok (`Authenticated (to_local user)) | (Error _ | Ok (_, false)) as res -> begin let () = match res with @@ -105,7 +122,9 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct go (limit + 1) m | `Authentication_with_payload (_domain_from, m, payload) -> (* assert (_domain_from = domain_from) ; *) - go (limit + 1) ~payload m end end + go (limit + 1) ~payload m + end + end | Mechanism.PLAIN, None -> begin let stamp = Bytes.create 0x10 in Mirage_crypto_rng.generate_into ?g:random stamp 0x10; @@ -125,7 +144,7 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in run flow m >>? fun () -> Lwt.return_ok (`Authenticated (to_local user)) - | (Error _ | Ok (_, false)) as res -> + | (Error _ | Ok (_, false)) as res -> ( let () = match res with | Error (`Msg err) -> @@ -143,7 +162,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct go (limit + 1) m | `Authentication_with_payload (_domain_from, m, payload) -> (* assert (_domain_from = domain_from) ; *) - go (limit + 1) ~payload m end in + go (limit + 1) ~payload m) + end in go 1 ?payload mechanism type authentication = @@ -152,7 +172,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct let dot = ".\r\n" - let receive_mail ?(limit = 0x100000) (Runner { run; flow}) ctx m bounded_stream = + 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 @@ -162,9 +183,7 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | str -> let len = String.length str in let str = str ^ "\r\n" in - bounded_stream#push str >>= - go (count + len + 2) - in + bounded_stream#push str >>= go (count + len + 2) in go 0 () let accept : @@ -181,17 +200,19 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct 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 -> + 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) -> + Lwt.return_ok (Runner {run= TLS.run; flow= TLS.make flow}) + end + >>? fun (Runner {run; flow} as runner) -> run flow m >>? function | `Quit -> Lwt.return_ok () - | #authentication as auth -> + | #authentication as auth -> ( let domain_from, m, payload = match auth with | `Authentication_with_payload (domain_from, m, v) -> @@ -200,18 +221,21 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct authentication ctx ~domain_from runner random hash server ?payload m >>? function | `Quit -> Lwt.return_ok () - | `Authenticated user -> + | `Authenticated user -> ( let m = SSMTP.m_relay ctx ~domain_from in run flow m >>? function | `Quit -> Lwt.return_ok () - | `Send {SSMTP.domain_from; recipients; from; _} -> + | `Send {SSMTP.domain_from; recipients; from; _} -> ( Ptt_common.recipients_are_reachable ~info:server.info dns resolver (List.map fst recipients) >>= function | true -> begin let id = succ server in let from = - let sender = Colombe.Path.{ local= user; domain= server.info.SSMTP.domain; rest= [] } in + 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 @@ -226,9 +250,12 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct bounded_stream >>? fun () -> let m = SSMTP.m_end ctx in - run flow m >>? fun `Quit -> Lwt.return_ok () end + 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 File "test/test.ml", line 1, characters 0-0: diff --git a/_build/default/test/test.ml b/_build/default/test/.formatted/test.ml index bc793b9..fba2d5a 100644 --- a/_build/default/test/test.ml +++ b/_build/default/test/.formatted/test.ml @@ -7,9 +7,7 @@ let () = Logs.set_level ~all:true (Some Logs.Debug) let reporter ppf = let report src level ~over k msgf = - let k _ = - over () ; - k () in + let k _ = over (); k () in let with_metadata header _tags k ppf fmt = Format.kfprintf k ppf ("%a[%a]: " ^^ fmt ^^ "\n%!") @@ -17,7 +15,7 @@ let reporter ppf = Fmt.(styled `Magenta string) (Logs.Src.name src) in msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in - { Logs.report } + {Logs.report} let () = Logs.set_reporter (reporter Fmt.stderr) let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) @@ -86,48 +84,72 @@ let authentication_test_0 = let auth hash mechanism authenticator fmt = Fmt.kstr (fun payload -> - Ptt.Authentication.decode_authentication hash mechanism - authenticator + Ptt.Authentication.decode_authentication hash mechanism authenticator (Base64.encode_exn payload)) fmt in let plain_none = Ptt.Authentication.PLAIN None in - auth Digestif.SHA1 plain_none auth0 "\000%s\000%s" "romain.calascibetta" "toto" - >|= Result.map snd >>= 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" - >|= Result.map snd >>= 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" - >|= Result.map snd >>= 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" - >|= Result.map snd >>= 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" "" - >|= Result.map snd >>= fun 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" - >|= Result.map snd >>= 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" - >|= Result.map snd >>= 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" - >|= 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" - >|= Result.map snd >>= fun invalid_username -> - Alcotest.(check (result bool msg)) "invalid username" (Error (`Msg "Invalid username: \"\"")) invalid_username; + 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" >|= Result.map snd + >>= fun invalid_username -> + Alcotest.(check (result bool msg)) + "invalid username" + (Error (`Msg "Invalid username: \"\"")) + invalid_username; Lwt.return_unit -let x25519 = Colombe.Domain.(Domain [ "x25519"; "net" ]) -let gmail = Colombe.Domain.(Domain [ "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" @@ -421,14 +443,11 @@ 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 = { @@ -453,16 +472,12 @@ 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 = { @@ -487,23 +502,22 @@ let smtp_test_3 = Alcotest_lwt.test_case "SMTP (relay) 3" `Quick @@ fun _sw () -> let rdwr, check = rdwr_from_flows - [ "EHLO gmail.com" + [ + "EHLO gmail.com"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET" ; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "RSET"; "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" + ] + [ + "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!"; "250 Yes buddy!" - ; "250 Yes buddy!" - ; "554 You reached the limit buddy!" ] in + ; "554 You reached the limit buddy!" + ] in let ctx = Colombe.State.Context.make () in let info = { @@ -528,16 +542,12 @@ 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:<romain.calascibetta@gmail.com>" - ; "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:<romain.calascibetta@gmail.com>"; "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 = { @@ -570,16 +580,15 @@ 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:<romain.calascibetta@gmail.com>" - ; "RCPT TO:<anil@recoil.org>"; "DATA" ] - [ "220 x25519.net" - ; "250-x25519.net at your service, [127.0.0.1]" - ; "250-8BITMIME" - ; "250-SMTPUTF8" - ; "250 SIZE 16777216" + [ + "EHLO gmail.com"; "MAIL FROM:<romain.calascibetta@gmail.com>" + ; "RCPT TO:<anil@recoil.org>"; "DATA" + ] + [ + "220 x25519.net"; "250-x25519.net at your service, [127.0.0.1]" + ; "250-8BITMIME"; "250-SMTPUTF8"; "250 SIZE 16777216"; "250 Ok, buddy!" ; "250 Ok, buddy!" - ; "250 Ok, buddy!" ] in + ] in let ctx = Colombe.State.Context.make () in let info = { @@ -623,17 +632,12 @@ 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:<romain.calascibetta@gmail.com>" - ; "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:<romain.calascibetta@gmail.com>"; "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 = { @@ -661,14 +665,11 @@ 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 = { @@ -756,7 +757,7 @@ let resolver = | None -> let err = Rresult.R.error_msgf "%a not found" Domain_name.pp domain_name in Lwt.return err in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let make_smtp_server ?stop ~port tbl info stack = let open Lwt.Infix in @@ -773,7 +774,8 @@ let make_smtp_server ?stop ~port tbl info stack = >>= function | Ok () -> Lwt.return () | Error (`Msg err) -> - Logs.err (fun m -> m "<%a:%d> raised an error: %s" Ipaddr.pp ipaddr port 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 @@ -803,11 +805,12 @@ let make_smtp_server ?stop ~port tbl info stack = (smtp_logic messaged (Queue.create ())) *) -module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make - (Time) (Mclock) (Tcpip_stack_socket.V4V6) +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) +module Sendmail = + Sendmail_mirage.Make (Pclock) (Tcpip_stack_socket.V4V6.TCP) + (Happy_eyeballs_daemon) let sendmail he ipaddr port ~domain sender recipients contents = let open Lwt.Infix in @@ -818,8 +821,8 @@ let sendmail he ipaddr port ~domain sender recipients contents = 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 + 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) -> @@ -872,7 +875,8 @@ let full_test_0 = let romain_calascibetta = let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_forward_path) - (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) @@ -881,8 +885,10 @@ let full_test_0 = 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 -> + 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 = @@ -893,26 +899,32 @@ let full_test_0 = let open Lwt.Infix in let tbl = Hashtbl.create 0 in make_smtp_server ~stop ~port:8888 tbl - { Ptt.SMTP.domain= gmail + { + Ptt.SMTP.domain= gmail ; ipaddr= Ipaddr.(V4 V4.localhost) ; tls= None ; zone= Mrmime.Date.Zone.GMT - ; size= 0x1000000L } tcpv4v6 + ; size= 0x1000000L + } + tcpv4v6 >>= fun (`Initialized th, stream) -> let sendmail = sendmail - [ "From: anil@recoil.org" - ; "Subject: SMTP server, PLZ!" - ; "" - ; "Hello World!" ] >>= fun () -> + [ + "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.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, []) + 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 = @@ -921,7 +933,8 @@ let full_test_1 = let romain_calascibetta = let open Mrmime.Mailbox in (Rresult.R.get_ok <.> Colombe_emile.to_forward_path) - (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) @@ -931,64 +944,68 @@ let full_test_1 = (Rresult.R.get_ok <.> Colombe_emile.to_reverse_path) (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 -> + 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 let tbl = Hashtbl.create 0 in make_smtp_server ~stop ~port:4444 tbl - { Ptt.SMTP.domain= gmail + { + Ptt.SMTP.domain= gmail ; ipaddr= Ipaddr.(V4 V4.localhost) ; tls= None ; zone= Mrmime.Date.Zone.GMT - ; size= 0x1000000L } tcpv4v6 + ; size= 0x1000000L + } + tcpv4v6 >>= fun (`Initialized th, stream) -> let sendmail ~domain sender contents = - sendmail he Ipaddr.(V4 V4.localhost) + sendmail he + Ipaddr.(V4 V4.localhost) 4444 ~domain sender [romain_calascibetta] contents in let sendmail = sendmail ~domain:recoil anil - [ "From: anil@recoil.org" - ; "Subject: SMTP server, PLZ!" - ; "" - ; "Hello World!" ] + [ + "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!" ] + [ + "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; ""; "Hello World!" + ] >>= fun () -> Lwt_switch.turn_off stop in - Lwt.join [ sendmail; th ] >>= fun () -> + Lwt.join [sendmail; th] >>= fun () -> Lwt_stream.to_list stream >|= List.map fst >|= List.rev >>= fun inbox -> Alcotest.(check (list key)) "inbox" inbox - [ Ptt.Messaged.key ~domain_from:gazagnaire ~from:(thomas, []) + [ + Ptt.Messaged.key ~domain_from:gazagnaire ~from:(thomas, []) ~recipients:[romain_calascibetta, []] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 1L ; 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] - ; "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 dune build @fmt failed "/usr/bin/env" "bash" "-c" "opam exec -- dune build @fmt --ignore-promoted-rules || (echo "dune build @fmt failed"; exit 2)" failed with exit status 2 2024-10-11 12:32.48: Job failed: Failed: Build failed