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