imapClientCore.proto

% -*-erlang-*-

%
%   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 =
  | ImapNoop
  | ImapFetch of (bool * string * string)
  | ImapStore of (bool * string * string * string)
  | ImapSearch of (bool * string)
  | ImapSearchCs of (bool * 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;
  commands : commands;
  status : status;
  fetched : (int * string) list;
  list : (string * 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_proto = {
%  rt_block_size : int;
%  rt_backtrace : bool;
%  rt_server_write_timeout : Time.t;
%}

-type runtime = {
  rt_plim : int;
  rt_proto : rt_proto;
}

{{
let get_tag() = Printf.sprintf "A%05d" (Random.int(65535-4096)+4096)
let string_of_command = function
  | ImapNoop -> "NOOP"
  | ImapFetch (uid,seq,items) -> sprintf "%sFETCH %s %s" (if uid then "UID " else "") seq items
  | 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
  | ImapExpunge -> "EXPUNGE"
let add_fetched str fetched =
  match fetched with
  | [] -> [(0,str)]
  | ((i,ss)::t) -> ((i,ss^str)::t) (* todo: bufferise this *)
}}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%      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 (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 (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 (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 " "UID "? "FETCH "~ str "\r\n"
-define (StoreOk (tag,str))                  = tag " OK " "UID "? "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: Started connection with mailbox=%s\n%!" mail.mailbox }}
  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 }}
      let tag = {{ get_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)
  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)] }}

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}} ]]
      commands(mail, tools)
  | err ->
    check_error(mail, tools, selex, tag, err)
  catch
  | 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 (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));
        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)

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)
  | 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
  | StarOk str ->
    debug {{ eprintf "fetch received * OK: %s\n" str }}
    fetch(mail, tools, tag)
  | 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)
  | msg ->
    % This is ridiculous and dangerous, we should parse the initial header and use fixed to read in the data.
    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)

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() }}
  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