Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 545 lines (506 sloc) 20.904 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
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
56 | FetchResult of (int * string * 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;
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
71 fetched : (int * string * 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
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
94 -type rt_tmp =
95 {
96 rt_callback : (payload -> int -> Buffer.t -> bool) option;
97 }
98
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
99 -type runtime = {
100 rt_plim : int;
101 rt_proto : rt_proto;
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
102 rt_tmp : rt_tmp;
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
103 }
104
105 {{
106 let get_tag() = Printf.sprintf "A%05d" (Random.int(65535-4096)+4096)
107 let string_of_command = function
108 | ImapNoop -> "NOOP"
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
109 | ImapFetch (uid,seq,items) -> sprintf "%sFETCH %s %s" (if uid then "UID " else "") seq items
110 | ImapStore (uid,seq,din,dinval) -> sprintf "%sSTORE %s %s %s" (if uid then "UID " else "") seq din dinval
111 | ImapSearch (uid,s) -> sprintf "%sSEARCH %s" (if uid then "UID " else "") s
112 | 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
113 | ImapList (r,m) -> sprintf "LIST %s %s" r m
114 | ImapCreate s -> sprintf "CREATE %s" s
115 | ImapDelete s -> sprintf "DELETE %s" s
116 | ImapRename (f,t) -> sprintf "RENAME %s %s" f t
117 | ImapExpunge -> "EXPUNGE"
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
118 let add_fetched str fetched =
119 match fetched with
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
120 | [] -> [(0,"",str)]
121 | ((i,what,ss)::t) -> ((i,what,ss^str)::t) (* todo: bufferise this *)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
122 }}
123
124 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
125 %% Messages envoyés/reçus %%
126 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
127 -define (Noop tag) = tag " NOOP\r\n"
128 -define (Login (tag, name, pass)) = tag " LOGIN " name " " pass "\r\n"
129 -define (Select (tag, mailbox)) = tag " SELECT " mailbox "\r\n"
130 -define (Examine (tag, mailbox)) = tag " EXAMINE " mailbox "\r\n"
131 -define (Exists num:int) = "* " num " EXISTS\r\n"
132 -define (Recent num:int) = "* " num " RECENT\r\n"
133 -define (Flags str) = "* FLAGS (" str ")\r\n"
134 -define (StarSearch result) = "* SEARCH " result "\r\n"
135 -define (StarExpunge num:int) = "* " num " EXPUNGE\r\n"
136 -define (StarFetchLen (num:int, what, len:int)) = "* " num " FETCH (" what " {" len "}\r\n"
137 -define (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
138 -define (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\r\n"
139 -define (Search (tag, params)) = tag " SEARCH " params "\r\n"
140 -define (UidSearch (tag, params)) = tag " UID SEARCH " params "\r\n"
141 -define (SearchCs (tag, cs, params)) = tag " SEARCH CHARSET " cs " " params "\r\n"
142 -define (UidSearchCs (tag, cs, params)) = tag " UID SEARCH CHARSET " cs " " params "\r\n"
143 -define (Fetch (tag, seq, items)) = tag " FETCH " seq " " items "\r\n"
144 -define (UidFetch (tag, seq, items)) = tag " UID FETCH " seq " " items "\r\n"
145 -define (Store (tag, seq, din, dinval)) = tag " STORE " seq " " din " " dinval "\r\n"
146 -define (UidStore (tag, seq, din, dinval)) = tag " UID STORE " seq " " din " " dinval "\r\n"
147 -define (List (tag, rf, mailbox)) = tag " LIST " rf " " mailbox "\r\n"
148 -define (Create (tag, mailbox)) = tag " CREATE " mailbox "\r\n"
149 -define (Delete (tag, mailbox)) = tag " DELETE " mailbox "\r\n"
150 -define (Rename (tag, frommb, tomb)) = tag " RENAME " frommb " " tomb "\r\n"
151 -define (Expunge tag) = tag " EXPUNGE\r\n"
152 -define (Close tag) = tag " CLOSE\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
153
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
154 -define (NoopOk (tag,str)) = tag " OK NOOP "~ str "\r\n"
155 -define (FetchOk (tag,str)) = tag " OK " "UID "? "FETCH "~ str "\r\n"
156 -define (StoreOk (tag,str)) = tag " OK " "UID "? "STORE "~ str "\r\n"
157 -define (ListOk (tag,str)) = tag " OK LIST "~ str "\r\n"
158 -define (CreateOk (tag,str)) = tag " OK CREATE "~ str "\r\n"
159 -define (DeleteOk (tag,str)) = tag " OK DELETE "~ str "\r\n"
160 -define (RenameOk (tag,str)) = tag " OK RENAME "~ str "\r\n"
161 -define (ExpungeOk (tag,str)) = tag " OK EXPUNGE "~ str "\r\n"
162 -define (CloseOk (tag,str)) = tag " OK CLOSE "~ str "\r\n"
163 -define (StarOk str) = "* OK " str "\r\n"
164 -define (FlagsOk (tag, flags, str)) = tag " OK [" flags "] " str "\r\n"
165 -define (JustOk (tag, str)) = tag " OK " str "\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
166
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
167 -define (JustNo (tag,str)) = tag " NO " str "\r\n"
168 -define (JustBad (tag,str)) = tag " BAD " str "\r\n"
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
169
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
170 -define RawInput str = str
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
171
172 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
173 %% L'automate %%
174 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
175 +imap(mail : mail, tools : imports):
176 debug {{ Printexc.record_backtrace true }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
177 debug {{ eprintf "imapClientCore: Started connection with mailbox=%s\n%!" mail.mailbox }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
178 let tag = {{ get_tag() }}
179 send (Login (tag, mail.username, mail.password));
180 login(mail, tools, tag)
181
182 login(mail, tools, tag):
183 receive
184 | StarOk str ->
185 debug {{ eprintf "login received * OK: %s\n%!" str }}
186 login(mail, tools, tag)
187 | FlagsOk (rtag,flags,str) ->
188 if {{ rtag <> tag }}
189 then
190 debug {{ eprintf "login received mismatched LOGIN OK: rtag=%s tag=%s str=%s\n%!" rtag tag str }}
191 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
192 else
193 debug {{ eprintf "login received LOGIN OK: tag=%s flags=%s str=%s\n%!" tag flags str }}
194 let tag = {{ get_tag() }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
195 if {{ mail.readonly }}
196 then
197 send (Examine (tag, mail.mailbox));
198 select(mail, tools, tag, {{"EXAMINE"}})
199 else
200 send (Select (tag, mail.mailbox));
201 select(mail, tools, tag, {{"SELECT"}})
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
202 | err ->
203 debug {{ eprintf "ImapClientCore.login received err: %s\n%!" (string_of_msg err) }}
204 error({{ string_of_msg err }}, tools)
205 catch
206 | exn ->
207 {{ eprintf "ImapClientCore.login: exn=%s\n%!" (Printexc.to_string exn) }}
208 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
209 {{ tools.k [Error (Printexc.to_string exn)] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
210
211 got_nobad(mail, tools, name, nobad, tag, rtag, str, result):
212 if {{ rtag <> tag }}
213 then
214 debug {{ eprintf "Received mismatched %s %s: rtag=%s tag=%s str=%s\n" name nobad rtag tag str }}
215 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
216 else
217 debug {{ eprintf "Received %s %s: tag=%s str=%s\n" name nobad tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
218 let mail = {{ { mail with results = (result::mail.results) } }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
219 quit(mail, tools)
220
221 check_error(mail, tools, name, tag, err):
222 match {{ err }} with
223 | JustNo (rtag, str) ->
224 got_nobad(mail, tools, name, {{"NO"}}, tag, rtag, str, {{(No str)}})
225 | JustBad (rtag, str) ->
226 got_nobad(mail, tools, name, {{"BAD"}}, tag, rtag, str, {{(Bad str)}})
227 | err ->
228 debug {{ eprintf "received err: %s\n" (string_of_msg err) }}
229 error({{ string_of_msg err }}, tools)
230
231 check_exception(_mail, tools, name, _tag, exn):
232 let _ = {{ (conn, sched) }}
233 {{ eprintf "ImapClientCore.%s: exn=%s\n" name (Printexc.to_string exn) }}
234 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
235 {{ tools.k [Error (Printexc.to_string exn)] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
236
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
237 select(mail, tools, tag, selex):
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
238 receive
239 | StarOk str ->
240 debug {{ eprintf "select received * OK: %s\n" str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
241 let mail = [[ {mail with status={mail.status with oks=str::mail.status.oks}} ]]
242 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
243 | Exists num ->
244 debug {{ eprintf "select received * EXISTS: %d\n" num }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
245 let mail = [[ {mail with status={mail.status with exists=num}} ]]
246 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
247 | Recent num ->
248 debug {{ eprintf "select received * RECENT: %d\n" num }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
249 let mail = [[ {mail with status={mail.status with recent=num}} ]]
250 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
251 | Flags str ->
252 debug {{ eprintf "select received * FLAGS: %s\n" str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
253 let mail = [[ {mail with status={mail.status with flags=str}} ]]
254 select(mail, tools, tag, selex)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
255 | FlagsOk (rtag,flags,str) ->
256 if {{ rtag <> tag }}
257 then
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
258 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
259 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
260 else
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
261 debug {{ eprintf "select received %s OK: tag=%s flags=%s str=%s\n" selex tag flags str }}
262 let mail = [[ {mail with status={mail.status with rwstatus=flags}} ]]
263 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
264 | err ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
265 check_error(mail, tools, selex, tag, err)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
266 catch
267 | exn ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
268 check_exception(mail, tools, {{String.lowercase selex}}, tag, exn)
269
270 commands(mail, tools):
271 let mail = {{ { mail with fetched=[]; list=[]; expunged=[] } }}
272 if {{ mail.commands = [] }}
273 then
274 close(mail, tools)
275 else
276 let tag = {{ get_tag() }}
277 let command = {{ List.hd mail.commands }}
278 debug {{ eprintf "imapClientCore: command=%s\n%!" (string_of_command command) }}
279 let commands = {{ List.tl mail.commands }}
280 let mail = {{ { mail with commands = commands} }}
281 match {{ command }} with
282 | ImapNoop ->
283 send (Noop tag);
284 wait_for_ok(mail, tools, tag, {{"noop"}}, {{"NOOP"}},
285 {{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
286 | ImapFetch (uid, seq, items) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
287 if {{ uid }}
288 then
289 send (UidFetch (tag, seq, items));
290 fetch(mail, tools, tag)
291 else
292 send (Fetch (tag, seq, items));
293 fetch(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
294 | ImapStore (uid, seq, din, dinval) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
295 if {{ uid }}
296 then
297 send (UidStore (tag, seq, din, dinval));
298 store(mail, tools, tag)
299 else
300 send (Store (tag, seq, din, dinval));
301 store(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
302 | ImapSearchCs (uid, charset, params) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
303 if {{ uid }}
304 then
305 send (UidSearchCs (tag, charset, params));
306 search(mail, tools, tag)
307 else
308 send (SearchCs (tag, charset, params));
309 search(mail, tools, tag)
efadd8e @nrs135 [feature] imapClient: Added uid flag to search, fetch and store comm…
nrs135 authored
310 | ImapSearch (uid, params) ->
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
311 if {{ uid }}
312 then
313 send (UidSearch (tag, params));
314 search(mail, tools, tag)
315 else
316 send (Search (tag, params));
317 search(mail, tools, tag)
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
318 | ImapList (rf, mailbox) ->
319 if {{ rf = "" || mailbox = "" }}
320 then
321 error({{ "Empty strings would make LIST command invalid, use \"\" instead" }}, tools)
322 else
323 send (List (tag, rf, mailbox));
324 list(mail, tools, tag)
325 end
326 | ImapCreate mailbox ->
327 send (Create (tag, mailbox));
328 wait_for_ok(mail, tools, tag, {{"create"}}, {{"CREATE"}},
329 {{function CreateOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "created"}})
330 | ImapDelete mailbox ->
331 send (Delete (tag, mailbox));
332 wait_for_ok(mail, tools, tag, {{"delete"}}, {{"DELETE"}},
333 {{function DeleteOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "deleted"}})
334 | ImapRename (frommb, tomb) ->
335 send (Rename (tag, frommb, tomb));
336 wait_for_ok(mail, tools, tag, {{"rename"}}, {{"RENAME"}},
337 {{function RenameOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "renamed"}})
338 | ImapExpunge ->
339 send (Expunge tag);
340 expunge(mail, tools, tag)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
341
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
342 wait_for_ok(mail, tools, tag, name, _NAME, fn, result):
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
343 receive
344 | StarOk str ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
345 debug {{ eprintf "%s received * OK: %s\n%!" name str }}
346 wait_for_ok(mail, tools, tag, name, _NAME, fn, result)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
347 | err ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
348 match {{ fn err }} with
349 | Some (rtag, str) ->
350 if {{ rtag <> tag }}
351 then
352 debug {{ eprintf "%s received mismatched %s OK: rtag=%s tag=%s str=%s\n%!" name _NAME rtag tag str }}
353 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
354 else
355 debug {{ eprintf "%s received %s OK: tag=%s str=%s\n%!" name _NAME tag str }}
356 bye(mail, tools, result)
357 end
358 | None ->
359 check_error(mail, tools, _NAME, tag, err)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
360 catch
361 | exn ->
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
362 check_exception(mail, tools, name, tag, exn)
363
364 bye(mail, tools, result):
365 let mail = {{ { mail with results = (result::mail.results) } }}
366 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
367
368 search(mail, tools, tag):
369 receive
370 | StarOk str ->
371 debug {{ eprintf "search received * OK: %s\n" str }}
372 search(mail, tools, tag)
373 | StarSearch str ->
374 debug {{ eprintf "search received * SEARCH: %s\n" str }}
375 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
376 let mail = {{ { mail with results = ((SearchResult il)::mail.results) } }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
377 search(mail, tools, tag)
378 | JustOk (rtag,str) ->
379 if {{ rtag <> tag }}
380 then
381 debug {{ eprintf "search received mismatched SEARCH OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
382 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
383 else
384 debug {{ eprintf "search received SEARCH OK: tag=%s str=%s\n" tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
385 commands(mail, tools)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
386 | err ->
387 check_error(mail, tools, {{"SEARCH"}}, tag, err)
388 catch
389 | exn ->
390 check_exception(mail, tools, {{"search"}}, tag, exn)
391
392 fetch(mail, tools, tag):
393 receive
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
394 | StarFetchLen (num, what, len) ->
395 debug {{ eprintf "fetch received * FETCH: %d %d\n" num len }}
396 let mail = {{ { mail with fetched = ((num,what,"")::mail.fetched) } }}
397 fetch_data(mail, tools, tag, len)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
398 | StarFetch (num, str) ->
399 debug {{ eprintf "fetch received * FETCH: %d %s\n" num (String.limit 50 str) }}
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
400 let mail = {{ { mail with fetched = ((num,"",str)::mail.fetched) } }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
401 fetch(mail, tools, tag)
402 | FetchOk (rtag,str) ->
403 if {{ rtag <> tag }}
404 then
405 debug {{ eprintf "fetch received mismatched FETCH OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
406 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
407 else
408 debug {{ eprintf "fetch received FETCH OK: tag=%s str=%s\n" tag str }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
409 let mail = {{ { mail with results = ((FetchResult (List.rev mail.fetched))::mail.results) } }}
410 commands(mail, tools)
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
411 | msg ->
412 % This is ridiculous and dangerous, we should parse the initial header and use fixed to read in the data.
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
413 % For the moment it's just a fallback in case the StarFetchLen pattern fails
294be7f @nrs135 [fix] imapClient: Fixed invalid message generation. Partial fix for…
nrs135 authored
414 let str = {{ string_of_msg msg }}
415 %debug {{ eprintf "fetch received raw input: str=%s\n" str }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
416 let mail = {{ { mail with fetched = (add_fetched str mail.fetched) } }}
417 fetch(mail, tools, tag)
418 catch
419 | exn ->
420 check_exception(mail, tools, {{"fetch"}}, tag, exn)
421
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
422 fetch_data(mail, tools, tag, len):
423 debug {{ eprintf "fetch_data: getting %d bytes\n%!" len }}
424 fixed {{ len }}
425 | data ->
426 debug {{ eprintf "fetch_data: data='%s'\n%!" (String.escaped (String.limit 50 data)) }}
427 let mail = {{ { mail with fetched = (add_fetched data mail.fetched) } }}
428 end_fetched_data(mail, tools, tag)
429
430 end_fetched_data(mail, tools, tag):
431 fixed {{ 3 }}
432 | data ->
433 if {{ data = ")\r\n" }}
434 then
435 debug {{ eprintf "fetch_data: ok\n%!" }}
436 fetch(mail, tools, tag)
437 else
438 debug {{ eprintf "fetch_data: error\n%!" }}
439 error({{ sprintf "Bad end of fetch data: %s" (String.escaped data) }}, tools)
440
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
441 store(mail, tools, tag):
442 receive
443 | StarFetch (num, str) ->
444 debug {{ eprintf "store received * FETCH: %d %s\n" num (String.limit 50 str) }}
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
445 let mail = {{ { mail with fetched = ((num,"",str)::mail.fetched) } }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
446 store(mail, tools, tag)
447 | StoreOk (rtag,str) ->
448 if {{ rtag <> tag }}
449 then
450 debug {{ eprintf "store received mismatched STORE OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
451 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
452 else
453 debug {{ eprintf "store received STORE OK: tag=%s str=%s\n" tag str }}
997d860 @nrs135 [fix] imapClient: Definitive fix for fetch data.
nrs135 authored
454 let mail = {{ { mail with results = ((StoreResult (List.rev (List.map (function (x,_,z) -> (x,z)) mail.fetched)))::mail.results) } }}
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
455 commands(mail, tools)
456 | err ->
457 check_error(mail, tools, {{"STORE"}}, tag, err)
458 catch
459 | exn ->
460 check_exception(mail, tools, {{"store"}}, tag, exn)
461
462 list(mail, tools, tag):
463 receive
464 | StarOk str ->
465 debug {{ eprintf "list received * OK: %s\n" str }}
466 list(mail, tools, tag)
467 | StarList (flags, rf, mailbox) ->
468 debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
469 let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
470 list(mail, tools, tag)
471 | ListOk (rtag,str) ->
472 if {{ rtag <> tag }}
473 then
474 debug {{ eprintf "list received mismatched LIST OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
475 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
476 else
477 debug {{ eprintf "list received LIST OK: tag=%s str=%s\n" tag str }}
478 let mail = {{ { mail with results = ((ListResult (List.rev mail.list))::mail.results) } }}
479 commands(mail, tools)
480 | err ->
481 check_error(mail, tools, {{"LIST"}}, tag, err)
482 catch
483 | exn ->
484 check_exception(mail, tools, {{"list"}}, tag, exn)
485
486 expunge(mail, tools, tag):
487 receive
488 | StarExpunge num ->
489 debug {{ eprintf "expunge received * EXPUNGE: %d\n" num }}
490 let mail = {{ { mail with expunged = (num::mail.expunged) } }}
491 expunge(mail, tools, tag)
492 | ExpungeOk (rtag,str) ->
493 if {{ rtag <> tag }}
494 then
495 debug {{ eprintf "expunge received mismatched EXPUNGE OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
496 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
497 else
498 debug {{ eprintf "expunge received EXPUNGE OK: tag=%s str=%s\n" tag str }}
499 let mail = {{ { mail with results = ((ExpungeResult (List.rev mail.expunged))::mail.results) } }}
500 commands(mail, tools)
501 | err ->
502 check_error(mail, tools, {{"EXPUNGE"}}, tag, err)
503 catch
504 | exn ->
505 check_exception(mail, tools, {{"expunge"}}, tag, exn)
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
506
507 close(mail, tools):
508 let tag = {{ get_tag() }}
509 send (Close tag);
510 wait_close(mail, tools, tag)
511
512 wait_close(mail, tools, tag):
513 receive
514 | StarOk str ->
515 debug {{ eprintf "close received * OK: %s\n%!" str }}
516 wait_close(mail, tools, tag)
517 | CloseOk (rtag,str) ->
518 if {{ rtag <> tag }}
519 then
520 debug {{ eprintf "close received mismatched CLOSE OK: rtag=%s tag=%s str=%s\n%!" rtag tag str }}
521 error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
522 else
523 debug {{ eprintf "close received CLOSE OK: tag=%s str=%s\n%!" tag str }}
524 quit(mail, tools)
525 | err ->
526 debug {{ eprintf "close received err: %s\n%!" (string_of_msg err) }}
527 quit(mail, tools)
528 catch
529 | exn ->
530 {{ eprintf "ImapClientCore.close: exn=%s\n%!" (Printexc.to_string exn) }}
531 debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
532 quit(mail, tools)
533
534 quit(mail, tools):
535 -!-
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
536 {{ tools.k (List.rev mail.results) }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
537
538 error(msg : string, tools : imports):
539 debug {{ eprintf "error: %s\n%!" msg }}
540 -!-
541 {{ Logger.error "Error: %s" msg;
3796837 @nrs135 [feature] imap client: Added new commands.
nrs135 authored
542 tools.k [Error msg] }}
84f98f6 @nrs135 [feature] imap: Rough draft of an IMAP client.
nrs135 authored
543
544 % End of file imapClientCore.proto
Something went wrong with that request. Please try again.