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: cocanwiki_mail.ml,v 1.1 2004/10/14 15:57:15 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.
25 (* Rebuild mail threads for (year, month).
26 * The algorithm used is by JWZ - see:
27 * http://www.jwz.org/doc/threading.html
29 class ['a] container m =
31 val mutable message = (m : 'a option)
32 val mutable parent = (None : 'a container option)
33 val mutable children = ([] : 'a container list)
35 method message = message
36 method set_message m = message <- Some m
38 (* Don't call 'set_parent' explicitly. I wish I could understand the
39 * section in the manual on friend methods ...
41 method parent = parent
42 method set_parent c = parent <- Some c
43 method set_no_parent () = parent <- None
45 method children = children
47 assert (not (List.exists (fun child -> Oo.id child = Oo.id c) children));
48 children <- c :: children;
49 assert (c#parent = None);
51 method remove_child c =
54 | Some parent when Oo.id parent <> Oo.id self
55 let n = List.length children in
56 children <- List.filter (fun child -> Oo.id child <> Oo.id c) children;
57 assert (List.length children = n-1)
60 let re_re = Pcre.regexp "^Re\\[\\d+\\]:\\s*"
62 let thread_mail (dbh : Dbi.connection) hostid year month =
63 let title = "Mail/%04d/%02d/Thread Index" in
65 (* Pull out all the emails relevant to this month. *)
67 dbh#prepare_cached "select id, subject, inet_message_id, message_date
70 and extract (year from message_date) = ?
71 and extract (month from message_date) = ?" in
72 sth#execute [`Int hostid; `Int year; `Int month];
76 (function [`Int id; `String subject; `String inet_message_id;
77 `Timestamp message_date] ->
78 id, (inet_message_id, subject, message_date)
79 | _ -> assert false) in
84 let qs = Dbi.placeholders (List.length msgs) in
85 dbh#prepare_cached ("select message_id, inet_message_id, ordering
87 where message_id in " ^ qs ^ "
88 order by message_id, ordering") in
89 sth#execute (List.map (fun (id, _) -> `Int id) msgs);
90 sth#map (function [`Int id; `String inet_message_id; _] ->
95 (* Aggregate the msgs and references structures together.
96 * Note that references will be in the correct order (because of the
97 * 'order by' clause in the select statement above), with the parent
98 * message appearing first in the list.
101 List.map (fun (id, (inet_message_id, subject, message_date)) ->
103 List.filter (fun (i, _) -> i = id) references in
104 let references = List.map snd references in
105 id, (inet_message_id, references, subject, message_date))
108 (* Get the base subject lines (removing Re:, etc.). *)
110 List.map (fun (id, (inet_message_id, references, subject, message_date)) ->
111 let rec loop subject =
112 let n = String.length subject in
113 if String.starts_with subject "Re: " then
114 loop (String.sub subject 4 (n-4))
115 else if String.starts_with subject "Re:" then
116 loop (String.sub subject 3 (n-3))
117 else if String.starts_with subject "RE: " then
118 loop (String.sub subject 4 (n-4))
119 else if String.starts_with subject "RE:" then
120 loop (String.sub subject 3 (n-3))
121 else if Pcre.pmatch ~rex:re_re subject then (
122 let subs = Pcre.exec ~rex:re_re subject in
123 let i = String.length (Pcre.get_substring subs 0) in
124 loop (String.sub subject i (n-i))
128 let base_subject = loop subject in
129 let is_reply = base_subject <> subject in
130 id, (inet_message_id, references,
131 subject, base_subject, is_reply, message_date)) msgs in
134 (* Hash of inet_message_id -> container. *)
135 let id_table = Hashtbl 1024 in
137 (fun ((id, (inet_message_id, references, _, _, _, _)) as message) ->
140 let container = Hashtbl.find id_table inet_message_id in
141 if container#message = None then container#set_message message;
145 let container = new container (Some message) in
146 Hashtbl.add id_table inet_message_id container;
152 (fun inet_message_id ->
154 Hashtbl.find id_table inet_message_id
157 let container = new container None in
158 Hashtbl.add id_table inet_message_id container;
159 container) references in
160 (* Link the reference containers together. *)
163 if not (reachable parent child) && not (reachable child parent)
165 if parent#child = None then parent#set_child = child;
166 if child#parent = None then child#set_parent = parent;
169 (* Parent of this message is first element in references. *)
170 match ref_containers with
172 let old_parent = container#parent in
173 container#set_no_parent ();
175 | parent :: _ when Oo.id parent <> my_parent_id ->