2024-12-19 23:14.30: 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:a1d38b4249ac3e00f0c6f66cd35168b4c94ec556539dcdb604ce4bf4e98cc679
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:a1d38b4249ac3e00f0c6f66cd35168b4c94ec556539dcdb604ce4bf4e98cc679
USER 1000:1000
RUN cd ~/opam-repository && (git cat-file -e 40261e81b0d4449cd32f7834e272aa9d38a28c49 || git fetch origin master) && git reset -q --hard 40261e81b0d4449cd32f7834e272aa9d38a28c49 && 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-12-19 23:14.30: Using cache hint "mirage/ptt-ocaml/opam:debian-12-ocaml-4.08@sha256:a1d38b4249ac3e00f0c6f66cd35168b4c94ec556539dcdb604ce4bf4e98cc679-debian-12-4.08_opam-2.3-ocamlformat-40261e81b0d4449cd32f7834e272aa9d38a28c49"
2024-12-19 23:14.30: Using OBuilder spec:
((from ocaml/opam:debian-12-ocaml-4.08@sha256:a1d38b4249ac3e00f0c6f66cd35168b4c94ec556539dcdb604ce4bf4e98cc679)
(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 40261e81b0d4449cd32f7834e272aa9d38a28c49 || git fetch origin master) && git reset -q --hard 40261e81b0d4449cd32f7834e272aa9d38a28c49 && 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-12-19 23:14.30: Waiting for resource in pool OCluster
2024-12-20 21:28.30: Waiting for worker…
2024-12-20 21:31.05: Got resource from pool OCluster
Building on x86-bm-c12.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:a1d38b4249ac3e00f0c6f66cd35168b4c94ec556539dcdb604ce4bf4e98cc679)
2024-12-20 21:31.05 ---> using "2c99520034ba7d2c12a0edb456b31a2f404e9da547f96b39b3b43810eae7bc5d" 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 40261e81b0d4449cd32f7834e272aa9d38a28c49 || git fetch origin master) && git reset -q --hard 40261e81b0d4449cd32f7834e272aa9d38a28c49 && git log --no-decorate -n1 --oneline && opam update -u"))
From https://github.com/ocaml/opam-repository
* branch master -> FETCH_HEAD
de786e28db..f51b2f3708 master -> origin/master
40261e81b0 Merge pull request #27148 from mtelvers/opam-publish-ocaml-version.3.7.2
<><> 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-12-20 21:31.05 ---> using "229558fd65677ec03ba45c306cfc481433c5c1c9702d4ae08c147431c769432b" 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.17.1
<><> Gathering sources ><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
[dune.3.17.1] found in cache
<><> Processing actions <><><><><><><><><><><><><><><><><><><><><><><><><><><><>
-> installed dune.3.17.1
Done.
# Run eval $(opam env) to update the current shell environment
2024-12-20 21:31.05 ---> using "ee160929347deabf14e8cf1de9cbf1c5721419022353cc2f23442bce597a2502" 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 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 ocaml-version 3.7.2 [required by ocamlformat-lib]
- install camlp-streams 5.0.1 [required by ocamlformat-lib]
- install dune-build-info 3.17.1 [required by ocamlformat-lib]
- install fix 20230505 [required by ocamlformat-lib]
- install menhir 20240715 [required by ocamlformat-lib]
- install topkg 1.0.7 [required by fpath, astring, uuseg]
- install base-bytes base [required by ocp-indent]
- install re 1.11.0 [required by ocamlformat]
- install dune-configurator 3.17.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.17.1] found in cache
[dune-configurator.3.17.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.2] 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.2
-> installed re.1.11.0
-> installed result.1.5
-> installed sexplib0.v0.14.0
-> installed dune-build-info.3.17.1
-> installed dune-configurator.3.17.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-12-20 21:31.05 ---> using "b4740d78c6193d7173d56b9608e419b8d78a0eaf07c7a6c39e836b67744bb126" from cache
/src: (copy (src .) (dst /src/))
2024-12-20 21:31.05 ---> saved as "1c0702e1c2c1dd812ab35432d2846b59f5f40c03c215c8d45044763a4b06fb2d"
/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 "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/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/ptt_aggregate.mli", line 1, characters 0-0:
diff --git a/_build/default/lib/ptt_aggregate.mli b/_build/default/lib/.formatted/ptt_aggregate.mli
index ca2e477..14ee1c7 100644
--- a/_build/default/lib/ptt_aggregate.mli
+++ b/_build/default/lib/.formatted/ptt_aggregate.mli
@@ -1 +1,4 @@
-val to_recipients : info:Ptt_common.info -> Colombe.Forward_path.t list -> Ptt_sendmail.recipients list
+val to_recipients :
+ info:Ptt_common.info
+ -> Colombe.Forward_path.t list
+ -> Ptt_sendmail.recipients list
File "lib/mxs.ml", line 1, characters 0-0:
diff --git a/_build/default/lib/mxs.ml b/_build/default/lib/.formatted/mxs.ml
index 624a0c5..31e1d84 100644
--- a/_build/default/lib/mxs.ml
+++ b/_build/default/lib/.formatted/mxs.ml
@@ -3,20 +3,22 @@ type key = Dns.Mx.t
let pp_key : key Fmt.t =
fun ppf elt ->
Fmt.pf ppf "{ @[<hov>preference= %d;@ mail_exchange= %a;@] }"
- elt.Dns.Mx.preference Domain_name.pp
- elt.Dns.Mx.mail_exchange
+ elt.Dns.Mx.preference Domain_name.pp elt.Dns.Mx.mail_exchange
module Key = struct
type t = key
- let compare {Dns.Mx.preference= a; _} {Dns.Mx.preference= b; _} = Int.compare a b
+ let compare {Dns.Mx.preference= a; _} {Dns.Mx.preference= b; _} =
+ Int.compare a b
end
include (Map.Make (Key) : Map.S with type key := key)
let v ~preference ~domain:mail_exchange ipaddr =
- singleton { preference; mail_exchange } ipaddr
+ singleton {preference; mail_exchange} ipaddr
let vs =
- (Fun.flip List.fold_left empty) begin fun acc (mx, ipaddr) ->
- add mx ipaddr acc end
+ (Fun.flip List.fold_left empty)
+ begin
+ fun acc (mx, ipaddr) -> add mx ipaddr acc
+ end
File "lib/ptt_map.mli", line 1, characters 0-0:
diff --git a/_build/default/lib/ptt_map.mli b/_build/default/lib/.formatted/ptt_map.mli
index 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/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 "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/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/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/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/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/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/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
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/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/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/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/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_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_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/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/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
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/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/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/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/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 "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/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 "bin/lipap.ml", line 1, characters 0-0:
diff --git a/_build/default/bin/lipap.ml b/_build/default/bin/.formatted/lipap.ml
index c0c2c0b..71de88c 100644
--- a/_build/default/bin/lipap.ml
+++ b/_build/default/bin/.formatted/lipap.ml
@@ -11,16 +11,17 @@ let ( <.> ) f g x = f (g x)
open Rresult
-module Happy_eyeballs_daemon = Happy_eyeballs_mirage.Make
- (Time) (Mclock) (Tcpip_stack_socket.V4V6)
+module Happy_eyeballs_daemon =
+ Happy_eyeballs_mirage.Make (Time) (Mclock) (Tcpip_stack_socket.V4V6)
-module Dns_client = Dns_client_mirage.Make
- (Mirage_crypto_rng) (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
- (Happy_eyeballs_daemon)
+module Dns_client =
+ Dns_client_mirage.Make (Mirage_crypto_rng) (Time) (Mclock) (Pclock)
+ (Tcpip_stack_socket.V4V6)
+ (Happy_eyeballs_daemon)
module Server =
- Lipap.Make (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6)
- (Dns_client) (Happy_eyeballs_daemon)
+ Lipap.Make (Time) (Mclock) (Pclock) (Tcpip_stack_socket.V4V6) (Dns_client)
+ (Happy_eyeballs_daemon)
let load_file filename = Bos.OS.File.read filename
@@ -37,9 +38,7 @@ let private_key =
X509.Private_key.decode_pem raw
let private_key = Rresult.R.get_ok private_key
-
let authenticator _username _password = Lwt.return true
-
let authenticator = Ptt.Authentication.v authenticator
let job ~domain locals =
@@ -52,8 +51,10 @@ let job ~domain locals =
~authenticator:(fun ?ip:_ ~host:_ _ -> Ok None)
() in
let tls = Rresult.R.failwith_error_msg tls in
- TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun tcpv4v6 ->
- UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None >>= fun udpv4v6 ->
+ TCP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
+ >>= fun tcpv4v6 ->
+ UDP.connect ~ipv4_only ~ipv6_only Ipaddr.V4.Prefix.global None
+ >>= fun udpv4v6 ->
connect udpv4v6 tcpv4v6 >>= fun stack ->
let info =
{
@@ -78,8 +79,8 @@ let romain_calascibetta =
let () =
let locals = Ptt_map.empty ~postmaster:romain_calascibetta in
- let domain = Colombe.Domain.Domain [ "ptt"; "fr" ] in
+ let domain = Colombe.Domain.Domain ["ptt"; "fr"] in
Ptt_map.add
- ~local:(`Dot_string [ "romain"; "calascibetta" ])
+ ~local:(`Dot_string ["romain"; "calascibetta"])
romain_calascibetta locals;
Lwt_main.run (job ~domain locals)
File "lib/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-12-20 21:31.09: Job failed: Failed: Build failed