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.11 2006/03/28 13:20:00 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 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             dbh hostid 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       dbh hostid q
  90       "Date or Message-ID header missing.  Cannot handle this message. ";
  91     return ()
  92   );
  93
  94   (* Can't handle funny characters in subject lines - remove them. *)
  95   let subject = String.map (fun c ->
  96                               if Char.code c < 32 then ' ' else c) subject in
  97
  98   (* Parse the date field. *)
  99   let message_date =
 100     try
 101       let date = Netdate.parse date in
 102       let cal = Calendar.make
 103         date.Netdate.year
 104         date.Netdate.month
 105         date.Netdate.day
 106         date.Netdate.hour
 107         date.Netdate.minute
 108         date.Netdate.second in
 109       let tz = Time_Zone.UTC_Plus (date.Netdate.zone / 60) in
 110       cal, tz
 111     with
 112       Invalid_argument _ ->
 113         failwith ("cannot parse date: " ^ date) in
 114
 115   (* Find the first thing in the In-Reply-To field which looks like a
 116    * message ID.
 117    *)
 118   let in_reply_to =
 119     try
 120       let subs = Pcre.exec ~rex:irt_re in_reply_to in
 121       Some (Pcre.get_substring subs 0)
 122     with
 123         Not_found -> None in
 124
 125   (* References is a space-separated list of message IDs.  Parse that up. *)
 126   let references = Pcre.split ~rex:ws_re references in
 127
 128   (* Reverse the references list, because we most often want to see the
 129    * head element (ie. the most immediate parent message).
 130    *)
 131   let references = List.rev references in
 132
 133   (* If the head element of references != the in-reply-to message ID, then
 134    * prepend it.
 135    *)
 136   let references =
 137     match in_reply_to with
 138       | None -> references
 139       | Some msgid ->
 140           match references with
 141             | [] -> [msgid]
 142             | m :: ms when m <> msgid -> msgid :: m :: ms
 143             | ms -> ms in
 144
 145   (* Does this message exist in the database already?  If so, and overwrite
 146    * is not specified, then silently skip this message.  'overwrite' becomes
 147    * 'Some id' if we need to overwrite an existing message id in the database,
 148    * else 'None' if this is a never-seen-before message.
 149    *)
 150   let overwrite =
 151     let rows = PGSQL(dbh)
 152       "select id from messages
 153         where hostid = $hostid and inet_message_id = $inet_message_id" in
 154     match rows with
 155     | [id] ->
 156         if not overwrite then (
 157           ok ~title:"Message exists"
 158             dbh hostid q "Message already imported";
 159           return ()
 160         );
 161         Some id
 162     | [] -> None
 163     | _ -> assert false in
 164
 165   (* Save all of this in the database. *)
 166   let msgid =
 167     match overwrite with
 168         None ->                         (* Never-seen-before message. *)
 169           PGSQL(dbh)
 170             "insert into messages (hostid, subject, inet_message_id,
 171                message_date)
 172              values ($hostid, $subject, $inet_message_id, $message_date)";
 173           let msgid = PGOCaml.serial4 dbh "messages_id_seq" in
 174
 175           let ordering = ref 0 in
 176           List.iter (fun inet_message_id ->
 177                        incr ordering; let ordering = Int32.of_int !ordering in
 178                        PGSQL(dbh)
 179                          "insert into msg_references (message_id,
 180                             inet_message_id, ordering)
 181                           values ($msgid, $inet_message_id, $ordering)"
 182                     ) references;
 183
 184           msgid
 185
 186       | Some msgid ->                   (* Overwrite an existing message. *)
 187           (* All the fields in the messages table should be identical to
 188            * last time we imported this message.  Just return the msgid.
 189            *)
 190           msgid in
 191
 192   (* The message is referred to by a unique title.
 193    * NB. Do not change this unique title - it is also used during thread
 194    * indexing.
 195    *)
 196   let title = sprintf "Mail/%s (%d)" subject msgid in
 197
 198   (* Choose a suitable URL. *)
 199   let url =
 200     match Wikilib.generate_url_of_title dbh hostid title with
 201         (* Duplicate URL is OK - eg. in the case where we are overwriting
 202          * an already imported message.
 203          *)
 204         Wikilib.GenURL_OK url | Wikilib.GenURL_Duplicate url -> url
 205       | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 206           failwith "generate_url_of_title returned 'TooShort' or 'BadURL'" in
 207
 208   (* To create the page, we need a few more headers ... *)
 209   let from = get_hdr "from" in
 210   let to_hdr = get_hdr "to" in
 211   let cc = get_hdr "cc" in
 212
 213   (* Create the page.  Or edit it (if we're overwriting ...). *)
 214   let model =
 215     match overwrite with
 216       | None -> new_page (Title title)
 217       | Some _ -> load_page dbh hostid ~url () in
 218   let model = { model with redirect = "" } in
 219
 220   (* Create the first section (mail header). *)
 221   let section0 =
 222     let content =
 223       (* XXX Escaping! *)
 224       hdr_template#set "subject" subject;
 225       hdr_template#set "from" from;
 226       hdr_template#set "inet_message_id" inet_message_id;
 227
 228       let yyyy, mm, dd = date.Dbi.year, date.Dbi.month, date.Dbi.day in
 229       hdr_template#set "yyyy" (sprintf "%04d" yyyy);
 230       hdr_template#set "mm" (sprintf "%02d" mm);
 231       hdr_template#set "dd" (sprintf "%02d" dd);
 232       hdr_template#set "short_month" (short_month mm);
 233
 234       let get_table hdr =
 235         List.map (fun addr -> [ "addr", Template.VarString addr ])
 236           (Pcre.split ~rex:comma_re hdr)
 237       in
 238       let table = get_table to_hdr in
 239       hdr_template#table "to" table;
 240       hdr_template#conditional "has_to" (table <> []);
 241       let table = get_table cc in
 242       hdr_template#table "cc" table;
 243       hdr_template#conditional "has_cc" (table <> []);
 244
 245       hdr_template#to_string
 246     in
 247     "", "mail_header", content in
 248
 249   (* Create the second section (mail body).
 250    * XXX Very simple.  Should be extended to understand attachments and
 251    * convert them into file or image uploads.
 252    *)
 253   let section1 =
 254     let is_text_plain hdr =
 255       try
 256         let ct = hdr#field "content-type" in
 257         String.starts_with ct "text/plain"
 258       with
 259           Not_found -> true in
 260
 261     (* Find the first text/plain body. *)
 262     let rec find_body = function
 263         (header, `Body mime_body) when is_text_plain header ->
 264           mime_body#value
 265       | (_, `Body _) -> raise Not_found
 266       | (_, `Parts []) -> raise Not_found (* should never happen *)
 267       | (_, `Parts (m :: _)) ->
 268           find_body m in
 269
 270     (* Markup a plain text body. *)
 271     let markup_body text =
 272       (* Get all the titles from the database! We're going to exclude
 273        * mail messages from this.
 274        *)
 275       let links =
 276         PGSQL(dbh)
 277           "select lower (title) from pages where hostid = $hostid
 278               and url is not null and title not like 'Mail/%'" in
 279       let links = List.map Option.get links in
 280
 281       (* This code cannot find titles which are split across multiple lines.
 282        * XXX
 283        *)
 284       let lines = Pcre.split ~rex:lines_re text in
 285
 286       (* We don't want to mark up the same link twice, so keep track of the
 287        * titles we've already used.
 288        *)
 289       let used = ref [] in
 290       let lines =
 291         List.map
 292           (fun line ->
 293              let find str sub_lc =
 294                try
 295                  String.find (String.lowercase str) sub_lc
 296                with
 297                    Invalid_string -> -1
 298              in
 299              let rec loop line = function
 300                  [] -> line
 301                | link :: links ->
 302                    let i = find line link in
 303                    if i >= 0 && not (List.mem link !used) then (
 304                      used := link :: !used;
 305                      let n = String.length link in
 306                      let n' = String.length line in
 307                      let line =
 308                        String.sub line 0 i ^
 309                        "[[" ^ String.sub line i n ^
 310                        "]]" ^ loop (String.sub line (i+n) (n' - (i+n))) links
 311                      in
 312                      line
 313                    ) else
 314                      loop line links
 315              in
 316              loop line links) lines in
 317
 318       let lines = List.map trim lines in
 319       let lines = List.map (fun line -> line ^ "<br>") lines in
 320
 321       String.concat "\n" lines
 322     in
 323
 324     let content =
 325       try
 326         let text = find_body msg in
 327         let content = markup_body text in
 328         content
 329       with
 330           Not_found ->
 331             "No plain text message body found" in
 332     "Message", "mail_body", content in
 333
 334   (* Overwrite the first two sections of the current page, regardless of
 335    * what they contain.
 336    * XXX We might consider more advanced strategies here: for example,
 337    * use the divname to identify the old mail_header and mail_body and
 338    * overwrite those, or insert them if they don't exist.
 339    *)
 340   let contents = model.contents in
 341   let contents =
 342     match contents with
 343         [] | [_] -> [ section0; section1 ]
 344       | _ :: _ :: xs -> section0 :: section1 :: xs in
 345   let model = { model with contents = contents } in
 346
 347   (* Write the page back.  This can throw several exceptions, but we ignore
 348    * them because we want to script to fail abruptly if any of these
 349    * unexpected conditions arises.
 350    *)
 351   save_page dbh hostid ~user ~r model;
 352
 353   (* Rebuild threads? *)
 354   if rebuild then
 355     thread_mail dbh hostid ~user ~r date.Dbi.year date.Dbi.month;
 356
 357   (* Commit to the database. *)
 358   PGOCaml.commit dbh;
 359
 360   (* Finish off. *)
 361   ok ~title:"Imported"
 362     dbh hostid q ("Message " ^ inet_message_id ^ " was imported.")
 363
 364 let () =
 365   register_script ~restrict:[CanImportMail] run