/
bslMail.ml
325 lines (293 loc) · 16.4 KB
/
bslMail.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
(*
Copyright © 2011, 2012 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
##module mailserve
let status_ok = ServerLib.static_field_of_name "ok"
let status_bad_sender = ServerLib.static_field_of_name "bad_sender"
let status_bad_recipient = ServerLib.static_field_of_name "bad_recipient"
let status_error = ServerLib.static_field_of_name "error"
##opa-type Email.send_status
##register [cps-bypass] mail_send_fun : string, string, string, string, string, string, string, \
caml_list(caml_tuple_4(string,string,string,string)), \
caml_list(caml_tuple_2(string,string)), \
option(string), option(string), option(string), option(string), option(string), opa[bool], \
(opa[email_send_status], continuation(opa[void]) -> void), \
continuation(opa[void]) -> void
let mail_send_fun mfrom mfrom_address_only mdst mto subject mdata html files custom_headers
via addr auth user pass dryrun cont k =
let cont = BslUtils.proj_cps k cont in
let cont x =
let res =
match x with
| SmtpClientCore.Ok str ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_ok (ServerLib.wrap_string str) in
ServerLib.make_record rc
| SmtpClientCore.Bad_Sender -> ServerLib.make_simple_record status_bad_sender
| SmtpClientCore.Bad_Recipient -> ServerLib.make_simple_record status_bad_recipient
| SmtpClientCore.Error err ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string err) in
ServerLib.make_record rc
| SmtpClientCore.Error_MX ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string "Error MX") in
ServerLib.make_record rc
| SmtpClientCore.Delayed i ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string ("Delayed "^(string_of_int i))) in
ServerLib.make_record rc
in cont (wrap_opa_email_send_status res)
in
let html = if html = "" then None else Some html
and mto = if mto = "" then None else Some mto
and dryrun = Some (ServerLib.unwrap_bool dryrun)
in
SmtpClient.mail_send_aux BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mdst ?mto:mto mdata ?html:html ~files ~custom_headers ~return_path:mfrom_address_only 10 ?via:via ?addr:addr ?auth:auth ?user:user ?pass:pass ?dryrun:dryrun cont ();
QmlCpsServerLib.return k ServerLib.void
##register [cps-bypass] mail_send_fun_secure : string, string, string, string, string, string, string, \
caml_list(caml_tuple_4(string,string,string,string)), \
caml_list(caml_tuple_2(string,string)), \
option(string), option(string), option(int), option(string), option(string), option(string), opa[bool], SSL.secure_type, \
(opa[email_send_status], continuation(opa[void]) -> void), \
continuation(opa[void]) -> void
let mail_send_fun_secure mfrom mfrom_address_only mdst mto subject mdata html files custom_headers
via addr port auth user pass dryrun secure_type cont k =
let cont = BslUtils.proj_cps k cont in
let cont x =
let res =
match x with
| SmtpClientCore.Ok str ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_ok (ServerLib.wrap_string str) in
ServerLib.make_record rc
| SmtpClientCore.Bad_Sender -> ServerLib.make_simple_record status_bad_sender
| SmtpClientCore.Bad_Recipient -> ServerLib.make_simple_record status_bad_recipient
| SmtpClientCore.Error err ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string err) in
ServerLib.make_record rc
| SmtpClientCore.Error_MX ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string "Error MX") in
ServerLib.make_record rc
| SmtpClientCore.Delayed i ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc status_error (ServerLib.wrap_string ("Delayed "^(string_of_int i))) in
ServerLib.make_record rc
in cont (wrap_opa_email_send_status res)
in
let html = if html = "" then None else Some html
and mto = if mto = "" then None else Some mto
and dryrun = Some (ServerLib.unwrap_bool dryrun)
in
let client_certificate, verify_params = secure_type in
SmtpClient.mail_send_aux ?client_certificate ?verify_params ~secure:true BslScheduler.opa ~charset:"UTF-8" ~subject mfrom mdst ?mto:mto mdata ?html:html ~files ~custom_headers ~return_path:mfrom_address_only 10 ?port:port ?via:via ?addr:addr ?auth:auth ?user:user ?pass:pass ?dryrun:dryrun cont ();
QmlCpsServerLib.return k ServerLib.void
##endmodule
##module imap
##opa-type Email.imap_command
##opa-type Email.imap_result
##opa-type Email.imap_status
let ok = ServerLib.static_field_of_name "Ok"
let selectresult = ServerLib.static_field_of_name "SelectResult"
let examineresult = ServerLib.static_field_of_name "ExamineResult"
let noopresult = ServerLib.static_field_of_name "NoopResult"
let searchresult = ServerLib.static_field_of_name "SearchResult"
let fetchresult = ServerLib.static_field_of_name "FetchResult"
let storeresult = ServerLib.static_field_of_name "StoreResult"
let statusresult = ServerLib.static_field_of_name "StatusResult"
let listresult = ServerLib.static_field_of_name "ListResult"
let expungeresult = ServerLib.static_field_of_name "ExpungeResult"
let no = ServerLib.static_field_of_name "No"
let bad = ServerLib.static_field_of_name "Bad"
let error = ServerLib.static_field_of_name "Error"
let flags = ServerLib.static_field_of_name "flags"
let exists = ServerLib.static_field_of_name "exists"
let recent = ServerLib.static_field_of_name "recent"
let oks = ServerLib.static_field_of_name "oks"
let rwstatus = ServerLib.static_field_of_name "rwstatus"
##register [cps-bypass] command : int, string, SSL.secure_type, \
string, string, opa[list(email_imap_command)], \
(opa[list(email_imap_result)], continuation(opa[void]) -> void), \
continuation(opa[void]) -> void
let command port addr secure_type username password commands cont k =
let cont = BslUtils.proj_cps k cont in
let wrap_s fld s =
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc fld (ServerLib.wrap_string s) in
ServerLib.make_record rc
in
let wrap_is (i,s) =
BslNativeLib.opa_tuple_2 (ServerLib.wrap_int i, ServerLib.wrap_string s) in
let wrap_ss (s1,s2) =
BslNativeLib.opa_tuple_2 (ServerLib.wrap_string s1, ServerLib.wrap_string s2) in
let wrap_iss (i1,s2,s3) =
BslNativeLib.opa_tuple_3 (ServerLib.wrap_int i1, ServerLib.wrap_string s2, ServerLib.wrap_string s3) in
let wrap_sss (s1,s2,s3) =
BslNativeLib.opa_tuple_3 (ServerLib.wrap_string s1, ServerLib.wrap_string s2, ServerLib.wrap_string s3) in
let wrap_sl sl = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string sl in
(* This segfaults...
let wrap_status (status:ImapClientCore.status) =
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc flags (ServerLib.wrap_string status.ImapClientCore.flags) in
let rc = ServerLib.add_field rc exists (ServerLib.wrap_int status.ImapClientCore.exists) in
let rc = ServerLib.add_field rc recent (ServerLib.wrap_int status.ImapClientCore.recent) in
let rc = ServerLib.add_field rc oks (BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string status.ImapClientCore.oks) in
let rc = ServerLib.add_field rc rwstatus (ServerLib.wrap_string status.ImapClientCore.rwstatus) in
wrap_opa_email_imap_status (ServerLib.make_record rc)
in
*)
let wrap_status (status:ImapClientCore.status) =
BslNativeLib.opa_tuple_5 (ServerLib.wrap_string status.ImapClientCore.flags,
ServerLib.wrap_int status.ImapClientCore.exists,
ServerLib.wrap_int status.ImapClientCore.recent,
wrap_sl status.ImapClientCore.oks,
ServerLib.wrap_string status.ImapClientCore.rwstatus)
in
let cont results =
let results =
BslNativeLib.caml_list_to_opa_list
(fun result ->
wrap_opa_email_imap_result
(match result with
| ImapClientCore.Ok str -> wrap_s ok str
| ImapClientCore.No str -> wrap_s no str
| ImapClientCore.Bad str -> wrap_s bad str
| ImapClientCore.Error str -> wrap_s error str
| ImapClientCore.SelectResult status ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc selectresult (wrap_status status) in
ServerLib.make_record rc
| ImapClientCore.ExamineResult status ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc examineresult (wrap_status status) in
ServerLib.make_record rc
| ImapClientCore.NoopResult status ->
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc noopresult (wrap_status status) in
ServerLib.make_record rc
| ImapClientCore.SearchResult il ->
let opa_il = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_int il in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc searchresult opa_il in
ServerLib.make_record rc
| ImapClientCore.ExpungeResult il ->
let opa_il = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_int il in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc expungeresult opa_il in
ServerLib.make_record rc
| ImapClientCore.FetchResult issl ->
let opa_issl = BslNativeLib.caml_list_to_opa_list wrap_iss issl in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc fetchresult opa_issl in
ServerLib.make_record rc
| ImapClientCore.StoreResult isl ->
let opa_isl = BslNativeLib.caml_list_to_opa_list wrap_is isl in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc storeresult opa_isl in
ServerLib.make_record rc
| ImapClientCore.StatusResult ssl ->
let opa_ssl = BslNativeLib.caml_list_to_opa_list wrap_ss ssl in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc statusresult opa_ssl in
ServerLib.make_record rc
| ImapClientCore.ListResult sssl ->
let opa_sssl = BslNativeLib.caml_list_to_opa_list wrap_sss sssl in
let rc = ServerLib.empty_record_constructor in
let rc = ServerLib.add_field rc listresult opa_sssl in
ServerLib.make_record rc))
results
in
cont results
in
let unwrap_bs value =
let b1, s2 = BslNativeLib.ocaml_tuple_2 value in
ServerLib.unwrap_bool b1, ServerLib.unwrap_string s2
in
let unwrap_ss value =
let s1, s2 = BslNativeLib.ocaml_tuple_2 value in
ServerLib.unwrap_string s1, ServerLib.unwrap_string s2
in
let unwrap_bss value =
let b, s1, s2 = BslNativeLib.ocaml_tuple_3 value in
ServerLib.unwrap_bool b, ServerLib.unwrap_string s1, ServerLib.unwrap_string s2
in
let unwrap_ssss value =
let s1, s2, s3, s4 = BslNativeLib.ocaml_tuple_4 value in
ServerLib.unwrap_string s1, ServerLib.unwrap_string s2, ServerLib.unwrap_string s3, ServerLib.unwrap_string s4
in
let unwrap_bsss value =
let b, s1, s2, s3 = BslNativeLib.ocaml_tuple_4 value in
ServerLib.unwrap_bool b, ServerLib.unwrap_string s1, ServerLib.unwrap_string s2, ServerLib.unwrap_string s3
in
let commands =
BslNativeLib.opa_list_to_ocaml_list
(fun command ->
ServerLib.fold_record
(fun f value _cmd ->
let value = Obj.magic(value) in
match ServerLib.name_of_field f with
| Some "ImapSelect" -> ImapClientCore.ImapSelect (ServerLib.unwrap_string value)
| Some "ImapExamine" -> ImapClientCore.ImapExamine (ServerLib.unwrap_string value)
| Some "ImapNoop" -> ImapClientCore.ImapNoop
| Some "ImapFetch" -> ImapClientCore.ImapFetch (unwrap_bss value)
| Some "ImapStore" -> ImapClientCore.ImapStore (unwrap_bsss value)
| Some "ImapSearch" -> ImapClientCore.ImapSearch (unwrap_bs value)
| Some "ImapSearchCs" -> ImapClientCore.ImapSearchCs (unwrap_bss value)
| Some "ImapCopy" -> ImapClientCore.ImapCopy (unwrap_bss value)
| Some "ImapList" -> ImapClientCore.ImapList (unwrap_ss value)
| Some "ImapCreate" -> ImapClientCore.ImapCreate (ServerLib.unwrap_string value)
| Some "ImapDelete" -> ImapClientCore.ImapDelete (ServerLib.unwrap_string value)
| Some "ImapRename" -> ImapClientCore.ImapRename (unwrap_ss value)
| Some "ImapStatus" -> ImapClientCore.ImapStatus (unwrap_ss value)
| Some "ImapAppend" -> ImapClientCore.ImapAppend (unwrap_ssss value)
| Some "ImapExpunge" -> ImapClientCore.ImapExpunge
| _ -> assert false)
(unwrap_opa_email_imap_command command) ImapClientCore.ImapNoop)
commands
in
let client_certificate, verify_params = secure_type in
let (err_cont:ImapClientCore.ecsa) =
fun (exn,name,_bt_opt) _runtime sched conn mailbox _ec ->
ImapClientCore.close_conn sched conn mailbox;
cont [ImapClientCore.Error (Printf.sprintf "Exception(at %s): %s" name (Printexc.to_string exn))]
in
ImapClient.mail_recv ?client_certificate ?verify_params ~secure:true BslScheduler.opa ~addr ~port
~username ~password ~commands
(cont:ImapClientCore.results -> unit) ~err_cont ();
QmlCpsServerLib.return k ServerLib.void
##endmodule
##module mailserver
##register [cps-bypass] init_server : int, string, SSL.secure_type, \
(opa[string], opa[list(string)], opa[string], continuation(opa[tuple_2(int, string)]) -> void), continuation(opa[void]) -> void
let init_server port addr secure_type handler cvoid =
let ssl_certificate, ssl_verify_params = secure_type in
let caml_handler email k =
let f = ServerLib.wrap_string email.SmtpServerCore.from in
let c = Rcontent.get_content email.SmtpServerCore.body in
let c = ServerLib.wrap_string c in
let t = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string email.SmtpServerCore.dests in
handler f t c (QmlCpsServerLib.cont_ml (
fun res -> let i, s = BslNativeLib.ocaml_tuple_2 res in
k (ServerLib.unwrap_int i, ServerLib.unwrap_string s)))
in
let _ = Runtime.add_smtpServer "smtpServer" {
SmtpServer.default_options with
SmtpServer.opt_addr = addr;
SmtpServer.opt_port = port;
SmtpServer.opt_ssl_certificate = ssl_certificate;
SmtpServer.opt_ssl_verify_params = ssl_verify_params;
SmtpServer.opt_email_handler = caml_handler;
} in QmlCpsServerLib.return cvoid ServerLib.void
##endmodule