Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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.