Skip to content

Commit

Permalink
[feature] imapClient: Added APPEND command. Fixed multiple items prob…
Browse files Browse the repository at this point in the history 
…lem for FETCH.
  • Loading branch information
@nrs135
nrs135 authored and Frederic Ye committed Apr 16, 2012
1 parent e7512eb commit 7ce964e
Show file tree
Hide file tree
Showing 3 changed files with 134 additions and 64 deletions.
192 changes: 128 additions & 64 deletions libnet/imapClientCore.proto
View file
Expand Up @@ -39,6 +39,7 @@
| ImapDelete of string
| ImapRename of (string * string)
| ImapStatus of (string * string)
| ImapAppend of (string * string * string * string)
| ImapExpunge

-type commands = command list
Expand Down Expand Up @@ -119,6 +120,7 @@ let string_of_command = function
| 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
Expand All @@ -129,58 +131,65 @@ 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 (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"
-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 (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\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 (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 (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
-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 (StarList (flags,rf,mailbox)) = "* LIST ("~ flags ") " rf " " mailbox "\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 RawInput str = str

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% L'automate %%
Expand Down Expand Up @@ -320,6 +329,22 @@ commands(mail, tools):
send (Status (tag, mailbox, items));
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"}},
Expand Down Expand Up @@ -428,7 +453,7 @@ fetch(mail, tools, tag):
| 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(mail, tools, tag, len)
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) } }}
Expand All @@ -442,6 +467,10 @@ fetch(mail, tools, tag):
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
Expand All @@ -453,24 +482,26 @@ fetch(mail, tools, tag):
| exn ->
check_exception(mail, tools, {{"fetch"}}, tag, exn)

fetch_data(mail, tools, tag, len):
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(mail, tools, tag)
end_fetched_data(num, mail, tools, tag)

end_fetched_data(mail, tools, tag):
fixed {{ 3 }}
| data ->
if {{ data = ")\r\n" }}
then
debug {{ eprintf "fetch_data: ok\n%!" }}
fetch(mail, tools, tag)
else
debug {{ eprintf "fetch_data: error\n%!" }}
error({{ sprintf "Bad end of fetch data: %s" (String.escaped data) }}, tools)
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
Expand Down Expand Up @@ -567,6 +598,39 @@ status(mail, tools, tag):
| exn ->
check_exception(mail, tools, {{"status"}}, tag, exn)

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 ->
Expand Down
5 changes: 5 additions & 0 deletions opabsl/mlbsl/bslMail.ml
View file
Expand Up @@ -240,6 +240,10 @@
let b, s1, s2 = BslNativeLib.ocaml_tuple_3 value in
ServerLib.unwrap_bool b, ServerLib.unwrap_string s1, ServerLib.unwrap_string s2
in
let unwrap_ssss value =
let s1, s2, s3, s4 = BslNativeLib.ocaml_tuple_4 value in
ServerLib.unwrap_string s1, ServerLib.unwrap_string s2, ServerLib.unwrap_string s3, ServerLib.unwrap_string s4
in
let unwrap_bsss value =
let b, s1, s2, s3 = BslNativeLib.ocaml_tuple_4 value in
ServerLib.unwrap_bool b, ServerLib.unwrap_string s1, ServerLib.unwrap_string s2, ServerLib.unwrap_string s3
Expand All @@ -264,6 +268,7 @@
| Some "ImapDelete" -> ImapClientCore.ImapDelete (ServerLib.unwrap_string value)
| Some "ImapRename" -> ImapClientCore.ImapRename (unwrap_ss value)
| Some "ImapStatus" -> ImapClientCore.ImapStatus (unwrap_ss value)
| Some "ImapAppend" -> ImapClientCore.ImapAppend (unwrap_ssss value)
| Some "ImapExpunge" -> ImapClientCore.ImapExpunge
| _ -> assert false)
(unwrap_opa_email_imap_command command) ImapClientCore.ImapNoop)
Expand Down
1 change: 1 addition & 0 deletions stdlib/web/mail/email.opa
View file
Expand Up @@ -120,6 +120,7 @@ type Email.imap_command =
/ { ImapDelete : string }
/ { ImapRename : (string, string) }
/ { ImapStatus : (string, string) }
/ { ImapAppend : (string, string, string, string) }
/ { ImapExpunge }

//type Email.imap_status = {
Expand Down

0 comments on commit 7ce964e

Please sign in to comment.