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 $
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.
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.
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.
33 open Cocanwiki_template
37 let irt_re = Pcre.regexp "<.*?>"
38 let ws_re = Pcre.regexp "\\S+"
40 let run r (q : cgi) (dbh : Dbi.connection) hostid _ user =
41 let hdr_template = get_template dbh hostid "mail_import_header.txt" in
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
48 (* Get the uploaded file. *)
51 let upload = q#upload "file" in
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.";
61 (* Parse the message. *)
64 (new input_string file)
66 let stm = new input_stream ch in
67 read_mime_message stm) in
69 (* Get the mail header for easy access. *)
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
80 (* If the message doesn't have a Date or Message-ID header, then we
81 * cannot thread it, so give up.
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. ";
90 (* Parse the date field. *)
93 let date = Netdate.parse date in
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;
102 Dbi.timezone = Some (date.Netdate.zone / 60); } in
105 Invalid_argument _ ->
106 failwith ("cannot parse date: " ^ date) in
108 (* Find the first thing in the In-Reply-To field which looks like a
113 let subs = Pcre.exec ~rex:irt_re in_reply_to in
114 Some (Pcre.get_substring subs 0)
118 (* References is a space-separated list of message IDs. Parse that up. *)
119 let references = Pcre.split ~rex:ws_re references in
121 (* Reverse the references list, because we most often want to see the
122 * head element (ie. the most immediate parent message).
124 let references = List.rev references in
126 (* If the head element of references != the in-reply-to message ID, then
130 match in_reply_to with
133 match references with
135 | m :: ms when m <> msgid -> msgid :: m :: ms
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.
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];
148 let id = sth#fetch1int () in
149 if not overwrite then (
150 ok ~title:"Message exists"
151 q "Message already imported";
158 (* Save all of this in the database. *)
161 None -> (* Never-seen-before message. *)
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
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;
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.
188 (* The message is referred to by a unique title: *)
189 let title = sprintf "Mail/%s (%d)" subject msgid in
191 (* Choose a suitable 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.
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
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
206 (* Create the page. Or edit it (if we're overwriting ...). *)
209 | None -> new_page (Title title)
210 | Some _ -> load_page dbh hostid ~url () in
211 let model = { model with redirect = "" } in
213 (* Create the first section (mail header). *)
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
227 "", "mail_header", content in
229 (* Create the second section (mail body). *)
231 let content = "(mail body should go here XXX)" in
232 "Message", "mail_body", content in
234 (* Overwrite the first two sections of the current page, regardless of
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.
240 let contents = model.contents in
243 [] | [_] -> [ section0; section1 ]
244 | _ :: _ :: xs -> section0 :: section1 :: xs in
245 let model = { model with contents = contents } in
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.
251 save_page dbh hostid ~user ~r model;
253 (* Commit to the database. *)
258 q ("Message " ^ inet_message_id ^ " was imported.")
261 register_script ~restrict:[CanImportMail] run