scripts/mail_import.ml

   1 (* COCANWIKI - a wiki written in Objective CAML.
   2  * Written by Richard W.M. Jones <rich@merjis.com>.
   3  * Copyright (C) 2004 Merjis Ltd.
   4  * $Id: mail_import.ml,v 1.5 2004/10/14 15:57:15 rich Exp $
   5  *
   6  * This program is free software; you can redistribute it and/or modify
   7  * it under the terms of the GNU General Public License as published by
   8  * the Free Software Foundation; either version 2 of the License, or
   9  * (at your option) any later version.
  10  *
  11  * This program is distributed in the hope that it will be useful,
  12  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  13  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14  * GNU General Public License for more details.
  15  *
  16  * You should have received a copy of the GNU General Public License
  17  * along with this program; see the file COPYING.  If not, write to
  18  * the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19  * Boston, MA 02111-1307, USA.
  20  *)
  21
  22 open Apache
  23 open Registry
  24 open Cgi
  25 open Printf
  26
  27 open Netmime
  28 open Netchannels
  29 open Netstream
  30
  31 open ExtString
  32
  33 open Cocanwiki
  34 open Cocanwiki_ok
  35 open Cocanwiki_template
  36 open Cocanwiki_date
  37 open Cocanwiki_strings
  38 open Cocanwiki_pages
  39 open Cocanwiki_mail
  40
  41 let irt_re = Pcre.regexp "<.*?>"
  42 let ws_re = Pcre.regexp "\\s+"
  43 let comma_re = Pcre.regexp "\\s*,\\s*"
  44 let lines_re = Pcre.regexp "\\r?\\n"
  45
  46 let run r (q : cgi) (dbh : Dbi.connection) hostid _ user =
  47   let hdr_template = get_template dbh hostid "mail_import_header.txt" in
  48
  49   (* Overwrite old messages? *)
  50   let overwrite = q#param_true "overwrite" in
  51   (* Rebuild index after importing this one message? *)
  52   let rebuild = q#param_true "rebuild" in
  53
  54   (* Get the uploaded file. *)
  55   let file =
  56     try
  57       let upload = q#upload "file" in
  58       upload.upload_value
  59     with
  60         Not_found ->
  61           error ~back_button:true ~title:"No message"
  62             q "No message was uploaded.";
  63           return () in
  64
  65   (* Parse the message. *)
  66   let msg =
  67     with_in_obj_channel
  68       (new input_string file)
  69       (fun ch ->
  70          let stm = new input_stream ch in
  71          read_mime_message stm) in
  72
  73   (* Get the mail header for easy access. *)
  74   let hdr = fst msg in
  75
  76   (* Get the interesting headers which will go into the database. *)
  77   let get_hdr name = try hdr#field name with Not_found -> "" in
  78   let subject = get_hdr "subject" in
  79   let inet_message_id = get_hdr "message-id" in
  80   let date = get_hdr "date" in
  81   let references = get_hdr "references" in
  82   let in_reply_to = get_hdr "in-reply-to" in
  83
  84   (* If the message doesn't have a Date or Message-ID header, then we
  85    * cannot thread it, so give up.
  86    *)
  87   if date = "" || inet_message_id = "" then (
  88     error ~back_button:true ~title:"Headers missing"
  89       q "Date or Message-ID header missing.  Cannot handle this message. ";
  90     return ()
  91   );
  92
  93   (* Parse the date field. *)
  94   let date, time =
  95     try
  96       let date = Netdate.parse date in
  97       let date, time =
  98         { Dbi.year = date.Netdate.year;
  99           Dbi.month = date.Netdate.month;
 100           Dbi.day = date.Netdate.day; },
 101         { Dbi.hour = date.Netdate.hour;
 102           Dbi.min = date.Netdate.minute;
 103           Dbi.sec = date.Netdate.second;
 104           Dbi.microsec = 0;
 105           Dbi.timezone = Some (date.Netdate.zone / 60); } in
 106       date, time
 107     with
 108         Invalid_argument _ ->
 109           failwith ("cannot parse date: " ^ date) in
 110
 111   (* Find the first thing in the In-Reply-To field which looks like a
 112    * message ID.
 113    *)
 114   let in_reply_to =
 115     try
 116       let subs = Pcre.exec ~rex:irt_re in_reply_to in
 117       Some (Pcre.get_substring subs 0)
 118     with
 119         Not_found -> None in
 120
 121   (* References is a space-separated list of message IDs.  Parse that up. *)
 122   let references = Pcre.split ~rex:ws_re references in
 123
 124   (* Reverse the references list, because we most often want to see the
 125    * head element (ie. the most immediate parent message).
 126    *)
 127   let references = List.rev references in
 128
 129   (* If the head element of references != the in-reply-to message ID, then
 130    * prepend it.
 131    *)
 132   let references =
 133     match in_reply_to with
 134       | None -> references
 135       | Some msgid ->
 136           match references with
 137             | [] -> [msgid]
 138             | m :: ms when m <> msgid -> msgid :: m :: ms
 139             | ms -> ms in
 140
 141   (* Does this message exist in the database already?  If so, and overwrite
 142    * is not specified, then silently skip this message.  'overwrite' becomes
 143    * 'Some id' if we need to overwrite an existing message id in the database,
 144    * else 'None' if this is a never-seen-before message.
 145    *)
 146   let overwrite =
 147     let sth = dbh#prepare_cached "select id from messages
 148                                    where hostid = ? and inet_message_id = ?" in
 149     sth#execute [`Int hostid; `String inet_message_id];
 150     try
 151       let id = sth#fetch1int () in
 152       if not overwrite then (
 153         ok ~title:"Message exists"
 154           q "Message already imported";
 155         return ()
 156       );
 157       Some id
 158     with
 159         Not_found -> None in
 160
 161   (* Save all of this in the database. *)
 162   let msgid =
 163     match overwrite with
 164         None ->                         (* Never-seen-before message. *)
 165           let sth =
 166             dbh#prepare_cached
 167               "insert into messages (hostid, subject, inet_message_id,
 168                  message_date) values (?, ?, ?, ?)" in
 169           sth#execute [`Int hostid; `String subject; `String inet_message_id;
 170                        `Timestamp (date, time)];
 171           let msgid = sth#serial "messages_id_seq" in
 172
 173           let sth =
 174             dbh#prepare_cached
 175               "insert into msg_references (message_id, inet_message_id,
 176                  ordering) values (?, ?, ?)" in
 177           let ordering = ref 0 in
 178           List.iter (fun inet_message_id ->
 179                        incr ordering; let ordering = !ordering in
 180                        sth#execute [`Int msgid; `String inet_message_id;
 181                                     `Int ordering]) references;
 182
 183           msgid
 184
 185       | Some msgid ->                   (* Overwrite an existing message. *)
 186           (* All the fields in the messages table should be identical to
 187            * last time we imported this message.  Just return the msgid.
 188            *)
 189           msgid in
 190
 191   (* The message is referred to by a unique title: *)
 192   let title = sprintf "Mail/%s (%d)" subject msgid in
 193
 194   (* Choose a suitable URL. *)
 195   let url =
 196     match Wikilib.generate_url_of_title dbh hostid title with
 197         (* Duplicate URL is OK - eg. in the case where we are overwriting
 198          * an already imported message.
 199          *)
 200         Wikilib.GenURL_OK url | Wikilib.GenURL_Duplicate url -> url
 201       | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 202           failwith "generate_url_of_title returned 'TooShort' or 'BadURL'" in
 203
 204   (* To create the page, we need a few more headers ... *)
 205   let from = get_hdr "from" in
 206   let to_hdr = get_hdr "to" in
 207   let cc = get_hdr "cc" in
 208
 209   (* Create the page.  Or edit it (if we're overwriting ...). *)
 210   let model =
 211     match overwrite with
 212       | None -> new_page (Title title)
 213       | Some _ -> load_page dbh hostid ~url () in
 214   let model = { model with redirect = "" } in
 215
 216   (* Create the first section (mail header). *)
 217   let section0 =
 218     let content =
 219       (* XXX Escaping! *)
 220       hdr_template#set "subject" subject;
 221       hdr_template#set "from" from;
 222       hdr_template#set "inet_message_id" inet_message_id;
 223
 224       let yyyy, mm, dd = date.Dbi.year, date.Dbi.month, date.Dbi.day in
 225       hdr_template#set "yyyy" (sprintf "%04d" yyyy);
 226       hdr_template#set "mm" (sprintf "%02d" mm);
 227       hdr_template#set "dd" (sprintf "%02d" dd);
 228       hdr_template#set "short_month" (short_month mm);
 229
 230       let get_table hdr =
 231         List.map (fun addr -> [ "addr", Template.VarString addr ])
 232           (Pcre.split ~rex:comma_re hdr)
 233       in
 234       let table = get_table to_hdr in
 235       hdr_template#table "to" table;
 236       hdr_template#conditional "has_to" (table <> []);
 237       let table = get_table cc in
 238       hdr_template#table "cc" table;
 239       hdr_template#conditional "has_cc" (table <> []);
 240
 241       hdr_template#to_string
 242     in
 243     "", "mail_header", content in
 244
 245   (* Create the second section (mail body).
 246    * XXX Very simple.  Should be extended to understand attachments and
 247    * convert them into file or image uploads.
 248    *)
 249   let section1 =
 250     let is_text_plain hdr =
 251       try
 252         let ct = hdr#field "content-type" in
 253         String.starts_with ct "text/plain"
 254       with
 255           Not_found -> true in
 256
 257     (* Find the first text/plain body. *)
 258     let rec find_body = function
 259         (header, `Body mime_body) when is_text_plain header ->
 260           mime_body#value
 261       | (_, `Body _) -> raise Not_found
 262       | (_, `Parts []) -> raise Not_found (* should never happen *)
 263       | (_, `Parts (m :: _)) ->
 264           find_body m in
 265
 266     (* Markup a plain text body. *)
 267     let markup_body text =
 268       (* Get all the titles from the database! We're going to exclude
 269        * mail messages from this.
 270        *)
 271       let sth =
 272         dbh#prepare_cached
 273           "select lower (title) from pages where hostid = ?
 274               and url is not null and title not like 'Mail/%'" in
 275       sth#execute [`Int hostid];
 276       let links = sth#map (function [`String s] -> s | _ -> assert false) in
 277
 278       (* This code cannot find titles which are split across multiple lines.
 279        * XXX
 280        *)
 281       let lines = Pcre.split ~rex:lines_re text in
 282
 283       (* We don't want to mark up the same link twice, so keep track of the
 284        * titles we've already used.
 285        *)
 286       let used = ref [] in
 287       let lines =
 288         List.map
 289           (fun line ->
 290              let find str sub_lc =
 291                try
 292                  String.find (String.lowercase str) sub_lc
 293                with
 294                    String.Invalid_string -> -1
 295              in
 296              let rec loop line = function
 297                  [] -> line
 298                | link :: links ->
 299                    let i = find line link in
 300                    if i >= 0 && not (List.mem link !used) then (
 301                      used := link :: !used;
 302                      let n = String.length link in
 303                      let n' = String.length line in
 304                      let line =
 305                        String.sub line 0 i ^
 306                        "[[" ^ String.sub line i n ^
 307                        "]]" ^ loop (String.sub line (i+n) (n' - (i+n))) links
 308                      in
 309                      line
 310                    ) else
 311                      loop line links
 312              in
 313              loop line links) lines in
 314
 315       let lines = List.map trim lines in
 316       let lines =
 317         List.map (fun line -> if line <> "" then line ^ " <br>" else "")
 318           lines in
 319
 320       String.concat "\n" lines
 321     in
 322
 323     let content =
 324       try
 325         let text = find_body msg in
 326         let content = markup_body text in
 327         content
 328       with
 329           Not_found ->
 330             "No plain text message body found" in
 331     "Message", "mail_body", content in
 332
 333   (* Overwrite the first two sections of the current page, regardless of
 334    * what they contain.
 335    * XXX We might consider more advanced strategies here: for example,
 336    * use the divname to identify the old mail_header and mail_body and
 337    * overwrite those, or insert them if they don't exist.
 338    *)
 339   let contents = model.contents in
 340   let contents =
 341     match contents with
 342         [] | [_] -> [ section0; section1 ]
 343       | _ :: _ :: xs -> section0 :: section1 :: xs in
 344   let model = { model with contents = contents } in
 345
 346   (* Write the page back.  This can throw several exceptions, but we ignore
 347    * them because we want to script to fail abruptly if any of these
 348    * unexpected conditions arises.
 349    *)
 350   save_page dbh hostid ~user ~r model;
 351
 352   (* Rebuild threads? *)
 353   if rebuild then
 354     thread_mail dbh hostid date.Dbi.year date.Dbi.month;
 355
 356   (* Commit to the database. *)
 357   dbh#commit ();
 358
 359   (* Finish off. *)
 360   ok ~title:"Imported"
 361     q ("Message " ^ inet_message_id ^ " was imported.")
 362
 363 let () =
 364   register_script ~restrict:[CanImportMail] run