imapClientCore.proto

% -*-proto-*-

%
%   Copyright © 2011, 2012 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 "ocamllib/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 (StarCapability items)                         = "* CAPABILITY "~ items "\r\n"
-define (SearchOk (tag,str))                           = tag " OK SEARCH "~ str "\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
  | StarCapability _items ->
    debug {{ eprintf "login received * CAPABILITY: %s\n%!" _items }}
    login(mail, tools, tag)
  | 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)
  | JustOk (rtag, _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 str=%s\n%!" tag _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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "%s received mismatched OK: rtag=%s tag=%s str=%s\n%!" name rtag tag _str }}
      error({{ sprintf "Tag mismatch: %s vs. %s" rtag tag }}, tools)
    else
      debug {{ eprintf "%s received OK: %s\n%!" name _str }}
      %wait_for_ok(mail, tools, tag, name, _NAME, fn, result)
      bye(mail, tools, 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)
  | SearchOk (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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "search received mismatched 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 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)
  | JustOk (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)
  | JustOk (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)
  | JustOk (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)
  | 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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "list received mismatched 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 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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "status received mismatched 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 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)
  | JustOk (rtag,_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 "appended")::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
  | Exists num ->
    debug {{ eprintf "expunge received * EXISTS: %d\n" num }}
    let mail = [[ {mail with status={mail.status with exists=num}} ]]
    expunge(mail, tools, tag)
  | 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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "expunge received mismatched 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 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)
  | JustOk (rtag,_str) ->
    if {{ rtag <> tag }}
    then
      debug {{ eprintf "close received mismatched 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 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