2024-11-05 15:20.37: New job: test mirage/ptt https://github.com/mirage/ptt.git#refs/heads/master (8c15b9d41c1dc721c07b31ad538314b3596dc250) (linux-x86_64:(lint-fmt)) Base: ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8 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 8c15b9d4 cat > Dockerfile <<'END-OF-DOCKERFILE' FROM ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8 USER 1000:1000 RUN cd ~/opam-repository && (git cat-file -e 654ee104df48ee785861d169cd1ca7eba64b6668 || git fetch origin master) && git reset -q --hard 654ee104df48ee785861d169cd1ca7eba64b6668 && 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-11-05 15:20.37: Using cache hint "mirage/ptt-ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8-debian-12-4.08_opam-2.2-ocamlformat-654ee104df48ee785861d169cd1ca7eba64b6668" 2024-11-05 15:20.37: Using OBuilder spec: ((from ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8) (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 654ee104df48ee785861d169cd1ca7eba64b6668 || git fetch origin master) && git reset -q --hard 654ee104df48ee785861d169cd1ca7eba64b6668 && 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-11-05 15:20.37: Waiting for resource in pool OCluster 2024-11-05 15:20.37: Waiting for worker… 2024-11-05 15:20.37: Got resource from pool OCluster Building on x86-bm-c5.sw.ocaml.org All commits already cached HEAD is now at 8c15b9d Merge pull request #49 from mirage/elit (from ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8) Unable to find image 'ocaml/opam:debian-12-ocaml-4.08@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8' locally docker.io/ocaml/opam@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8: Pulling from ocaml/opam c06f3571e47c: Pulling fs layer c06f3571e47c: Verifying Checksum c06f3571e47c: Download complete c06f3571e47c: Pull complete Digest: sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8 Status: Downloaded newer image for ocaml/opam@sha256:e4f2cf9099096504addd23b73b0d98c5a1fbb1633a6d52b7627cfa16f89debf8 2024-11-05 15:20.37 ---> using "45ed51cabfe3de1acd486922e22b24eee2a37ab1a07c3ddaa8a9367527eeade3" 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 654ee104df48ee785861d169cd1ca7eba64b6668 || git fetch origin master) && git reset -q --hard 654ee104df48ee785861d169cd1ca7eba64b6668 && git log --no-decorate -n1 --oneline && opam update -u")) From https://github.com/ocaml/opam-repository * branch master -> FETCH_HEAD d872638bdf..8582dee8ae master -> origin/master 654ee104df Merge pull request #26834 from mtelvers/opam-publish-ocaml-version.3.7.0 <><> 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-11-05 15:20.37 ---> using "18901fe09c8dc82dfc1bd6387f454db3a5837c77a102a9a582c26793a9a85840" 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.1 <><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><> [dune.3.16.1] found in cache <><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><> -> installed dune.3.16.1 Done. # Run eval $(opam env) to update the current shell environment 2024-11-05 15:20.37 ---> using "38c457990c07d85296d3b7bed82ffaff5af001eae317464ac0a075812df097e9" 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 menhirLib 20240715 [required by ocamlformat-lib] - install menhirCST 20240715 [required by menhir] - install menhirSdk 20240715 [required by ocamlformat-lib] - install ocaml-version 3.7.0 [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 fix 20230505 [required by ocamlformat-lib] - install dune-build-info 3.16.1 [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.1 [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.1] found in cache [dune-configurator.3.16.1] 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.7.0] 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 either.1.0.0 -> installed fix.20230505 -> installed cmdliner.1.3.0 -> installed menhirCST.20240715 -> installed menhirLib.20240715 -> installed menhirSdk.20240715 -> installed ocaml-version.3.7.0 -> installed re.1.11.0 -> installed result.1.5 -> installed sexplib0.v0.14.0 -> installed dune-build-info.3.16.1 -> installed dune-configurator.3.16.1 -> 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 topkg.1.0.7 -> installed stdio.v0.14.0 -> 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-11-05 15:20.37 ---> using "461fccf8bc43bcf03b770a5f2324a4ebdbf1e3173fbd6e418b4a30a84fb31b26" from cache /src: (copy (src .) (dst /src/)) 2024-11-05 15:20.37 ---> saved as "0beb7e81b5621a23cf7413e73f340ab1fe1038d8c4d4f4df732cc61e3deb7b59" /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 0f25c32..56b31f8 100644 --- a/_build/default/lib/dune +++ b/_build/default/lib/.formatted/dune @@ -8,7 +8,8 @@ (name ptt_sendmail) (public_name ptt.sendmail) (modules ptt_sendmail) - (libraries hxd.core hxd.string emile colombe.emile mrmime sendmail-mirage ptt.common)) + (libraries hxd.core hxd.string emile colombe.emile mrmime sendmail-mirage + ptt.common)) (library (name ptt_aggregate) @@ -32,15 +33,16 @@ (name ptt) (public_name ptt) (modules ptt authentication logic mechanism msgd relay sMTP sSMTP submission) - (libraries ptt.common ptt.flow ptt.aggregate digestif mrmime colombe.emile domain-name dns sendmail.starttls - logs ipaddr) + (libraries ptt.common ptt.flow ptt.aggregate digestif mrmime colombe.emile + domain-name dns sendmail.starttls logs ipaddr) (preprocess future_syntax)) (library (name ptt_server) (public_name ptt.server) (modules ptt_server) - (libraries lwt tls-mirage bigstringaf mirage-time mirage-flow tcpip mimic ptt)) + (libraries lwt tls-mirage bigstringaf mirage-time mirage-flow tcpip mimic + ptt)) (library (name ptt_fake_dns) @@ -52,31 +54,36 @@ (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 elit) (public_name ptt.elit) (modules elit) - (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server dns-client-mirage uspf-mirage)) + (libraries mirage-time mirage-clock mirage-random ptt ptt.map ptt.server + dns-client-mirage uspf-mirage)) (library (name ptt_value) @@ -88,4 +95,5 @@ (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)) 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/elit.mli", line 1, characters 0-0: diff --git a/_build/default/lib/elit.mli b/_build/default/lib/.formatted/elit.mli index 59ec360..4fcf4be 100644 --- a/_build/default/lib/elit.mli +++ b/_build/default/lib/.formatted/elit.mli @@ -4,20 +4,22 @@ 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 type 'k t - type 'k iter = (Ptt_map.local -> 'k Digestif.t -> Emile.mailbox list -> unit Lwt.t) -> unit Lwt.t + + type 'k iter = + (Ptt_map.local -> 'k Digestif.t -> Emile.mailbox list -> unit Lwt.t) + -> unit Lwt.t val v : - ?g:Mirage_crypto_rng.g - -> ?mechanisms:Ptt.Mechanism.t list - -> postmaster:Emile.mailbox - -> ?forward_granted:Ipaddr.Prefix.t list - -> 'k Digestif.hash - -> 'k iter - -> Ipaddr.t - -> 'k t Lwt.t + ?g:Mirage_crypto_rng.g + -> ?mechanisms:Ptt.Mechanism.t list + -> postmaster:Emile.mailbox + -> ?forward_granted:Ipaddr.Prefix.t list + -> 'k Digestif.hash + -> 'k iter + -> Ipaddr.t + -> 'k t Lwt.t val job : ?stop:Lwt_switch.t 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/msgd.mli", line 1, characters 0-0: diff --git a/_build/default/lib/msgd.mli b/_build/default/lib/.formatted/msgd.mli index 2be1913..10b5a60 100644 --- a/_build/default/lib/msgd.mli +++ b/_build/default/lib/.formatted/msgd.mli @@ -28,7 +28,6 @@ type error = | `Requested_action_not_taken of [ `Temporary | `Permanent ] ] type result = [ error | `Ok ] - type t = (key * string Lwt_stream.t * result Lwt.u) Lwt_stream.t val pp_error : error Fmt.t 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/ptt_fake_dns.mli", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_fake_dns.mli b/_build/default/lib/.formatted/ptt_fake_dns.mli index 575c8b6..2bf7777 100644 --- a/_build/default/lib/ptt_fake_dns.mli +++ b/_build/default/lib/.formatted/ptt_fake_dns.mli @@ -1,5 +1,8 @@ -module Make (Destination : sig val ipaddr : Ipaddr.t end) : sig - include Dns_client_mirage.S - with type 'a Transport.io = 'a Lwt.t - and type Transport.stack = unit +module Make (Destination : sig + val ipaddr : Ipaddr.t +end) : sig + include + Dns_client_mirage.S + with type 'a Transport.io = 'a Lwt.t + and type Transport.stack = unit end 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 5d932a8..1effd71 100644 --- a/_build/default/lib/mxs.mli +++ b/_build/default/lib/.formatted/mxs.mli @@ -4,5 +4,10 @@ val pp_key : key Fmt.t include Map.S with type key := key -val v : preference:int -> domain:[ `host ] Domain_name.t -> Ipaddr.t list -> Ipaddr.t list t +val v : + preference:int + -> domain:[ `host ] Domain_name.t + -> Ipaddr.t list + -> Ipaddr.t list t + val vs : (Dns.Mx.t * Ipaddr.t list) list -> Ipaddr.t list t 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/authentication.ml", line 1, characters 0-0: diff --git a/_build/default/lib/authentication.ml b/_build/default/lib/.formatted/authentication.ml index 1fdd531..4990dac 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 = [ `Dot_string of string list | `String of string ] 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' @@ -26,23 +25,28 @@ let decode_plain_authentication hash ?stamp t v = char '\000' *> available >>= take >>= fun v2 -> return (v0, v1, v2) in let payload = Base64.decode ~pad:false (* XXX(dinosaure): not really sure. *) v - >>= (R.reword_error (fun _ -> `Msg "Invalid input") <.> Angstrom.parse_string ~consume:All parser) in + >>= (R.reword_error (fun _ -> `Msg "Invalid input") + <.> Angstrom.parse_string ~consume:All parser) in match stamp, payload with | Some stamp, Ok (v0, v1, v2) -> if Eqaf.equal stamp v0 then - match Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 with + match + Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 + with | Ok username -> authenticate hash username v2 t | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1) else Lwt.return (R.error_msgf "Invalid stamp") - | None, Ok ("", v1, v2) -> - begin match Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 with + | None, Ok ("", v1, v2) -> begin + match + Angstrom.parse_string ~consume:All Colombe.Path.Decoder.local_part v1 + with | Ok username -> authenticate hash username v2 t - | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1) end + | Error _ -> Lwt.return (R.error_msgf "Invalid username: %S" v1) + end | None, Ok (_, _, _) -> Lwt.return (R.error_msgf "Unexpected stamp") | _, (Error _ as err) -> Lwt.return err 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 "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 "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 "lib/msgd.ml", line 1, characters 0-0: diff --git a/_build/default/lib/msgd.ml b/_build/default/lib/.formatted/msgd.ml index 89f9ab2..ecf1b08 100644 --- a/_build/default/lib/msgd.ml +++ b/_build/default/lib/.formatted/msgd.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 @@ -67,8 +68,8 @@ let pp_error ppf = function | `Too_big -> Fmt.string ppf "Email too big" | `Failed -> Fmt.string ppf "Failed" | `Requested_action_not_taken `Temporary -> - Fmt.string ppf "Requested action not taken (temporary)" + Fmt.string ppf "Requested action not taken (temporary)" | `Requested_action_not_taken `Permanent -> - Fmt.string ppf "Requested action not taken (permanent)" + Fmt.string ppf "Requested action not taken (permanent)" type t = (key * string Lwt_stream.t * result Lwt.u) Lwt_stream.t 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 b0fcad7..f664740 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 exists : local:local -> t -> bool val all : t -> Colombe.Forward_path.t list 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 8b6b87d..4ab103c 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 list, [> `Msg of string ] as 'a) result Lwt.t + -> (Ipaddr.t list, ([> `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_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 18253bc..e3d0102 100644 --- a/_build/default/lib/ptt_sendmail.mli +++ b/_build/default/lib/.formatted/ptt_sendmail.mli @@ -22,16 +22,22 @@ 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 ] @@ -39,9 +45,9 @@ and policy = [ `Ignore ] val pp_recipients : recipients Fmt.t 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_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/relay.mli", line 1, characters 0-0: diff --git a/_build/default/lib/relay.mli b/_build/default/lib/.formatted/relay.mli index 363bd67..fadc7fd 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 * (Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) Lwt_stream.t * (unit -> unit) + -> server + * (Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) Lwt_stream.t + * (unit -> unit) val accept : ?encoder:(unit -> bytes) 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 78e3f2e..3f433a6 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,13 +31,13 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [(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 = @@ -46,8 +46,8 @@ struct (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, _) -> Submission.accept_without_starttls ~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 @@ -56,9 +56,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 () = @@ -71,25 +71,41 @@ 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.Msgd.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.wakeup_later wk `Ok; 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 @@ -102,12 +118,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_fake_dns.ml", line 1, characters 0-0: diff --git a/_build/default/lib/ptt_fake_dns.ml b/_build/default/lib/.formatted/ptt_fake_dns.ml index 514355a..a56d844 100644 --- a/_build/default/lib/ptt_fake_dns.ml +++ b/_build/default/lib/.formatted/ptt_fake_dns.ml @@ -1,61 +1,111 @@ let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt -module Make (Destination : sig val ipaddr : Ipaddr.t end) = struct +module Make (Destination : sig + val ipaddr : Ipaddr.t +end) = +struct module Transport = struct type context = unit type stack = unit type t = unit type 'a io = 'a Lwt.t + type io_addr = - [ `Plaintext of Ipaddr.t * int + [ `Plaintext of Ipaddr.t * int | `Tls of Tls.Config.client * Ipaddr.t * int ] - + let create ?nameservers:_ ~timeout:_ _ = () let nameservers _ = `Tcp, [] let rng _ = String.empty let clock _ = 0L - let connect _ = Lwt.return_error (msgf "Ptt_fake_dns.Transport.connect: not implemented") - let send_recv _ _ = Lwt.return_error (msgf "Ptt_fake_dns.Transport.send_Recv: not implemented") + + let connect _ = + Lwt.return_error (msgf "Ptt_fake_dns.Transport.connect: not implemented") + + let send_recv _ _ = + Lwt.return_error + (msgf "Ptt_fake_dns.Transport.send_Recv: not implemented") + let close _ = Lwt.return_unit let bind = Lwt.bind let lift = Lwt.return let happy_eyeballs _ = assert false end - + type happy_eyeballs = unit - + include Dns_client.Make (Transport) - + (* NOTE(dinosaure): [ptt] only uses [getaddrinfo], [gethostbyname] & [gethostbyname6]. The rest is useless. *) - - let getaddrinfo - : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (a, [> `Msg of string ]) result Lwt.t - = fun _ record domain_name -> match record, Domain_name.host domain_name with - | Dns.Rr_map.Mx, Ok mail_exchange -> Lwt.return_ok (0l, Dns.Rr_map.Mx_set.singleton { Dns.Mx.preference= 0; mail_exchange; }) - | _ -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K record) Domain_name.pp domain_name) - - let gethostbyname _t domain_name = match Destination.ipaddr with + + let getaddrinfo : + type a. + t + -> a Dns.Rr_map.key + -> 'x Domain_name.t + -> (a, [> `Msg of string ]) result Lwt.t = + fun _ record domain_name -> + match record, Domain_name.host domain_name with + | Dns.Rr_map.Mx, Ok mail_exchange -> + Lwt.return_ok + (0l, Dns.Rr_map.Mx_set.singleton {Dns.Mx.preference= 0; mail_exchange}) + | _ -> + Lwt.return_error + (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk + Dns.Rr_map.(K record) + Domain_name.pp domain_name) + + let gethostbyname _t domain_name = + match Destination.ipaddr with | Ipaddr.V4 ipv4 -> Lwt.return_ok ipv4 | _ -> Lwt.return_error (msgf "%a not found" Domain_name.pp domain_name) - - let gethostbyname6 _t domain_name = match Destination.ipaddr with + + let gethostbyname6 _t domain_name = + match Destination.ipaddr with | Ipaddr.V6 ipv6 -> Lwt.return_ok ipv6 | _ -> Lwt.return_error (msgf "%a not found" Domain_name.pp domain_name) - - let get_resource_record - : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (a, [> `Msg of string | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ]) result Lwt.t - = fun _t record domain_name -> match record, Domain_name.host domain_name with - | Dns.Rr_map.Mx, Ok mail_exchange -> Lwt.return_ok (0l, Dns.Rr_map.Mx_set.singleton { Dns.Mx.preference= 0; mail_exchange; }) - | _ -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K record) Domain_name.pp domain_name) - - let get_raw_reply - : type a. t -> a Dns.Rr_map.key -> 'x Domain_name.t -> (Dns.Packet.reply, [> `Msg of string | `Partial ]) result Lwt.t - = fun _t _record _domain_name -> Lwt.return_error (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk Dns.Rr_map.(K _record) Domain_name.pp _domain_name) - - let nameserver_of_string _ = Error (msgf "Ptt_fake_dns.nameserver_of_string: not implemented") + + let get_resource_record : + type a. + t + -> a Dns.Rr_map.key + -> 'x Domain_name.t + -> ( a + , [> `Msg of string + | `No_data of [ `raw ] Domain_name.t * Dns.Soa.t + | `No_domain of [ `raw ] Domain_name.t * Dns.Soa.t ] ) + result + Lwt.t = + fun _t record domain_name -> + match record, Domain_name.host domain_name with + | Dns.Rr_map.Mx, Ok mail_exchange -> + Lwt.return_ok + (0l, Dns.Rr_map.Mx_set.singleton {Dns.Mx.preference= 0; mail_exchange}) + | _ -> + Lwt.return_error + (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk + Dns.Rr_map.(K record) + Domain_name.pp domain_name) + + let get_raw_reply : + type a. + t + -> a Dns.Rr_map.key + -> 'x Domain_name.t + -> (Dns.Packet.reply, [> `Msg of string | `Partial ]) result Lwt.t = + fun _t _record _domain_name -> + Lwt.return_error + (msgf "Impossible to get %a from %a" Dns.Rr_map.ppk + Dns.Rr_map.(K _record) + Domain_name.pp _domain_name) + + let nameserver_of_string _ = + Error (msgf "Ptt_fake_dns.nameserver_of_string: not implemented") + let nameservers _ = `Tcp, [] let transport _ = () + let connect ?cache_size ?edns ?nameservers:_ ?timeout () = create ?cache_size ?edns ~nameservers:(`Tcp, []) ?timeout () |> Lwt.return end 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 cdc85dc..aa4e904 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,13 +32,13 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -59,15 +59,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 () = @@ -76,9 +76,8 @@ struct | Some (key, stream, wk) -> let sender, _ = Ptt.Msgd.from key in let ctx = - Uspf.empty - |> Uspf.with_ip (Ptt.Msgd.ipaddr key) - |> fun ctx -> Option.fold ~none:ctx + Uspf.empty |> Uspf.with_ip (Ptt.Msgd.ipaddr key) |> fun ctx -> + Option.fold ~none:ctx ~some:(fun sender -> Uspf.with_sender (`MAILFROM sender) ctx) sender in let verify () = @@ -89,29 +88,39 @@ struct Lwt.return_unit | 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 result = match result with + let stream = + Lwt_stream.append (stream_of_field field_name unstrctrd) stream + in + let result = + match result with | `Pass _ | `Neutral | `None -> `Ok | `Permerror | `Fail -> `Requested_action_not_taken `Permanent - | `Temperror | `Softfail -> `Requested_action_not_taken `Temporary in + | `Temperror | `Softfail -> `Requested_action_not_taken `Temporary + in Lwt.wakeup_later wk result; let recipients = Ptt.Msgd.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.Msgd.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 in verify () >>= Lwt.pause >>= go in @@ -130,12 +139,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/sSMTP.mli", line 1, characters 0-0: diff --git a/_build/default/lib/sSMTP.mli b/_build/default/lib/.formatted/sSMTP.mli index a245c6c..bf53101 100644 --- a/_build/default/lib/sSMTP.mli +++ b/_build/default/lib/.formatted/sSMTP.mli @@ -74,9 +74,7 @@ val m_end : -> ([> `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/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 63af715..fef8350 100644 --- a/_build/default/lib/ptt_flow.ml +++ b/_build/default/lib/.formatted/ptt_flow.ml @@ -1,13 +1,12 @@ let src = Logs.Src.create "ptt.flow" module Log = (val Logs.src_log src) - open Colombe.Sigs 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) @@ -16,7 +15,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 @@ -32,29 +31,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 = @@ -75,31 +71,36 @@ 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 pp_data buffer off _ ppf = function | `End -> Fmt.string ppf "<end>" - | `Len len -> Fmt.pf ppf "@[<hov>%a@]" (Hxd_string.pp Hxd.default) (Bytes.sub_string buffer off len) + | `Len len -> + Fmt.pf ppf "@[<hov>%a@]" + (Hxd_string.pp Hxd.default) + (Bytes.sub_string buffer off len) 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 -> - Log.debug (fun m -> m "-> %a" (pp_data buffer off len) v); - go (k v) - | Write { buffer; off; len; k } -> - Log.debug (fun m -> m "<- @[<hov>%a@]" - (Hxd_string.pp Hxd.default) (String.sub buffer off len)); - rdwr.wr flow buffer off len >>= fun () -> go (k len) + | Read {buffer; off; len; k} -> + rdwr.rd flow buffer off len >>= fun v -> + Log.debug (fun m -> m "-> %a" (pp_data buffer off len) v); + go (k v) + | Write {buffer; off; len; k} -> + Log.debug (fun m -> + m "<- @[<hov>%a@]" + (Hxd_string.pp Hxd.default) + (String.sub buffer off len)); + 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 @@ -107,8 +108,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 ocamlformat: Cannot process "lib/relay.ml". Please report this bug at https://github.com/ocaml-ppx/ocamlformat/issues. BUG: comment changed. File "lib/relay.ml", line 59, characters 6-58: Error: comment (* NOTE(dinosaure): [552] will be returned later. *) dropped. -> required by _build/default/lib/.formatted/relay.ml -> required by alias lib/.formatted/fmt -> required by alias lib/fmt 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 f46fb32..15fe295 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 : @@ -83,9 +78,7 @@ val m_end : -> ([> `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 @@ -94,5 +87,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/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 8bd0b36..3fecb5a 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 @@ -36,11 +38,9 @@ let exists_as_sender sender ~info t = let exists ~local 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) @@ -48,20 +48,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/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/submission.mli", line 1, characters 0-0: diff --git a/_build/default/lib/submission.mli b/_build/default/lib/.formatted/submission.mli index 5526645..b6b6df7 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 * (Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) Lwt_stream.t * (unit -> unit) + -> 'k server + * (Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) Lwt_stream.t + * (unit -> unit) val accept_without_starttls : ?encoder:(unit -> bytes) 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 d66b438..a82229e 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,13 +31,13 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -52,17 +52,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 @@ -72,17 +73,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.Msgd.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.wakeup_later wk `Ok; Lwt.pause () >>= go in @@ -101,12 +107,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/nec.ml", line 1, characters 0-0: diff --git a/_build/default/lib/nec.ml b/_build/default/lib/.formatted/nec.ml index 113be48..dea0a36 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,13 +31,13 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} let server_job ~pool ?stop ~port stack dns server close = let handler flow = @@ -56,9 +56,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 () = @@ -68,35 +68,56 @@ 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.Msgd.from key in let recipients = Ptt.Msgd.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.Msgd.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.wakeup_later wk `Ok; 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 @@ -109,12 +130,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/sMTP.ml", line 1, characters 0-0: diff --git a/_build/default/lib/sMTP.ml b/_build/default/lib/.formatted/sMTP.ml index 400dc97..7d92bf0 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 @@ -118,11 +118,11 @@ let m_relay_init ctx info = go () | `Quit -> m_politely_close ctx | `Hello _from_domain -> - (* NOTE(dinosaure): [nstools.fr] asks [EHLO]/[HELO] two times. We must - handle it correctly. *) - incr bad; - let* () = send ctx Value.PP_250 capabilities in - go () + (* NOTE(dinosaure): [nstools.fr] asks [EHLO]/[HELO] two times. We must + handle it correctly. *) + incr bad; + let* () = send ctx Value.PP_250 capabilities in + go () | _ -> incr bad; let* () = @@ -143,8 +143,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 "lib/sSMTP.ml", line 1, characters 0-0: diff --git a/_build/default/lib/sSMTP.ml b/_build/default/lib/.formatted/sSMTP.ml index f272791..b22b901 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/spartacus.ml", line 1, characters 0-0: diff --git a/_build/default/lib/spartacus.ml b/_build/default/lib/.formatted/spartacus.ml index 334456b..bf6f3a8 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,13 +31,13 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [(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,9 +58,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 () = @@ -73,8 +73,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.Msgd.from key in let recipients = Ptt.Msgd.recipients key in @@ -82,12 +81,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.Msgd.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.wakeup_later wk `Ok; Lwt.pause () >>= go in @@ -106,12 +110,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/logic.ml", line 1, characters 0-0: diff --git a/_build/default/lib/logic.ml b/_build/default/lib/.formatted/logic.ml index 78793a4..be36a31 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 : @@ -270,16 +272,19 @@ module Make (Monad : MONAD) = struct let m_end result ctx = let open Monad in - let* () = match result with + let* () = + match result with | `Ok -> send ctx Value.PP_250 ["Mail sended, buddy!"] | `Aborted -> - send ctx Value.Code (451, ["Requested action aborted: local error in processing"]) + send ctx Value.Code + (451, ["Requested action aborted: local error in processing"]) | `Not_enough_memory -> - send ctx Value.Code (452, ["Requested action not taken: insufficient system storage"]) + send ctx Value.Code + (452, ["Requested action not taken: insufficient system storage"]) | `Too_big -> - send ctx Value.Code (552, ["Requested mail action aborted: exceeded storage allocation"]) - | `Failed -> - send ctx Value.Code (554, ["Transaction failed"]) + send ctx Value.Code + (552, ["Requested mail action aborted: exceeded storage allocation"]) + | `Failed -> send ctx Value.Code (554, ["Transaction failed"]) | `Requested_action_not_taken `Temporary -> send ctx Value.Code (450, ["Requested mail action not taken"]) | `Requested_action_not_taken `Permanent -> @@ -294,9 +299,7 @@ module Make (Monad : MONAD) = struct 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 + ; "8BITMIME"; "SMTPUTF8"; Fmt.str "SIZE %Ld" info.Ptt_common.size ] in m_relay ctx ~domain_from @@ -307,9 +310,7 @@ module Make (Monad : MONAD) = struct 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 + ; "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/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 3884fb4..12a6f91 100644 --- a/_build/default/lib/ptt_sendmail.ml +++ b/_build/default/lib/.formatted/ptt_sendmail.ml @@ -1,38 +1,42 @@ 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 ] [@@@warning "+30"] -let pp_recipients ppf { domain; locals } = +let pp_recipients ppf {domain; locals} = let pp_domain ppf = function | `Ipaddr (Ipaddr.V4 ipv4) -> Fmt.pf ppf "[%a]" Ipaddr.V4.pp ipv4 | `Ipaddr (Ipaddr.V6 ipv6) -> Fmt.pf ppf "[IPv6:%a]" Ipaddr.V6.pp ipv6 @@ -40,122 +44,138 @@ let pp_recipients ppf { domain; locals } = match locals with | `All -> Fmt.pf ppf "<%a>" pp_domain domain | `Postmaster -> Fmt.pf ppf "Postmaster@%a" pp_domain domain - | `Some locals -> Fmt.pf ppf "%a@%a" Fmt.(Dump.list Emile.pp_local) locals pp_domain domain + | `Some locals -> + Fmt.pf ppf "%a@%a" Fmt.(Dump.list Emile.pp_local) locals pp_domain domain 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 ) (* NOTE(dinosaure): to ensure that we are able to inject a fake DNS resolver, we must use an IP address as a destination to avoid the resolution mechanism of happy-eyeballs! *) - let sendmail ?(last_option= false) he t ~ipaddrs elt = + let sendmail ?(last_option = false) he t ~ipaddrs elt = let ( let* ) = Lwt.bind in let destination = `Ipaddrs ipaddrs 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 debug = Lwt_stream.clone backup in - let* debug = Lwt_stream.to_list debug in - let debug = String.concat "" debug in - Log.debug (fun m -> m "Incoming bad email:"); - Log.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) debug); - let* forward_path = guess_return_path backup in - Lwt.return (`Errored (forward_path, err)) - else match result with + let debug = Lwt_stream.clone backup in + let* debug = Lwt_stream.to_list debug in + let debug = String.concat "" debug in + Log.debug (fun m -> m "Incoming bad email:"); + Log.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) debug); + 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 debug = Lwt_stream.clone backup in - let* debug = Lwt_stream.to_list debug in - let debug = String.concat "" debug in - Log.debug (fun m -> m "Incoming bad email:"); - Log.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) debug); - let* forward_path = guess_return_path backup in - Lwt.return (`Errored (forward_path, err)) + let debug = Lwt_stream.clone backup in + let* debug = Lwt_stream.to_list debug in + let debug = String.concat "" debug in + Log.debug (fun m -> m "Incoming bad email:"); + Log.debug (fun m -> m "@[<hov>%a@]" (Hxd_string.pp Hxd.default) debug); + 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 -> Lwt.return_unit (* TODO *) let pp_error ppf = function @@ -166,73 +186,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 -> Lwt.return_unit (* 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 -> + Lwt.return_ok Mxs.(v ~preference:0 ~domain [ipaddr]) + | `Domain domain -> ( let* r = t.resolver.getmxbyname dns domain in match r with | Ok mxs -> - let resolve = (Fun.flip Lwt_list.fold_left_s [] ) - begin fun acc ({ Dns.Mx.mail_exchange; _ } as mx) -> - let* r = t.resolver.gethostbyname dns mail_exchange in - match r with - | Ok ipaddrs -> Lwt.return ((mx, ipaddrs) :: 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 ipaddrs -> Lwt.return ((mx, ipaddrs) :: 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, ipaddrs ] -> + (* 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, ipaddrs)] -> let* result = sendmail ~last_option:true he t ~ipaddrs elt in - begin match result with - | `Retry | `Ok -> Lwt.return_unit - | `Errored value -> error_while_sending_email elt value end - | (_mx, ipaddrs) :: mxs -> + begin + match result with + | `Retry | `Ok -> Lwt.return_unit + | `Errored value -> error_while_sending_email elt value + end + | (_mx, ipaddrs) :: mxs -> ( let* result = sendmail he t ~ipaddrs 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/submission.ml", line 1, characters 0-0: diff --git a/_build/default/lib/submission.ml b/_build/default/lib/.formatted/submission.ml index 71beff2..7410077 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,20 +11,22 @@ 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 ; msgd: Msgd.t - ; push: ((Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) option -> unit) + ; push: (Msgd.key * string Lwt_stream.t * Msgd.result Lwt.u) 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 @@ -47,9 +48,13 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | `Invalid_recipients | `End_of_input ] - 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 @@ -61,18 +66,26 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct | `Invalid_recipients -> Fmt.string ppf "Invalid recipients" | `End_of_input -> Fmt.string ppf "End of input" - 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 @@ -95,7 +108,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; @@ -113,9 +128,8 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct >>= function | Ok (user, true) -> let m = SSMTP.(Monad.send ctx Value.PP_235 ["Accepted, buddy!"]) in - run flow m >>? fun () -> - Lwt.return_ok (`Authenticated user) - | (Error _ | Ok (_, false)) as res -> + run flow m >>? fun () -> Lwt.return_ok (`Authenticated user) + | (Error _ | Ok (_, false)) as res -> ( let () = match res with | Error (`Msg err) -> @@ -133,7 +147,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 = @@ -142,20 +157,22 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct let dot = ".\r\n" - let receive_mail ?(limit = 0x100000) (Runner { run; flow}) ctx m push = + let receive_mail ?(limit = 0x100000) (Runner {run; flow}) ctx m push = let rec go count () = - if count >= limit - then begin push None; Lwt.return_error `Too_big end + if count >= limit then begin + push None; Lwt.return_error `Too_big + end else run flow (m ctx) >>? function - | ".." -> push (Some dot); go (count + 3) () + | ".." -> + push (Some dot); + go (count + 3) () | "." -> push None; Lwt.return_ok () | str -> let len = String.length str in let str = str ^ "\r\n" in push (Some str); - go (count + len + 2) () - in + go (count + len + 2) () in go 0 () let merge from_protocol from_logic = @@ -180,17 +197,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) -> @@ -199,18 +218,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 = Msgd.key ~domain_from ~from ~recipients ~ipaddr id in let stream, push = Lwt_stream.create () in @@ -224,16 +246,21 @@ module Make (Stack : Tcpip.Stack.V4V6) = struct SSMTP.(fun ctx -> Monad.recv ctx Value.Payload) push >>= fun result -> - Log.debug (fun m -> m "Email received, waiting result from the logic"); + Log.debug (fun m -> + m "Email received, waiting result from the logic"); th >>= fun result' -> let m = SSMTP.m_end (merge result result') ctx in run flow m >>? fun `Quit -> - let result = match merge result result' with + let result = + match merge result result' with | `Ok -> Ok () | #Msgd.error as err -> Error err in - Lwt.return result end + Lwt.return result + 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 "lib/elit.ml", line 1, characters 0-0: diff --git a/_build/default/lib/elit.ml b/_build/default/lib/.formatted/elit.ml index 95bc4c0..3cf6e02 100644 --- a/_build/default/lib/elit.ml +++ b/_build/default/lib/.formatted/elit.ml @@ -5,7 +5,7 @@ let src = Logs.Src.create "ptt.elit" 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) @@ -26,41 +26,41 @@ struct let submission_resolver = let open Ptt_common in let getmxbyname _ipaddr mail_exchange = - Dns.Rr_map.Mx_set.(singleton { Dns.Mx.preference= 0; mail_exchange }) + Dns.Rr_map.Mx_set.(singleton {Dns.Mx.preference= 0; mail_exchange}) |> Lwt.return_ok in - let gethostbyname ipaddr _domain_name = - Lwt.return_ok ipaddr in - { getmxbyname; gethostbyname } + let gethostbyname ipaddr _domain_name = Lwt.return_ok ipaddr in + {getmxbyname; gethostbyname} - let submission_job ~pool ?stop ?(port= 465) ~destination - random hash stack server close = + let submission_job + ~pool ?stop ?(port = 465) ~destination random hash stack server close = let handler flow = let ipaddr, port = Stack.TCP.dst flow in Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, _) -> - Submission.accept_without_starttls - ~encoder:(Fun.const encoder) ~decoder:(Fun.const decoder) ~ipaddr - flow destination submission_resolver - random hash server + Submission.accept_without_starttls ~encoder:(Fun.const encoder) + ~decoder:(Fun.const decoder) ~ipaddr flow destination + submission_resolver random hash server >|= R.reword_error (R.msgf "%a" Submission.pp_error)) (fun () -> Stack.TCP.close flow) >>= 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 + let job = job >|= close in + job let submission_logic_job ~info map (ic, oc) = let rec go () = Lwt_stream.get ic >>= function | None -> oc None; Lwt.return_unit | Some (key, stream, wk) -> - Lwt.catch + Lwt.catch (fun () -> let sender = fst (Ptt.Msgd.from key) in let recipients = Ptt.Msgd.recipients key in @@ -68,29 +68,54 @@ 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.Msgd.id key) in - Log.debug (fun m -> m "%a submitted a new email %a." - Colombe.Reverse_path.pp sender Mrmime.MessageID.pp id); - let elts = List.map (fun recipients -> - { Ptt_sendmail.sender - ; recipients - ; data= Lwt_stream.clone stream - ; policies= [] - ; id }) recipients in - Log.debug (fun m -> m "Notice the SMTP server that everything is ok for %a from %a." - Colombe.Reverse_path.pp sender Mrmime.MessageID.pp id); + Log.debug (fun m -> + m "%a submitted a new email %a." Colombe.Reverse_path.pp + sender Mrmime.MessageID.pp id); + let elts = + List.map + (fun recipients -> + { + Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id + }) + recipients in + Log.debug (fun m -> + m + "Notice the SMTP server that everything is ok for %a from \ + %a." + Colombe.Reverse_path.pp sender Mrmime.MessageID.pp id); Lwt.wakeup_later wk `Ok; - Log.debug (fun m -> m "Send the incoming email %a to our destination." - Mrmime.MessageID.pp id); + Log.debug (fun m -> + m "Send the incoming email %a to our destination." + Mrmime.MessageID.pp id); List.iter (oc $ Option.some) elts; Lwt.return_unit) - (fun exn -> - Log.err (fun m -> m "Got an error into the submission logic: %S" (Printexc.to_string exn)); - Lwt.return_unit) - >>= Lwt.pause >>= go in + (fun exn -> + Log.err (fun m -> + m "Got an error into the submission logic: %S" + (Printexc.to_string exn)); + Lwt.return_unit) + >>= Lwt.pause + >>= go in go () - let job ?(limit = 20) ?stop ~locals ?port ~tls ~info ~destination - stack he random hash authenticator mechanisms = + let job + ?(limit = 20) + ?stop + ~locals + ?port + ~tls + ~info + ~destination + stack + he + random + hash + authenticator + mechanisms = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create 0x7ff in @@ -103,14 +128,17 @@ 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 ic_server, stream0, close0 = Submission.create ~info ~authenticator mechanisms in - let oc_server, push0 = Sendmail.v ~resolver:submission_resolver ~pool:pool1 ~info tls 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:submission_resolver ~pool:pool1 ~info tls in Lwt.join - [ submission_job ~pool:pool0 ?stop ?port ~destination random hash stack ic_server close0 - ; submission_logic_job ~info locals (stream0, push0) - ; Sendmail.job destination he oc_server ] + [ + submission_job ~pool:pool0 ?stop ?port ~destination random hash stack + ic_server close0; submission_logic_job ~info locals (stream0, push0) + ; Sendmail.job destination he oc_server + ] end module Out = struct @@ -119,8 +147,8 @@ struct let mail_exchange_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 @@ -128,130 +156,169 @@ struct let ipv6 = Dns_client.gethostbyname6 dns domain_name >|= Result.map (fun ipv6 -> Ipaddr.V6 ipv6) in - Lwt.all [ ipv4; ipv6 ] >|= function - | [ Ok ipv4; Ok ipv6 ] -> Ok [ ipv4; ipv6 ] - | [ Error _; (Ok ipv6) ] -> Ok [ ipv6 ] - | [ (Ok ipv4); Error _ ] -> Ok [ ipv4 ] - | [ (Error _ as err); _ ] -> err + Lwt.all [ipv4; ipv6] >|= function + | [Ok ipv4; Ok ipv6] -> Ok [ipv4; ipv6] + | [Error _; Ok ipv6] -> Ok [ipv6] + | [Ok ipv4; Error _] -> Ok [ipv4] + | [(Error _ as err); _] -> err | [] | [_] | _ :: _ :: _ -> assert false in - { getmxbyname; gethostbyname } + {getmxbyname; gethostbyname} - let mail_exchange_job ~pool ?stop ?(port= 25) stack dns server close = + let mail_exchange_job ~pool ?stop ?(port = 25) stack dns server close = let handler flow = let ipaddr, port = Stack.TCP.dst flow in Lwt.finalize (fun () -> Lwt_pool.use pool @@ fun (encoder, decoder, queue) -> - Relay.accept ~encoder:(Fun.const encoder) ~decoder:(Fun.const decoder) - ~queue:(Fun.const queue) ~ipaddr flow dns mail_exchange_resolver server + Relay.accept ~encoder:(Fun.const encoder) + ~decoder:(Fun.const decoder) ~queue:(Fun.const queue) ~ipaddr flow + dns mail_exchange_resolver server >|= R.reword_error (R.msgf "%a" Relay.pp_error)) (fun () -> Stack.TCP.close flow) >>= 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 + 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 forward_granted ipaddr allowed_to_forward = - List.exists (fun prefix -> Ipaddr.Prefix.mem ipaddr prefix) allowed_to_forward + List.exists + (fun prefix -> Ipaddr.Prefix.mem ipaddr prefix) + allowed_to_forward let only_registered_recipients ~info map recipients = let for_all = function | Colombe.Forward_path.Postmaster -> true | Domain domain' -> Colombe.Domain.equal info.Ptt_common.domain domain' - | Forward_path { Colombe.Path.local; domain= domain'; _ } -> + | Forward_path {Colombe.Path.local; domain= domain'; _} -> Colombe.Domain.equal info.Ptt_common.domain domain' && Ptt_map.exists ~local map in List.for_all for_all recipients let verify ~info ~sender ~ipaddr dns stream = let ctx = - Uspf.empty - |> Uspf.with_ip ipaddr - |> fun ctx -> Option.fold ~none:ctx + Uspf.empty |> Uspf.with_ip ipaddr |> fun ctx -> + Option.fold ~none:ctx ~some:(fun v -> Uspf.with_sender (`MAILFROM v) ctx) sender in Uspf_client.get ~ctx dns >>= function | Error _ -> Lwt.return (`Requested_action_not_taken `Permanent) | 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 (`Ok stream) let mail_exchange_logic_job ~info ~map ~allowed_to_forward dns (ic, oc) = let sender = - let local = `Dot_string [ "ptt"; "elit" ] in - Some (Colombe.Path.{ local; domain= info.Ptt_common.domain; rest= [] }) in + let local = `Dot_string ["ptt"; "elit"] 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 - | Some (key, stream, wk) -> + | Some (key, stream, wk) -> ( let id = Ptt_common.id_to_messageID ~info (Ptt.Msgd.id key) in - Log.debug (fun m -> m "%a sent a new email %a to: @[<hov>%a@]." - Colombe.Reverse_path.pp sender Mrmime.MessageID.pp id - Fmt.(Dump.list Colombe.Forward_path.pp) (List.map fst (Ptt.Msgd.recipients key))); + Log.debug (fun m -> + m "%a sent a new email %a to: @[<hov>%a@]." + Colombe.Reverse_path.pp sender Mrmime.MessageID.pp id + Fmt.(Dump.list Colombe.Forward_path.pp) + (List.map fst (Ptt.Msgd.recipients key))); let fake_recipients = Ptt.Msgd.recipients key in let fake_recipients = List.map fst fake_recipients in let real_recipients = Ptt_map.expand ~info map fake_recipients in - Log.debug (fun m -> m "real recipients of %a: @[<hov>%a@]" - Mrmime.MessageID.pp id - Fmt.(Dump.list Colombe.Forward_path.pp) real_recipients); - let real_recipients = Ptt_aggregate.to_recipients ~info real_recipients in + Log.debug (fun m -> + m "real recipients of %a: @[<hov>%a@]" Mrmime.MessageID.pp id + Fmt.(Dump.list Colombe.Forward_path.pp) + real_recipients); + let real_recipients = + Ptt_aggregate.to_recipients ~info real_recipients in begin - if forward_granted (Ptt.Msgd.ipaddr key) allowed_to_forward - then Lwt.return (`Ok stream) - else verify ~info - ~sender:(fst (Ptt.Msgd.from key)) - ~ipaddr:(Ptt.Msgd.ipaddr key) dns stream end >>= function + if forward_granted (Ptt.Msgd.ipaddr key) allowed_to_forward then + Lwt.return (`Ok stream) + else + verify ~info + ~sender:(fst (Ptt.Msgd.from key)) + ~ipaddr:(Ptt.Msgd.ipaddr key) dns stream + end + >>= function | #Ptt.Msgd.error as err -> - Log.warn (fun m -> m "Can not verify SPF informations from %a for %a, discard it!" - Colombe.Reverse_path.pp (fst (Ptt.Msgd.from key)) - Mrmime.MessageID.pp id); + Log.warn (fun m -> + m "Can not verify SPF informations from %a for %a, discard it!" + Colombe.Reverse_path.pp + (fst (Ptt.Msgd.from key)) + Mrmime.MessageID.pp id); Lwt.wakeup_later wk err; Lwt.pause () >>= go | `Ok stream -> - let elts = List.map (fun recipients -> - { Ptt_sendmail.sender - ; recipients - ; data= Lwt_stream.clone stream - ; policies= [] - ; id }) real_recipients in + let elts = + List.map + (fun recipients -> + { + Ptt_sendmail.sender + ; recipients + ; data= Lwt_stream.clone stream + ; policies= [] + ; id + }) + real_recipients in let src = Ptt.Msgd.ipaddr key in - if forward_granted src allowed_to_forward - || only_registered_recipients ~info map fake_recipients + if + forward_granted src allowed_to_forward + || only_registered_recipients ~info map fake_recipients then begin List.iter (oc $ Option.some) elts; - Log.debug (fun m -> m "Notice the SMTP server that everything is ok for %a from %a (%a)." - Mrmime.MessageID.pp id - Colombe.Reverse_path.pp (fst (Ptt.Msgd.from key)) - Ipaddr.pp (Ptt.Msgd.ipaddr key)); + Log.debug (fun m -> + m + "Notice the SMTP server that everything is ok for %a from \ + %a (%a)." + Mrmime.MessageID.pp id Colombe.Reverse_path.pp + (fst (Ptt.Msgd.from key)) + Ipaddr.pp (Ptt.Msgd.ipaddr key)); Lwt.wakeup_later wk `Ok - end else begin - Log.warn (fun m -> m "Email %a to unknown users (%a), discard it!" - Mrmime.MessageID.pp id - Fmt.(Dump.list Colombe.Forward_path.pp) fake_recipients); + end + else begin + Log.warn (fun m -> + m "Email %a to unknown users (%a), discard it!" + Mrmime.MessageID.pp id + Fmt.(Dump.list Colombe.Forward_path.pp) + fake_recipients); Lwt.wakeup_later wk (`Requested_action_not_taken `Permanent) end; - Lwt.pause () >>= go in + Lwt.pause () >>= go) in go () - let job ?(limit = 20) ?stop ~locals ?port ~tls ~info ?(forward_granted= []) stack dns he = + let job + ?(limit = 20) + ?stop + ~locals + ?port + ~tls + ~info + ?(forward_granted = []) + stack + dns + he = let pool0 = Lwt_pool.create limit @@ fun () -> let encoder = Bytes.create 0x7ff in @@ -264,32 +331,45 @@ 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:mail_exchange_resolver ~pool:pool1 ~info tls in + let oc_server, push0 = + Sendmail.v ~resolver:mail_exchange_resolver ~pool:pool1 ~info tls in let allowed_to_forward = forward_granted in Lwt.join - [ mail_exchange_job ~pool:pool0 ?stop ?port stack dns ic_server close0 - ; mail_exchange_logic_job ~info ~map:locals ~allowed_to_forward dns (stream0, push0) - ; Sendmail.job dns he oc_server ] + [ + mail_exchange_job ~pool:pool0 ?stop ?port stack dns ic_server close0 + ; mail_exchange_logic_job ~info ~map:locals ~allowed_to_forward dns + (stream0, push0); Sendmail.job dns he oc_server + ] end - type 'k t = - { locals : Ptt_map.t - ; tls : Tls.Config.client - ; random : Mirage_crypto_rng.g option - ; hash : 'k Digestif.hash - ; authentication : 'k Ptt.Authentication.t - ; mechanisms : Ptt.Mechanism.t list - ; destination : Ipaddr.t - ; forward_granted : Ipaddr.Prefix.t list } + type 'k t = { + locals: Ptt_map.t + ; tls: Tls.Config.client + ; random: Mirage_crypto_rng.g option + ; hash: 'k Digestif.hash + ; authentication: 'k Ptt.Authentication.t + ; mechanisms: Ptt.Mechanism.t list + ; destination: Ipaddr.t + ; forward_granted: Ipaddr.Prefix.t list + } - type 'k iter = (Ptt_map.local -> 'k Digestif.t -> Emile.mailbox list -> unit Lwt.t) -> unit Lwt.t + type 'k iter = + (Ptt_map.local -> 'k Digestif.t -> Emile.mailbox list -> unit Lwt.t) + -> unit Lwt.t - let v ?g ?(mechanisms= [ Ptt.Mechanism.PLAIN ]) ~postmaster ?(forward_granted= []) hash iter destination = + let v + ?g + ?(mechanisms = [Ptt.Mechanism.PLAIN]) + ~postmaster + ?(forward_granted = []) + hash + iter + destination = let authenticator = R.failwith_error_msg (Nss.authenticator ()) in - let tls = Rresult.R.failwith_error_msg (Tls.Config.client ~authenticator ()) in + let tls = + Rresult.R.failwith_error_msg (Tls.Config.client ~authenticator ()) in let locals = Ptt_map.empty ~postmaster in let passwds = Hashtbl.create 0x100 in let add local passwd dsts = @@ -302,17 +382,29 @@ struct | Some passwd -> Lwt.return (Digestif.equal hash passwd passwd') | None -> Lwt.return false in let authentication = Ptt.Authentication.v authentication in - { locals; tls; random= g; hash; authentication; mechanisms; destination - ; forward_granted } + { + locals + ; tls + ; random= g + ; hash + ; authentication + ; mechanisms + ; destination + ; forward_granted + } let job ?stop t ~info ?submission ?relay stack dns he = - if Option.is_some info.Ptt_common.tls - then Log.warn (fun m -> m "Discard the TLS server configuration from the [info] value"); - let submission = { info with Ptt_common.tls= submission } in - let relay = { info with Ptt_common.tls= relay } in + if Option.is_some info.Ptt_common.tls then + Log.warn (fun m -> + m "Discard the TLS server configuration from the [info] value"); + let submission = {info with Ptt_common.tls= submission} in + let relay = {info with Ptt_common.tls= relay} in Lwt.join - [ Local.job ?stop ~locals:t.locals ~tls:t.tls ~info:submission ~destination:[ t.destination ] - stack he t.random t.hash t.authentication t.mechanisms - ; Out.job ?stop ~locals:t.locals ~tls:t.tls ~info:relay ~forward_granted:t.forward_granted - stack dns he ] + [ + Local.job ?stop ~locals:t.locals ~tls:t.tls ~info:submission + ~destination:[t.destination] stack he t.random t.hash t.authentication + t.mechanisms + ; Out.job ?stop ~locals:t.locals ~tls:t.tls ~info:relay + ~forward_granted:t.forward_granted stack dns he + ] 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 bf1ab6c..de98f74 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) @@ -75,7 +73,8 @@ let auth0 = |> Map.add Local.(v [w "hannes"]) Digestif.(digest_string SHA1 "titi") |> Map.add Local.(v [w "gemma"]) Digestif.(digest_string SHA1 "") in let f username password = - let username = match username with + let username = + match username with | `Dot_string vs -> List.map (fun x -> `Atom x) vs | `String _ -> assert false in match Map.find username m with @@ -89,52 +88,75 @@ 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" - let put_crlf x = x ^ "\r\n" let rdwr_from_flows inputs outputs = @@ -213,14 +235,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 = { @@ -245,16 +264,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 = { @@ -279,23 +294,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 = { @@ -320,16 +334,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 = { @@ -362,16 +372,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 = { @@ -415,17 +424,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 = { @@ -453,14 +457,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 = { @@ -506,7 +507,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 @@ -523,7 +524,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 @@ -531,23 +533,24 @@ let make_smtp_server ?stop ~port tbl info stack = let th = th >|= close in `Initialized th, stream0 -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 - let destination = `Ipaddrs [ ipaddr ] in + let destination = `Ipaddrs [ipaddr] in let stream = Lwt_stream.of_list contents in let stream = Lwt_stream.map (fun str -> str ^ "\r\n") stream in let mail () = Lwt_stream.get stream >|= function | Some str -> Some (str, 0, String.length str) | None -> None in - Sendmail.sendmail he ~destination ~port ~domain - sender recipients mail >>= function + 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) -> @@ -560,7 +563,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) @@ -569,8 +573,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 = @@ -581,31 +587,40 @@ 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 () -> Lwt_switch.turn_off stop - >|= fun () -> `Done in + [ + "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; ""; "Hello World!" + ] + >>= fun () -> + Lwt_switch.turn_off stop >|= fun () -> `Done in let fold (key, _, wk) acc = let acc = match acc with `Done -> [] | `Inbox acc -> acc in Lwt.wakeup_later wk `Ok; Lwt.return (`Inbox (key :: acc)) in - Lwt.all [ sendmail; (th >|= fun () -> `Done) - ; Lwt_stream.fold_s fold stream (`Inbox []) ] >>= fun results -> - let[@warning "-8"] [ `Done; `Done; `Inbox inbox ] = results in - Alcotest.(check (list key)) "inbox" inbox - [ Ptt.Msgd.key ~domain_from:recoil ~from:(anil, []) + Lwt.all + [ + sendmail; (th >|= fun () -> `Done) + ; Lwt_stream.fold_s fold stream (`Inbox []) + ] + >>= fun results -> + let[@warning "-8"] [`Done; `Done; `Inbox inbox] = results in + Alcotest.(check (list key)) + "inbox" inbox + [ + Ptt.Msgd.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 = @@ -614,7 +629,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) @@ -624,70 +640,75 @@ 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!" ] - >>= fun () -> Lwt_switch.turn_off stop - >|= fun () -> `Done in + [ + "From: anil@recoil.org"; "Subject: SMTP server, PLZ!"; ""; "Hello World!" + ] + >>= fun () -> + Lwt_switch.turn_off stop >|= fun () -> `Done in let fold (key, _, wk) acc = let acc = match acc with `Done -> [] | `Inbox acc -> acc in Lwt.wakeup_later wk `Ok; Lwt.return (`Inbox (key :: acc)) in - Lwt.all [ sendmail; (th >|= fun () -> `Done) - ; Lwt_stream.fold_s fold stream `Done ] >>= fun results -> - let[@warning "-8"] [ `Done; `Done; `Inbox inbox ] = results in + Lwt.all + [sendmail; (th >|= fun () -> `Done); Lwt_stream.fold_s fold stream `Done] + >>= fun results -> + let[@warning "-8"] [`Done; `Done; `Inbox inbox] = results in Alcotest.(check (list key)) "inbox" inbox - [ Ptt.Msgd.key ~domain_from:gazagnaire ~from:(thomas, []) + [ + Ptt.Msgd.key ~domain_from:gazagnaire ~from:(thomas, []) ~recipients:[romain_calascibetta, []] ~ipaddr:(Ipaddr.V4 Ipaddr.V4.localhost) 1L ; Ptt.Msgd.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-11-05 15:20.42: Job failed: Failed: Build failed