X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=scripts%2Fmail_import.ml;h=ae04ef763f5183dc0fd2e1ec824066f0c2190d0c;hb=cd059731a60fd3d4dcf426430ad26ff227b91910;hp=19b107312cfbac6827c3588a8e7da8dd0fe40dd9;hpb=0b0fae5825c5cf6a9501d0164c9414046797df74;p=cocanwiki.git diff --git a/scripts/mail_import.ml b/scripts/mail_import.ml index 19b1073..ae04ef7 100644 --- a/scripts/mail_import.ml +++ b/scripts/mail_import.ml @@ -1,7 +1,7 @@ (* COCANWIKI - a wiki written in Objective CAML. * Written by Richard W.M. Jones . * Copyright (C) 2004 Merjis Ltd. - * $Id: mail_import.ml,v 1.3 2004/10/11 16:07:25 rich Exp $ + * $Id: mail_import.ml,v 1.12 2006/03/28 16:24:07 rich Exp $ * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -36,13 +36,14 @@ open Cocanwiki_template open Cocanwiki_date open Cocanwiki_strings open Cocanwiki_pages +open Cocanwiki_mail let irt_re = Pcre.regexp "<.*?>" let ws_re = Pcre.regexp "\\s+" let comma_re = Pcre.regexp "\\s*,\\s*" let lines_re = Pcre.regexp "\\r?\\n" -let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = +let run r (q : cgi) dbh hostid _ user = let hdr_template = get_template dbh hostid "mail_import_header.txt" in (* Overwrite old messages? *) @@ -57,10 +58,8 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = upload.upload_value with Not_found -> - (* Force an error status which a script can detect. *) - Request.set_status r cHTTP_BAD_REQUEST; error ~back_button:true ~title:"No message" - q "No message was uploaded."; + dbh hostid q "No message was uploaded."; return () in (* Parse the message. *) @@ -86,29 +85,32 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = * cannot thread it, so give up. *) if date = "" || inet_message_id = "" then ( - Request.set_status r cHTTP_BAD_REQUEST; error ~back_button:true ~title:"Headers missing" - q "Date or Message-ID header missing. Cannot handle this message. "; + dbh hostid q + "Date or Message-ID header missing. Cannot handle this message. "; return () ); + (* Can't handle funny characters in subject lines - remove them. *) + let subject = String.map (fun c -> + if Char.code c < 32 then ' ' else c) subject in + (* Parse the date field. *) - let date, time = + let message_date = try let date = Netdate.parse date in - let date, time = - { Dbi.year = date.Netdate.year; - Dbi.month = date.Netdate.month; - Dbi.day = date.Netdate.day; }, - { Dbi.hour = date.Netdate.hour; - Dbi.min = date.Netdate.minute; - Dbi.sec = date.Netdate.second; - Dbi.microsec = 0; - Dbi.timezone = Some (date.Netdate.zone / 60); } in - date, time + let cal = Calendar.make + date.Netdate.year + date.Netdate.month + date.Netdate.day + date.Netdate.hour + date.Netdate.minute + date.Netdate.second in + let tz = Time_Zone.UTC_Plus (date.Netdate.zone / 60) in + cal, tz with - Invalid_argument _ -> - failwith ("cannot parse date: " ^ date) in + Invalid_argument _ -> + failwith ("cannot parse date: " ^ date) in (* Find the first thing in the In-Reply-To field which looks like a * message ID. @@ -146,41 +148,38 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = * else 'None' if this is a never-seen-before message. *) let overwrite = - let sth = dbh#prepare_cached "select id from messages - where hostid = ? and inet_message_id = ?" in - sth#execute [`Int hostid; `String inet_message_id]; - try - let id = sth#fetch1int () in - if not overwrite then ( - ok ~title:"Message exists" - q "Message already imported"; - return () - ); - Some id - with - Not_found -> None in + let rows = PGSQL(dbh) + "select id from messages + where hostid = $hostid and inet_message_id = $inet_message_id" in + match rows with + | [id] -> + if not overwrite then ( + ok ~title:"Message exists" + dbh hostid q "Message already imported"; + return () + ); + Some id + | [] -> None + | _ -> assert false in (* Save all of this in the database. *) let msgid = match overwrite with None -> (* Never-seen-before message. *) - let sth = - dbh#prepare_cached - "insert into messages (hostid, subject, inet_message_id, - message_date) values (?, ?, ?, ?)" in - sth#execute [`Int hostid; `String subject; `String inet_message_id; - `Timestamp (date, time)]; - let msgid = sth#serial "messages_id_seq" in - - let sth = - dbh#prepare_cached - "insert into msg_references (message_id, inet_message_id, - ordering) values (?, ?, ?)" in + PGSQL(dbh) + "insert into messages (hostid, subject, inet_message_id, + message_date) + values ($hostid, $subject, $inet_message_id, $message_date)"; + let msgid = PGOCaml.serial4 dbh "messages_id_seq" in + let ordering = ref 0 in List.iter (fun inet_message_id -> - incr ordering; let ordering = !ordering in - sth#execute [`Int msgid; `String inet_message_id; - `Int ordering]) references; + incr ordering; let ordering = Int32.of_int !ordering in + PGSQL(dbh) + "insert into msg_references (message_id, + inet_message_id, ordering) + values ($msgid, $inet_message_id, $ordering)" + ) references; msgid @@ -190,8 +189,11 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = *) msgid in - (* The message is referred to by a unique title: *) - let title = sprintf "Mail/%s (%d)" subject msgid in + (* The message is referred to by a unique title. + * NB. Do not change this unique title - it is also used during thread + * indexing. + *) + let title = sprintf "Mail/%s (%ld)" subject msgid in (* Choose a suitable URL. *) let url = @@ -213,7 +215,7 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = match overwrite with | None -> new_page (Title title) | Some _ -> load_page dbh hostid ~url () in - let model = { model with redirect = "" } in + let model = { model with redirect = None } in (* Create the first section (mail header). *) let section0 = @@ -223,11 +225,12 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = hdr_template#set "from" from; hdr_template#set "inet_message_id" inet_message_id; - let yyyy, mm, dd = date.Dbi.year, date.Dbi.month, date.Dbi.day in - hdr_template#set "yyyy" (sprintf "%04d" yyyy); - hdr_template#set "mm" (sprintf "%02d" mm); - hdr_template#set "dd" (sprintf "%02d" dd); - hdr_template#set "short_month" (short_month mm); + let date = fst message_date in + hdr_template#set "yyyy" (Printer.CalendarPrinter.sprint "%Y" date); + hdr_template#set "mm" (Printer.CalendarPrinter.sprint "%m" date); + hdr_template#set "dd" (Printer.CalendarPrinter.sprint "%d" date); + hdr_template#set "short_month" + (Printer.short_name_of_month (Calendar.month date)); let get_table hdr = List.map (fun addr -> [ "addr", Template.VarString addr ]) @@ -242,7 +245,7 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = hdr_template#to_string in - "", "mail_header", content in + None, Some "mail_header", content in (* Create the second section (mail body). * XXX Very simple. Should be extended to understand attachments and @@ -270,12 +273,11 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = (* Get all the titles from the database! We're going to exclude * mail messages from this. *) - let sth = - dbh#prepare_cached - "select lower (title) from pages where hostid = ? + let links = + PGSQL(dbh) + "select lower (title) from pages where hostid = $hostid and url is not null and title not like 'Mail/%'" in - sth#execute [`Int hostid]; - let links = sth#map (function [`String s] -> s | _ -> assert false) in + let links = List.map Option.get links in (* This code cannot find titles which are split across multiple lines. * XXX @@ -293,7 +295,7 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = try String.find (String.lowercase str) sub_lc with - String.Invalid_string -> -1 + Invalid_string -> -1 in let rec loop line = function [] -> line @@ -315,9 +317,7 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = loop line links) lines in let lines = List.map trim lines in - let lines = - List.map (fun line -> if line <> "" then line ^ "
" else "") - lines in + let lines = List.map (fun line -> line ^ "
") lines in String.concat "\n" lines in @@ -330,7 +330,7 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = with Not_found -> "No plain text message body found" in - "Message", "mail_body", content in + Some "Message", Some "mail_body", content in (* Overwrite the first two sections of the current page, regardless of * what they contain. @@ -338,25 +338,31 @@ let run r (q : cgi) (dbh : Dbi.connection) hostid _ user = * use the divname to identify the old mail_header and mail_body and * overwrite those, or insert them if they don't exist. *) - let contents = model.contents in + let contents = model.contents_ in let contents = match contents with - [] | [_] -> [ section0; section1 ] - | _ :: _ :: xs -> section0 :: section1 :: xs in - let model = { model with contents = contents } in + | [] | [_] -> [ section0; section1 ] + | _ :: _ :: xs -> section0 :: section1 :: xs in + let model = { model with contents_ = contents } in (* Write the page back. This can throw several exceptions, but we ignore * them because we want to script to fail abruptly if any of these * unexpected conditions arises. *) - save_page dbh hostid ~user ~r model; + ignore (save_page dbh hostid ~user ~r model); + + (* Rebuild threads? *) + if rebuild then + thread_mail dbh hostid ~user ~r + (Calendar.year (fst message_date)) + (Date.int_of_month (Calendar.month (fst message_date))); (* Commit to the database. *) - dbh#commit (); + PGOCaml.commit dbh; (* Finish off. *) ok ~title:"Imported" - q ("Message " ^ inet_message_id ^ " was imported.") + dbh hostid q ("Message " ^ inet_message_id ^ " was imported.") let () = register_script ~restrict:[CanImportMail] run