Source file `sendmail_handler.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
module Lwt_scheduler = Colombe.Sigs.Make (Lwt)

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

let lwt_bind x f =
  let open Lwt.Infix in
  let open Lwt_scheduler in
  inj (prj x >>= (prj <.> f))
;;

let lwt =
  { Colombe.Sigs.bind = lwt_bind; return = (fun x -> Lwt_scheduler.inj (Lwt.return x)) }
;;

type flow =
  { ic : Lwt_io.input_channel
  ; oc : Lwt_io.output_channel
  }

let rdwr =
  { Colombe.Sigs.rd =
      (fun { ic; _ } bytes off len ->
        let open Lwt.Infix in
        let res =
          Lwt_io.read_into ic bytes off len
          >>= function
          | 0 -> Lwt.return `End
          | len -> Lwt.return (`Len len)
        in
        Lwt_scheduler.inj res)
  ; wr =
      (fun { oc; _ } bytes off len ->
        let res = Lwt_io.write_from_exactly oc (Bytes.unsafe_of_string bytes) off len in
        Lwt_scheduler.inj res)
  }
;;

let run_with_starttls
  ~hostname
  ?port
  ~domain
  ?authentication
  ~tls_authenticator
  ~from
  ~recipients
  ~mail
  =
  let port =
    match port with
    | Some port -> port
    | None -> 465
  in
  let tls = Tls.Config.client ~authenticator:tls_authenticator () in
  let ctx = Sendmail_with_starttls.Context_with_tls.make () in
  let open Lwt.Infix in
  Lwt_unix.gethostbyname (Domain_name.to_string hostname)
  >>= fun res ->
  if Array.length res.Lwt_unix.h_addr_list = 0
  then Lwt.fail_with (Fmt.str "%a can not be resolved" Domain_name.pp hostname)
  else (
    let socket = Lwt_unix.socket Lwt_unix.PF_INET Unix.SOCK_STREAM 0 in
    Lwt_unix.connect socket (Lwt_unix.ADDR_INET (res.Lwt_unix.h_addr_list.(0), port))
    >>= fun () ->
    let closed = ref false in
    let close () =
      if !closed
      then Lwt.return ()
      else (
        closed := true;
        Lwt_unix.close socket)
    in
    let ic = Lwt_io.of_fd ~close ~mode:Lwt_io.Input socket in
    let oc = Lwt_io.of_fd ~close ~mode:Lwt_io.Output socket in
    let mail_stream () =
      match mail () with
      | Some v -> Lwt_scheduler.inj (Lwt.return (Some v))
      | None -> Lwt_scheduler.inj (Lwt.return None)
    in
    let fiber =
      Sendmail_with_starttls.sendmail
        lwt
        rdwr
        { ic; oc }
        ctx
        tls
        ?authentication
        ~domain
        from
        recipients
        mail_stream
    in
    Lwt_scheduler.prj fiber)
;;

let run ~hostname ?port ~domain ?authentication ~tls_authenticator ~from ~recipients ~mail
  =
  let ( let* ) = Lwt.bind in
  let port =
    match port with
    | Some port -> port
    | None -> 465
  in
  let ctx = Colombe.State.Context.make () in
  let* ic, oc =
    Tls_lwt.connect tls_authenticator (Domain_name.to_string hostname, port)
  in
  let mail_stream () =
    match mail () with
    | Some v -> Lwt_scheduler.inj (Lwt.return (Some v))
    | None -> Lwt_scheduler.inj (Lwt.return None)
  in
  let fiber =
    Sendmail.sendmail
      lwt
      rdwr
      { ic; oc }
      ctx
      ?authentication
      ~domain
      from
      recipients
      mail_stream
  in
  Lwt_scheduler.prj fiber
;;