Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

745 lines (698 sloc) 30.005 kB
% -*-proto-*-
%
% Copyright © 2011 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/>.
%
-generate client
-debugvar PROTOCOL_DEBUG
-protocol IMAP
-open Printf
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Les types %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-type command =
| ImapSelect of string
| ImapExamine of string
| ImapNoop
| ImapFetch of (bool * string * string)
| ImapStore of (bool * string * string * string)
| ImapSearch of (bool * string)
| ImapSearchCs of (bool * string * string)
| ImapCopy of (bool * string * string)
| ImapList of (string * string)
| ImapCreate of string
| ImapDelete of string
| ImapRename of (string * string)
| ImapStatus of (string * string)
| ImapAppend of (string * string * string * string)
| ImapExpunge
-type commands = command list
-type status = {
flags : string;
exists : int;
recent : int;
oks : string list;
rwstatus : string;
}
-type result =
| Ok of string
| No of string
| Bad of string
| SelectResult of status
| ExamineResult of status
| NoopResult of status
| SearchResult of int list
| FetchResult of (int * string * string) list
| StoreResult of (int * string) list
| ListResult of (string * string * string) list
| StatusResult of (string * string) list
| ExpungeResult of int list
| Error of string
-type results = result list
-type mail = {
username : string;
password : string;
commands : commands;
status : status;
fetched : (int * string * string) list;
list : (string * string * string) list;
statused : (string * string) list;
expunged : int list;
results : results;
from : string;
dests : string list;
data : string
}
-type cont = result list -> unit
-type imports = {
k : cont
}
-type payload = unit
-include "libnet/rt_proto.proto"
-type rt_tmp =
{
rt_callback : (payload -> int -> Buffer.t -> bool) option;
}
-type runtime = {
rt_plim : int;
rt_proto : rt_proto;
rt_tmp : rt_tmp;
}
{{
let get_tag() = Printf.sprintf "A%05d" (Random.int(65535-4096)+4096)
let string_of_command = function
| ImapSelect s -> sprintf "SELECT %s" s
| ImapExamine s -> sprintf "EXAMINE %s" s
| ImapNoop -> "NOOP"
| ImapFetch (uid,seq,items) -> sprintf "%sFETCH %s %s" (if uid then "UID " else "") seq items
| ImapCopy (uid,seq,m) -> sprintf "%sCOPY %s %s" (if uid then "UID " else "") seq m
| ImapStore (uid,seq,din,dinval) -> sprintf "%sSTORE %s %s %s" (if uid then "UID " else "") seq din dinval
| ImapSearch (uid,s) -> sprintf "%sSEARCH %s" (if uid then "UID " else "") s
| ImapSearchCs (uid,cs,s) -> sprintf "%sSEARCH CHARSET %s %s" (if uid then "UID " else "") cs s
| ImapList (r,m) -> sprintf "LIST %s %s" r m
| ImapCreate s -> sprintf "CREATE %s" s
| ImapDelete s -> sprintf "DELETE %s" s
| ImapRename (f,t) -> sprintf "RENAME %s %s" f t
| ImapStatus (m,i) -> sprintf "STATUS %s %s" m i
| ImapAppend (m,f,t,l) -> sprintf "APPEND %s %s %s (%d bytes)" m f t (String.length l)
| ImapExpunge -> "EXPUNGE"
let add_fetched str fetched =
match fetched with
| [] -> [(0,"",str)]
| ((i,what,ss)::t) -> ((i,what,ss^str)::t) (* todo: bufferise this *)
}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Messages envoyés/reçus %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-define (Ready str) = "+ " str "\r\n"
-define (Noop tag) = tag " NOOP\r\n"
-define (Login (tag, name, pass)) = tag " LOGIN " name " " pass "\r\n"
-define (Select (tag, mailbox)) = tag " SELECT " mailbox "\r\n"
-define (Examine (tag, mailbox)) = tag " EXAMINE " mailbox "\r\n"
-define (Exists num:int) = "* " num " EXISTS\r\n"
-define (Recent num:int) = "* " num " RECENT\r\n"
-define (Flags str) = "* FLAGS (" str ")\r\n"
-define (StarSearch result) = "* SEARCH " result "\r\n"
-define StarEmptySearch = "* SEARCH\r\n"
% TODO: watch out for other empty messages
-define (StarExpunge num:int) = "* " num " EXPUNGE\r\n"
-define (StarFetchLen (num:int, what, len:int)) = "* " num " FETCH (" what " {" len "}\r\n"
-define (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
-define (FetchContinue (what, len:int)) = " " what " {" len "}\r\n"
-define FetchEnd = ")\r\n"
-define (StarListLen (flags,rf,len:int)) = "* LIST ("~ flags ") " rf " {" len "}\r\n"
-define (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\r\n"
-define (StarStatusLen (len:int)) = "* STATUS {" len "}\r\n"
-define (StarStatus (mailbox,items)) = "* STATUS "~ mailbox " (" items ")\r\n"
-define (Search (tag, params)) = tag " SEARCH " params "\r\n"
-define (UidSearch (tag, params)) = tag " UID SEARCH " params "\r\n"
-define (SearchCs (tag, cs, params)) = tag " SEARCH CHARSET " cs " " params "\r\n"
-define (UidSearchCs (tag, cs, params)) = tag " UID SEARCH CHARSET " cs " " params "\r\n"
-define (Fetch (tag, seq, items)) = tag " FETCH " seq " " items "\r\n"
-define (UidFetch (tag, seq, items)) = tag " UID FETCH " seq " " items "\r\n"
-define (Store (tag, seq, din, dinval)) = tag " STORE " seq " " din " " dinval "\r\n"
-define (UidStore (tag, seq, din, dinval)) = tag " UID STORE " seq " " din " " dinval "\r\n"
-define (Copy (tag, seq, mailbox)) = tag " COPY " seq " " mailbox "\r\n"
-define (UidCopy (tag, seq, mailbox)) = tag " UID COPY " seq " " mailbox "\r\n"
-define (List (tag, rf, mailbox)) = tag " LIST " rf " " mailbox "\r\n"
-define (Create (tag, mailbox)) = tag " CREATE " mailbox "\r\n"
-define (Delete (tag, mailbox)) = tag " DELETE " mailbox "\r\n"
-define (Rename (tag, frommb, tomb)) = tag " RENAME " frommb " " tomb "\r\n"
-define (Status (tag, mailbox, items)) = tag " STATUS " mailbox " (" items ")\r\n"
-define (Append1 (tag, mailbox, len:int)) = tag " APPEND " mailbox " {" len "}\r\n"
-define (Append2 (tag, mailbox, flags, len:int)) = tag " APPEND " mailbox " (" flags ") {" len "}\r\n"
-define (Append3 (tag, mailbox, flags, time, len:int)) = tag " APPEND " mailbox " (" flags ") " time " {" len "}\r\n"
-define (Expunge tag) = tag " EXPUNGE\r\n"
-define (Close tag) = tag " CLOSE\r\n"
-define (NoopOk (tag,str)) = tag " OK NOOP "~ str "\r\n"
-define (FetchOk (tag,str)) = tag " OK " "UID "? "FETCH "~ str "\r\n"
-define (StoreOk (tag,str)) = tag " OK " "UID "? "STORE "~ str "\r\n"
-define (CopyOk (tag,str)) = tag " OK " "UID "? "COPY "~ str "\r\n"
-define (ListOk (tag,str)) = tag " OK LIST "~ str "\r\n"
-define (CreateOk (tag,str)) = tag " OK CREATE "~ str "\r\n"
-define (DeleteOk (tag,str)) = tag " OK DELETE "~ str "\r\n"
-define (RenameOk (tag,str)) = tag " OK RENAME "~ str "\r\n"
-define (StatusOk (tag,str)) = tag " OK STATUS "~ str "\r\n"
-define (AppendOk (tag,str)) = tag " OK APPEND "~ str "\r\n"
-define (ExpungeOk (tag,str)) = tag " OK EXPUNGE "~ str "\r\n"
-define (CloseOk (tag,str)) = tag " OK CLOSE "~ str "\r\n"
-define (StarOk str) = "* OK " str "\r\n"
-define (FlagsOk (tag, flags, str)) = tag " OK [" flags "] " str "\r\n"
-define (JustOk (tag, str)) = tag " OK " str "\r\n"
-define (JustNo (tag,str)) = tag " NO " str "\r\n"
-define (JustBad (tag,str)) = tag " BAD " str "\r\n"
-define StatusLenEnd items = " (" items ")\r\n"
-define End = "\r\n"
-define RawInput str = str
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% L'automate %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+imap(mail : mail, tools : imports):
debug {{ Printexc.record_backtrace true }}
debug {{ eprintf "imapClientCore: Started connection\n%!" }}
let tag = {{ get_tag() }}
send (Login (tag, mail.username, mail.password));
login(mail, tools, tag)
login(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "login received * OK: %s\n%!" _str }}
login(mail, tools, tag)
| FlagsOk (rtag,_flags,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "login received mismatched LOGIN OK: rtag=%s tag=%s str=%s\n%!" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "login received LOGIN OK: tag=%s flags=%s str=%s\n%!" tag _flags _str }}
commands(mail, tools)
| err ->
debug {{ eprintf "ImapClientCore.login received err: %s\n%!" (string_of_msg err) }}
error({{ string_of_msg err }}, tools)
catch
| exn ->
{{ eprintf "ImapClientCore.login: exn=%s\n%!" (Printexc.to_string exn) }}
debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
{{ tools.k [Error (Printexc.to_string exn)] }}
got_nobad(mail, tools, _name, _nobad, tag, rtag, _str, result):
if {{ rtag <> tag }}
then
debug {{ eprintf "Received mismatched %s %s: rtag=%s tag=%s str=%s\n" _name _nobad rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "Received %s %s: tag=%s str=%s\n" _name _nobad tag _str }}
let mail = {{ { mail with results = (result::mail.results) } }}
quit(mail, tools)
check_error(mail, tools, name, tag, err):
match {{ err }} with
| JustNo (rtag, str) ->
got_nobad(mail, tools, name, {{"NO"}}, tag, rtag, str, {{(No str)}})
| JustBad (rtag, str) ->
got_nobad(mail, tools, name, {{"BAD"}}, tag, rtag, str, {{(Bad str)}})
| err ->
debug {{ eprintf "received err: %s\n" (string_of_msg err) }}
error({{ string_of_msg err }}, tools)
check_exception(_mail, tools, _name, _tag, exn):
let _ = {{ (conn, sched) }}
{{ eprintf "ImapClientCore.%s: exn=%s\n" _name (Printexc.to_string exn) }}
debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
{{ tools.k [Error (Printexc.to_string exn)] }}
commands(mail, tools):
let mail = {{ { mail with fetched=[]; list=[]; expunged=[] } }}
if {{ mail.commands = [] }}
then
close(mail, tools)
else
let tag = {{ get_tag() }}
let command = {{ List.hd mail.commands }}
debug {{ eprintf "imapClientCore: command=%s\n%!" (string_of_command command) }}
let commands = {{ List.tl mail.commands }}
let mail = {{ { mail with commands = commands} }}
match {{ command }} with
| ImapNoop ->
send (Noop tag);
wait_for_ok(mail, tools, tag, {{"noop"}}, {{"NOOP"}},
{{function NoopOk (rt,s) -> Some (rt,s) | _ -> None}}, {{NoopResult mail.status}})
| ImapFetch (uid, seq, items) ->
if {{ uid }}
then
send (UidFetch (tag, seq, items));
fetch(mail, tools, tag)
else
send (Fetch (tag, seq, items));
fetch(mail, tools, tag)
| ImapStore (uid, seq, din, dinval) ->
if {{ uid }}
then
send (UidStore (tag, seq, din, dinval));
store(mail, tools, tag)
else
send (Store (tag, seq, din, dinval));
store(mail, tools, tag)
| ImapSearchCs (uid, charset, params) ->
if {{ uid }}
then
send (UidSearchCs (tag, charset, params));
search(mail, tools, tag)
else
send (SearchCs (tag, charset, params));
search(mail, tools, tag)
| ImapSearch (uid, params) ->
if {{ uid }}
then
send (UidSearch (tag, params));
search(mail, tools, tag)
else
send (Search (tag, params));
search(mail, tools, tag)
| ImapList (rf, mailbox) ->
if {{ rf = "" || mailbox = "" }}
then
error({{ "Empty strings would make LIST command invalid, use \"\" instead" }}, tools)
else
send (List (tag, rf, mailbox));
let mail = {{ { mail with list = [] } }}
list(mail, tools, tag)
end
| ImapCopy (uid, seq, mailbox) ->
if {{ uid }}
then
send (UidCopy (tag, seq, mailbox));
copy(mail, tools, tag)
else
send (Copy (tag, seq, mailbox));
copy(mail, tools, tag)
| ImapCreate mailbox ->
send (Create (tag, mailbox));
wait_for_ok(mail, tools, tag, {{"create"}}, {{"CREATE"}},
{{function CreateOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "created"}})
| ImapDelete mailbox ->
send (Delete (tag, mailbox));
wait_for_ok(mail, tools, tag, {{"delete"}}, {{"DELETE"}},
{{function DeleteOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "deleted"}})
| ImapStatus (mailbox, items) ->
if {{ items = "" || mailbox = "" }}
then
error({{ "Empty strings would make STATUS command invalid, use \"\" instead" }}, tools)
else
send (Status (tag, mailbox, items));
let mail = {{ { mail with statused = [] } }}
status(mail, tools, tag)
end
| ImapAppend (mailbox, flags, time, msg) ->
let len = {{ String.length msg }}
if {{ time = "" }}
then
if {{ flags = "" }}
then
send (Append1 (tag,mailbox,len));
append(mail, tools, tag, msg)
else
send (Append2 (tag,mailbox,flags,len));
append(mail, tools, tag, msg)
end
else
send (Append3 (tag,mailbox,flags,time,len));
append(mail, tools, tag, msg)
end
| ImapRename (frommb, tomb) ->
send (Rename (tag, frommb, tomb));
wait_for_ok(mail, tools, tag, {{"rename"}}, {{"RENAME"}},
{{function RenameOk (rt,s) -> Some (rt,s) | _ -> None}}, {{Ok "renamed"}})
| ImapExpunge ->
send (Expunge tag);
expunge(mail, tools, tag)
| ImapSelect mailbox ->
send (Select (tag, mailbox));
select(mail, tools, tag, {{"SELECT"}})
| ImapExamine mailbox ->
send (Examine (tag, mailbox));
select(mail, tools, tag, {{"EXAMINE"}})
select(mail, tools, tag, selex):
receive
| StarOk str ->
debug {{ eprintf "select received * OK: %s\n" str }}
let mail = [[ {mail with status={mail.status with oks=str::mail.status.oks}} ]]
select(mail, tools, tag, selex)
| Exists num ->
debug {{ eprintf "select received * EXISTS: %d\n" num }}
let mail = [[ {mail with status={mail.status with exists=num}} ]]
select(mail, tools, tag, selex)
| Recent num ->
debug {{ eprintf "select received * RECENT: %d\n" num }}
let mail = [[ {mail with status={mail.status with recent=num}} ]]
select(mail, tools, tag, selex)
| Flags str ->
debug {{ eprintf "select received * FLAGS: %s\n" str }}
let mail = [[ {mail with status={mail.status with flags=str}} ]]
select(mail, tools, tag, selex)
| FlagsOk (rtag,flags,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "select received mismatched %s OK: rtag=%s tag=%s str=%s\n" selex rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "select received %s OK: tag=%s flags=%s str=%s\n" selex tag flags _str }}
let mail = [[ {mail with status={mail.status with rwstatus=flags}} ]]
let result = {{ if selex = "SELECT" then (SelectResult mail.status) else (ExamineResult mail.status) }}
let mail = [[ {mail with results=(result::mail.results)} ]]
commands(mail, tools)
| err ->
check_error(mail, tools, selex, tag, err)
catch
| exn ->
check_exception(mail, tools, {{String.lowercase selex}}, tag, exn)
wait_for_ok(mail, tools, tag, name, _NAME, fn, result):
receive
| StarOk _str ->
debug {{ eprintf "%s received * OK: %s\n%!" name _str }}
wait_for_ok(mail, tools, tag, name, _NAME, fn, result)
| err ->
match {{ fn err }} with
| Some (rtag, _str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "%s received mismatched %s OK: rtag=%s tag=%s str=%s\n%!" name _NAME rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "%s received %s OK: tag=%s str=%s\n%!" name _NAME tag _str }}
bye(mail, tools, result)
end
| None ->
check_error(mail, tools, _NAME, tag, err)
catch
| exn ->
check_exception(mail, tools, name, tag, exn)
bye(mail, tools, result):
let mail = {{ { mail with results = (result::mail.results) } }}
commands(mail, tools)
search(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "search received * OK: %s\n" _str }}
search(mail, tools, tag)
| StarSearch str ->
debug {{ eprintf "search received * SEARCH: %s\n" str }}
let il = {{ List.map (fun s -> try int_of_string s with _ -> -1) (String.slice ' ' str) }}
let mail = {{ { mail with results = ((SearchResult il)::mail.results) } }}
search(mail, tools, tag)
| StarEmptySearch ->
debug {{ eprintf "search received * SEARCH\n" }}
let mail = {{ { mail with results = ((SearchResult [])::mail.results) } }}
search(mail, tools, tag)
| JustOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "search received mismatched SEARCH OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "search received SEARCH OK: tag=%s str=%s\n" tag _str }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"SEARCH"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"search"}}, tag, exn)
fetch(mail, tools, tag):
receive
| StarFetchLen (num, what, len) ->
debug {{ eprintf "fetch received * FETCH: %d %d\n" num len }}
let mail = {{ { mail with fetched = ((num,what,"")::mail.fetched) } }}
fetch_data(num, mail, tools, tag, len)
| StarFetch (num, str) ->
debug {{ eprintf "fetch received * FETCH: %d %s\n" num (String.limit 50 str) }}
let mail = {{ { mail with fetched = ((num,"",str)::mail.fetched) } }}
fetch(mail, tools, tag)
| FetchOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "fetch received mismatched FETCH OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "fetch received FETCH OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((FetchResult (List.rev mail.fetched))::mail.results) } }}
commands(mail, tools)
| JustNo (rtag, str) ->
got_nobad(mail, tools, {{"FETCH"}}, {{"NO"}}, tag, rtag, str, {{(No str)}})
| JustBad (rtag, str) ->
got_nobad(mail, tools, {{"FETCH"}}, {{"BAD"}}, tag, rtag, str, {{(Bad str)}})
| msg ->
% This is ridiculous and dangerous, we should parse the initial header and use fixed to read in the data.
% For the moment it's just a fallback in case the StarFetchLen pattern fails
let str = {{ string_of_msg msg }}
%debug {{ eprintf "fetch received raw input: str=%s\n" str }}
let mail = {{ { mail with fetched = (add_fetched str mail.fetched) } }}
fetch(mail, tools, tag)
catch
| exn ->
check_exception(mail, tools, {{"fetch"}}, tag, exn)
fetch_data(num, mail, tools, tag, len):
debug {{ eprintf "fetch_data: getting %d bytes\n%!" len }}
fixed {{ len }}
| data ->
debug {{ eprintf "fetch_data: data='%s'\n%!" (String.escaped (String.limit 50 data)) }}
let mail = {{ { mail with fetched = (add_fetched data mail.fetched) } }}
end_fetched_data(num, mail, tools, tag)
end_fetched_data(num, mail, tools, tag):
receive
| FetchEnd ->
debug {{ eprintf "fetch_data: ok\n%!" }}
fetch(mail, tools, tag)
| FetchContinue (what, len) ->
debug {{ eprintf "fetch received continuation: %d %d\n" num len }}
let mail = {{ { mail with fetched = ((num,what,"")::mail.fetched) } }}
fetch_data(num, mail, tools, tag, len)
| err ->
debug {{ eprintf "fetch_data: error\n%!" }}
error({{ sprintf "Bad end of fetch data: %s" (String.escaped (string_of_msg err)) }}, tools)
store(mail, tools, tag):
receive
| StarFetch (num, str) ->
debug {{ eprintf "store received * FETCH: %d %s\n" num (String.limit 50 str) }}
let mail = {{ { mail with fetched = ((num,"",str)::mail.fetched) } }}
store(mail, tools, tag)
| StoreOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "store received mismatched STORE OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "store received STORE OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((StoreResult (List.rev (List.map (function (x,_,z) -> (x,z)) mail.fetched)))::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"STORE"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"store"}}, tag, exn)
copy(mail, tools, tag):
receive
| CopyOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "copy received mismatched COPY OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "fetch received COPY OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((Ok "copied")::mail.results) } }}
commands(mail, tools)
| FlagsOk (rtag,flags,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "copy received mismatched COPY OK: rtag=%s tag=%s flags=%s str=%s\n" rtag tag flags _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "fetch received COPY OK: tag=%s flags=%s str=%s\n" tag flags _str }}
let mail = {{ { mail with results = ((Ok flags)::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"COPY"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"copy"}}, tag, exn)
list(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "list received * OK: %s\n" _str }}
list(mail, tools, tag)
| StarListLen (flags, rf, len) ->
list_data(mail, tools, tag, flags, rf, len)
| StarList (flags, rf, mailbox) ->
let mailbox = {{ String.strip_quotes mailbox }}
debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
list(mail, tools, tag)
| ListOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "list received mismatched LIST OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "list received LIST OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((ListResult (List.rev mail.list))::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"LIST"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"list"}}, tag, exn)
list_data(mail, tools, tag, flags, rf, len):
debug {{ eprintf "list_data: getting %d bytes\n%!" len }}
fixed {{ len }}
| mailbox ->
debug {{ eprintf "list received * LIST: (%s) %s %s\n" flags rf mailbox }}
let mail = {{ { mail with list = ((flags,rf,mailbox)::mail.list) } }}
list_end(mail, tools, tag)
list_end(mail, tools, tag):
receive
| End ->
debug {{ eprintf "list_data: ok\n%!" }}
list(mail, tools, tag)
| err ->
debug {{ eprintf "list_data: error\n%!" }}
error({{ sprintf "Bad end of list data: %s" (String.escaped (string_of_msg err)) }}, tools)
status(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "status received * OK: %s\n" _str }}
status(mail, tools, tag)
| StarStatusLen len ->
status_data(mail, tools, tag, len)
| StarStatus (mailbox, items) ->
let mailbox = {{ String.strip_quotes mailbox }}
debug {{ eprintf "mailbox(hdr) = '%s'\n%!" mailbox }}
debug {{ eprintf "status received * STATUS: %s (%s)\n" mailbox items }}
let mail = {{ { mail with statused = ((mailbox,items)::mail.statused) } }}
status(mail, tools, tag)
| StatusOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "status received mismatched STATUS OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "status received STATUS OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((StatusResult mail.statused)::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"STATUS"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"status"}}, tag, exn)
status_data(mail, tools, tag, len):
debug {{ eprintf "status_data: getting %d bytes\n%!" len }}
fixed {{ len }}
| mailbox ->
debug {{ eprintf "mailbox(len) = '%s'\n%!" mailbox }}
debug {{ eprintf "status received * STATUS: %s\n" mailbox }}
status_end(mail, tools, tag, mailbox)
status_end(mail, tools, tag, mailbox):
receive
| StatusLenEnd items ->
debug {{ eprintf "status_data: ok\n%!" }}
let mail = {{ { mail with statused = ((mailbox,items)::mail.statused) } }}
status(mail, tools, tag)
| err ->
debug {{ eprintf "status_data: error\n%!" }}
error({{ sprintf "Bad end of status data: %s" (String.escaped (string_of_msg err)) }}, tools)
append(mail, tools, tag, msg):
receive
| Ready _str ->
debug {{ eprintf "append received + %s\n" _str }}
send_buf {{ msg }}
send_buf {{ "\r\n" }}
append1(mail, tools, tag)
| err ->
check_error(mail, tools, {{"APPEND"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"append"}}, tag, exn)
append1(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "append received * OK: %s\n" _str }}
append1(mail, tools, tag)
| FlagsOk (rtag,flags,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "append received mismatched APPEND OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "append received APPEND OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((Ok flags)::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"APPEND"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"append"}}, tag, exn)
expunge(mail, tools, tag):
receive
| Recent num ->
debug {{ eprintf "expunge received * RECENT: %d\n" num }}
let mail = [[ {mail with status={mail.status with recent=num}} ]]
expunge(mail, tools, tag)
| StarExpunge num ->
debug {{ eprintf "expunge received * EXPUNGE: %d\n" num }}
let mail = {{ { mail with expunged = (num::mail.expunged) } }}
expunge(mail, tools, tag)
| ExpungeOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "expunge received mismatched EXPUNGE OK: rtag=%s tag=%s str=%s\n" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "expunge received EXPUNGE OK: tag=%s str=%s\n" tag _str }}
let mail = {{ { mail with results = ((ExpungeResult (List.rev mail.expunged))::mail.results) } }}
commands(mail, tools)
| err ->
check_error(mail, tools, {{"EXPUNGE"}}, tag, err)
catch
| exn ->
check_exception(mail, tools, {{"expunge"}}, tag, exn)
close(mail, tools):
let tag = {{ get_tag() }}
send (Close tag);
wait_close(mail, tools, tag)
wait_close(mail, tools, tag):
receive
| StarOk _str ->
debug {{ eprintf "close received * OK: %s\n%!" _str }}
wait_close(mail, tools, tag)
| CloseOk (rtag,_str) ->
if {{ rtag <> tag }}
then
debug {{ eprintf "close received mismatched CLOSE OK: rtag=%s tag=%s str=%s\n%!" rtag tag _str }}
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "close received CLOSE OK: tag=%s str=%s\n%!" tag _str }}
quit(mail, tools)
| _err ->
debug {{ eprintf "close received err: %s\n%!" (string_of_msg _err) }}
quit(mail, tools)
catch
| exn ->
{{ eprintf "ImapClientCore.close: exn=%s\n%!" (Printexc.to_string exn) }}
debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
quit(mail, tools)
quit(mail, tools):
-!-
{{ tools.k (List.rev mail.results) }}
error(msg : string, tools : imports):
debug {{ eprintf "error: %s\n%!" msg }}
-!-
{{ Logger.error "Error: %s" msg;
tools.k [Error msg] }}
% End of file imapClientCore.proto
Jump to Line
Something went wrong with that request. Please try again.