Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

[feature] imap client: Added new commands.

  • Loading branch information...
commit 3796837f89abd18ff456c2e2172cb3b5acb17f04 1 parent 03afae5
@nrs135 nrs135 authored Aqua-Ye committed
View
51 libnet/imapClient.ml
@@ -20,37 +20,20 @@
It is NOT really RFC compliant. *)
module ICC = ImapClientCore
-module List = Base.List
-module String = Base.String
-let (<|) f a = f a
-let (|>) a f = f a
-let ( @* ) g f x = g(f(x))
-
-let sprintf = Printf.sprintf
-
-exception Bad_address of string
-exception Too_much_try
-exception Unknown_address of string
-
-let read_code s =
- let get i = int_of_char (String.unsafe_get s i) - 48 in
- let l = String.length s in
- if l > 3 then 100 * get 0 + 10 * get 1 + get 2, String.sub s 4 (4 - 3)
- else 0, "unknown server answer"
-
-let analyze_error = Mailerror.parse_mailerror_error
let mail_recv_aux ?client_certificate ?verify_params ?(secure=false) sched
~addr ?(port=993)
- ~mailbox ~username ~password
- ?(command=ICC.ImapNoop) cont () =
+ ~mailbox ?readonly ~username ~password
+ ?(commands=[]) cont ?err_cont () =
let mail = { ICC.mailbox=mailbox;
+ readonly=Option.default false readonly;
username=username;
password=password;
- command=command;
- fetched=[];
- result=(ICC.Ok "nothing happened");
- from = ""; dests = []; data = "" } in
+ commands=commands;
+ status={ ICC.flags=""; exists=(-1); recent=(-1); oks=[]; rwstatus="" };
+ fetched=[]; list=[]; expunged=[];
+ results=[];
+ from=""; dests=[]; data="" } in
let rec try_mx mail cont =
let tools = {
ICC.k = (function res -> cont res);
@@ -69,21 +52,25 @@ let mail_recv_aux ?client_certificate ?verify_params ?(secure=false) sched
rt_payload = ();
};
};
- ICC.err_cont = None;
+ ICC.err_cont = err_cont;
ICC.extra_params = (mail,tools)
} in
let secure_mode =
if secure
then Network.Secured (client_certificate, verify_params)
else Network.Unsecured
- in ICC.connect client ~secure_mode sched addr port
- in try_mx mail cont
+ in
+ try
+ ICC.connect client ~secure_mode sched addr port
+ with exn -> cont ([ICC.Error (Printf.sprintf "Got connection exception: %s" (Printexc.to_string exn))])
+ in
+ try_mx mail cont
let mail_recv ?client_certificate ?verify_params ?secure sched
~addr ?port
- ~mailbox ~username ~password ?command
- (cont:ICC.result -> unit) () =
+ ~mailbox ?readonly ~username ~password ?commands
+ (cont:ICC.results -> unit) ?err_cont () =
mail_recv_aux ?client_certificate ?verify_params ?secure sched
~addr ?port
- ~mailbox ~username ~password ?command
- cont ()
+ ~mailbox ?readonly ~username ~password ?commands
+ cont ?err_cont ()
View
323 libnet/imapClientCore.proto
@@ -28,30 +28,56 @@
-type command =
| ImapNoop
| ImapFetch of (string * string)
+ | ImapStore of (string * string * string)
| ImapSearch of string
| ImapSearchCs of (string * string)
+ | ImapList of (string * string)
+ | ImapCreate of string
+ | ImapDelete of string
+ | ImapRename of (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
+ | NoopResult of status
| SearchResult of int list
| FetchResult of (int * string) list
+ | StoreResult of (int * string) list
+ | ListResult of (string * string * string) list
+ | ExpungeResult of int list
| Error of string
+-type results = result list
+
-type mail = {
mailbox : string;
+ readonly : bool;
username : string;
password : string;
- command : command;
+ commands : commands;
+ status : status;
fetched : (int * string) list;
- result : result;
+ list : (string * string * string) list;
+ expunged : int list;
+ results : results;
from : string;
dests : string list;
data : string
}
--type cont = result -> unit
+-type cont = result list -> unit
-type imports = {
k : cont
@@ -75,8 +101,14 @@ let get_tag() = Printf.sprintf "A%05d" (Random.int(65535-4096)+4096)
let string_of_command = function
| ImapNoop -> "NOOP"
| ImapFetch (seq,items) -> sprintf "FETCH %s %s" seq items
+ | ImapStore (seq,din,dinval) -> sprintf "STORE %s %s %s" seq din dinval
| ImapSearch s -> sprintf "SEARCH %s" s
| ImapSearchCs (cs,s) -> sprintf "SEARCH CHARSET %s %s" 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
+ | ImapExpunge -> "EXPUNGE"
let add_fetched str fetched =
match fetched with
| [] -> [(0,str)]
@@ -86,39 +118,53 @@ let add_fetched str fetched =
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Messages envoyés/reçus %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
--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 (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 (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
--define (Search (tag, params)) = tag " SEARCH " params "\r\n"
--define (SearchCs (tag, cs, params)) = tag " SEARCH CHARSET " cs " " params "\r\n"
--define (Fetch (tag, seq, items)) = tag " FETCH " seq " " items "\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 FETCH "~ 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 RawInput str = str
+-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 (StarExpunge num:int) = "* " num " EXPUNGE\r\n"
+-define (StarFetch (num:int, result)) = "* " num " FETCH " result "\r\n"
+-define (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\r\n"
+-define (Search (tag, params)) = tag " SEARCH " params "\r\n"
+-define (SearchCs (tag, cs, params)) = tag " SEARCH CHARSET " cs " " params "\r\n"
+-define (Fetch (tag, seq, items)) = tag " FETCH " seq " " items "\r\n"
+-define (Store (tag, seq, din, dinval)) = tag " STORE " seq " " din " " dinval "\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 (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 FETCH "~ str "\r\n"
+-define (StoreOk (tag,str)) = tag " OK STORE "~ 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 (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 RawInput str = str
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% L'automate %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+imap(mail : mail, tools : imports):
debug {{ Printexc.record_backtrace true }}
- debug {{ eprintf "imapClientCore: mailbox=%s command=%s\n%!" mail.mailbox (string_of_command mail.command) }}
+ debug {{ eprintf "imapClientCore: Started connection with mailbox=%s\n%!" mail.mailbox }}
let tag = {{ get_tag() }}
- debug {{ eprintf "imapClientCore: Started connection with tag %s\n%!" tag }}
send (Login (tag, mail.username, mail.password));
login(mail, tools, tag)
@@ -135,8 +181,13 @@ login(mail, tools, tag):
else
debug {{ eprintf "login received LOGIN OK: tag=%s flags=%s str=%s\n%!" tag flags str }}
let tag = {{ get_tag() }}
- send (Select (tag, mail.mailbox));
- select(mail, tools, tag)
+ if {{ mail.readonly }}
+ then
+ send (Examine (tag, mail.mailbox));
+ select(mail, tools, tag, {{"EXAMINE"}})
+ else
+ send (Select (tag, mail.mailbox));
+ select(mail, tools, tag, {{"SELECT"}})
| err ->
debug {{ eprintf "ImapClientCore.login received err: %s\n%!" (string_of_msg err) }}
error({{ string_of_msg err }}, tools)
@@ -144,7 +195,7 @@ login(mail, tools, tag):
| exn ->
{{ eprintf "ImapClientCore.login: exn=%s\n%!" (Printexc.to_string exn) }}
debug {{ Printexc.print_backtrace stderr; Pervasives.flush stderr }}
- {{ tools.k (Ok (Printexc.to_string exn)) }}
+ {{ tools.k [Error (Printexc.to_string exn)] }}
got_nobad(mail, tools, name, nobad, tag, rtag, str, result):
if {{ rtag <> tag }}
@@ -153,7 +204,7 @@ got_nobad(mail, tools, name, nobad, tag, rtag, str, result):
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 result = result } }}
+ let mail = {{ { mail with results = (result::mail.results) } }}
quit(mail, tools)
check_error(mail, tools, name, tag, err):
@@ -170,68 +221,118 @@ 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)) }}
+ {{ tools.k [Error (Printexc.to_string exn)] }}
-select(mail, tools, tag):
+select(mail, tools, tag, selex):
receive
| StarOk str ->
debug {{ eprintf "select received * OK: %s\n" str }}
- select(mail, tools, tag)
+ 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 }}
- select(mail, tools, tag)
+ 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 }}
- select(mail, tools, tag)
+ 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 }}
- select(mail, tools, tag)
+ 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 SELECT OK: rtag=%s tag=%s str=%s\n" rtag tag str }}
+ 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 SELECT OK: tag=%s flags=%s str=%s\n" tag flags str }}
- let tag = {{ get_tag() }}
- match !"ImapClientCore.select" {{ mail.command }} with
- | ImapNoop ->
- send (Noop tag);
- noop(mail, tools, tag)
- | ImapFetch (seq, items) ->
- send (Fetch (tag, seq, items));
- fetch(mail, tools, tag)
- | ImapSearchCs (charset, params) ->
- send (SearchCs (tag, charset, params));
- search(mail, tools, tag)
- | ImapSearch params ->
- send (Search (tag, params));
- search(mail, tools, tag)
- end
+ 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}} ]]
+ commands(mail, tools)
| err ->
- check_error(mail, tools, {{"SELECT"}}, tag, err)
+ check_error(mail, tools, selex, tag, err)
catch
| exn ->
- check_exception(mail, tools, {{"select"}}, tag, exn)
+ check_exception(mail, tools, {{String.lowercase selex}}, tag, 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 (seq, items) ->
+ send (Fetch (tag, seq, items));
+ fetch(mail, tools, tag)
+ | ImapStore (seq, din, dinval) ->
+ send (Store (tag, seq, din, dinval));
+ store(mail, tools, tag)
+ | ImapSearchCs (charset, params) ->
+ send (SearchCs (tag, charset, params));
+ search(mail, tools, tag)
+ | ImapSearch params ->
+ 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));
+ list(mail, tools, tag)
+ end
+ | 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"}})
+ | 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)
-noop(mail, tools, tag):
+wait_for_ok(mail, tools, tag, name, _NAME, fn, result):
receive
| StarOk str ->
- debug {{ eprintf "noop received * OK: %s\n%!" str }}
- noop(mail, tools, tag)
- | NoopOk (rtag,str) ->
- if {{ rtag <> tag }}
- then
- debug {{ eprintf "noop received mismatched NOOP OK: rtag=%s tag=%s str=%s\n%!" rtag tag str }}
- error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
- else
- debug {{ eprintf "noop received NOOP OK: tag=%s str=%s\n%!" tag str }}
- bye(mail, tools)
+ debug {{ eprintf "%s received * OK: %s\n%!" name str }}
+ wait_for_ok(mail, tools, tag, name, _NAME, fn, result)
| err ->
- check_error(mail, tools, {{"NOOP"}}, tag, 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, {{"noop"}}, tag, 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
@@ -241,7 +342,7 @@ 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 result = (SearchResult il) } }}
+ let mail = {{ { mail with results = ((SearchResult il)::mail.results) } }}
search(mail, tools, tag)
| JustOk (rtag,str) ->
if {{ rtag <> tag }}
@@ -250,7 +351,7 @@ search(mail, tools, tag):
error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
else
debug {{ eprintf "search received SEARCH OK: tag=%s str=%s\n" tag str }}
- close(mail, tools)
+ commands(mail, tools)
| err ->
check_error(mail, tools, {{"SEARCH"}}, tag, err)
catch
@@ -273,8 +374,8 @@ fetch(mail, tools, tag):
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 result = (FetchResult (List.rev (add_fetched str mail.fetched))) } }}
- close(mail, tools)
+ let mail = {{ { mail with results = ((FetchResult (List.rev mail.fetched))::mail.results) } }}
+ commands(mail, tools)
| RawInput str ->
%debug {{ eprintf "fetch received RawInput: str=%s\n" str }}
let mail = {{ { mail with fetched = (add_fetched str mail.fetched) } }}
@@ -285,9 +386,71 @@ fetch(mail, tools, tag):
| exn ->
check_exception(mail, tools, {{"fetch"}}, tag, exn)
-bye(mail, tools):
- let mail = {{ { mail with result = (Ok "bye") } }}
- close(mail, 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 mail.fetched))::mail.results) } }}
+ commands(mail, tools)
+ | err ->
+ check_error(mail, tools, {{"STORE"}}, tag, err)
+ catch
+ | exn ->
+ check_exception(mail, tools, {{"store"}}, tag, exn)
+
+list(mail, tools, tag):
+ receive
+ | StarOk str ->
+ debug {{ eprintf "list received * OK: %s\n" str }}
+ list(mail, tools, tag)
+ | StarList (flags, rf, 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)
+
+expunge(mail, tools, tag):
+ receive
+ | 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() }}
@@ -318,12 +481,12 @@ wait_close(mail, tools, tag):
quit(mail, tools):
-!-
- {{ tools.k mail.result }}
+ {{ 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) }}
+ tools.k [Error msg] }}
% End of file imapClientCore.proto
View
174 opabsl/mlbsl/bslMail.ml
@@ -101,78 +101,150 @@
##opa-type Email.imap_command
##opa-type Email.imap_result
+ ##opa-type Email.imap_status
let ok = ServerLib.static_field_of_name "Ok"
+ let noopresult = ServerLib.static_field_of_name "NoopResult"
let searchresult = ServerLib.static_field_of_name "SearchResult"
let fetchresult = ServerLib.static_field_of_name "FetchResult"
+ let storeresult = ServerLib.static_field_of_name "StoreResult"
+ let listresult = ServerLib.static_field_of_name "ListResult"
+ let expungeresult = ServerLib.static_field_of_name "ExpungeResult"
let no = ServerLib.static_field_of_name "No"
let bad = ServerLib.static_field_of_name "Bad"
let error = ServerLib.static_field_of_name "Error"
+ let flags = ServerLib.static_field_of_name "flags"
+ let exists = ServerLib.static_field_of_name "exists"
+ let recent = ServerLib.static_field_of_name "recent"
+ let oks = ServerLib.static_field_of_name "oks"
+ let rwstatus = ServerLib.static_field_of_name "rwstatus"
+
##register [cps-bypass] command : int, string, SSL.secure_type, \
- string, string, string, opa[email_imap_command], \
- (opa[email_imap_result], continuation(opa[void]) -> void), \
+ string, opa[bool], string, string, opa[list(email_imap_command)], \
+ (opa[list(email_imap_result)], continuation(opa[void]) -> void), \
continuation(opa[void]) -> void
- let command port addr secure_type mailbox username password command cont k =
+ let command port addr secure_type mailbox readonly username password commands cont k =
let cont = BslUtils.proj_cps k cont in
- let wrap_is (i,s) = BslNativeLib.opa_tuple_2 (ServerLib.wrap_int i, ServerLib.wrap_string s) in
+ let wrap_s fld s =
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc fld (ServerLib.wrap_string s) in
+ ServerLib.make_record rc
+ in
+ let wrap_is (i,s) =
+ BslNativeLib.opa_tuple_2 (ServerLib.wrap_int i, ServerLib.wrap_string s) in
+ let wrap_sss (s1,s2,s3) =
+ BslNativeLib.opa_tuple_3 (ServerLib.wrap_string s1, ServerLib.wrap_string s2, ServerLib.wrap_string s3) in
- let cont x =
- let res =
- match x with
- | ImapClientCore.Ok str ->
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc ok (ServerLib.wrap_string str) in
- ServerLib.make_record rc
- | ImapClientCore.No str ->
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc no (ServerLib.wrap_string str) in
- ServerLib.make_record rc
- | ImapClientCore.Bad str ->
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc bad (ServerLib.wrap_string str) in
- ServerLib.make_record rc
- | ImapClientCore.Error err ->
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc error (ServerLib.wrap_string err) in
- ServerLib.make_record rc
- | ImapClientCore.SearchResult il ->
- let opa_il = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_int il in
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc searchresult opa_il in
- ServerLib.make_record rc
- | ImapClientCore.FetchResult isl ->
- let opa_isl = BslNativeLib.caml_list_to_opa_list wrap_is isl in
- let rc = ServerLib.empty_record_constructor in
- let rc = ServerLib.add_field rc fetchresult opa_isl in
- ServerLib.make_record rc
- in cont (wrap_opa_email_imap_result res)
+ let wrap_sl sl = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string sl in
+
+(* This segfaults...
+ let wrap_status (status:ImapClientCore.status) =
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc flags (ServerLib.wrap_string status.ImapClientCore.flags) in
+ let rc = ServerLib.add_field rc exists (ServerLib.wrap_int status.ImapClientCore.exists) in
+ let rc = ServerLib.add_field rc recent (ServerLib.wrap_int status.ImapClientCore.recent) in
+ let rc = ServerLib.add_field rc oks (BslNativeLib.caml_list_to_opa_list ServerLib.wrap_string status.ImapClientCore.oks) in
+ let rc = ServerLib.add_field rc rwstatus (ServerLib.wrap_string status.ImapClientCore.rwstatus) in
+ wrap_opa_email_imap_status (ServerLib.make_record rc)
+ in
+*)
+
+ let wrap_status (status:ImapClientCore.status) =
+ BslNativeLib.opa_tuple_5 (ServerLib.wrap_string status.ImapClientCore.flags,
+ ServerLib.wrap_int status.ImapClientCore.exists,
+ ServerLib.wrap_int status.ImapClientCore.recent,
+ wrap_sl status.ImapClientCore.oks,
+ ServerLib.wrap_string status.ImapClientCore.rwstatus)
in
- let command = unwrap_opa_email_imap_command command in
- let command =
- ServerLib.fold_record
- (fun f value _cmd ->
- let value = Obj.magic(value) in
- match ServerLib.name_of_field f with
- | Some "ImapNoop" -> ImapClientCore.ImapNoop
- | Some "ImapSearch" -> ImapClientCore.ImapSearch (ServerLib.unwrap_string value)
- | Some "ImapSearchCs" ->
- let charset, params = BslNativeLib.ocaml_tuple_2 value in
- ImapClientCore.ImapSearchCs (ServerLib.unwrap_string charset, ServerLib.unwrap_string params)
- | Some "ImapFetch" ->
- let seq, items = BslNativeLib.ocaml_tuple_2 value in
- ImapClientCore.ImapFetch (ServerLib.unwrap_string seq, ServerLib.unwrap_string items)
- | _ -> assert false)
- command ImapClientCore.ImapNoop
+ let cont results =
+ let results =
+ BslNativeLib.caml_list_to_opa_list
+ (fun result ->
+ wrap_opa_email_imap_result
+ (match result with
+ | ImapClientCore.Ok str -> wrap_s ok str
+ | ImapClientCore.No str -> wrap_s no str
+ | ImapClientCore.Bad str -> wrap_s bad str
+ | ImapClientCore.Error str -> wrap_s error str
+ | ImapClientCore.NoopResult status ->
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc noopresult (wrap_status status) in
+ ServerLib.make_record rc
+ | ImapClientCore.SearchResult il ->
+ let opa_il = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_int il in
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc searchresult opa_il in
+ ServerLib.make_record rc
+ | ImapClientCore.ExpungeResult il ->
+ let opa_il = BslNativeLib.caml_list_to_opa_list ServerLib.wrap_int il in
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc expungeresult opa_il in
+ ServerLib.make_record rc
+ | ImapClientCore.FetchResult isl ->
+ let opa_isl = BslNativeLib.caml_list_to_opa_list wrap_is isl in
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc fetchresult opa_isl in
+ ServerLib.make_record rc
+ | ImapClientCore.StoreResult isl ->
+ let opa_isl = BslNativeLib.caml_list_to_opa_list wrap_is isl in
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc storeresult opa_isl in
+ ServerLib.make_record rc
+ | ImapClientCore.ListResult sssl ->
+ let opa_sssl = BslNativeLib.caml_list_to_opa_list wrap_sss sssl in
+ let rc = ServerLib.empty_record_constructor in
+ let rc = ServerLib.add_field rc listresult opa_sssl in
+ ServerLib.make_record rc))
+ results
+ in
+ cont results
+ in
+
+ let unwrap_ss value =
+ let s1, s2 = BslNativeLib.ocaml_tuple_2 value in
+ ServerLib.unwrap_string s1, ServerLib.unwrap_string s2
+ in
+ let unwrap_sss value =
+ let s1, s2, s3 = BslNativeLib.ocaml_tuple_3 value in
+ ServerLib.unwrap_string s1, ServerLib.unwrap_string s2, ServerLib.unwrap_string s3
+ in
+ let commands =
+ BslNativeLib.opa_list_to_ocaml_list
+ (fun command ->
+ ServerLib.fold_record
+ (fun f value _cmd ->
+ let value = Obj.magic(value) in
+ match ServerLib.name_of_field f with
+ | Some "ImapNoop" -> ImapClientCore.ImapNoop
+ | Some "ImapFetch" -> ImapClientCore.ImapFetch (unwrap_ss value)
+ | Some "ImapStore" -> ImapClientCore.ImapStore (unwrap_sss value)
+ | Some "ImapSearch" -> ImapClientCore.ImapSearch (ServerLib.unwrap_string value)
+ | Some "ImapSearchCs" -> ImapClientCore.ImapSearchCs (unwrap_ss value)
+ | Some "ImapList" -> ImapClientCore.ImapList (unwrap_ss value)
+ | Some "ImapCreate" -> ImapClientCore.ImapCreate (ServerLib.unwrap_string value)
+ | Some "ImapDelete" -> ImapClientCore.ImapDelete (ServerLib.unwrap_string value)
+ | Some "ImapRename" -> ImapClientCore.ImapRename (unwrap_ss value)
+ | Some "ImapExpunge" -> ImapClientCore.ImapExpunge
+ | _ -> assert false)
+ (unwrap_opa_email_imap_command command) ImapClientCore.ImapNoop)
+ commands
in
let client_certificate, verify_params = secure_type in
+ let (err_cont:ImapClientCore.ecsa) =
+ fun (exn,name,_bt_opt) _runtime sched conn mailbox _ec ->
+ ImapClientCore.close_conn sched conn mailbox;
+ cont [ImapClientCore.Error (Printf.sprintf "Exception(at %s): %s" name (Printexc.to_string exn))]
+ in
+
ImapClient.mail_recv ?client_certificate ?verify_params ~secure:true BslScheduler.opa ~addr ~port
- ~mailbox ~username ~password ~command (cont:ImapClientCore.result -> unit) ();
+ ~mailbox ~readonly:(ServerLib.unwrap_bool readonly) ~username ~password ~commands
+ (cont:ImapClientCore.results -> unit) ~err_cont ();
QmlCpsServerLib.return k ServerLib.void
##endmodule
View
30 opabsl/mlbsl/bslNativeLib.ml
@@ -109,19 +109,23 @@ let unwrap_option proj opa =
caml_tuple_* as known by OCaml
*)
##extern-type caml_tuple_2('a,'b) = ('a*'b)
+##extern-type caml_tuple_3('a,'b,'c) = ('a*'b*'c)
##extern-type caml_tuple_4('a,'b,'c,'d) = ('a*'b*'c*'d)
+##extern-type caml_tuple_5('a,'b,'c,'d,'e) = ('a*'b*'c*'d*'e)
(**
tuple_* as known by OPA
*)
-##opa-type tuple_2('a, 'b)
-##opa-type tuple_3('a, 'b, 'c)
+##opa-type tuple_2('a,'b)
+##opa-type tuple_3('a,'b,'c)
##opa-type tuple_4('a,'b,'c,'d)
+##opa-type tuple_5('a,'b,'c,'d,'e)
let f1 = ServerLib.static_field_of_name "f1"
let f2 = ServerLib.static_field_of_name "f2"
let f3 = ServerLib.static_field_of_name "f3"
let f4 = ServerLib.static_field_of_name "f4"
+let f5 = ServerLib.static_field_of_name "f5"
@@ -178,6 +182,28 @@ let opa_tuple_4 (a, b, c, d) =
in
wrap_opa_tuple_4 record
+##register ocaml_tuple_5 : opa[tuple_5('a,'b,'c,'d,'e)] -> caml_tuple_5('a,'b,'c,'d,'e)
+let ocaml_tuple_5 opa =
+ let record = unwrap_opa_tuple_5 opa in
+ let a = ServerLib.unsafe_dot record f1 in
+ let b = ServerLib.unsafe_dot record f2 in
+ let c = ServerLib.unsafe_dot record f3 in
+ let d = ServerLib.unsafe_dot record f4 in
+ let e = ServerLib.unsafe_dot record f5 in
+ (a, b, c, d, e)
+
+let opa_tuple_5 (a, b, c, d, e) =
+ let record =
+ let acc = ServerLib.empty_record_constructor in
+ let acc = ServerLib.add_field acc f1 a in
+ let acc = ServerLib.add_field acc f2 b in
+ let acc = ServerLib.add_field acc f3 c in
+ let acc = ServerLib.add_field acc f4 d in
+ let acc = ServerLib.add_field acc f5 e in
+ ServerLib.make_record acc
+ in
+ wrap_opa_tuple_5 record
+
(**
{1 Continuations}
*)
View
1  protocols/genproto.ml
@@ -161,6 +161,7 @@ let gen_functor_sign has_raw arg lst =
[ O.Val (Ident.source "number_of_connections", O.TypeVerbatim "int ref");
O.Val (Ident.source "connect",
O.TypeVerbatim ("t -> ?secure_mode:Network.secure_mode -> Scheduler.t -> string -> int -> unit"));
+ O.Val (Ident.source "close_conn", O.TypeVerbatim ("Scheduler.t -> Scheduler.connection_info -> Buffer.t * int ref -> unit"));
O.Val (Ident.source "run_client", O.TypeVerbatim ("Scheduler.t -> unit"));
O.Val (Ident.source funame, O.TypeVerbatim ("t -> string -> int -> unit"));
O.Val (Ident.source "protocol", O.TypeVerbatim "NetAddr.protocol");
View
21 stdlib/web/mail/email.opa
@@ -108,15 +108,34 @@ type Email.options = {
type Email.imap_command =
{ ImapNoop }
/ { ImapFetch : (string, string) }
+ / { ImapStore : (string, string, string) }
/ { ImapSearch : string }
/ { ImapSearchCs : (string, string) }
+ / { ImapList : (string, string) }
+ / { ImapCreate : string }
+ / { ImapDelete : string }
+ / { ImapRename : (string, string) }
+ / { ImapExpunge }
+
+type Email.imap_status = {
+ flags : string
+ exists : int
+ recent : int
+ oks : string list
+ rwstatus : string
+}
type Email.imap_result =
{ Ok : string }
/ { No : string }
/ { Bad : string }
+ // { NoopResult : Email.imap_status }
+ / { NoopResult : (string,int,int,list(string),string) }
/ { SearchResult : list(int) }
/ { FetchResult : list((int, string)) }
+ / { StoreResult : list((int, string)) }
+ / { ListResult : list((string, string, string)) }
+ / { ExpungeResult : list(int) }
/ { Error of string }
type caml_tuple_2('a,'b) = external
@@ -364,7 +383,7 @@ Email = {{
Imap = {{
- command = %% BslMail.Imap.command %% : int , string, SSL.secure_type, string , string , string, Email.imap_command, (Email.imap_result -> void) -> void
+ command = %% BslMail.Imap.command %% : int , string, SSL.secure_type, string , bool, string , string, list(Email.imap_command), (list(Email.imap_result) -> void) -> void
}}
Please sign in to comment.
Something went wrong with that request. Please try again.