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