scripts/cocanwiki_mail.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: cocanwiki_mail.ml,v 1.1 2004/10/14 15:57:15 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 ExtString
  23
  24 (*
  25 (* Rebuild mail threads for (year, month).
  26  * The algorithm used is by JWZ - see:
  27  * http://www.jwz.org/doc/threading.html
  28  *)
  29 class ['a] container m =
  30 object (self)
  31   val mutable message = (m : 'a option)
  32   val mutable parent = (None : 'a container option)
  33   val mutable children = ([] : 'a container list)
  34
  35   method message = message
  36   method set_message m = message <- Some m
  37
  38   (* Don't call 'set_parent' explicitly.  I wish I could understand the
  39    * section in the manual on friend methods ...
  40    *)
  41   method parent = parent
  42   method set_parent c = parent <- Some c
  43   method set_no_parent () = parent <- None
  44
  45   method children = children
  46   method add_child c =
  47     assert (not (List.exists (fun child -> Oo.id child = Oo.id c) children));
  48     children <- c :: children;
  49     assert (c#parent = None);
  50     c#set_parent self
  51   method remove_child c =
  52     match c#parent with
  53         None
  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)
  58 end
  59
  60 let re_re = Pcre.regexp "^Re\\[\\d+\\]:\\s*"
  61
  62 let thread_mail (dbh : Dbi.connection) hostid year month =
  63   let title = "Mail/%04d/%02d/Thread Index" in
  64
  65   (* Pull out all the emails relevant to this month. *)
  66   let sth =
  67     dbh#prepare_cached "select id, subject, inet_message_id, message_date
  68                           from messages
  69                          where hostid = ?
  70                            and extract (year from message_date) = ?
  71                            and extract (month from message_date) = ?" in
  72   sth#execute [`Int hostid; `Int year; `Int month];
  73
  74   let msgs =
  75     sth#map
  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
  80
  81   let references =
  82     if msgs <> [] then (
  83       let sth =
  84         let qs = Dbi.placeholders (List.length msgs) in
  85         dbh#prepare_cached ("select message_id, inet_message_id, ordering
  86                                from messages
  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; _] ->
  91                  id, inet_message_id
  92                  | _ -> assert false)
  93     ) else [] in
  94
  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.
  99    *)
 100   let msgs =
 101     List.map (fun (id, (inet_message_id, subject, message_date)) ->
 102                 let references =
 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))
 106       msgs in
 107
 108   (* Get the base subject lines (removing Re:, etc.). *)
 109   let msgs =
 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))
 125                   ) else
 126                     subject
 127                 in
 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
 132
 133   (*--- Step 1. ---*)
 134   (* Hash of inet_message_id -> container. *)
 135   let id_table = Hashtbl 1024 in
 136   List.iter
 137     (fun ((id, (inet_message_id, references, _, _, _, _)) as message) ->
 138        let container =
 139          try
 140            let container = Hashtbl.find id_table inet_message_id in
 141            if container#message = None then container#set_message message;
 142            container
 143          with
 144              Not_found ->
 145                let container = new container (Some message) in
 146                Hashtbl.add id_table inet_message_id container;
 147                container in
 148
 149        (* References. *)
 150        let ref_containers =
 151          List.map
 152            (fun inet_message_id ->
 153               try
 154                 Hashtbl.find id_table inet_message_id
 155               with
 156                   Not_found ->
 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. *)
 161        iter_in_pairs
 162          (fun child parent ->
 163             if not (reachable parent child) && not (reachable child parent)
 164             then (
 165               if parent#child = None then parent#set_child = child;
 166               if child#parent = None then child#set_parent = parent;
 167             )) ref_containers;
 168
 169        (* Parent of this message is first element in references. *)
 170        match ref_containers with
 171            [] ->
 172              let old_parent = container#parent in
 173              container#set_no_parent ();
 174              if old_parent <>
 175          | parent :: _ when Oo.id parent <> my_parent_id ->
 176              container#set_parent
 177
 178
 179
 180     ) msgs;
 181 *)