Skip to content

A
acs-mail-lite
Commit 06137b99 authored by Frank Bergmann's avatar Frank Bergmann
Browse files
Options

- Upgrade to OpenACS 5.6

parent 39ab7e34
Hide whitespace changes
Inline Side-by-side
Showing with 1097 additions and 0 deletions
sql/oracle/upgrade/upgrade-5.4.0d1-5.4.0d2.sql 0 → 100644
View file @ 06137b99
-- Make sure that emails are going to parties not to users and
-- therefore logging is for parties, not for users.
alter table acs_mail_lite_mail_log add party_id integer constraint amlml_party_id_fk references parties(party_id) on delete cascade;
update acs_mail_lite_mail_log set party_id = user_id;
alter table acs_mail_lite_mail_log drop column user_id;
alter table acs_mail_lite_bounce add party_id integer constraint amlb_party_id_fk references parties(party_id) on delete cascade;
update acs_mail_lite_bounce set party_id = user_id;
alter table acs_mail_lite_bounce drop column user_id;
alter table acs_mail_lite_bounce_notif drop constraint acs_mail_li_bou_notif_us_id_fk;
alter table acs_mail_lite_bounce_notif add party_id integer constraint amlbn_party_id_fk references parties (party_id) on delete cascade;
update acs_mail_lite_bounce_notif set party_id = user_id;
alter table acs_mail_lite_bounce_notif drop column user_id;
sql/oracle/upgrade/upgrade-5.4.0d2-5.4.0d3.sql 0 → 100644
View file @ 06137b99
-- acs-mail-lite/sql/oracle/upgrade/upgrade-5.4.0d2-5.4.0d3.sql
--
-- Upgrade acs_mail_lite_queue;
--
-- new columns
alter table acs_mail_lite_queue add creation_date varchar(4000);
alter table acs_mail_lite_queue add locking_server varchar(4000);
alter table acs_mail_lite_queue add cc_addr clob;
alter table acs_mail_lite_queue add reply_to varchar(400);
alter table acs_mail_lite_queue add file_ids varchar(4000);
alter table acs_mail_lite_queue add mime_type varchar(200);
alter table acs_mail_lite_queue add object_id integer;
alter table acs_mail_lite_queue add no_callback_p char(1)
constraint amlq_no_callback_p_ck
check (no_callback_p in ('t','f'));
alter table acs_mail_lite_queue add use_sender_p char(1)
constraint amlq_use_sender_p_ck
check (use_sender_p in ('t','f'));
-- renamed columns
alter table acs_mail_lite_queue rename column bcc to bcc_addr;
alter table acs_mail_lite_queue rename column extra_headers to extraheaders;
-- datatype changes
alter table acs_mail_lite_queue modify to_addr varchar(4000);
alter table acs_mail_lite_queue modify from_addr varchar(400);
alter table acs_mail_lite_queue modify subject varchar(4000);
sql/postgresql/upgrade/upgrade-5.4.0d1-5.4.0d2.sql 0 → 100644
View file @ 06137b99
-- Make sure that emails are going to parties not to users and
-- therefore logging is for parties, not for users.
alter table acs_mail_lite_mail_log add column party_id integer constraint amlml_party_id_fk references parties(party_id) on delete cascade;
update acs_mail_lite_mail_log set party_id = user_id;
alter table acs_mail_lite_mail_log drop column user_id;
alter table acs_mail_lite_bounce add column party_id integer constraint amlb_party_id_fk references parties(party_id) on delete cascade;
update acs_mail_lite_bounce set party_id = user_id;
alter table acs_mail_lite_bounce drop column user_id;
alter table acs_mail_lite_bounce_notif drop constraint acs_mail_li_bou_notif_us_id_fk;
alter table acs_mail_lite_bounce_notif add column party_id integer constraint amlbn_party_id_fk references parties(party_id) on delete cascade;
update acs_mail_lite_bounce_notif set party_id = user_id;
alter table acs_mail_lite_bounce_notif drop column user_id;
sql/postgresql/upgrade/upgrade-5.4.0d2-5.4.0d3.sql 0 → 100644
View file @ 06137b99
-- acs-mail-lite/sql/postgresql/upgrade/upgrade-5.4.0d2-5.4.0d3.sql
--
-- Modify acs_mail_lite_queue
--
-- New columns
alter table acs_mail_lite_queue
add column creation_date text,
add column locking_server text,
add column cc_addr text,
add column reply_to text,
add column file_ids text,
add column mime_type text,
add column object_id integer,
add column no_callback_p boolean,
add column use_sender_p boolean;
-- Renamed columns
alter table acs_mail_lite_queue rename column bcc to bcc_addr;
alter table acs_mail_lite_queue rename column extra_headers to extraheaders;
-- Column datatype changes
alter table acs_mail_lite_queue
alter column from_addr type text,
alter column subject type text;
tcl/acs-mail-lite-callback-procs.tcl 0 → 100644
View file @ 06137b99
# packages/acs-mail-lite/tcl/acs-mail-lite-callback-procs.tcl
ad_library {
Callback procs for acs-mail-lite
@author Malte Sussdorff (sussdorff@sussdorff.de)
@creation-date 2005-06-15
@arch-tag: d9aec4df-102d-4b0d-8d0e-3dc470dbe783
@cvs-id $Id$
}
ad_proc -public -callback acs_mail_lite::send {
-package_id:required
-message_id:required
-from_addr:required
-to_addr:required
-body:required
{-mime_type "text/plain"}
{-subject}
{-cc_addr}
{-bcc_addr}
{-file_ids}
{-object_id}
} {
Callback for executing code after an email has been send using the send mechanism.
@param package_id Package ID of the sending package
@param message_id the generated message_id for this mail
@param from_addr email of the sender
@param to_addr list of emails to whom did we send this email
@param body Text body of the email
@param mime_type Mime type of the email body
@param subject of the email
@param cc_addr list of emails to whom did we send this email in CC
@param bcc_addr list of emails to whom did we send this email in BCC
@param file_ids List of file ids sent as attachments.
@param object_id The ID of the object that is responsible for sending the mail in the first place
} -
ad_proc -public -callback acs_mail_lite::incoming_email {
-array:required
-package_id
} {
Callback that is executed for incoming e-mails if the email is *NOT* like $object_id@servername
} -
ad_proc -public -callback acs_mail_lite::incoming_object_email {
-array:required
-object_id:required
} {
Callback that is executed for incoming e-mails if the email is like $object_id@servername
} -
ad_proc -public -callback acs_mail_lite::email_form_elements {
-varname:required
} {
} -
ad_proc -public -callback acs_mail_lite::files {
-varname:required
-recipient_ids:required
} {
} -
ad_proc -public -callback acs_mail_lite::incoming_email -impl acs-mail-lite {
-array:required
-package_id:required
} {
Implementation of the interface acs_mail_lite::incoming_email for acs-mail-lite. This proc
takes care of emails bounced back from mailer deamons. The required syntax for the To header
is as follows: EnvelopPrefix-user_id-signature-package_id@myhost.com. This email was set for
the Return-Path header of the original email. The signature is created by calculating the SHA
value of the original Message-Id header. Thus an email is valid if the signature is correct and
the user is known. If this is the case we record the bounce.
@author Nima Mazloumi (nima.mazloumi@gmx.de)
@creation-date 2005-07-15
@param array An array with all headers, files and bodies. To access the array you need to use upvar.
@param package_id The package instance that registered the prefix
@return nothing
@error
} {
upvar $array email
set to [acs_mail_lite::parse_email_address -email $email(to)]
ns_log Debug "acs_mail_lite::incoming_email -impl acs-mail-lite called. Recepient $to"
util_unlist [acs_mail_lite::parse_bounce_address -bounce_address $to] user_id package_id signature
# If no user_id found or signature invalid, ignore message
if {$user_id eq ""} {
ns_log Debug "acs_mail_lite::incoming_email impl acs-mail-lite: No equivalent user found for $to"
} else {
ns_log Debug "acs_mail_lite::incoming_email impl acs-mail-lite: Bounce checking $to, $user_id"
acs_mail_lite::record_bounce -user_id $user_id
}
}
tcl/acs-mail-lite-callback-procs.xql 0 → 100644
View file @ 06137b99
<?xml version="1.0"?>
<queryset>
<fullquery name="callback::acs_mail_lite::incoming_email::impl::acs-mail-lite.record_bounce">
<querytext>
update acs_mail_lite_bounce
set bounce_count = bounce_count + 1
where party_id = :user_id
</querytext>
</fullquery>
<fullquery name="callback::acs_mail_lite::incoming_email::impl::acs-mail-lite.insert_bounce">
<querytext>
insert into acs_mail_lite_bounce (party_id, bounce_count)
values (:user_id, 1)
</querytext>
</fullquery>
</queryset>
tcl/apm-callback-procs.tcl 0 → 100644
View file @ 06137b99
ad_library {
Installation procs for acs-mail-lite
@author Emmanuelle Raffenne (eraffenne@gmail.com)
}
namespace eval acs_mail_lite {}
ad_proc -private acs_mail_lite::after_upgrade {
{-from_version_name:required}
{-to_version_name:required}
} {
After upgrade callback for acs-mail-lite
} {
apm_upgrade_logic \
-from_version_name $from_version_name \
-to_version_name $to_version_name \
-spec {
5.4.0d2 5.4.0d3 {
db_transaction {
db_dml remove_param_values {
delete from apm_parameter_values where parameter_id in (select parameter_id from apm_parameters where package_key = 'acs-mail-lite' and parameter_name='SendmailBin')
}
db_dml remove_param {
delete from apm_parameters where package_key = 'acs-mail-lite' and parameter_name='SendmailBin'
}
} on_error {
ns_log Error "acs-mail-lite::after_upgrade from 5.4.0d2 to 5.4.0d3: $errmsg"
}
}
}
}
tcl/bounce-procs-oracle.xql 0 → 100644
View file @ 06137b99
<?xml version="1.0"?>
<queryset>
<rdbms><type>oracle</type><version>8.1.6</version></rdbms>
<fullquery name="acs_mail_lite::check_bounces.send_notification_to_bouncing_email">
<querytext>
insert into acs_mail_lite_bounce_notif
(party_id, notification_count, notification_time)
(select user_id, 0 as notification_count,
trunc(sysdate-1-:notification_interval) as notification_time
from acs_mail_lite_bounce
where bounce_count >= :max_bounce_count)
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.get_recent_bouncing_users">
<querytext>
select u.user_id, u.email, u.first_names || ' ' || u.last_name as name
from cc_users u, acs_mail_lite_bounce_notif n
where u.user_id = n.party_id
and u.email_bouncing_p = 't'
and n.notification_time < sysdate - :notification_interval
and n.notification_count < :max_notification_count
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.log_notication_sending">
<querytext>
update acs_mail_lite_bounce_notif
set notification_time = trunc(sysdate),
notification_count = notification_count + 1
where party_id = :user_id
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.delete_log_if_no_recent_bounce">
<querytext>
delete from acs_mail_lite_bounce
where party_id in (select party_id
from acs_mail_lite_mail_log
where last_mail_date < sysdate - :max_days_to_bounce)
</querytext>
</fullquery>
</queryset>
tcl/bounce-procs-postgresql.xql 0 → 100644
View file @ 06137b99
<?xml version="1.0"?>
<queryset>
<rdbms><type>postgresql</type><version>7.1</version></rdbms>
<fullquery name="acs_mail_lite::check_bounces.send_notification_to_bouncing_email">
<querytext>
insert into acs_mail_lite_bounce_notif (party_id, notification_count, notification_time)
select party_id, 0 as notification_count,
date_trunc('day', current_timestamp - to_interval(1 + :notification_interval, 'days'))
as notification_time
from acs_mail_lite_bounce
where bounce_count >= :max_bounce_count
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.get_recent_bouncing_users">
<querytext>
select u.user_id, u.email, u.first_names || ' ' || u.last_name as name
from cc_users u, acs_mail_lite_bounce_notif n
where u.user_id = n.party_id
and u.email_bouncing_p = 't'
and n.notification_time < current_timestamp - to_interval(:notification_interval, 'days')
and n.notification_count < :max_notification_count
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.log_notication_sending">
<querytext>
update acs_mail_lite_bounce_notif
set notification_time = date_trunc('day',current_timestamp),
notification_count = notification_count + 1
where party_id = :user_id
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.delete_log_if_no_recent_bounce">
<querytext>
delete from acs_mail_lite_bounce
where party_id in (select party_id
from acs_mail_lite_mail_log
where last_mail_date < current_timestamp - to_interval(:max_days_to_bounce, 'days'))
</querytext>
</fullquery>
</queryset>
tcl/bounce-procs.tcl 0 → 100644
View file @ 06137b99
ad_library {
Provides a simple API for reliably sending email.
@author Eric Lorenzo (eric@openforce.net)
@creation-date 22 March 2002
@cvs-id $Id$
}
package require mime 1.4
package require smtp 1.4
package require base64 2.3.1
namespace eval acs_mail_lite {
#---------------------------------------
ad_proc -private bounce_prefix {} {
@return bounce prefix for x-envelope-from
} {
return [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter "EnvelopePrefix"]
}
#---------------------------------------
ad_proc -public bouncing_email_p {
-email:required
} {
Checks if email address is bouncing mail
@option email email address to be checked for bouncing
@return boolean 1 if bouncing 0 if ok.
} {
return [db_string bouncing_p {} -default 0]
}
#---------------------------------------
ad_proc -public bouncing_user_p {
-user_id:required
} {
Checks if email address of user is bouncing mail
@option user_id user to be checked for bouncing
@return boolean 1 if bouncing 0 if ok.
} {
return [db_string bouncing_p {} -default 0]
}
#---------------------------------------
ad_proc -public bounce_address {
-user_id:required
-package_id:required
-message_id:required
} {
Composes a bounce address
@option user_id user_id of the mail recipient
@option package_id package_id of the mail sending package
(needed to call package-specific code to deal with bounces)
@option message_id message-id of the mail
@return bounce address
} {
return "[bounce_prefix]-$user_id-[ns_sha1 $message_id]-$package_id@[address_domain]"
}
#---------------------------------------
ad_proc -public parse_bounce_address {
-bounce_address:required
} {
This takes a reply address, checks it for consistency,
and returns a list of user_id, package_id and bounce_signature found
@option bounce_address bounce address to be checked
@return tcl-list of user_id package_id bounce_signature
} {
set regexp_str "\[[bounce_prefix]\]-(\[0-9\]+)-(\[^-\]+)-(\[0-9\]*)\@"
if {![regexp $regexp_str $bounce_address all user_id signature package_id]} {
ns_log Debug "acs-mail-lite: bounce address not found for $bounce_address"
return ""
}
return [list $user_id $package_id $signature]
}
#---------------------------------------
ad_proc -public scan_replies {} {
Scheduled procedure that will scan for bounced mails
} {
# Make sure that only one thread is processing the queue at a time.
if {[nsv_incr acs_mail_lite check_bounce_p] > 1} {
nsv_incr acs_mail_lite check_bounce_p -1
return
}
with_finally -code {
ns_log Debug "acs-mail-lite: about to load qmail queue for [mail_dir]"
load_mails -queue_dir [mail_dir]
} -finally {
nsv_incr acs_mail_lite check_bounce_p -1
}
}
#---------------------------------------
ad_proc -private check_bounces { } {
Daily proc that sends out warning mail that emails
are bouncing and disables emails if necessary
} {
set max_bounce_count [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter MaxBounceCount -default 10]
set max_days_to_bounce [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter MaxDaysToBounce -default 3]
set notification_interval [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter NotificationInterval -default 7]
set max_notification_count [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter MaxNotificationCount -default 4]
set notification_sender [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter NotificationSender -default "reminder@[address_domain]"]
# delete all bounce-log-entries for users who received last email
# X days ago without any bouncing (parameter)
db_dml delete_log_if_no_recent_bounce {}
# disable mail sending for users with more than X recently
# bounced mails
db_dml disable_bouncing_email {}
# notify users of this disabled mail sending
db_dml send_notification_to_bouncing_email {}
# now delete bounce log for users with disabled mail sending
db_dml delete_bouncing_users_from_log {}
set subject "[ad_system_name] Email Reminder"
# now periodically send notifications to users with
# disabled email to tell them how to reenable the email
set notifications [db_list_of_ns_sets get_recent_bouncing_users {}]
# send notification to users with disabled email
foreach notification $notifications {
set notification_list [util_ns_set_to_list -set $notification]
array set user $notification_list
set user_id $user(user_id)
set body "Dear $user(name),\n\nDue to returning mails from your email account, we currently do not send you any email from our system. To reenable your email account, please visit\n[ad_url]/register/restore-bounce?[export_url_vars user_id]"
send -to_addr $notification_list -from_addr $notification_sender -subject $subject -body $body -valid_email
ns_log Notice "Bounce notification send to user $user_id"
# schedule next notification
db_dml log_notication_sending {}
}
}
ad_proc -public record_bounce {
{-user_id ""}
{-email ""}
} {
Records that an email bounce for this user
} {
if {$user_id eq ""} {
set user_id [party::get_by_email -email $email]
}
if { $user_id ne "" && ![acs_mail_lite::bouncing_user_p -user_id $user_id] } {
ns_log Debug "acs_mail_lite::incoming_email impl acs-mail-lite: Bouncing email from user $user_id"
# record the bounce in the database
db_dml record_bounce {}
if {![db_resultrows]} {
db_dml insert_bounce {}
}
}
}
}
tcl/bounce-procs.xql 0 → 100755
View file @ 06137b99
<?xml version="1.0"?>
<queryset>
<fullquery name="acs_mail_lite::bouncing_email_p.bouncing_p">
<querytext>
select case when email_bouncing_p = 't' then 1 else 0 end
as send_p
from users, parties
where lower(email) = lower(:email)
and party_id = user_id
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::bouncing_user_p.bouncing_p">
<querytext>
select case when email_bouncing_p = 't' then 1 else 0 end
as send_p
from users
where user_id = :user_id
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.delete_log_if_no_recent_bounce">
<querytext>
delete from acs_mail_lite_bounce
where party_id in (select party_id
from acs_mail_lite_mail_log
where last_mail_date < sysdate - :max_days_to_bounce)
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.disable_bouncing_email">
<querytext>
update users
set email_bouncing_p = 't'
where user_id in (select party_id
from acs_mail_lite_bounce
where bounce_count >= :max_bounce_count)
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::check_bounces.delete_bouncing_users_from_log">
<querytext>
delete from acs_mail_lite_bounce
where bounce_count >= :max_bounce_count
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::record_bounce.record_bounce">
<querytext>
update acs_mail_lite_bounce
set bounce_count = bounce_count + 1
where party_id = :user_id
</querytext>
</fullquery>
<fullquery name="acs_mail_lite::record_bounce.insert_bounce">
<querytext>
insert into acs_mail_lite_bounce (party_id, bounce_count)
values (:user_id, 1)
</querytext>
</fullquery>
</queryset>
tcl/incoming-mail-procs.tcl 0 → 100644
View file @ 06137b99
ad_library {
Provides a simple API for reliably sending email.
@author Eric Lorenzo (eric@openforce.net)
@creation-date 22 March 2002
@cvs-id $Id$
}
package require mime 1.4
package require smtp 1.4
package require base64 2.3.1
namespace eval acs_mail_lite {
#---------------------------------------
ad_proc -public address_domain {} {
@return domain address to which bounces are directed to
} {
set domain [parameter::get_from_package_key -package_key "acs-mail-lite" -parameter "BounceDomain"]
if { $domain eq "" } {
regsub {http://} [ns_config ns/server/[ns_info server]/module/nssock hostname] {} domain
}
return $domain
}
#---------------------------------------
ad_proc -private load_mails {
-queue_dir:required
} {
Scans for incoming email. You need
An incoming email has to comply to the following syntax rule:
[<SitePrefix>][-]<ReplyPrefix>-Whatever@<BounceDomain>
[] = optional
<> = Package Parameters
If no SitePrefix is set we assume that there is only one OpenACS installation. Otherwise
only messages are dealt with which contain a SitePrefix.
ReplyPrefixes are provided by packages that implement the callback acs_mail_lite::incoming_email
and provide a package parameter called ReplyPrefix. Only implementations are considered where the
implementation name is equal to the package key of the package.
Also we only deal with messages that contain a valid and registered ReplyPrefix.
These prefixes are automatically set in the acs_mail_lite_prefixes table.
@author Nima Mazloumi (nima.mazloumi@gmx.de)
@creation-date 2005-07-15
@option queue_dir The location of the qmail mail (BounceMailDir) queue in the file-system i.e. /home/service0/mail.
@see acs_mail_lite::incoming_email
@see acs_mail_lite::parse_email
} {
# get list of all incoming mail
if {[catch {
set messages [glob "$queue_dir/new/*"]
} errmsg]} {
if {[string match "no files matched glob pattern*" $errmsg ]} {
ns_log Debug "load_mails: queue dir = $queue_dir/new/*, no messages"
} else {
ns_log Error "load_mails: queue dir = $queue_dir/new/ error $errmsg"
}
return [list]
}
# loop over every incoming mail
foreach msg $messages {
ns_log Debug "load_mails: opening $msg"
array set email {}
# This will parse the E-mail and extract the files to the file system
parse_email -file $msg -array email
set email(to) [parse_email_address -email $email(to)]
set email(from) [parse_email_address -email $email(from)]
set subject [lindex $email(subject) 0]
if {$email(bodies) eq ""} {
ad_script_abort
ns_log Notice "E-Mail without body"
}
# Do no execute any callbacks if the email is an autoreply.
# Thanks to Vinod for the idea and the code
set callback_executed_p [acs_mail_lite::autoreply_p -subject $subject -from $email(from)]
if {!$callback_executed_p} {
# Special treatment for e-mails which look like they contain an object_id
set pot_object_id [lindex [split $email(to) "@"] 0]
ns_log Debug "Object_id for mail:: $pot_object_id"
if {[ad_var_type_check_number_p $pot_object_id]} {
if {[acs_object::object_p -id $pot_object_id]} {
callback acs_mail_lite::incoming_object_email -array email -object_id $pot_object_id
# Mark that the callback has been executed already
set no_callback_p 1
}
}
}
if {!$callback_executed_p} {
# We execute all callbacks now
callback acs_mail_lite::incoming_email -array email
}
#let's delete the file now
if {[catch {ns_unlink $msg} errmsg]} {
ns_log Error "load_mails: unable to delete queued message $msg: $errmsg"
} else {
ns_log Debug "load_mails: deleted $msg"
}
}
}
#---------------------------------------
ad_proc parse_email {
-file:required
-array:required
} {
An email is splitted into several parts: headers, bodies and files lists and all headers directly.
The headers consists of a list with header names as keys and their correponding values. All keys are lower case.
The bodies consists of a list with two elements: content-type and content.
The files consists of a list with three elements: content-type, filename and content.
The array with all the above data is upvared to the caller environment.
Important headers are:
-message-id (a unique id for the email, is different for each email except it was bounced from a mailer deamon)
-subject
-from
-to
Others possible headers:
-date
-received
-references (this references the original message id if the email is a reply)
-in-reply-to (this references the original message id if the email is a reply)
-return-path (this is used for mailer deamons to bounce emails back like bounce-user_id-signature-package_id@service0.com)
Optional application specific stuff only exist in special cases:
X-Mozilla-Status
X-Virus-Scanned
X-Mozilla-Status2
X-UIDL
X-Account-Key
X-Sasl-enc
You can therefore get a value for a header either through iterating the headers list or simply by calling i.e. "set message_id $email(message-id)".
Note: We assume "application/octet-stream" for all attachments and "base64" for
as transfer encoding for all files.
Note: tcllib required - mime, base64
@author Nima Mazloumi (nima.mazloumi@gmx.de)
@creation-date 2005-07-15
} {
upvar $array email
#prepare the message
if {[catch {set mime [mime::initialize -file $file]} errormsg]} {
ns_log error "Email could not be delivered for file $file"
set stream [open $file]
set content [read $stream]
close $stream
ns_log error "$content"
ns_unlink $file
return
}
#get the content type
set content [mime::getproperty $mime content]
#get all available headers
set keys [mime::getheader $mime -names]
set headers [list]
# create both the headers array and all headers directly for the email array
foreach header $keys {
set value [mime::getheader $mime $header]
set email([string tolower $header]) $value
lappend headers [list $header $value]
}
set email(headers) $headers
#check for multipart, otherwise we only have one part
if { [string first "multipart" $content] != -1 } {
set parts [mime::getproperty $mime parts]
} else {
set parts [list $mime]
}
# travers the tree and extract parts into a flat list
set all_parts [list]
foreach part $parts {
if {[mime::getproperty $part content] eq "multipart/alternative"} {
foreach child_part [mime::getproperty $part parts] {
lappend all_parts $child_part
}
} else {
lappend all_parts $part
}
}
set bodies [list]
set files [list]
#now extract all parts (bodies/files) and fill the email array
foreach part $all_parts {
# Attachments have a "Content-disposition" part
# Therefore we filter out if it is an attachment here
if {[catch {mime::getheader $part Content-disposition}] || [mime::getheader $part Content-disposition] eq "inline"} {
switch [mime::getproperty $part content] {
"text/plain" {
lappend bodies [list "text/plain" [mime::getbody $part]]
}
"text/html" {
lappend bodies [list "text/html" [mime::getbody $part]]
}
}
} else {
set encoding [mime::getproperty $part encoding]
set body [mime::getbody $part -decode]
set content $body
set params [mime::getproperty $part params]
array set param $params
# Append the file if there exist a filename to use. Otherwise do not append
if {[exists_and_not_null param(name)]} {
set filename $param(name)
# Determine the content_type
set content_type [mime::getproperty $part content]
if {$content_type eq "application/octet-stream"} {
set content_type [ns_guesstype $filename]
}
lappend files [list $content_type $encoding $filename $content]
}
}
}
set email(bodies) $bodies
set email(files) $files
#release the message
mime::finalize $mime -subordinates all
}
ad_proc -public autoreply_p {
{-subject ""}
{-from ""}
} {
Parse the subject, from and body to determin if the email is an auto reply
Typical autoreplies are "Out of office" messages. This is what the procedure does
@param subject Subject of the Email that will be scanned for "out of office"
@param from From address which will be checked if it is coming from a mailer daemon
@return 1 if this is actually an autoreply
} {
set autoreply_p 0
if {$subject ne ""} {
# check subject
set autoreply_p [regexp -nocase "(out of.*office|automated response|autoreply)" $subject]
set autoreply_p [regexp "NDN" $subject]
set autoreply_p [regexp "\[QuickML\] Error" $subject]
}
if {$from ne ""} {
# check from if it comes from the mailer daemon
set autoreply_p [regexp -nocase "mailer.*daemon" $from]
}
return $autoreply_p
}
}
\ No newline at end of file
tcl/utils-procs.tcl 0 → 100644
View file @ 06137b99
# packages/acs-mail-lite/tcl/utils-procs.tcl
ad_library {
Helper procs to build email messages
@author Emmanuelle Raffenne (eraffenne@gmail.com)
@creation-date 2007-12-16
@arch-tag: 820de9a9-533f-4fc3-b11d-2c9fb616a620
@cvs-id $Id$
}
namespace eval acs_mail_lite {}
namespace eval acs_mail_lite::utils {}
package require mime
ad_proc acs_mail_lite::utils::build_subject {
{-charset "UTF-8"}
subject
} {
Encode the subject, using quoted-printable, of an email message
and trim long lines.
Depending on the available mime package version, it uses either
the mime::word_encode proc to do it or local code (word_encode is
buggy in mime < 1.5.2 )
} {
set charset [string toupper $charset]
set charset_code [ns_encodingforcharset $charset]
# maxlen for each line
# 69 = 76 - 7 where 7 is for "=?"+"?Q?+"?="
set maxlen [expr {69 - [string length $charset]}]
set result ""
set line ""
set i 0
set subject_length [string length $subject]
while { $i < $subject_length } {
set chunk [string index $subject $i]
# encode that chunk
set chunk [encoding convertto $charset_code "$chunk"]
if { $chunk eq "\x3F" } {
# ER: workaround (kludge!) for tcllib error
set chunk "=3F"
} else {
set chunk [mime::qp_encode "$chunk" 1 0]
}
set newline $line
append newline $chunk
if { [string length $newline] <= $maxlen } {
append line $chunk
} else {
append result "=?$charset?Q?$line?=\n "
set line $chunk
}
incr i
}
if { $line ne "" } {
append result "=?$charset?Q?$line?="
}
return $result
}
ad_proc acs_mail_lite::utils::build_date {
{date ""}
} {
Depending on the available mime package version, it uses either
the mime::parsedatetime to do it or local code (parsedatetime is
buggy in mime < 1.5.2 )
@param date A 822-style date-time specification "YYYYMMDD HH:MI:SS"
} {
if { $date eq "" } {
set clock [clock seconds]
set date [clock format $clock -format "%Y-%m-%d %H:%M:%S"]
} else {
set clock [clock scan $date]
}
if { [catch {package require mime 1.5.2}] } {
set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" -gmt true]
if {[set diff [expr {($clock-[clock scan $gmt])/60}]] < 0} {
set s -
set diff [expr {-($diff)}]
} else {
set s +
}
set zone [format %s%02d%02d $s [expr {$diff/60}] [expr {$diff%60}]]
set wdays_short [list Sun Mon Tue Wed Thu Fri Sat]
set months_short [list Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec]
set wday [lindex $wdays_short [clock format $clock -format %w]]
set mon [lindex $months_short [expr {[string trimleft [clock format $clock -format %m] 0] - 1}]]
set result [clock format $clock -format "$wday, %d $mon %Y %H:%M:%S $zone"]
} else {
set result [mime::parsedatetime $date proper]
}
return $result
}
ad_proc acs_mail_lite::utils::build_body {
{-mime_type "text/plain"}
{-charset "UTF-8"}
body
} {
Encode the body using quoted-printable and build the alternative
part if necessary
Return a list of message tokens
} {
# Encode the body
set encoding [ns_encodingforcharset $charset]
set body [encoding convertto $encoding $body]
if { $mime_type eq "text/plain" } {
# Set the message token
set message_token [mime::initialize \
-canonical "$mime_type" \
-param [list charset $charset] \
-encoding "quoted-printable" \
-string "$body"]
} else {
set message_html_part [mime::initialize \
-canonical "text/html" \
-param [list charset $charset] \
-encoding "quoted-printable" \
-string "$body"]
set message_text_part [mime::initialize \
-canonical "text/plain" \
-param [list charset $charset] \
-encoding "quoted-printable" \
-string [ad_html_to_text "$body"]]
set message_token [mime::initialize \
-canonical "multipart/alternative" \
-parts [list $message_text_part $message_html_part]]
}
return [list $message_token]
}
ad_proc -public acs_mail_lite::utils::valid_email_p {
email
} {
Checks if the email is valid. Returns 1 if it is. Uses mime::parsemail to determine this
} {
array set test [lindex [mime::parseaddress "$email"] 0]
if {$email ne $test(proper)} {
regsub "\"" $test(proper) "" proper
if {$email ne $proper} {
return 0
} else {
return 1
}
} else {
return 1
}
}
www/restore-bounce.adp 0 → 100644
View file @ 06137b99
<master>
<property name="title">@page_title;noquote@</property>
<property name="context">@context;noquote@</property>
<p>#acs-mail-lite.Bounce_disabled#</p>
<p>
<b>&raquo;</b> <a href="@return_url@">#acs-subsite.Continue#</a>
</p>
www/restore-bounce.tcl 0 → 100644
View file @ 06137b99
ad_page_contract {
The page restores a user from the deleted state.
@cvs-id $Id$
} {
{return_url {[ad_pvt_home]}}
}
set page_title [_ acs-mail-lite.Restore_bounce]
set context [list [list [ad_pvt_home] [ad_pvt_home_name]] $page_title]
# We do require authentication, though their account will be closed
set user_id [auth::require_login]
db_dml unbounce_user "update users set email_bouncing_p = 'f' where user_id = :user_id"
# Used in a message key
set system_name [ad_system_name]
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment