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