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