- Publicity: Public Only All
notification-email-procs.tcl
Notifications Email Delivery Method
- Location:
- packages/notifications/tcl/notification-email-procs.tcl
- Created:
- 2002-06-20
- Author:
- Ben Adida
- CVS Identification:
$Id: notification-email-procs.tcl,v 1.47.2.8 2024/07/15 12:04:49 gustafn Exp $
Procedures in this file
- notification::email::address_domain (public)
- notification::email::bounce_mail_message (public)
- notification::email::get_package_id (public)
- notification::email::get_parameter (public, deprecated)
- notification::email::manage_notifications_url (public)
- notification::email::reply_address_prefix (public)
- notification::email::send (public)
Detailed information
notification::email::address_domain (public)
notification::email::address_domain
Get the domain name to use for e-mail. The package parameter "EmailDomain" is preferred, but if it doesn't exist, we build one using the system URL.
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::bounce_mail_message (public)
notification::email::bounce_mail_message -to_addr to_addr \ -from_addr from_addr -body body -message_headers message_headers \ [ -reason reason ]
This sends a bounce message indicating a failure while sending a message to the system.
- Switches:
- -to_addr (required)
- who the bounce is going to
- -from_addr (required)
- who the bouncing message as sent to
- -body (required)
- the message body
- -message_headers (required)
- the headers of the message
- -reason (optional)
- (defaults to nothing). Reason for bounce
- Author:
- mkovach@alal.com
- Created:
- 05 Nov 2003
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::get_package_id (public)
notification::email::get_package_id
Get the package id for notifications (depends on this being a singular package)
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::get_parameter (public, deprecated)
notification::email::get_parameter -name name [ -default default ]
Deprecated. Invoking this procedure generates a warning.
Shorthand proc to return a given notifications package parameter. Deprecated: just a wrapper for parameter::get
- Switches:
- -name (required)
- -default (optional)
- See Also:
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::manage_notifications_url (public)
notification::email::manage_notifications_url
Build a URL to the "manage notifications" script.
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::reply_address_prefix (public)
notification::email::reply_address_prefix
Shorthand proc to return the email reply address prefix parameter value.
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
notification::email::send (public)
notification::email::send from_user_id to_user_id reply_object_id \ notification_type_id subject content_text content_html file_ids
Send the actual email.
- Parameters:
- from_user_id (required)
- The user_id of the user that the email should be sent as. Provide empty for the standard mailer from address.
- to_user_id (required)
- reply_object_id (required)
- notification_type_id (required)
- subject (required)
- content_text (required)
- content_html (required)
- file_ids (required)
- Partial Call Graph (max 5 caller/called nodes):
- Testcases:
- No testcase defined.
Content File Source
ad_library { Notifications Email Delivery Method @creation-date 2002-06-20 @author Ben Adida <ben@openforce.biz> @cvs-id $Id: notification-email-procs.tcl,v 1.47.2.8 2024/07/15 12:04:49 gustafn Exp $ } namespace eval notification::email { ad_proc -public get_package_id {} { Get the package id for notifications (depends on this being a singular package) } { return [apm_package_id_from_key notifications] } d_proc -deprecated -public get_parameter { {-name:required} {-default ""} } { Shorthand proc to return a given notifications package parameter. Deprecated: just a wrapper for parameter::get @see parameter::get } { return [parameter::get -package_id [get_package_id] -parameter $name -default $default] } ad_proc -public address_domain {} { Get the domain name to use for e-mail. The package parameter "EmailDomain" is preferred, but if it doesn't exist, we build one using the system URL. } { set domain [parameter::get -package_id [get_package_id] -parameter "EmailDomain" -default ""] if { $domain eq "" } { # No domain set up, let's use the default from the system info # This may not find anything, but at least it's worth a try if { ![regexp {^(https?://)?(www\.)?([^/]*)} [ad_url] match ignore ignore domain] } { ns_log Warning "notification::email::address_domain: Couldn't find an email domain for notifications." } else { regsub -nocase {(.*):.*} $domain "\\1" domain } } return $domain } ad_proc -public manage_notifications_url {} { Build a URL to the "manage notifications" script. } { return "[ad_url][apm_package_url_from_key [notification::package_key]]manage" } ad_proc -public reply_address_prefix {} { Shorthand proc to return the email reply address prefix parameter value. } { return [parameter::get -package_id [get_package_id] -parameter "EmailReplyAddressPrefix" -default ""] } ad_proc -private qmail_mail_queue_dir {} { Shorthand proc to return the email qmail-style mail queue (i.e. a Maildir directory) } { return [parameter::get -package_id [get_package_id] -parameter "EmailQmailQueue" -default ""] } ad_proc -private parse_email_address {email} { Strip out the user's name (in angle brackets) from an e-mail address if it exists. } { if {![regexp {<([^>]*)>} $email all clean_email]} { return $email } else { return $clean_email } } d_proc -private reply_address { {-object_id:required} {-type_id:required} } { Build an object/type-specific e-mail address that the user can reply to. } { if {$object_id eq "" || $type_id eq ""} { return "\"[address_domain] mailer\" <[reply_address_prefix]@[address_domain]>" } else { return "\"[address_domain] mailer\" <[reply_address_prefix]-$object_id-$type_id@[address_domain]>" } } d_proc -private parse_reply_address { {-reply_address:required} } { This takes a reply address, checks it for consistency, and returns a list of object_id and type_id } { # The pattern to match set regexp_str "^[reply_address_prefix]-(\[0-9\]*)-(\[0-9\]*)\@" # Check the format and extract type_id and object_id at the same time if {![regexp $regexp_str $reply_address all object_id type_id]} { return "" } return [list $object_id $type_id] } d_proc -public send { from_user_id to_user_id reply_object_id notification_type_id subject content_text content_html file_ids } { Send the actual email. @param from_user_id The user_id of the user that the email should be sent as. Provide empty for the standard mailer from address. } { # Get user data set email [party::email -party_id $to_user_id] set user_locale [lang::user::site_wide_locale -user_id $to_user_id] if { $user_locale eq "" } { set user_locale [lang::system::site_wide_locale] } # Variable used in the content set manage_notifications_url [manage_notifications_url] if { $content_html eq "" } { set mime_type "text/plain" append content_text "\n#" "notifications.lt_Getting_too_much_emai#" set content $content_text } else { set mime_type "text/html" append content_html "<p>#" "notifications.lt_Getting_too_much_emai#</p>" set content $content_html } # convert relative URLs to fully qualified URLs set content [ad_html_qualify_links $content] # Use this to build up extra mail headers set extra_headers [list] # This should disable most auto-replies. lappend extra_headers [list "Precedence" "list"] set reply_to [reply_address -object_id $reply_object_id -type_id $notification_type_id] if { $from_user_id ni {"" 0} && [person::person_p -party_id $from_user_id]} { # Notification is sent on behalf of a person on the system. set from_email [party::email -party_id $from_user_id] if {[parameter::get \ -package_id [get_package_id] \ -parameter EmailQmailQueueScanP -default 0] != 1} { # We did not activate the processing of incoming # messages: this means we do not process replies to # notifications. There is no point in setting the # Reply-To to something different than the Sender. set reply_to "" } else { # We support notification replies. # Set the Mail-Followup-To address to the # address of the notifications handler. lappend extra_headers [list "Mail-Followup-To" $reply_to] } } else { # Notification is sent by the system itself. set from_email $reply_to } acs_mail_lite::send \ -to_addr $email \ -from_addr $from_email \ -reply_to $reply_to \ -mime_type $mime_type \ -subject [lang::util::localize $subject $user_locale] \ -body [lang::util::localize $content $user_locale] \ -file_ids $file_ids \ -use_sender \ -extraheaders $extra_headers } d_proc -public bounce_mail_message { {-to_addr:required} {-from_addr:required} {-body:required} {-message_headers:required} {-reason ""} } { This sends a bounce message indicating a failure while sending a message to the system. @author mkovach@alal.com @creation-date 05 Nov 2003 @param to_addr who the bounce is going to @param from_addr who the bouncing message as sent to @param body the message body @param message_headers the headers of the message @param reason (defaults to nothing). Reason for bounce } { set domain [address_domain] set bounce_to [parse_email_address $to_addr] set bounce_address [parse_email_address $from_addr] set bounce_from "MAILER-DAEMON@$domain" set bounce_subject "failure notice" set l "Hi. This is the notification program at $domain.\n" append l "I'm afraid I wasn't able to deliver your message to the\n" append l "following addresses. This is a permanent error; I've\n" append l "given up. Sorry it didn't work out.\n\n" append l "<$from_addr>:\n" append l "$reason\n\n" append l "--- Below is this line is a copy of the message.\n\n" append l "$message_headers\n\n" append l "$body\n" acs_mail_lite::send \ -to_addr $bounce_to \ -from_addr $bounce_from \ -subject $bounce_subject \ -body $l \ -extraheaders "" } d_proc -private load_qmail_mail_queue { {-queue_dir:required} } { Scans qmail incoming email queue and queues up messages using acs-mail. @author ben@openforce.net @author dan.wickstrom@openforce.net @creation-date 22 Sept, 2001 @param queue_dir The location of the qmail mail queue in the file-system. } { ns_log debug "load_qmail_mail_queue: checking $queue_dir/new/ for incoming mail" if {[catch { set messages [glob "$queue_dir/new/*"] } errmsg]} { if {[string match "no files matched glob pattern*" $errmsg ]} { ns_log Debug "load_qmail_mail_queue: queue dir = $queue_dir/new/*, no messages" } else { ns_log Error "load_qmail_mail_queue: queue dir = $queue_dir/new/ error $errmsg" } return {} } set list_of_reply_ids [list] set new_messages_p 0 foreach msg $messages { ns_log Debug "load_qmail_mail_queue: opening file: $msg" if {[catch {set f [open $msg r]} errmsg]} { # spit out an error message for failure to open and continue to next message ns_log Warning "load_qmail_mail_queue: error opening file $errmsg" continue } set orig_file [read $f] close $f set file [split $orig_file "\n"] set new_messages 1 set end_of_headers_p 0 set i 0 set line [lindex $file $i] set headers [list] set orig_headers "" # walk through the headers and extract each one set is_auto_reply_p 0 while {$line ne ""} { set next_line [lindex $file $i+1] if {[regexp {^[ ]*$} $next_line match] && $i > 0} { set end_of_headers_p 1 } set multiline_header_p 0 if {[regexp {^([^:]+):[ ]+(.+)$} $line match name value]} { # join headers that span more than one line (e.g. Received) if { ![regexp {^([^:]+):[ ]+(.+)$} $next_line match] && !$end_of_headers_p} { set multiline_header_p 1 } else { # we only want messages a person typed in themselves - nothing # from any sort of auto-responder. if { [string compare -nocase $name "Auto-Submitted"] == 0 } { set is_auto_reply_p 1 break } elseif { [string compare -nocase $name "Subject"] == 0 && [string first "Out of Office AutoReply:" $value] == 0 } { # added for BP set is_auto_reply_p 1 break } else { lappend headers [string tolower $name] $value append orig_headers "$line\n" } } if {$end_of_headers_p} { incr i break } } else { # The headers and the body are delimited by a null line as specified by RFC822 if {[regexp {^[ ]*$} $line match]} { incr i break } } incr i if { $multiline_header_p } { append line [lindex $file $i] } else { set line [lindex $file $i] } } # a break above just exited the while loop; now we need to skip # the rest of the foreach as well if { $is_auto_reply_p } { ns_log Debug "load_qmail_mail_queue: message $msg is from an auto-responder, skipping" if {[catch {file delete -- $msg} errmsg]} { ns_log Warning "load_qmail_mail_queue: couldn't remove message $msg: $errmsg" } continue } set body [ad_parse_incoming_email $orig_file] # okay now we have a list of headers and the body, let's # put it into notifications stuff array set email_headers $headers if {[catch {set from $email_headers(from)}]} { set from "" } if {[catch {set to $email_headers(to)}]} { set to "" } set from [parse_email_address $from] set to [parse_email_address $to] # Find the from user set from_user [party::get_by_email -email $from] # We don't accept empty users for now if {$from_user eq ""} { ns_log debug "load_qmail_mail_queue: no user for from address: $from, to: $to. bouncing message." # bounce message with an informative error. bounce_mail_message -to_addr $email_headers(from) \ -from_addr $email_headers(to) \ -body $body \ -message_headers $orig_headers \ -reason "Invalid sender. You must be a member of the site and\nyour From address must match your registered address." if {[catch {file delete -- $msg} errmsg]} { ns_log Warning "load_qmail_mail_queue: couldn't remove message $msg: $errmsg" } continue } set to_stuff [parse_reply_address -reply_address $to] # We don't accept a bad incoming email address if {$to_stuff eq ""} { ns_log debug "load_qmail_mail_queue: bad to address $to from $from. bouncing message." # bounce message here bounce_mail_message -to_addr $email_headers(from) \ -from_addr $email_headers(to) \ -body $body \ -message_headers $orig_headers \ -reason "Invalid To Address" if {[catch {file delete -- $msg} errmsg]} { ns_log Warning "load_qmail_mail_queue: couldn't remove message file $msg: $errmsg" } continue } lassign $to_stuff object_id type_id set to_addr $to db_transaction { set reply_id [notification::reply::new \ -object_id $object_id \ -type_id $type_id \ -from_user $from_user \ -subject $email_headers(subject) \ -content $body] set headers $orig_headers db_dml holdinsert {} -clobs [list $to_addr $headers $body] if {[catch {file delete -- $msg} errmsg]} { ns_log Error "load_qmail_mail_queue: unable to delete queued message $msg: $errmsg" } lappend list_of_reply_ids $reply_id } on_error { ns_log Error "load_qmail_mail_queue: error inserting incoming email into the queue: $errmsg" } } return $list_of_reply_ids } ad_proc -private scan_replies {} { scan for replies } { ns_log debug "notification::email::scan_replies: about to load qmail queue" return [load_qmail_mail_queue -queue_dir [qmail_mail_queue_dir]] } } # Local variables: # mode: tcl # tcl-indent-level: 4 # indent-tabs-mode: nil # End: