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 -N -r1.28 -r1.29
--- openacs-4/packages/acs-mail-lite/acs-mail-lite.info 24 Dec 2006 11:09:52 -0000 1.28
+++ openacs-4/packages/acs-mail-lite/acs-mail-lite.info 29 Jan 2007 17:16:50 -0000 1.29
@@ -7,7 +7,7 @@
f
t
-
+
Eric Lorenzo
Timo Hentschel
@@ -16,9 +16,9 @@
This package provides a simple ns_sendmail-like interface for sending messages, but queues messages in the database to ensure reliable sending and make sending a message 'transactional'. Prefered over acs-messaging or acs-mail.
2
-
+
+
-
Index: openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-callback-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-callback-procs.tcl,v
diff -u -N -r1.13 -r1.14
--- openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-callback-procs.tcl 10 Jan 2007 21:22:05 -0000 1.13
+++ openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-callback-procs.tcl 29 Jan 2007 17:16:50 -0000 1.14
@@ -71,8 +71,16 @@
-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
} {
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 -N -r1.66 -r1.67
--- openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl 10 Jan 2007 21:22:05 -0000 1.66
+++ openacs-4/packages/acs-mail-lite/tcl/acs-mail-lite-procs.tcl 29 Jan 2007 17:16:50 -0000 1.67
@@ -438,131 +438,6 @@
}
#---------------------------------------
- ad_proc -private -deprecated load_mail_dir {
- -queue_dir:required
- } {
- Scans qmail incoming email queue for bounced mail and processes
- these bounced mails.
-
- @author ben@openforce.net
- @author dan.wickstrom@openforce.net
- @creation-date 22 Sept, 2001
-
- @option queue_dir The location of the qmail mail queue in the file-system.
- } {
- if {[catch {
- # get list of all incoming mail
- set messages [glob "$queue_dir/new/*"]
- } errmsg]} {
- ns_log Debug "queue dir = $queue_dir/new/*, no messages"
- return [list]
- }
-
- set list_of_bounce_ids [list]
- set new_messages_p 0
-
- # loop over every incoming mail
- foreach msg $messages {
- ns_log Debug "opening file: $msg"
- if [catch {set f [open $msg r]}] {
- continue
- }
- set file [read $f]
- close $f
- set file [split $file "\n"]
-
- set new_messages 1
- set end_of_headers_p 0
- set i 0
- set line [lindex $file $i]
- set headers [list]
-
- # walk through the headers and extract each one
- while {$line ne ""} {
- set next_line [lindex $file [expr {$i + 1}]]
- if {[regexp {^[ ]*$} $next_line match] && $i > 0} {
- set end_of_headers_p 1
- }
- 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} {
- append line $next_line
- incr i
- }
- lappend headers [string tolower $name] $value
-
- 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
- set line [lindex $file $i]
- }
- set body "\n[join [lrange $file $i end] "\n"]"
-
- # 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 to [parse_email_address -email $to]
- ns_log Debug "acs-mail-lite: To: $to"
- util_unlist [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 "" || ![valid_signature -signature $signature -msg $body]} {
- if {$user_id eq ""} {
- ns_log Notice "acs-mail-lite: No user id $user_id found"
- } else {
- ns_log Notice "acs-mail-lite: Invalid mail signature"
- }
- if {[catch {ns_unlink $msg} errmsg]} {
- ns_log Notice "acs-mail-lite: couldn't remove message"
- }
- continue
- }
-
- # Try to invoke package-specific procedure for special treatment
- # of mail bounces
- if {$package_id ne ""} {
- catch {acs_sc::invoke -contract AcsMailLite -operation MailBounce -impl [string map {- _} [apm_package_key_from_id $package_id]] -call_args [list [array get email_headers] $body]}
- }
-
- # Okay, we have a bounce for a system user
- # Check if the user has been marked as bouncing mail
- # if the user is bouncing mail, we simply disgard the
- # bounce since it was sent before the user's email was
- # disabled.
-
- ns_log Debug "Bounce checking: $to, $user_id"
-
- if { ![bouncing_user_p -user_id $user_id] } {
- ns_log Notice "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 {}
- }
- }
- catch {ns_unlink $msg}
- }
- }
-
- #---------------------------------------
ad_proc -public scan_replies {} {
Scheduled procedure that will scan for bounced mails
} {
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 -N
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-mail-lite/tcl/incoming-mail-procs.tcl 29 Jan 2007 17:16:51 -0000 1.1
@@ -0,0 +1,236 @@
+ad_library {
+
+ Provides a simple API for reliably sending email.
+
+ @author Eric Lorenzo (eric@openforce.net)
+ @creation-date 22 March 2002
+ @cvs-id $Id: incoming-mail-procs.tcl,v 1.1 2007/01/29 17:16: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 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)]
+
+ # Special treatment for e-mails which look like they contain an object_id
+ set callback_executed_p 0
+ set pot_object_id [lindex [split $email(to) "@"] 0]
+ 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 callback_executed_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}]} {
+ 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
+ }
+
+}
\ No newline at end of file