Index: openacs-4/packages/acs-mail-lite/acs-mail-lite.info
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail-lite/acs-mail-lite.info,v
diff -u -r1.29 -r1.30
--- openacs-4/packages/acs-mail-lite/acs-mail-lite.info 29 Jan 2007 17:16:50 -0000 1.29
+++ openacs-4/packages/acs-mail-lite/acs-mail-lite.info 8 Apr 2007 08:12:51 -0000 1.30
@@ -33,7 +33,7 @@
-
+
Index: openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl,v
diff -u -r1.67 -r1.68
--- openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl 29 Jan 2007 17:16:50 -0000 1.67
+++ openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl 8 Apr 2007 08:12:51 -0000 1.68
@@ -88,38 +88,6 @@
}
#---------------------------------------
- ad_proc -public address_domain {} {
- @returns domain address to which bounces are directed to
- } {
- set domain [get_parameter -name "BounceDomain"]
- if { $domain eq "" } {
- regsub {http://} [ns_config ns/server/[ns_info server]/module/nssock hostname] {} domain
- }
- return $domain
- }
-
- #---------------------------------------
- ad_proc -private bounce_sendmail {} {
- @returns path to the sendmail executable
- } {
- return [get_parameter -name "SendmailBin"]
- }
-
- #---------------------------------------
- ad_proc -private bounce_prefix {} {
- @returns bounce prefix for x-envelope-from
- } {
- return [get_parameter -name "EnvelopePrefix"]
- }
-
- #---------------------------------------
- ad_proc -private mail_dir {} {
- @returns incoming mail directory to be scanned for bounces
- } {
- return [get_parameter -name "BounceMailDir"]
- }
-
- #---------------------------------------
ad_proc -public parse_email_address {
-email:required
} {
@@ -134,29 +102,8 @@
}
}
- #---------------------------------------
- ad_proc -public bouncing_email_p {
- -email:required
- } {
- Checks if email address is bouncing mail
- @option email email address to be checked for bouncing
- @returns 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
- @returns boolean 1 if bouncing 0 if ok.
- } {
- return [db_string bouncing_p {} -default 0]
- }
-
- #---------------------------------------
ad_proc -private log_mail_sending {
-user_id:required
} {
@@ -169,40 +116,8 @@
}
}
- #---------------------------------------
- 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
- @returns 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
- @returns 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 generate_message_id {
} {
Generate an id suitable as a Message-Id: header for an email.
@@ -232,277 +147,6 @@
}
#---------------------------------------
- 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:
- [][-]-Whatever@
-
- [] = 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 {}
-
- parse_email -file $msg -array email
- set email(to) [parse_email_address -email $email(to)]
- set email(from) [parse_email_address -email $email(from)]
-
- # 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}]} {
- 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]
- if {[lindex $params 0] eq "name"} {
- set filename [lindex $params 1]
- } else {
- set filename ""
- }
-
- # 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 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 [get_parameter -name MaxBounceCount -default 10]
- set max_days_to_bounce [get_parameter -name MaxDaysToBounce -default 3]
- set notification_interval [get_parameter -name NotificationInterval -default 7]
- set max_notification_count [get_parameter -name MaxNotificationCount -default 4]
- set notification_sender [get_parameter -name 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 deliver_mail {
-to_addr:required
-from_addr:required
@@ -954,28 +598,6 @@
}
#---------------------------------------
- ad_proc -private after_install {} {
- Callback to be called after package installation.
- Adds the service contract package-specific bounce management.
-
- @author Timo Hentschel (thentschel@sussdorff-roy.com)
- } {
- acs_sc::contract::new -name AcsMailLite -description "Callbacks for Bounce Management"
- acs_sc::contract::operation::new -contract_name AcsMailLite -operation MailBounce -input "header:string body:string" -output "" -description "Callback to handle bouncing mails"
- }
-
- #---------------------------------------
- ad_proc -private before_uninstall {} {
- Callback to be called before package uninstallation.
- Removes the service contract for package-specific bounce management.
-
- @author Timo Hentschel (thentschel@sussdorff-roy.com)
- } {
- # shouldn't we first delete the bindings?
- acs_sc::contract::delete -name AcsMailLite
- }
-
- #---------------------------------------
ad_proc -private message_interpolate {
{-values:required}
{-text:required}
Index: openacs-4/packages/acs-mail-lite/tcl/bounce-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail-lite/tcl/Attic/bounce-procs.tcl,v
diff -u
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-mail-lite/tcl/bounce-procs.tcl 8 Apr 2007 08:12:51 -0000 1.1
@@ -0,0 +1,151 @@
+ad_library {
+
+ Provides a simple API for reliably sending email.
+
+ @author Eric Lorenzo (eric@openforce.net)
+ @creation-date 22 March 2002
+ @cvs-id $Id: bounce-procs.tcl,v 1.1 2007/04/08 08:12:51 maltes Exp $
+
+}
+
+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_sendmail {} {
+ @returns path to the sendmail executable
+ } {
+ return [get_parameter -name "SendmailBin"]
+ }
+
+ #---------------------------------------
+ ad_proc -private bounce_prefix {} {
+ @returns bounce prefix for x-envelope-from
+ } {
+ return [get_parameter -name "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
+ @returns 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
+ @returns 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
+ @returns 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
+ @returns 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 [get_parameter -name MaxBounceCount -default 10]
+ set max_days_to_bounce [get_parameter -name MaxDaysToBounce -default 3]
+ set notification_interval [get_parameter -name NotificationInterval -default 7]
+ set max_notification_count [get_parameter -name MaxNotificationCount -default 4]
+ set notification_sender [get_parameter -name 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 {}
+ }
+ }
+
+
+}
Index: openacs-4/packages/acs-mail-lite/tcl/incoming-mail-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail-lite/tcl/Attic/incoming-mail-procs.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/acs-mail-lite/tcl/incoming-mail-procs.tcl 29 Jan 2007 17:16:51 -0000 1.1
+++ openacs-4/packages/acs-mail-lite/tcl/incoming-mail-procs.tcl 8 Apr 2007 08:12:51 -0000 1.2
@@ -14,6 +14,18 @@
namespace eval acs_mail_lite {
#---------------------------------------
+ ad_proc -public address_domain {} {
+ @returns domain address to which bounces are directed to
+ } {
+ set domain [get_parameter -name "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
} {
@@ -233,4 +245,4 @@
mime::finalize $mime -subordinates all
}
-}
\ No newline at end of file
+}