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.12 2006/03/28 16:24:07 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 (%ld)" 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 = None } 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 date = fst message_date in
 229       hdr_template#set "yyyy" (Printer.CalendarPrinter.sprint "%Y" date);
 230       hdr_template#set "mm" (Printer.CalendarPrinter.sprint "%m" date);
 231       hdr_template#set "dd" (Printer.CalendarPrinter.sprint "%d" date);
 232       hdr_template#set "short_month"
 233         (Printer.short_name_of_month (Calendar.month date));
 234
 235       let get_table hdr =
 236         List.map (fun addr -> [ "addr", Template.VarString addr ])
 237           (Pcre.split ~rex:comma_re hdr)
 238       in
 239       let table = get_table to_hdr in
 240       hdr_template#table "to" table;
 241       hdr_template#conditional "has_to" (table <> []);
 242       let table = get_table cc in
 243       hdr_template#table "cc" table;
 244       hdr_template#conditional "has_cc" (table <> []);
 245
 246       hdr_template#to_string
 247     in
 248     None, Some "mail_header", content in
 249
 250   (* Create the second section (mail body).
 251    * XXX Very simple.  Should be extended to understand attachments and
 252    * convert them into file or image uploads.
 253    *)
 254   let section1 =
 255     let is_text_plain hdr =
 256       try
 257         let ct = hdr#field "content-type" in
 258         String.starts_with ct "text/plain"
 259       with
 260           Not_found -> true in
 261
 262     (* Find the first text/plain body. *)
 263     let rec find_body = function
 264         (header, `Body mime_body) when is_text_plain header ->
 265           mime_body#value
 266       | (_, `Body _) -> raise Not_found
 267       | (_, `Parts []) -> raise Not_found (* should never happen *)
 268       | (_, `Parts (m :: _)) ->
 269           find_body m in
 270
 271     (* Markup a plain text body. *)
 272     let markup_body text =
 273       (* Get all the titles from the database! We're going to exclude
 274        * mail messages from this.
 275        *)
 276       let links =
 277         PGSQL(dbh)
 278           "select lower (title) from pages where hostid = $hostid
 279               and url is not null and title not like 'Mail/%'" in
 280       let links = List.map Option.get links in
 281
 282       (* This code cannot find titles which are split across multiple lines.
 283        * XXX
 284        *)
 285       let lines = Pcre.split ~rex:lines_re text in
 286
 287       (* We don't want to mark up the same link twice, so keep track of the
 288        * titles we've already used.
 289        *)
 290       let used = ref [] in
 291       let lines =
 292         List.map
 293           (fun line ->
 294              let find str sub_lc =
 295                try
 296                  String.find (String.lowercase str) sub_lc
 297                with
 298                    Invalid_string -> -1
 299              in
 300              let rec loop line = function
 301                  [] -> line
 302                | link :: links ->
 303                    let i = find line link in
 304                    if i >= 0 && not (List.mem link !used) then (
 305                      used := link :: !used;
 306                      let n = String.length link in
 307                      let n' = String.length line in
 308                      let line =
 309                        String.sub line 0 i ^
 310                        "[[" ^ String.sub line i n ^
 311                        "]]" ^ loop (String.sub line (i+n) (n' - (i+n))) links
 312                      in
 313                      line
 314                    ) else
 315                      loop line links
 316              in
 317              loop line links) lines in
 318
 319       let lines = List.map trim lines in
 320       let lines = List.map (fun line -> line ^ "<br>") lines in
 321
 322       String.concat "\n" lines
 323     in
 324
 325     let content =
 326       try
 327         let text = find_body msg in
 328         let content = markup_body text in
 329         content
 330       with
 331           Not_found ->
 332             "No plain text message body found" in
 333     Some "Message", Some "mail_body", content in
 334
 335   (* Overwrite the first two sections of the current page, regardless of
 336    * what they contain.
 337    * XXX We might consider more advanced strategies here: for example,
 338    * use the divname to identify the old mail_header and mail_body and
 339    * overwrite those, or insert them if they don't exist.
 340    *)
 341   let contents = model.contents_ in
 342   let contents =
 343     match contents with
 344     | [] | [_] -> [ section0; section1 ]
 345     | _ :: _ :: xs -> section0 :: section1 :: xs in
 346   let model = { model with contents_ = contents } in
 347
 348   (* Write the page back.  This can throw several exceptions, but we ignore
 349    * them because we want to script to fail abruptly if any of these
 350    * unexpected conditions arises.
 351    *)
 352   ignore (save_page dbh hostid ~user ~r model);
 353
 354   (* Rebuild threads? *)
 355   if rebuild then
 356     thread_mail dbh hostid ~user ~r
 357       (Calendar.year (fst message_date))
 358       (Date.int_of_month (Calendar.month (fst message_date)));
 359
 360   (* Commit to the database. *)
 361   PGOCaml.commit dbh;
 362
 363   (* Finish off. *)
 364   ok ~title:"Imported"
 365     dbh hostid q ("Message " ^ inet_message_id ^ " was imported.")
 366
 367 let () =
 368   register_script ~restrict:[CanImportMail] run