package sendmail

  1. Overview
  2. Docs

Source file sendmail.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
open Colombe.Sigs
open Colombe.State
open Colombe

let ( <.> ) f g x = f (g x)

module Value = struct
  type helo = Domain.t
  type mail_from = Reverse_path.t * (string * string option) list
  type rcpt_to = Forward_path.t * (string * string option) list
  type auth = PLAIN | LOGIN
  type pp_220 = string list
  type pp_221 = string list
  type pp_250 = string list
  type tp_354 = string list
  type tp_334 = string
  type code = int * string list

  type error =
    [ Request.Encoder.error
    | Reply.Decoder.error
    | `Unexpected_response of int * string list
    | `Invalid_base64_value of string
    | `Invalid_login_challenge of string ]

  let pp_error ppf = function
    | #Request.Encoder.error as err -> Request.Encoder.pp_error ppf err
    | #Reply.Decoder.error as err -> Reply.Decoder.pp_error ppf err
    | `Unexpected_response (code, txts) ->
        Fmt.pf ppf "Unexpected response %3d: %a" code
          Fmt.(Dump.list string)
          txts
    | `Invalid_base64_value str -> Fmt.pf ppf "Invalid Base64 value: %S" str
    | `Invalid_login_challenge str ->
        Fmt.pf ppf "Invalid login challenge: %S" str

  type encoder = Encoder.encoder
  type decoder = Decoder.decoder

  type 'x send =
    | Helo : helo send
    | Mail_from : mail_from send
    | Rcpt_to : rcpt_to send
    | Data : unit send
    | Dot : unit send
    | Quit : unit send
    | Auth : auth send
    | Payload : string send

  type 'x recv =
    | PP_220 : pp_220 recv
    | PP_221 : pp_221 recv
    | PP_250 : pp_250 recv
    | TP_334 : tp_334 recv
    | TP_354 : tp_354 recv
    | Code : code recv
    | Response_or : 'a recv -> ('a, code) result recv

  let encode : type a. encoder -> a send -> a -> (unit, [> Encoder.error ]) t =
   fun encoder w v ->
    let fiber : a send -> [> Encoder.error ] Encoder.state = function
      | Payload -> Request.Encoder.request (`Payload v) encoder
      | Helo -> Request.Encoder.request (`Hello v) encoder
      | Mail_from -> Request.Encoder.request (`Mail v) encoder
      | Rcpt_to -> Request.Encoder.request (`Recipient v) encoder
      | Data -> Request.Encoder.request `Data encoder
      | Dot -> Request.Encoder.request `Data_end encoder
      | Quit -> Request.Encoder.request `Quit encoder
      | Auth ->
      match v with
      | PLAIN -> Request.Encoder.request (`Verb ("AUTH", [ "PLAIN" ])) encoder
      | LOGIN -> Request.Encoder.request (`Verb ("AUTH", [ "LOGIN" ])) encoder
    in
    let rec go = function
      | Encoder.Done -> Return ()
      | Encoder.Write { continue; buffer; off; len } ->
          Write { k = go <.> continue; buffer; off; len }
      | Encoder.Error err -> Error err in
    (go <.> fiber) w

  let decode : type a. decoder -> a recv -> (a, [> Decoder.error ]) t =
   fun decoder w ->
    let k : Reply.t -> (a, [> Decoder.error ]) t =
     fun v ->
      match (w, v) with
      | PP_220, `PP_220 txts -> Return txts
      | PP_221, `PP_221 txts -> Return txts
      | PP_250, `PP_250 txts -> Return txts
      | TP_334, `Other (334, txts) -> (
          match Base64.decode (String.concat "" txts) with
          | Ok payload -> Return payload
          | Error _ -> Error (`Invalid_base64_value (String.concat "" txts)))
      | TP_354, `TP_354 txts -> Return txts
      | Code, `Other v -> Return v
      | Code, `PN_501 txts -> Return (501, txts)
      | Code, `PN_504 txts -> Return (504, txts)
      | Code, `PP_250 txts -> Return (250, txts)
      | Response_or w, v -> (
          match (w, v) with
          | PP_220, `PP_220 txts -> Return (Ok txts)
          | PP_221, `PP_221 txts -> Return (Ok txts)
          | PP_250, `PP_250 txts -> Return (Ok txts)
          | TP_334, `Other (334, txts) -> (
              match Base64.decode (String.concat "" txts) with
              | Ok payload -> Return (Ok payload)
              | Error _ -> Error (`Invalid_base64_value (String.concat "" txts))
              )
          | TP_354, `TP_354 txts -> Return (Ok txts)
          | _, v ->
              let code = Reply.code v in
              let txts = Reply.lines v in
              Return (Error (code, txts)))
      | _, v ->
          let code = Reply.code v in
          let txts = Reply.lines v in
          Error (`Unexpected_response (code, txts)) in
    let rec go = function
      | Decoder.Done v -> k v
      | Decoder.Read { buffer; off; len; continue } ->
          Read { k = go <.> continue; buffer; off; len }
      | Decoder.Error { error; _ } -> Error error in
    go (Reply.Decoder.response decoder)
end

let src = Logs.Src.create "sendmail" ~doc:"logs sendmail's event"

module Log = (val Logs.src_log src : Logs.LOG)
module Monad = State.Scheduler (State.Context) (Value)

let run :
    type s flow.
    s impl ->
    (flow, s) rdwr ->
    flow ->
    ('a, 'err) t ->
    (('a, 'err) result, s) io =
 fun { bind; return } rdwr flow m ->
  let ( >>= ) = bind in

  let rec go = function
    | Read { buffer; off; len; k } ->
        rdwr.rd flow buffer off len >>= fun v -> go (k v)
    | Write { buffer; off; len; k } ->
        rdwr.wr flow buffer off len >>= fun () -> go (k len)
    | Return v -> return (Ok v)
    | Error err -> return (Error err : ('a, 'err) result) in
  go m

let properly_quit_and_fail ctx err =
  let open Monad in
  reword_error
    (fun _ -> err)
    ( send ctx Value.Quit () >>= fun () ->
      recv ctx Value.PP_221 >>= fun _ -> fail err )

let username_challenge_or_quit ctx txts =
  let open Monad in
  match Base64.decode (String.concat "" txts) with
  | Ok "User Name\000" | Ok "Username:\000" -> return ()
  | Ok challenge ->
      properly_quit_and_fail ctx
        (`Protocol (`Invalid_login_challenge challenge))
  | Error _ ->
      properly_quit_and_fail ctx
        (`Protocol (`Invalid_base64_value (String.concat "" txts)))

let auth ctx mechanism info =
  let open Monad in
  match info with
  | None -> return `Anonymous
  | Some (username, password) ->
  match mechanism with
  | Value.LOGIN -> (
      let* code, txts =
        send ctx Value.Auth mechanism >>= fun () -> recv ctx Value.Code in
      match code with
      | 504 -> properly_quit_and_fail ctx `Unsupported_mechanism
      | 538 -> properly_quit_and_fail ctx `Encryption_required
      | 534 -> properly_quit_and_fail ctx `Weak_mechanism
      | 334 -> (
          username_challenge_or_quit ctx txts >>= fun () ->
          let payload = Base64.encode_string ~pad:true username in
          send ctx Value.Payload payload >>= fun () ->
          recv ctx (Value.Response_or Value.TP_334) >>= function
          | Ok "Password\000" | Ok "Password:\000" -> (
              let payload = Base64.encode_string ~pad:true password in
              send ctx Value.Payload payload >>= fun () ->
              recv ctx Value.Code >>= function
              | 235, _txts -> return `Authenticated
              | 501, _txts ->
                  properly_quit_and_fail ctx `Authentication_rejected
              | 535, _txts -> properly_quit_and_fail ctx `Authentication_failed
              | code, txts ->
                  fail (`Protocol (`Unexpected_response (code, txts))))
          | Ok challenge ->
              properly_quit_and_fail ctx
                (`Protocol (`Invalid_login_challenge challenge))
          | Error (_code, _txts) ->
              properly_quit_and_fail ctx `Authentication_failed)
      | code -> fail (`Protocol (`Unexpected_response (code, txts))))
  | Value.PLAIN -> (
      let* code, txts =
        send ctx Value.Auth mechanism >>= fun () -> recv ctx Value.Code in
      match code with
      | 504 -> properly_quit_and_fail ctx `Unsupported_mechanism
      | 538 -> properly_quit_and_fail ctx `Encryption_required
      | 534 -> properly_quit_and_fail ctx `Weak_mechanism
      | 334 -> (
          let* () =
            match txts with
            | [] ->
                let payload =
                  Base64.encode_string ~pad:true
                    (Fmt.str "\000%s\000%s" username password) in
                send ctx Value.Payload payload
            | x :: _ ->
            match Base64.decode x with
            | Ok x ->
                let payload =
                  Base64.encode_string ~pad:true
                    (Fmt.str "%s\000%s\000%s" x username password) in
                send ctx Value.Payload payload
            | Error _ ->
                Log.warn (fun m ->
                    m "The server send an invalid base64 value: %S" x) ;
                let payload =
                  Base64.encode_string ~pad:true
                    (Fmt.str "\000%s\000%s" username password) in
                send ctx Value.Payload payload in
          recv ctx Value.Code >>= function
          | 235, _txts -> return `Authenticated
          | 501, _txts -> properly_quit_and_fail ctx `Authentication_rejected
          | 535, _txts -> properly_quit_and_fail ctx `Authentication_failed
          | code, txts -> fail (`Protocol (`Unexpected_response (code, txts))))
      | code -> fail (`Protocol (`Unexpected_response (code, txts))))

type domain = Domain.t
type reverse_path = Reverse_path.t
type forward_path = Forward_path.t

type authentication = {
  username : string;
  password : string;
  mechanism : Value.auth;
}

type mechanism = Value.auth = PLAIN | LOGIN
type ('a, 's) stream = unit -> ('a option, 's) io

type tmp_error =
  [ `Mailbox_unavailable
  | `Error_processing
  | `Action_ignored
  | `Unable_to_accomodate_parameters ]

let pp_tmp_error ppf = function
  | `Mailbox_unavailable -> Fmt.string ppf "Mailbox unavailable"
  | `Error_processing -> Fmt.string ppf "Error processing"
  | `Action_ignored -> Fmt.string ppf "Action ignored"
  | `Unable_to_accomodate_parameters ->
      Fmt.string ppf "Unable to accomodate parameters"

type error =
  [ `Protocol of Value.error
  | `Unsupported_mechanism
  | `Encryption_required
  | `Weak_mechanism
  | `Authentication_rejected
  | `Authentication_failed
  | `Authentication_required
  | `Temporary_failure of tmp_error ]

let pp_error ppf = function
  | `Protocol err -> Value.pp_error ppf err
  | `Unsupported_mechanism -> Fmt.pf ppf "Unsupported mechanism"
  | `Encryption_required -> Fmt.pf ppf "Encryption required"
  | `Weak_mechanism -> Fmt.pf ppf "Weak mechanism"
  | `Authentication_rejected -> Fmt.pf ppf "Authentication rejected"
  | `Authentication_failed -> Fmt.pf ppf "Authentication failed"
  | `Authentication_required -> Fmt.pf ppf "Authentication required"
  | `Temporary_failure err -> pp_tmp_error ppf err

let has_8bit_mime_transport_extension = List.exists (( = ) "8BITMIME")

let pp_status ppf = function
  | `Anonymous -> Fmt.string ppf "<anonymous>"
  | `Authenticated -> Fmt.string ppf "<authenticated>"

let m0 ctx ?authentication ~domain sender recipients =
  let open Monad in
  recv ctx Value.PP_220 >>= fun _txts ->
  let* txts = send ctx Value.Helo domain >>= fun () -> recv ctx Value.PP_250 in
  let has_8bit_mime_transport_extension =
    has_8bit_mime_transport_extension txts in
  Log.debug (fun m ->
      m "8BITMIME extension: %b" has_8bit_mime_transport_extension) ;
  (match authentication with
  | Some a -> auth ctx a.mechanism (Some (a.username, a.password))
  | None -> return `Anonymous)
  >>= fun status ->
  Log.debug (fun m -> m "Auth status: %a" pp_status status) ;
  let parameters =
    if has_8bit_mime_transport_extension
    then [ ("BODY", Some "8BITMIME") ]
    else [] in
  let* code, txts =
    send ctx Value.Mail_from (sender, parameters) >>= fun () ->
    recv ctx Value.Code in
  let rec go = function
    | [] ->
        send ctx Value.Data () >>= fun () ->
        recv ctx Value.TP_354 >>= fun _txts -> return ()
    | x :: r -> (
        send ctx Value.Rcpt_to (x, []) >>= fun () ->
        recv ctx Value.Code >>= function
        | 250, _txts -> go r
        | 450, _txts ->
            properly_quit_and_fail ctx (`Temporary_failure `Mailbox_unavailable)
        | 451, _txts ->
            properly_quit_and_fail ctx (`Temporary_failure `Error_processing)
        | 452, _txts ->
            properly_quit_and_fail ctx (`Temporary_failure `Action_ignored)
        | 455, _txts ->
            properly_quit_and_fail ctx
              (`Temporary_failure `Unable_to_accomodate_parameters)
        | code, txts -> fail (`Protocol (`Unexpected_response (code, txts))))
  in
  match code with
  | 250 -> go recipients
  | 451 -> properly_quit_and_fail ctx (`Temporary_failure `Error_processing)
  | 452 -> properly_quit_and_fail ctx (`Temporary_failure `Action_ignored)
  | 455 ->
      properly_quit_and_fail ctx
        (`Temporary_failure `Unable_to_accomodate_parameters)
  | 530 -> properly_quit_and_fail ctx `Authentication_required
  | _ -> fail (`Protocol (`Unexpected_response (code, txts)))

let m1 ctx =
  let open Monad in
  let* code, txts = send ctx Value.Dot () >>= fun () -> recv ctx Value.Code in
  match code with
  | 250 ->
      let* _txts = send ctx Value.Quit () >>= fun () -> recv ctx Value.PP_221 in
      return ()
  | 450 -> properly_quit_and_fail ctx (`Temporary_failure `Mailbox_unavailable)
  | 451 -> properly_quit_and_fail ctx (`Temporary_failure `Error_processing)
  | 452 -> properly_quit_and_fail ctx (`Temporary_failure `Action_ignored)
  | code -> fail (`Protocol (`Unexpected_response (code, txts)))

let sendmail ({ bind; return } as impl) rdwr flow context ?authentication
    ~domain sender recipients mail =
  let ( >>- ) = bind in
  let ( >>= ) x f =
    x >>- function Ok v -> f v | Error _ as err -> return err in

  let m0 = m0 context ~domain ?authentication sender recipients in
  run impl rdwr flow m0 >>= fun () ->
  (* assert that context is empty. *)
  let rec go = function
    | Some (buf, off, len) ->
        if len >= 1 && buf.[off] = '.'
        then
          rdwr.wr flow "." 0 1 >>- fun () ->
          rdwr.wr flow buf off len >>- mail >>- go
        else rdwr.wr flow buf off len >>- mail >>- go
    | None -> return () in
  Log.debug (fun m -> m "Start to send email") ;
  mail () >>- go >>- fun () ->
  let m1 = m1 context in
  run impl rdwr flow m1
OCaml

Innovation. Community. Security.