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.3 2004/10/11 16:07:25 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
  40 let irt_re = Pcre.regexp "<.*?>"
  41 let ws_re = Pcre.regexp "\\s+"
  42 let comma_re = Pcre.regexp "\\s*,\\s*"
  43 let lines_re = Pcre.regexp "\\r?\\n"
  44
  45 let run r (q : cgi) (dbh : Dbi.connection) hostid _ user =
  46   let hdr_template = get_template dbh hostid "mail_import_header.txt" in
  47
  48   (* Overwrite old messages? *)
  49   let overwrite = q#param_true "overwrite" in
  50   (* Rebuild index after importing this one message? *)
  51   let rebuild = q#param_true "rebuild" in
  52
  53   (* Get the uploaded file. *)
  54   let file =
  55     try
  56       let upload = q#upload "file" in
  57       upload.upload_value
  58     with
  59         Not_found ->
  60           (* Force an error status which a script can detect. *)
  61           Request.set_status r cHTTP_BAD_REQUEST;
  62           error ~back_button:true ~title:"No message"
  63             q "No message was uploaded.";
  64           return () in
  65
  66   (* Parse the message. *)
  67   let msg =
  68     with_in_obj_channel
  69       (new input_string file)
  70       (fun ch ->
  71          let stm = new input_stream ch in
  72          read_mime_message stm) in
  73
  74   (* Get the mail header for easy access. *)
  75   let hdr = fst msg in
  76
  77   (* Get the interesting headers which will go into the database. *)
  78   let get_hdr name = try hdr#field name with Not_found -> "" in
  79   let subject = get_hdr "subject" in
  80   let inet_message_id = get_hdr "message-id" in
  81   let date = get_hdr "date" in
  82   let references = get_hdr "references" in
  83   let in_reply_to = get_hdr "in-reply-to" in
  84
  85   (* If the message doesn't have a Date or Message-ID header, then we
  86    * cannot thread it, so give up.
  87    *)
  88   if date = "" || inet_message_id = "" then (
  89     Request.set_status r cHTTP_BAD_REQUEST;
  90     error ~back_button:true ~title:"Headers missing"
  91       q "Date or Message-ID header missing.  Cannot handle this message. ";
  92     return ()
  93   );
  94
  95   (* Parse the date field. *)
  96   let date, time =
  97     try
  98       let date = Netdate.parse date in
  99       let date, time =
 100         { Dbi.year = date.Netdate.year;
 101           Dbi.month = date.Netdate.month;
 102           Dbi.day = date.Netdate.day; },
 103         { Dbi.hour = date.Netdate.hour;
 104           Dbi.min = date.Netdate.minute;
 105           Dbi.sec = date.Netdate.second;
 106           Dbi.microsec = 0;
 107           Dbi.timezone = Some (date.Netdate.zone / 60); } in
 108       date, time
 109     with
 110         Invalid_argument _ ->
 111           failwith ("cannot parse date: " ^ date) in
 112
 113   (* Find the first thing in the In-Reply-To field which looks like a
 114    * message ID.
 115    *)
 116   let in_reply_to =
 117     try
 118       let subs = Pcre.exec ~rex:irt_re in_reply_to in
 119       Some (Pcre.get_substring subs 0)
 120     with
 121         Not_found -> None in
 122
 123   (* References is a space-separated list of message IDs.  Parse that up. *)
 124   let references = Pcre.split ~rex:ws_re references in
 125
 126   (* Reverse the references list, because we most often want to see the
 127    * head element (ie. the most immediate parent message).
 128    *)
 129   let references = List.rev references in
 130
 131   (* If the head element of references != the in-reply-to message ID, then
 132    * prepend it.
 133    *)
 134   let references =
 135     match in_reply_to with
 136       | None -> references
 137       | Some msgid ->
 138           match references with
 139             | [] -> [msgid]
 140             | m :: ms when m <> msgid -> msgid :: m :: ms
 141             | ms -> ms in
 142
 143   (* Does this message exist in the database already?  If so, and overwrite
 144    * is not specified, then silently skip this message.  'overwrite' becomes
 145    * 'Some id' if we need to overwrite an existing message id in the database,
 146    * else 'None' if this is a never-seen-before message.
 147    *)
 148   let overwrite =
 149     let sth = dbh#prepare_cached "select id from messages
 150                                    where hostid = ? and inet_message_id = ?" in
 151     sth#execute [`Int hostid; `String inet_message_id];
 152     try
 153       let id = sth#fetch1int () in
 154       if not overwrite then (
 155         ok ~title:"Message exists"
 156           q "Message already imported";
 157         return ()
 158       );
 159       Some id
 160     with
 161         Not_found -> None in
 162
 163   (* Save all of this in the database. *)
 164   let msgid =
 165     match overwrite with
 166         None ->                         (* Never-seen-before message. *)
 167           let sth =
 168             dbh#prepare_cached
 169               "insert into messages (hostid, subject, inet_message_id,
 170                  message_date) values (?, ?, ?, ?)" in
 171           sth#execute [`Int hostid; `String subject; `String inet_message_id;
 172                        `Timestamp (date, time)];
 173           let msgid = sth#serial "messages_id_seq" in
 174
 175           let sth =
 176             dbh#prepare_cached
 177               "insert into msg_references (message_id, inet_message_id,
 178                  ordering) values (?, ?, ?)" in
 179           let ordering = ref 0 in
 180           List.iter (fun inet_message_id ->
 181                        incr ordering; let ordering = !ordering in
 182                        sth#execute [`Int msgid; `String inet_message_id;
 183                                     `Int ordering]) references;
 184
 185           msgid
 186
 187       | Some msgid ->                   (* Overwrite an existing message. *)
 188           (* All the fields in the messages table should be identical to
 189            * last time we imported this message.  Just return the msgid.
 190            *)
 191           msgid in
 192
 193   (* The message is referred to by a unique title: *)
 194   let title = sprintf "Mail/%s (%d)" subject msgid in
 195
 196   (* Choose a suitable URL. *)
 197   let url =
 198     match Wikilib.generate_url_of_title dbh hostid title with
 199         (* Duplicate URL is OK - eg. in the case where we are overwriting
 200          * an already imported message.
 201          *)
 202         Wikilib.GenURL_OK url | Wikilib.GenURL_Duplicate url -> url
 203       | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 204           failwith "generate_url_of_title returned 'TooShort' or 'BadURL'" in
 205
 206   (* To create the page, we need a few more headers ... *)
 207   let from = get_hdr "from" in
 208   let to_hdr = get_hdr "to" in
 209   let cc = get_hdr "cc" in
 210
 211   (* Create the page.  Or edit it (if we're overwriting ...). *)
 212   let model =
 213     match overwrite with
 214       | None -> new_page (Title title)
 215       | Some _ -> load_page dbh hostid ~url () in
 216   let model = { model with redirect = "" } in
 217
 218   (* Create the first section (mail header). *)
 219   let section0 =
 220     let content =
 221       (* XXX Escaping! *)
 222       hdr_template#set "subject" subject;
 223       hdr_template#set "from" from;
 224       hdr_template#set "inet_message_id" inet_message_id;
 225
 226       let yyyy, mm, dd = date.Dbi.year, date.Dbi.month, date.Dbi.day in
 227       hdr_template#set "yyyy" (sprintf "%04d" yyyy);
 228       hdr_template#set "mm" (sprintf "%02d" mm);
 229       hdr_template#set "dd" (sprintf "%02d" dd);
 230       hdr_template#set "short_month" (short_month mm);
 231
 232       let get_table hdr =
 233         List.map (fun addr -> [ "addr", Template.VarString addr ])
 234           (Pcre.split ~rex:comma_re hdr)
 235       in
 236       let table = get_table to_hdr in
 237       hdr_template#table "to" table;
 238       hdr_template#conditional "has_to" (table <> []);
 239       let table = get_table cc in
 240       hdr_template#table "cc" table;
 241       hdr_template#conditional "has_cc" (table <> []);
 242
 243       hdr_template#to_string
 244     in
 245     "", "mail_header", content in
 246
 247   (* Create the second section (mail body).
 248    * XXX Very simple.  Should be extended to understand attachments and
 249    * convert them into file or image uploads.
 250    *)
 251   let section1 =
 252     let is_text_plain hdr =
 253       try
 254         let ct = hdr#field "content-type" in
 255         String.starts_with ct "text/plain"
 256       with
 257           Not_found -> true in
 258
 259     (* Find the first text/plain body. *)
 260     let rec find_body = function
 261         (header, `Body mime_body) when is_text_plain header ->
 262           mime_body#value
 263       | (_, `Body _) -> raise Not_found
 264       | (_, `Parts []) -> raise Not_found (* should never happen *)
 265       | (_, `Parts (m :: _)) ->
 266           find_body m in
 267
 268     (* Markup a plain text body. *)
 269     let markup_body text =
 270       (* Get all the titles from the database! We're going to exclude
 271        * mail messages from this.
 272        *)
 273       let sth =
 274         dbh#prepare_cached
 275           "select lower (title) from pages where hostid = ?
 276               and url is not null and title not like 'Mail/%'" in
 277       sth#execute [`Int hostid];
 278       let links = sth#map (function [`String s] -> s | _ -> assert false) in
 279
 280       (* This code cannot find titles which are split across multiple lines.
 281        * XXX
 282        *)
 283       let lines = Pcre.split ~rex:lines_re text in
 284
 285       (* We don't want to mark up the same link twice, so keep track of the
 286        * titles we've already used.
 287        *)
 288       let used = ref [] in
 289       let lines =
 290         List.map
 291           (fun line ->
 292              let find str sub_lc =
 293                try
 294                  String.find (String.lowercase str) sub_lc
 295                with
 296                    String.Invalid_string -> -1
 297              in
 298              let rec loop line = function
 299                  [] -> line
 300                | link :: links ->
 301                    let i = find line link in
 302                    if i >= 0 && not (List.mem link !used) then (
 303                      used := link :: !used;
 304                      let n = String.length link in
 305                      let n' = String.length line in
 306                      let line =
 307                        String.sub line 0 i ^
 308                        "[[" ^ String.sub line i n ^
 309                        "]]" ^ loop (String.sub line (i+n) (n' - (i+n))) links
 310                      in
 311                      line
 312                    ) else
 313                      loop line links
 314              in
 315              loop line links) lines in
 316
 317       let lines = List.map trim lines in
 318       let lines =
 319         List.map (fun line -> if line <> "" then line ^ " <br>" else "")
 320           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     "Message", "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   save_page dbh hostid ~user ~r model;
 353
 354   (* Commit to the database. *)
 355   dbh#commit ();
 356
 357   (* Finish off. *)
 358   ok ~title:"Imported"
 359     q ("Message " ^ inet_message_id ^ " was imported.")
 360
 361 let () =
 362   register_script ~restrict:[CanImportMail] run