email parsing and archive import fixes

email_parse.ml

@@ -102,7 +102,7 @@ let email_content attachment base64 email =
  * headers or the message and not both
  * should add encrypt and compress to the message metadata TBD
  *)
-let parse message ~save_message ~save_attachment =
+let parse (message:Mailbox.Message.t) ~save_message ~save_attachment =
   let do_encrypt data =
     if srv_config.encrypt then
       pub_key () >>= fun pub ->
@@ -122,7 +122,7 @@ let parse message ~save_message ~save_attachment =
       email_content attach base64 email >>= fun (contid,content) -> 
       if attach then ( (* consider adding Content-type: message/external-body...  *)
         let ext = "X-Imaplet-External-Content: " ^ contid ^ "\n\n" in
-        (Buffer.length buffer,Bytes.length ext,base64) :: map;
+        let map = (Buffer.length buffer,Bytes.length ext,base64) :: map in
         Buffer.add_string buffer ext;
         save_attachment contid content >>
         return map
@@ -140,9 +140,11 @@ let parse message ~save_message ~save_attachment =
       add_boundary buffer ~boundary ~suffix:"--\n" ;
       return map
   in
-  walk message.Mailbox.Message.email None true [] >>= fun map ->
-  let map_sexp_str = Sexp.to_string (sexp_of_list (fun (a,b,c) -> sexp_of_string ((string_of_int a) ^
-      " " ^ (string_of_int b) ^ " " ^ (string_of_bool c)))  (List.rev map)) in
+  walk message.email None true [] >>= fun map ->
+  let map_sexp_str = Sexp.to_string (sexp_of_list (fun (a,b,c) -> 
+      sexp_of_string 
+      (String.concat " " [string_of_int a;string_of_int b; string_of_bool c])
+    )  (List.rev map)) in
   let content = Printf.sprintf "%04d%s%s" (Bytes.length map_sexp_str) map_sexp_str (Buffer.contents buffer) in
   do_encrypt (Mailbox.Postmark.to_string message.postmark) >>= fun postmark ->
   do_encrypt (headers_str message.email) >>= fun headers ->
@@ -174,6 +176,7 @@ let get_hdr_attrs buffer headers boundary =
   ) (boundary,None,false) headers
 
 let restore ~get_message ~get_attachment  =
+  catch (fun () ->
   let do_decrypt data =
     if srv_config.encrypt then (
       priv_key() >>= fun priv ->
@@ -188,9 +191,11 @@ let restore ~get_message ~get_attachment  =
   let len = int_of_string (Bytes.sub content 0 4) in
   let map_sexp_str = Bytes.sub content 4 len in
   let map = list_of_sexp (fun sexp -> 
-    let str = Sexp.to_string sexp in
+    let str = replace ~regx:"\"" ~tmpl:"" (Sexp.to_string sexp) in
     let parts = Str.split (Str.regexp " ") str in
-    (int_of_string (List.nth parts 0),int_of_string (List.nth parts 1),bool_of_string (List.nth parts 2))
+      (int_of_string (List.nth parts 0),
+       int_of_string (List.nth parts 1),
+       bool_of_string (List.nth parts 2))
   ) (Sexp.of_string map_sexp_str) in
   let content = Bytes.sub content (4 + len) (Bytes.length content - 4 - len) in
   begin
@@ -223,3 +228,5 @@ let restore ~get_message ~get_attachment  =
   let postmark = Mailbox.Postmark.of_string postmark in
   let email = Email.of_string (headers ^ "\n" ^ content ^ "\n") in
   return {Mailbox.Message.postmark=postmark;Mailbox.Message.email=email}
+  ) (fun ex -> Printf.printf "restore exception %s\n%!" (Printexc.to_string ex);
+  raise ex)

imaplet_irmin_build.ml

@@ -102,7 +102,6 @@ let append ist ?uid message size flags mailbox =
   IrminStorage.status ist >>= fun mailbox_metadata ->
   let modseq = Int64.add mailbox_metadata.modseq Int64.one in
   let uid = match uid with None -> mailbox_metadata.uidnext|Some uid -> uid in
-  Printf.printf "#### appending %s with UID %d\n%!" mailbox uid;
   let message_metadata = {
     uid;
     modseq;
@@ -126,60 +125,44 @@ let append ist ?uid message size flags mailbox =
   IrminStorage.store_mailbox_metadata ist mailbox_metadata >>
   IrminStorage.append ist message message_metadata 
   )
-  (fun ex -> Printf.printf "exception: %s %s\n%!" (Printexc.to_string ex) (Printexc.get_backtrace()); return ())
+  (fun ex -> Printf.fprintf stderr "append exception: %s %s\n%!" (Printexc.to_string ex) (Printexc.get_backtrace()); return ())
 
 let mailbox_of_gmail_label message = 
   if Regex.match_regex message ~regx:"^X-Gmail-Labels: \\(.+\\)$" = false then 
-    "INBOX"
+    ("INBOX",[])
   else (
     let labels = Str.split (Str.regexp ",") (Str.matched_group 1 message) in
-    let mailbox =
-    if List.length labels = 0 then
-      "INBOX"
-    else if List.length labels = 1 then (
-      match (List.hd labels) with
-      | "Sent" -> "Sent Messages"
-      | "Important" | "Starred" -> "INBOX"
-      | "Trash" -> "Deleted Messages"
-      | label -> label
-    ) else (
-      let (sent,trash,draft,label) =
-      List.fold_left (fun (sent,trash,draft,label) i -> 
-        match i with 
-        | "Important" | "Starred" -> (sent,trash,draft,label)
-        | "Sent" -> (true,trash,draft,label)
-        | "Draft" -> (sent,trash,true,label)
-        | "Trash" -> (sent,true,draft,label)
-        | label -> (sent,trash,draft,label)
-      ) (false,false,false,"") labels
-      in
-      if label = "" then (
-        if sent = false && trash = false && draft = false then
-          "INBOX"
-        else if trash = true then
-          "Deleted Messages"
-        else if sent = true then
-          "Sent Messages"
-        else
-          "Drafts"
-      ) else if label = "Inbox" then
-        "INBOX"
-      else
-        label
-    )
+    let (label,inferred,flags) =
+    List.fold_left (fun (label,inferred,flags) l ->
+      match l with 
+      | "Important" -> (label,inferred,(Flags_Keyword "Important") :: flags)
+      | "Starred" -> (label,inferred,(Flags_Keyword "Starred") :: flags)
+      | "Sent" -> (label,(Some "Sent Messages"),Flags_Answered :: flags)
+      | "Trash" -> (label,(Some "Deleted Messages"),Flags_Deleted :: flags)
+      | "Unread" -> (label,inferred,Flags_Recent :: flags)
+      | "Draft" -> (label,(Some "Drafts"),Flags_Draft :: flags)
+      | label -> ((Some label),inferred, flags)
+    ) (None,None,[]) labels
     in
-    if mailbox = "Inbox" then
-      "INBOX"
-    else
-      Regex.replace ~regx:"[Imap]/" ~tmpl:"" mailbox 
+    match label with
+    | None ->
+      begin
+      match inferred with
+      | None -> ("INBOX",flags)
+      | Some label -> (label,flags)
+      end
+    | Some label ->
+      let label = Regex.replace ~regx:"[Imap]/" ~tmpl:"" label in
+      let label = Regex.replace ~case:false ~regx:"inbox" ~tmpl:"INBOX" label in
+      (label,flags)
   )
 
 let append_messages ist path flags =
   Printf.printf "#### appending messages %s\n%!" path;
   let open Email_message in
   let open Email_message.Mailbox in
   let wseq = With_seq.t_of_file path in
-  With_seq.fold_message wseq ~f:(fun _ message ->
+  With_seq.fold_message wseq ~f:(fun _ (message:Mailbox.Message.t) ->
     if Regex.match_regex (Postmark.to_string message.postmark) ~regx:"^From[ ]+MAILER_DAEMON" then 
       return ()
     else (
@@ -195,29 +178,34 @@ let append_archive_messages user path flags =
   let open Email_message in
   let open Email_message.Mailbox in
   let wseq = With_seq.t_of_file path in
-  With_seq.fold_message wseq ~f:(fun (a:int Lwt.t) message ->
-    a >>= fun cnt ->
-    Printf.printf "-- message %d %!" cnt;
+  With_seq.fold_message wseq ~f:(fun acc message ->
+    acc >>= fun (cnt, prev_mailbox, prev_ist) ->
     let size = String.length (Email.to_string message.email) in
-    let headers = String_monoid.to_string (Header.to_string_monoid
-        (Email.header message.email)) in
-    let mailbox = mailbox_of_gmail_label headers in
+    let headers = String_monoid.to_string (Header.to_string_monoid (Email.header message.email)) in
+    let (mailbox,fl) = mailbox_of_gmail_label headers in
+    Printf.printf "-- processing message %d, mailbox %s\n%!" cnt mailbox;
     begin
-    try 
-      let _ = MapStr.find mailbox !gmail_mailboxes in
-      IrminStorage.create user mailbox 
-    with Not_found ->
+    if prev_ist = None then (
       gmail_mailboxes := MapStr.add mailbox "" !gmail_mailboxes;
       create_mailbox user mailbox 
+    ) else if prev_mailbox <> mailbox then (
+      IrminStorage.commit (Utils.option_value_exn prev_ist) >>
+      if MapStr.exists (fun mb _ -> mailbox = mb) !gmail_mailboxes then
+        IrminStorage.create user mailbox
+      else (
+        gmail_mailboxes := MapStr.add mailbox "" !gmail_mailboxes;
+        create_mailbox user mailbox
+      )
+    ) else (
+      return (Utils.option_value_exn prev_ist)
+    ) 
     end >>= fun ist ->
-    append ist message size flags mailbox >>
-    IrminStorage.commit ist >>
-    if cnt = 150 then
-      exit 1
-    else
-      return (cnt + 1)
-  ) ~init:(return 1) >>= fun _ ->
-  return ()
+    append ist message size (List.concat [flags;fl]) mailbox >>
+    return (cnt + 1,mailbox,Some ist)
+  ) ~init:(return(1,"",None)) >>= fun (_,_,ist) ->
+  match ist with
+  | None -> return ()
+  | Some ist -> IrminStorage.commit ist
 
 let append_maildir_message ist ?uid path flags =
   Printf.printf "#### appending maildir message %s\n%!" path;
@@ -305,7 +293,6 @@ let populate_maildir_msgs ist path flagsmap uidmap =
           else
             None
         in
-        Printf.printf "#### found UID %d\n%!" (Utils.option_value uid ~default:0);
         append_maildir_message ist ?uid (Filename.concat path name) flags
       )
     ) acc
@@ -407,7 +394,7 @@ let create_maildir user mailboxes fs =
       populate_maildir_msgs ist path flagsmap uidmap >>= fun () ->
       IrminStorage.commit ist
     )
-    ( fun ex -> Printf.printf "exception1: %s %s\n%!" (Printexc.to_string ex)
+    ( fun ex -> Printf.fprintf stderr "create_maildir exception: %s %s\n%!" (Printexc.to_string ex)
     (Printexc.get_backtrace());return())
   )
 
@@ -432,7 +419,7 @@ let () =
           create_account user (Filename.concat mailbox "subscriptions") >>
           create_archive_maildir user mailbox 
       )
-      (fun ex -> Printf.printf "exception: %s %s\n%!" (Printexc.to_string ex)
+      (fun ex -> Printf.fprintf stderr "exception: %s %s\n%!" (Printexc.to_string ex)
       (Printexc.get_backtrace());return())
     )
   )

regex.ml

@@ -13,25 +13,25 @@
  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
+
+let prep_regex ?(case=true) regx =
+  if case = false then
+    Str.regexp_case_fold regx
+  else
+    Str.regexp regx
+
 let match_regex_i ?(case=true) str ~regx = 
   try
-    let regexp =
-    (
-      if case = false then
-        Str.regexp_case_fold regx
-      else
-        Str.regexp regx
-    ) in
-    (Str.search_forward regexp str 0)
+    Str.search_forward (prep_regex ~case regx) str 0
   with _ ->
     (-1)
 
 let match_regex ?(case=true) str ~regx = 
   let i = match_regex_i ~case str ~regx in
   (i >= 0)
 
-let replace ~regx ~tmpl str =
-  Str.global_replace (Str.regexp regx) tmpl str
+let replace ?(case=true) ~regx ~tmpl str =
+  Str.global_replace (prep_regex ~case regx) tmpl str
 
 let dq = "\""
 

regex.mli

@@ -17,7 +17,7 @@ val match_regex_i: ?case:bool -> string -> regx:string -> int
 
 val match_regex: ?case:bool -> string -> regx:string ->  bool
 
-val replace: regx:string -> tmpl:string -> string -> string
+val replace: ?case:bool -> regx:string -> tmpl:string -> string -> string
 
 val date_regex : string
 

storage/irmin_core.ml

@@ -31,8 +31,6 @@ exception InvalidKey of string
 module Store = Irmin.Basic (Irmin_git.FS) (Irmin.Contents.String)
 module View = Irmin.View(Store)
 
-module MapStr = Map.Make(String)
-
 module Key_ :
   sig
     type t
@@ -593,7 +591,6 @@ module IrminMailbox :
       Lwt_list.iter_s (fun key ->
         let contid = (List.nth key (List.length key - 1)) in
         IrminIntf_tr.read_exn mbox.trans key >>= fun attachment ->
-        (* return (MapStr.add contid attachment attachments) *)
         f contid attachment
       ) l
 

utils.ml

@@ -131,9 +131,7 @@ let option_value_exn = function
   | None -> raise Not_found
 
 let list_find l f =
-  try
-    let _ = List.find f l in true
-  with Not_found -> false
+  List.exists f l
 
 let list_findi l f =
   let rec findi l i f =