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.1 2004/10/11 14:13:04 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 Cocanwiki
  32 open Cocanwiki_ok
  33 open Cocanwiki_template
  34 open Cocanwiki_date
  35 open Cocanwiki_pages
  36
  37 let irt_re = Pcre.regexp "<.*?>"
  38 let ws_re = Pcre.regexp "\\S+"
  39
  40 let run r (q : cgi) (dbh : Dbi.connection) hostid _ user =
  41   let hdr_template = get_template dbh hostid "mail_import_header.txt" in
  42
  43   (* Overwrite old messages? *)
  44   let overwrite = q#param_true "overwrite" in
  45   (* Rebuild index after importing this one message? *)
  46   let rebuild = q#param_true "rebuild" in
  47
  48   (* Get the uploaded file. *)
  49   let file =
  50     try
  51       let upload = q#upload "file" in
  52       upload.upload_value
  53     with
  54         Not_found ->
  55           (* Force an error status which a script can detect. *)
  56           Request.set_status r cHTTP_BAD_REQUEST;
  57           error ~back_button:true ~title:"No message"
  58             q "No message was uploaded.";
  59           return () in
  60
  61   (* Parse the message. *)
  62   let msg =
  63     with_in_obj_channel
  64       (new input_string file)
  65       (fun ch ->
  66          let stm = new input_stream ch in
  67          read_mime_message stm) in
  68
  69   (* Get the mail header for easy access. *)
  70   let hdr = fst msg in
  71
  72   (* Get the interesting headers which will go into the database. *)
  73   let get_hdr name = try hdr#field name with Not_found -> "" in
  74   let subject = get_hdr "subject" in
  75   let inet_message_id = get_hdr "message-id" in
  76   let date = get_hdr "date" in
  77   let references = get_hdr "references" in
  78   let in_reply_to = get_hdr "in-reply-to" in
  79
  80   (* If the message doesn't have a Date or Message-ID header, then we
  81    * cannot thread it, so give up.
  82    *)
  83   if date = "" || inet_message_id = "" then (
  84     Request.set_status r cHTTP_BAD_REQUEST;
  85     error ~back_button:true ~title:"Headers missing"
  86       q "Date or Message-ID header missing.  Cannot handle this message. ";
  87     return ()
  88   );
  89
  90   (* Parse the date field. *)
  91   let date, time =
  92     try
  93       let date = Netdate.parse date in
  94       let date, time =
  95         { Dbi.year = date.Netdate.year;
  96           Dbi.month = date.Netdate.month;
  97           Dbi.day = date.Netdate.day; },
  98         { Dbi.hour = date.Netdate.hour;
  99           Dbi.min = date.Netdate.minute;
 100           Dbi.sec = date.Netdate.second;
 101           Dbi.microsec = 0;
 102           Dbi.timezone = Some (date.Netdate.zone / 60); } in
 103       date, time
 104     with
 105         Invalid_argument _ ->
 106           failwith ("cannot parse date: " ^ date) in
 107
 108   (* Find the first thing in the In-Reply-To field which looks like a
 109    * message ID.
 110    *)
 111   let in_reply_to =
 112     try
 113       let subs = Pcre.exec ~rex:irt_re in_reply_to in
 114       Some (Pcre.get_substring subs 0)
 115     with
 116         Not_found -> None in
 117
 118   (* References is a space-separated list of message IDs.  Parse that up. *)
 119   let references = Pcre.split ~rex:ws_re references in
 120
 121   (* Reverse the references list, because we most often want to see the
 122    * head element (ie. the most immediate parent message).
 123    *)
 124   let references = List.rev references in
 125
 126   (* If the head element of references != the in-reply-to message ID, then
 127    * prepend it.
 128    *)
 129   let references =
 130     match in_reply_to with
 131       | None -> references
 132       | Some msgid ->
 133           match references with
 134             | [] -> [msgid]
 135             | m :: ms when m <> msgid -> msgid :: m :: ms
 136             | ms -> ms in
 137
 138   (* Does this message exist in the database already?  If so, and overwrite
 139    * is not specified, then silently skip this message.  'overwrite' becomes
 140    * 'Some id' if we need to overwrite an existing message id in the database,
 141    * else 'None' if this is a never-seen-before message.
 142    *)
 143   let overwrite =
 144     let sth = dbh#prepare_cached "select id from messages
 145                                    where hostid = ? and inet_message_id = ?" in
 146     sth#execute [`Int hostid; `String inet_message_id];
 147     try
 148       let id = sth#fetch1int () in
 149       if not overwrite then (
 150         ok ~title:"Message exists"
 151           q "Message already imported";
 152         return ()
 153       );
 154       Some id
 155     with
 156         Not_found -> None in
 157
 158   (* Save all of this in the database. *)
 159   let msgid =
 160     match overwrite with
 161         None ->                         (* Never-seen-before message. *)
 162           let sth =
 163             dbh#prepare_cached
 164               "insert into messages (hostid, subject, inet_message_id,
 165                  message_date) values (?, ?, ?, ?)" in
 166           sth#execute [`Int hostid; `String subject; `String inet_message_id;
 167                        `Timestamp (date, time)];
 168           let msgid = sth#serial "messages_id_seq" in
 169
 170           let sth =
 171             dbh#prepare_cached
 172               "insert into msg_references (message_id, inet_message_id,
 173                  ordering) values (?, ?, ?)" in
 174           let ordering = ref 0 in
 175           List.iter (fun inet_message_id ->
 176                        incr ordering; let ordering = !ordering in
 177                        sth#execute [`Int msgid; `String inet_message_id;
 178                                     `Int ordering]) references;
 179
 180           msgid
 181
 182       | Some msgid ->                   (* Overwrite an existing message. *)
 183           (* All the fields in the messages table should be identical to
 184            * last time we imported this message.  Just return the msgid.
 185            *)
 186           msgid in
 187
 188   (* The message is referred to by a unique title: *)
 189   let title = sprintf "Mail/%s (%d)" subject msgid in
 190
 191   (* Choose a suitable URL. *)
 192   let url =
 193     match Wikilib.generate_url_of_title dbh hostid title with
 194         (* Duplicate URL is OK - eg. in the case where we are overwriting
 195          * an already imported message.
 196          *)
 197         Wikilib.GenURL_OK url | Wikilib.GenURL_Duplicate url -> url
 198       | Wikilib.GenURL_TooShort | Wikilib.GenURL_BadURL ->
 199           failwith "generate_url_of_title returned 'TooShort' or 'BadURL'" in
 200
 201   (* To create the page, we need a few more headers ... *)
 202   let from = get_hdr "from" in
 203   let to_hdr = get_hdr "to" in
 204   let cc = get_hdr "cc" in
 205
 206   (* Create the page.  Or edit it (if we're overwriting ...). *)
 207   let model =
 208     match overwrite with
 209       | None -> new_page (Title title)
 210       | Some _ -> load_page dbh hostid ~url () in
 211   let model = { model with redirect = "" } in
 212
 213   (* Create the first section (mail header). *)
 214   let section0 =
 215     let content =
 216       (* XXX Escaping! *)
 217       hdr_template#set "subject" subject;
 218       let yyyy, mm, dd = date.Dbi.year, date.Dbi.month, date.Dbi.day in
 219       hdr_template#set "yyyy" (sprintf "%04d" yyyy);
 220       hdr_template#set "mm" (sprintf "%02d" mm);
 221       hdr_template#set "dd" (sprintf "%02d" dd);
 222       hdr_template#set "short_month" (short_month mm);
 223       hdr_template#set "from" from;
 224       hdr_template#set "inet_message_id" inet_message_id;
 225       hdr_template#to_string
 226     in
 227     "", "mail_header", content in
 228
 229   (* Create the second section (mail body). *)
 230   let section1 =
 231     let content = "(mail body should go here XXX)" in
 232     "Message", "mail_body", content in
 233
 234   (* Overwrite the first two sections of the current page, regardless of
 235    * what they contain.
 236    * XXX We might consider more advanced strategies here: for example,
 237    * use the divname to identify the old mail_header and mail_body and
 238    * overwrite those, or insert them if they don't exist.
 239    *)
 240   let contents = model.contents in
 241   let contents =
 242     match contents with
 243         [] | [_] -> [ section0; section1 ]
 244       | _ :: _ :: xs -> section0 :: section1 :: xs in
 245   let model = { model with contents = contents } in
 246
 247   (* Write the page back.  This can throw several exceptions, but we ignore
 248    * them because we want to script to fail abruptly if any of these
 249    * unexpected conditions arises.
 250    *)
 251   save_page dbh hostid ~user ~r model;
 252
 253   (* Commit to the database. *)
 254   dbh#commit ();
 255
 256   (* Finish off. *)
 257   ok ~title:"Imported"
 258     q ("Message " ^ inet_message_id ^ " was imported.")
 259
 260 let () =
 261   register_script ~restrict:[CanImportMail] run