Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 517 lines (481 sloc) 19.655 kB
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
1 % -*-erlang-*-
2
3 %
4 % Copyright © 2011 MLstate
5 %
6 % This file is part of OPA.
7 %
8 % OPA is free software: you can redistribute it and/or modify it under the
9 % terms of the GNU Affero General Public License, version 3, as published by
10 % the Free Software Foundation.
11 %
12 % OPA is distributed in the hope that it will be useful, but WITHOUT ANY
13 % WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
14 % FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
15 % more details.
16 %
17 % You should have received a copy of the GNU Affero General Public License
18 % along with OPA. If not, see <http://www.gnu.org/licenses/>.
19 %
20 -generate client
21 -debugvar PROTOCOL_DEBUG
22 -protocol IMAP
23 -open Printf
24
25 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
26 %% Les types %%
27 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
28 -type command =
29 | ImapNoop
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
30 | ImapFetch of (bool * string * string)
31 | ImapStore of (bool * string * string * string)
32 | ImapSearch of (bool * string)
33 | ImapSearchCs of (bool * string * string)
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
34 | ImapList of (string * string)
35 | ImapCreate of string
36 | ImapDelete of string
37 | ImapRename of (string * string)
38 | ImapExpunge
39
40 -type commands = command list
41
42 -type status = {
43 flags : string;
44 exists : int;
45 recent : int;
46 oks : string list;
47 rwstatus : string;
48 }
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
49
50 -type result =
51 | Ok of string
52 | No of string
53 | Bad of string
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
54 | NoopResult of status
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
55 | SearchResult of int list
56 | FetchResult of (int * string) list
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
57 | StoreResult of (int * string) list
58 | ListResult of (string * string * string) list
59 | ExpungeResult of int list
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
60 | Error of string
61
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
62 -type results = result list
63
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
64 -type mail = {
65 mailbox : string;
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
66 readonly : bool;
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
67 username : string;
68 password : string;
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
69 commands : commands;
70 status : status;
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
71 fetched : (int * string) list;
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
72 list : (string * string * string) list;
73 expunged : int list;
74 results : results;
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
75 from : string;
76 dests : string list;
77 data : string
78 }
79
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
80 -type cont = result list -> unit
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
81
82 -type imports = {
83 k : cont
84 }
85
86 -type payload = unit
87 -include "libnet/rt_proto.proto"
88 %-type rt_proto = {
89 % rt_block_size : int;
90 % rt_backtrace : bool;
91 % rt_server_write_timeout : Time.t;
92 %}
93
94 -type runtime = {
95 rt_plim : int;
96 rt_proto : rt_proto;
97 }
98
99 {{
100 let get_tag() = Printf.sprintf "A%05d" (Random.int(65535-4096)+4096)
101 let string_of_command = function
102 | ImapNoop -> "NOOP"
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
103 | ImapFetch (uid,seq,items) -> sprintf "%sFETCH %s %s" (if uid then "UID " else "") seq items
104 | ImapStore (uid,seq,din,dinval) -> sprintf "%sSTORE %s %s %s" (if uid then "UID " else "") seq din dinval
105 | ImapSearch (uid,s) -> sprintf "%sSEARCH %s" (if uid then "UID " else "") s
106 | ImapSearchCs (uid,cs,s) -> sprintf "%sSEARCH CHARSET %s %s" (if uid then "UID " else "") cs s
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
107 | ImapList (r,m) -> sprintf "LIST %s %s" r m
108 | ImapCreate s -> sprintf "CREATE %s" s
109 | ImapDelete s -> sprintf "DELETE %s" s
110 | ImapRename (f,t) -> sprintf "RENAME %s %s" f t
111 | ImapExpunge -> "EXPUNGE"
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
112 let add_fetched str fetched =
113 match fetched with
114 | [] -> [(0,str)]
115 | ((i,ss)::t) -> ((i,ss^str)::t) (* todo: bufferise this *)
116 }}
117
118 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
119 %% Messages envoyés/reçus %%
120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
121 -define (Noop tag) = tag " NOOP\r\n"
122 -define (Login (tag, name, pass)) = tag " LOGIN " name " " pass "\r\n"
123 -define (Select (tag, mailbox)) = tag " SELECT " mailbox "\r\n"
124 -define (Examine (tag, mailbox)) = tag " EXAMINE " mailbox "\r\n"
125 -define (Exists num:int) = "* " num " EXISTS\r\n"
126 -define (Recent num:int) = "* " num " RECENT\r\n"
127 -define (Flags str) = "* FLAGS (" str ")\r\n"
128 -define (StarSearch result) = "* SEARCH " result "\r\n"
129 -define (StarExpunge num:int) = "* " num " EXPUNGE\r\n"
130 -define (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
131 -define (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\r\n"
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
132 -define (Search (tag, params)) = tag " SEARCH " params "\r\n"
133 -define (UidSearch (tag, params)) = tag " UID SEARCH " params "\r\n"
134 -define (SearchCs (tag, cs, params)) = tag " SEARCH CHARSET " cs " " params "\r\n"
135 -define (UidSearchCs (tag, cs, params)) = tag " UID SEARCH CHARSET " cs " " params "\r\n"
136 -define (Fetch (tag, seq, items)) = tag " FETCH " seq " " items "\r\n"
137 -define (UidFetch (tag, seq, items)) = tag " UID FETCH " seq " " items "\r\n"
138 -define (Store (tag, seq, din, dinval)) = tag " STORE " seq " " din " " dinval "\r\n"
139 -define (UidStore (tag, seq, din, dinval)) = tag " UID STORE " seq " " din " " dinval "\r\n"
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
140 -define (List (tag, rf, mailbox)) = tag " LIST " rf " " mailbox "\r\n"
141 -define (Create (tag, mailbox)) = tag " CREATE " mailbox "\r\n"
142 -define (Delete (tag, mailbox)) = tag " DELETE " mailbox "\r\n"
143 -define (Rename (tag, frommb, tomb)) = tag " RENAME " frommb " " tomb "\r\n"
144 -define (Expunge tag) = tag " EXPUNGE\r\n"
145 -define (Close tag) = tag " CLOSE\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
146
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
147 -define (NoopOk (tag,str)) = tag " OK NOOP "~ str "\r\n"
148 -define (FetchOk (tag,str)) = tag " OK " "UID "? "FETCH "~ str "\r\n"
149 -define (StoreOk (tag,str)) = tag " OK " "UID "? "STORE "~ str "\r\n"
150 -define (ListOk (tag,str)) = tag " OK LIST "~ str "\r\n"
151 -define (CreateOk (tag,str)) = tag " OK CREATE "~ str "\r\n"
152 -define (DeleteOk (tag,str)) = tag " OK DELETE "~ str "\r\n"
153 -define (RenameOk (tag,str)) = tag " OK RENAME "~ str "\r\n"
154 -define (ExpungeOk (tag,str)) = tag " OK EXPUNGE "~ str "\r\n"
155 -define (CloseOk (tag,str)) = tag " OK CLOSE "~ str "\r\n"
156 -define (StarOk str) = "* OK " str "\r\n"
157 -define (FlagsOk (tag, flags, str)) = tag " OK [" flags "] " str "\r\n"
158 -define (JustOk (tag, str)) = tag " OK " str "\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
159
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
160 -define (JustNo (tag,str)) = tag " NO " str "\r\n"
161 -define (JustBad (tag,str)) = tag " BAD " str "\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
162
163 -define RawInput str = str
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
164
165 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
166 %% L'automate %%
167 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
168 +imap(mail : mail, tools : imports):
169 debug {{ Printexc.record_backtrace true }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
170 debug {{ eprintf "imapClientCore: Started connection with mailbox=%s\n%!" mail.mailbox }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
171 let tag = {{ get_tag() }}
172 send (Login (tag, mail.username, mail.password));
173 login(mail, tools, tag)
174
175 login(mail, tools, tag):
176 receive
177 | StarOk str ->
178 debug {{ eprintf "login received * OK: %s\n%!" str }}
179 login(mail, tools, tag)
180 | FlagsOk (rtag,flags,str) ->
181 if {{ rtag <> tag }}
182 then
183 debug {{ eprintf "login received mismatched LOGIN OK: rtag=%s tag=%s str=%s\n%!" rtag tag str }}
184 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
185 else
186 debug {{ eprintf "login received LOGIN OK: tag=%s flags=%s str=%s\n%!" tag flags str }}
187 let tag = {{ get_tag() }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
188 if {{ mail.readonly }}
189 then
190 send (Examine (tag, mail.mailbox));
191 select(mail, tools, tag, {{"EXAMINE"}})
192 else
193 send (Select (tag, mail.mailbox));
194 select(mail, tools, tag, {{"SELECT"}})
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
195 | err ->
196 debug {{ eprintf "ImapClientCore.login received err: %s\n%!" (string_of_msg err) }}
197 error({{ string_of_msg err }}, tools)
198 catch
199 | exn ->
200 {{ eprintf "ImapClientCore.login: exn=%s\n%!" (Printexc.to_string exn) }}
201 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
202 {{ tools.k [Error (Printexc.to_string exn)] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
203
204 got_nobad(mail, tools, name, nobad, tag, rtag, str, result):
205 if {{ rtag <> tag }}
206 then
207 debug {{ eprintf "Received mismatched %s %s: rtag=%s tag=%s str=%s\n" name nobad rtag tag str }}
208 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
209 else
210 debug {{ eprintf "Received %s %s: tag=%s str=%s\n" name nobad tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
211 let mail = {{ { mail with results = (result::mail.results) } }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
212 quit(mail, tools)
213
214 check_error(mail, tools, name, tag, err):
215 match {{ err }} with
216 | JustNo (rtag, str) ->
217 got_nobad(mail, tools, name, {{"NO"}}, tag, rtag, str, {{(No str)}})
218 | JustBad (rtag, str) ->
219 got_nobad(mail, tools, name, {{"BAD"}}, tag, rtag, str, {{(Bad str)}})
220 | err ->
221 debug {{ eprintf "received err: %s\n" (string_of_msg err) }}
222 error({{ string_of_msg err }}, tools)
223
224 check_exception(_mail, tools, name, _tag, exn):
225 let _ = {{ (conn, sched) }}
226 {{ eprintf "ImapClientCore.%s: exn=%s\n" name (Printexc.to_string exn) }}
227 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
228 {{ tools.k [Error (Printexc.to_string exn)] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
229
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
230 select(mail, tools, tag, selex):
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
231 receive
232 | StarOk str ->
233 debug {{ eprintf "select received * OK: %s\n" str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
234 let mail = [[ {mail with status={mail.status with oks=str::mail.status.oks}} ]]
235 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
236 | Exists num ->
237 debug {{ eprintf "select received * EXISTS: %d\n" num }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
238 let mail = [[ {mail with status={mail.status with exists=num}} ]]
239 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
240 | Recent num ->
241 debug {{ eprintf "select received * RECENT: %d\n" num }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
242 let mail = [[ {mail with status={mail.status with recent=num}} ]]
243 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
244 | Flags str ->
245 debug {{ eprintf "select received * FLAGS: %s\n" str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
246 let mail = [[ {mail with status={mail.status with flags=str}} ]]
247 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
248 | FlagsOk (rtag,flags,str) ->
249 if {{ rtag <> tag }}
250 then
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
251 debug {{ eprintf "select received mismatched %s OK: rtag=%s tag=%s str=%s\n" selex rtag tag str }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
252 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
253 else
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
254 debug {{ eprintf "select received %s OK: tag=%s flags=%s str=%s\n" selex tag flags str }}
255 let mail = [[ {mail with status={mail.status with rwstatus=flags}} ]]
256 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
257 | err ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
258 check_error(mail, tools, selex, tag, err)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
259 catch
260 | exn ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
261 check_exception(mail, tools, {{String.lowercase selex}}, tag, exn)
262
263 commands(mail, tools):
264 let mail = {{ { mail with fetched=[]; list=[]; expunged=[] } }}
265 if {{ mail.commands = [] }}
266 then
267 close(mail, tools)
268 else
269 let tag = {{ get_tag() }}
270 let command = {{ List.hd mail.commands }}
271 debug {{ eprintf "imapClientCore: command=%s\n%!" (string_of_command command) }}
272 let commands = {{ List.tl mail.commands }}
273 let mail = {{ { mail with commands = commands} }}
274 match {{ command }} with
275 | ImapNoop ->
276 send (Noop tag);
277 wait_for_ok(mail, tools, tag, {{"noop"}}, {{"NOOP"}},
278 {{function NoopOk (rt,s) -> Some (rt,s) | _ -> None}}, {{NoopResult mail.status}})
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
279 | ImapFetch (uid, seq, items) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
280 if {{ uid }}
281 then
282 send (UidFetch (tag, seq, items));
283 fetch(mail, tools, tag)
284 else
285 send (Fetch (tag, seq, items));
286 fetch(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
287 | ImapStore (uid, seq, din, dinval) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
288 if {{ uid }}
289 then
290 send (UidStore (tag, seq, din, dinval));
291 store(mail, tools, tag)
292 else
293 send (Store (tag, seq, din, dinval));
294 store(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
295 | ImapSearchCs (uid, charset, params) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
296 if {{ uid }}
297 then
298 send (UidSearchCs (tag, charset, params));
299 search(mail, tools, tag)
300 else
301 send (SearchCs (tag, charset, params));
302 search(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
303 | ImapSearch (uid, params) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
304 if {{ uid }}
305 then
306 send (UidSearch (tag, params));
307 search(mail, tools, tag)
308 else
309 send (Search (tag, params));
310 search(mail, tools, tag)
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
311 | ImapList (rf, mailbox) ->
312 if {{ rf = "" || mailbox = "" }}
313 then
314 error({{ "Empty strings would make LIST command invalid, use \"\" instead" }}, tools)
315 else
316 send (List (tag, rf, mailbox));
317 list(mail, tools, tag)
318 end
319 | ImapCreate mailbox ->
320 send (Create (tag, mailbox));
321 wait_for_ok(mail, tools, tag, {{"create"}}, {{"CREATE"}},
322 {{function CreateOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "created"}})
323 | ImapDelete mailbox ->
324 send (Delete (tag, mailbox));
325 wait_for_ok(mail, tools, tag, {{"delete"}}, {{"DELETE"}},
326 {{function DeleteOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "deleted"}})
327 | ImapRename (frommb, tomb) ->
328 send (Rename (tag, frommb, tomb));
329 wait_for_ok(mail, tools, tag, {{"rename"}}, {{"RENAME"}},
330 {{function RenameOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "renamed"}})
331 | ImapExpunge ->
332 send (Expunge tag);
333 expunge(mail, tools, tag)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
334
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
335 wait_for_ok(mail, tools, tag, name, _NAME, fn, result):
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
336 receive
337 | StarOk str ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
338 debug {{ eprintf "%s received * OK: %s\n%!" name str }}
339 wait_for_ok(mail, tools, tag, name, _NAME, fn, result)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
340 | err ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
341 match {{ fn err }} with
342 | Some (rtag, str) ->
343 if {{ rtag <> tag }}
344 then
345 debug {{ eprintf "%s received mismatched %s OK: rtag=%s tag=%s str=%s\n%!" name _NAME rtag tag str }}
346 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
347 else
348 debug {{ eprintf "%s received %s OK: tag=%s str=%s\n%!" name _NAME tag str }}
349 bye(mail, tools, result)
350 end
351 | None ->
352 check_error(mail, tools, _NAME, tag, err)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
353 catch
354 | exn ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
355 check_exception(mail, tools, name, tag, exn)
356
357 bye(mail, tools, result):
358 let mail = {{ { mail with results = (result::mail.results) } }}
359 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
360
361 search(mail, tools, tag):
362 receive
363 | StarOk str ->
364 debug {{ eprintf "search received * OK: %s\n" str }}
365 search(mail, tools, tag)
366 | StarSearch str ->
367 debug {{ eprintf "search received * SEARCH: %s\n" str }}
368 let il = {{ List.map (fun s -> try int_of_string s with _ -> -1) (String.slice ' ' str) }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
369 let mail = {{ { mail with results = ((SearchResult il)::mail.results) } }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
370 search(mail, tools, tag)
371 | JustOk (rtag,str) ->
372 if {{ rtag <> tag }}
373 then
374 debug {{ eprintf "search received mismatched SEARCH OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
375 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
376 else
377 debug {{ eprintf "search received SEARCH OK: tag=%s str=%s\n" tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
378 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
379 | err ->
380 check_error(mail, tools, {{"SEARCH"}}, tag, err)
381 catch
382 | exn ->
383 check_exception(mail, tools, {{"search"}}, tag, exn)
384
385 fetch(mail, tools, tag):
386 receive
387 | StarOk str ->
388 debug {{ eprintf "fetch received * OK: %s\n" str }}
389 fetch(mail, tools, tag)
390 | StarFetch (num, str) ->
391 debug {{ eprintf "fetch received * FETCH: %d %s\n" num (String.limit 50 str) }}
392 let mail = {{ { mail with fetched = ((num,str)::mail.fetched) } }}
393 fetch(mail, tools, tag)
394 | FetchOk (rtag,str) ->
395 if {{ rtag <> tag }}
396 then
397 debug {{ eprintf "fetch received mismatched FETCH OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
398 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
399 else
400 debug {{ eprintf "fetch received FETCH OK: tag=%s str=%s\n" tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
401 let mail = {{ { mail with results = ((FetchResult (List.rev mail.fetched))::mail.results) } }}
402 commands(mail, tools)
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
403 | msg ->
404 % This is ridiculous and dangerous, we should parse the initial header and use fixed to read in the data.
405 let str = {{ string_of_msg msg }}
406 %debug {{ eprintf "fetch received raw input: str=%s\n" str }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
407 let mail = {{ { mail with fetched = (add_fetched str mail.fetched) } }}
408 fetch(mail, tools, tag)
409 catch
410 | exn ->
411 check_exception(mail, tools, {{"fetch"}}, tag, exn)
412
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
413 store(mail, tools, tag):
414 receive
415 | StarFetch (num, str) ->
416 debug {{ eprintf "store received * FETCH: %d %s\n" num (String.limit 50 str) }}
417 let mail = {{ { mail with fetched = ((num,str)::mail.fetched) } }}
418 store(mail, tools, tag)
419 | StoreOk (rtag,str) ->
420 if {{ rtag <> tag }}
421 then
422 debug {{ eprintf "store received mismatched STORE OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
423 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
424 else
425 debug {{ eprintf "store received STORE OK: tag=%s str=%s\n" tag str }}
426 let mail = {{ { mail with results = ((StoreResult (List.rev mail.fetched))::mail.results) } }}
427 commands(mail, tools)
428 | err ->
429 check_error(mail, tools, {{"STORE"}}, tag, err)
430 catch
431 | exn ->
432 check_exception(mail, tools, {{"store"}}, tag, exn)
433
434 list(mail, tools, tag):
435 receive
436 | StarOk str ->
437 debug {{ eprintf "list received * OK: %s\n" str }}
438 list(mail, tools, tag)
439 | StarList (flags, rf, mailbox) ->
440 debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
441 let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
442 list(mail, tools, tag)
443 | ListOk (rtag,str) ->
444 if {{ rtag <> tag }}
445 then
446 debug {{ eprintf "list received mismatched LIST OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
447 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
448 else
449 debug {{ eprintf "list received LIST OK: tag=%s str=%s\n" tag str }}
450 let mail = {{ { mail with results = ((ListResult (List.rev mail.list))::mail.results) } }}
451 commands(mail, tools)
452 | err ->
453 check_error(mail, tools, {{"LIST"}}, tag, err)
454 catch
455 | exn ->
456 check_exception(mail, tools, {{"list"}}, tag, exn)
457
458 expunge(mail, tools, tag):
459 receive
460 | StarExpunge num ->
461 debug {{ eprintf "expunge received * EXPUNGE: %d\n" num }}
462 let mail = {{ { mail with expunged = (num::mail.expunged) } }}
463 expunge(mail, tools, tag)
464 | ExpungeOk (rtag,str) ->
465 if {{ rtag <> tag }}
466 then
467 debug {{ eprintf "expunge received mismatched EXPUNGE OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
468 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
469 else
470 debug {{ eprintf "expunge received EXPUNGE OK: tag=%s str=%s\n" tag str }}
471 let mail = {{ { mail with results = ((ExpungeResult (List.rev mail.expunged))::mail.results) } }}
472 commands(mail, tools)
473 | err ->
474 check_error(mail, tools, {{"EXPUNGE"}}, tag, err)
475 catch
476 | exn ->
477 check_exception(mail, tools, {{"expunge"}}, tag, exn)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
478
479 close(mail, tools):
480 let tag = {{ get_tag() }}
481 send (Close tag);
482 wait_close(mail, tools, tag)
483
484 wait_close(mail, tools, tag):
485 receive
486 | StarOk str ->
487 debug {{ eprintf "close received * OK: %s\n%!" str }}
488 wait_close(mail, tools, tag)
489 | CloseOk (rtag,str) ->
490 if {{ rtag <> tag }}
491 then
492 debug {{ eprintf "close received mismatched CLOSE OK: rtag=%s tag=%s str=%s\n%!" rtag tag str }}
493 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
494 else
495 debug {{ eprintf "close received CLOSE OK: tag=%s str=%s\n%!" tag str }}
496 quit(mail, tools)
497 | err ->
498 debug {{ eprintf "close received err: %s\n%!" (string_of_msg err) }}
499 quit(mail, tools)
500 catch
501 | exn ->
502 {{ eprintf "ImapClientCore.close: exn=%s\n%!" (Printexc.to_string exn) }}
503 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
504 quit(mail, tools)
505
506 quit(mail, tools):
507 -!-
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
508 {{ tools.k (List.rev mail.results) }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
509
510 error(msg : string, tools : imports):
511 debug {{ eprintf "error: %s\n%!" msg }}
512 -!-
513 {{ Logger.error "Error: %s" msg;
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
514 tools.k [Error msg] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
515
516 % End of file imapClientCore.proto
Something went wrong with that request. Please try again.