# list.pm - This module includes all list processing functions # RCS Identication ; $Revision: 5404 $ ; $Date: 2008-12-09 15:06:48 +0100 (mar, 09 déc 2008) $ # # Sympa - SYsteme de Multi-Postage Automatique # Copyrigh (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites # Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel # # 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 # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License# along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. package List; use strict; use Datasource; use SQLSource qw(create_db %date_format); use Upgrade; use Lock; use Task; use Scenario; require Fetch; require Exporter; require Encode; require 'tools.pl'; require "--LIBDIR--/tt2.pl"; my @ISA = qw(Exporter); my @EXPORT = qw(%list_of_lists); use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN); =head1 CONSTRUCTOR =item new( [PHRASE] ) List->new(); Creates a new object which will be used for a list and eventually loads the list if a name is given. Returns a List object. =back =head1 METHODS =over 4 =item load ( LIST ) Loads the indicated list into the object. =item save ( LIST ) Saves the indicated list object to the disk files. =item savestats () Saves updates the statistics file on disk. =item update_stats( BYTES ) Updates the stats, argument is number of bytes, returns the next sequence number. Does nothing if no stats. =item send_sub_to_owner ( WHO, COMMENT ) Send a message to the list owners telling that someone wanted to subscribe to the list. =item send_to_editor ( MSG ) Send a Mail::Internet type object to the editor (for approval). =item send_msg ( MSG ) Sends the Mail::Internet message to the list. =item send_file ( FILE, USER, GECOS ) Sends the file to the USER. FILE may only be welcome for now. =item delete_user ( ARRAY ) Delete the indicated users from the list. =item delete_admin_user ( ROLE, ARRAY ) Delete the indicated admin user with the predefined role from the list. =item get_cookie () Returns the cookie for a list, if available. =item get_max_size () Returns the maximum allowed size for a message. =item get_reply_to () Returns an array with the Reply-To values. =item get_default_user_options () Returns a default option of the list for subscription. =item get_total () Returns the number of subscribers to the list. =item get_user_db ( USER ) Returns a hash with the informations regarding the indicated user. =item get_subscriber ( USER ) Returns a subscriber of the list. =item get_admin_user ( ROLE, USER) Return an admin user of the list with predefined role =item get_first_user () Returns a hash to the first user on the list. =item get_first_admin_user ( ROLE ) Returns a hash to the first admin user with predefined role on the list. =item get_next_user () Returns a hash to the next users, until we reach the end of the list. =item get_next_admin_user () Returns a hash to the next admin users, until we reach the end of the list. =item update_user ( USER, HASHPTR ) Sets the new values given in the hash for the user. =item update_admin_user ( USER, ROLE, HASHPTR ) Sets the new values given in the hash for the admin user. =item add_user ( USER, HASHPTR ) Adds a new user to the list. May overwrite existing entries. =item add_admin_user ( USER, ROLE, HASHPTR ) Adds a new admin user to the list. May overwrite existing entries. =item is_user ( USER ) Returns true if the indicated user is member of the list. =item am_i ( FUNCTION, USER ) Returns true is USER has FUNCTION (owner, editor) on the list. =item get_state ( FLAG ) Returns the value for a flag : sig or sub. =item may_do ( ACTION, USER ) Chcks is USER may do the ACTION for the list. ACTION can be one of following : send, review, index, getm add, del, reconfirm, purge. =item is_moderated () Returns true if the list is moderated. =item archive_exist ( FILE ) Returns true if the indicated file exists. =item archive_send ( WHO, FILE ) Send the indicated archive file to the user, if it exists. =item archive_ls () Returns the list of available files, if any. =item archive_msg ( MSG ) Archives the Mail::Internet message given as argument. =item is_archived () Returns true is the list is configured to keep archives of its messages. =item get_stats ( OPTION ) Returns either a formatted printable strings or an array whith the statistics. OPTION can be 'text' or 'array'. =item print_info ( FDNAME ) Print the list informations to the given file descriptor, or the currently selected descriptor. =cut use Carp; use IO::Scalar; use Storable; use Mail::Header; use Archive; use Language; use Log; use Conf; use mail; use Ldap; use Time::Local; use MIME::Entity; use MIME::EncWords; use MIME::WordDecoder; use MIME::Parser; use Message; use Family; use PlainDigest; ## Database and SQL statement handlers my ($dbh, $sth, $db_connected, @sth_stack, $use_db); my %list_cache; ## DB fields with numeric type ## We should not do quote() for these while inserting data my %numeric_field = ('cookie_delay_user' => 1, 'bounce_score_subscriber' => 1, 'subscribed_subscriber' => 1, 'included_subscriber' => 1, 'subscribed_admin' => 1, 'included_admin' => 1, ); ## List parameters defaults my %default = ('occurrence' => '0-1', 'length' => 25 ); my @param_order = qw (subject visibility info subscribe add unsubscribe del owner owner_include send editor editor_include account topics host lang web_archive archive digest digest_max_size available_user_options default_user_options msg_topic msg_topic_keywords_apply_on msg_topic_tagging reply_to_header reply_to forced_reply_to * verp_rate welcome_return_path remind_return_path user_data_source include_file include_remote_file include_list include_remote_sympa_list include_ldap_query include_ldap_2level_query include_sql_query include_admin ttl distribution_ttl creation update status serial custom_attribute); ## List parameters aliases my %alias = ('reply-to' => 'reply_to', 'replyto' => 'reply_to', 'forced_replyto' => 'forced_reply_to', 'forced_reply-to' => 'forced_reply_to', 'custom-subject' => 'custom_subject', 'custom-header' => 'custom_header', 'subscription' => 'subscribe', 'unsubscription' => 'unsubscribe', 'max-size' => 'max_size'); ############################################################## ## This hash COMPLETELY defines ALL list parameters ## It is then used to load, save, view, edit list config files ############################################################## ## List parameters format accepts the following keywords : ## format : Regexp aplied to the configuration file entry; ## some common regexps are defined in %regexp ## file_format : Config file format of the parameter might not be ## the same in memory ## split_char: Character used to separate multiple parameters ## length : Length of a scalar variable ; used in web forms ## scenario : tells that the parameter is a scenario, providing its name ## default : Default value for the param ; may be a configuration parameter (conf) ## synonym : Defines synonyms for parameter values (for compatibility reasons) ## unit : Unit of the parameter ; this is used in web forms ## occurrence : Occurerence of the parameter in the config file ## possible values: 0-1 | 1 | 0-n | 1-n ## example : a list may have multiple owner ## gettext_id : Title reference in NLS catalogues ## description : deescription text of a parameter ## group : Group of parameters ## obsolete : Obsolete parameter ; should not be displayed ## nor saved ## obsolete_values : defined obsolete values for a parameter ## these values should not get proposed on the web interface edition form ## order : Order of parameters within paragraph ## internal : Indicates that the parameter is an internal parameter ## that should always be saved in the config file ## field_type : used to select passwords web input type ############################################################### %::pinfo = ('account' => {'format' => '\S+', 'length' => 10, 'gettext_id' => "Account", 'group' => 'other' }, 'add' => {'scenario' => 'add', 'gettext_id' => "Who can add subscribers", 'group' => 'command' }, 'anonymous_sender' => {'format' => '.+', 'gettext_id' => "Anonymous sender", 'group' => 'sending' }, 'archive' => {'format' => {'period' => {'format' => ['day','week','month','quarter','year'], 'synonym' => {'weekly' => 'week'}, 'gettext_id' => "frequency", 'order' => 1 }, 'access' => {'format' => ['open','private','public','owner','closed'], 'synonym' => {'open' => 'public'}, 'gettext_id' => "access right", 'order' => 2 } }, 'gettext_id' => "Text archives", 'group' => 'archives' }, 'archive_crypted_msg' => {'format' => ['original','decrypted'], 'default' => 'original', 'gettext_id' => "Archive encrypted mails as cleartext", 'group' => 'archives' }, 'available_user_options' => {'format' => {'reception' => {'format' => ['mail','notice','digest','digestplain','summary','nomail','txt','html','urlize','not_me'], 'occurrence' => '1-n', 'split_char' => ',', 'default' => 'mail,notice,digest,digestplain,summary,nomail,txt,html,urlize,not_me', 'gettext_id' => "reception mode" }, }, 'gettext_id' => "Available subscription options", 'group' => 'sending' }, 'bounce' => {'format' => {'warn_rate' => {'format' => '\d+', 'length' => 3, 'unit' => '%', 'default' => {'conf' => 'bounce_warn_rate'}, 'gettext_id' => "warn rate", 'order' => 1 }, 'halt_rate' => {'format' => '\d+', 'length' => 3, 'unit' => '%', 'default' => {'conf' => 'bounce_halt_rate'}, 'gettext_id' => "halt rate", 'order' => 2 } }, 'gettext_id' => "Bounces management", 'group' => 'bounces' }, 'bouncers_level1' => {'format' => {'rate' => {'format' => '\d+', 'length' => 2, 'unit' => 'Points', 'default' => {'conf' => 'default_bounce_level1_rate'}, 'gettext_id' => "threshold", 'order' => 1 }, 'action' => {'format' => ['remove_bouncers','notify_bouncers','none'], 'default' => 'notify_bouncers', 'gettext_id' => "action for this population", 'order' => 2 }, 'notification' => {'format' => ['none','owner','listmaster'], 'default' => 'owner', 'gettext_id' => "notification", 'order' => 3 } }, 'gettext_id' => "Management of bouncers, 1st level", 'group' => 'bounces' }, 'bouncers_level2' => {'format' => {'rate' => {'format' => '\d+', 'length' => 2, 'unit' => 'Points', 'default' => {'conf' => 'default_bounce_level2_rate'}, 'gettext_id' => "threshold", 'order' => 1 }, 'action' => {'format' => ['remove_bouncers','notify_bouncers','none'], 'default' => 'remove_bouncers', 'gettext_id' => "action for this population", 'order' => 2 }, 'notification' => {'format' => ['none','owner','listmaster'], 'default' => 'owner', 'gettext_id' => "notification", 'order' => 3 } }, 'gettext_id' => "Management of bouncers, 2nd level", 'group' => 'bounces' }, 'clean_delay_queuemod' => {'format' => '\d+', 'length' => 3, 'unit' => 'days', 'default' => {'conf' => 'clean_delay_queuemod'}, 'gettext_id' => "Expiration of unmoderated messages", 'group' => 'other' }, 'cookie' => {'format' => '\S+', 'length' => 15, 'default' => {'conf' => 'cookie'}, 'gettext_id' => "Secret string for generating unique keys", 'group' => 'other' }, 'creation' => {'format' => {'date_epoch' => {'format' => '\d+', 'occurrence' => '1', 'gettext_id' => "", 'order' => 3 }, 'date' => {'format' => '.+', 'gettext_id' => "", 'order' => 2 }, 'email' => {'format' => 'listmaster|'.&tools::get_regexp('email'), 'occurrence' => '1', 'gettext_id' => "", 'order' => 1 } }, 'gettext_id' => "Creation of the list", 'occurrence' => '0-1', 'internal' => 1, 'group' => 'other' }, 'custom_attribute' => { 'format' => { 'id' => { 'format' => '\w+', 'length' => 20, 'gettext_id' => "internal identifier", 'occurrence' => '1', 'order' =>1 }, 'name' => { 'format' => '.+', 'length' =>30, 'occurrence' => '1', 'gettext_id' => "label", 'order' => 2 }, 'comment' => { 'format' => '.+', 'length' => 100, 'gettext_id' => "additional comment", 'order' => 3 }, 'type' => { 'format' => ['string','text','integer','enum'], 'default' => 'string', 'occurence' => 1, 'gettext_id' => "type", 'order' => 4 }, 'enum_values' => { 'format' => '.+', 'length' => 100, 'gettext_id' => "possible attribute values (if enum is used)", 'order' => 5 }, 'optional' => { 'format' => ['required','optional'], 'gettext_id' => "is the attribute optionnal ?", 'order' => 6 } }, 'occurrence' => '0-n', 'gettext_id' => "Custom user attributes", 'group' => 'other' }, 'custom_header' => {'format' => '\S+:\s+.*', 'length' => 30, 'occurrence' => '0-n', 'gettext_id' => "Custom header field", 'group' => 'sending' }, 'custom_subject' => {'format' => '.+', 'length' => 15, 'gettext_id' => "Subject tagging", 'group' => 'sending' }, 'custom_vars' => {'format' => {'name' => {'format' => '\S+', 'occurrence' => '1', 'gettext_id' => 'var name', 'order' => 1 }, 'value' => {'format' => '\S+', 'occurrence' => '1', 'gettext_id' => 'var value', 'order' => 2 } }, 'gettext_id' => "custom parameters", 'occurrence' => '0-n', 'group' => 'other' }, 'default_user_options' => {'format' => {'reception' => {'format' => ['digest','digestplain','mail','nomail','summary','notice','txt','html','urlize','not_me'], 'default' => 'mail', 'gettext_id' => "reception mode", 'order' => 1 }, 'visibility' => {'format' => ['conceal','noconceal'], 'default' => 'noconceal', 'gettext_id' => "visibility", 'order' => 2 } }, 'gettext_id' => "Subscription profile", 'group' => 'sending' }, 'del' => {'scenario' => 'del', 'gettext_id' => "Who can delete subscribers", 'group' => 'command' }, 'digest' => {'file_format' => '\d+(\s*,\s*\d+)*\s+\d+:\d+', 'format' => {'days' => {'format' => [0..6], 'file_format' => '1|2|3|4|5|6|7', 'occurrence' => '1-n', 'gettext_id' => "days", 'order' => 1 }, 'hour' => {'format' => '\d+', 'length' => 2, 'occurrence' => '1', 'gettext_id' => "hour", 'order' => 2 }, 'minute' => {'format' => '\d+', 'length' => 2, 'occurrence' => '1', 'gettext_id' => "minute", 'order' => 3 } }, 'gettext_id' => "Digest frequency", 'group' => 'sending' }, 'digest_max_size' => {'format' => '\d+', 'length' => 2, 'unit' => 'messages', 'default' => 25, 'gettext_id' => "Digest maximum number of messages", 'group' => 'sending' }, 'distribution_ttl' => {'format' => '\d+', 'length' => 6, 'unit' => 'seconds', 'gettext_id' => "Inclusions timeout for message distribution", 'group' => 'data_source' }, 'editor' => {'format' => {'email' => {'format' => &tools::get_regexp('email'), 'length' => 30, 'occurrence' => '1', 'gettext_id' => "email address", 'order' => 1 }, 'reception' => {'format' => ['mail','nomail'], 'default' => 'mail', 'gettext_id' => "reception mode", 'order' => 4 }, 'visibility' => {'format' => ['conceal','noconceal'], 'default' => 'noconceal', 'gettext_id' => "visibility", 'order' => 5 }, 'gecos' => {'format' => '.+', 'length' => 30, 'gettext_id' => "name", 'order' => 2 }, 'info' => {'format' => '.+', 'length' => 30, 'gettext_id' => "private information", 'order' => 3 } }, 'occurrence' => '0-n', 'gettext_id' => "Moderators", 'group' => 'description' }, 'editor_include' => {'format' => {'source' => {'datasource' => 1, 'occurrence' => '1', 'gettext_id' => 'the datasource', 'order' => 1 }, 'source_parameters' => {'format' => '.*', 'occurrence' => '0-1', 'gettext_id' => 'datasource parameters', 'order' => 2 }, 'reception' => {'format' => ['mail','nomail'], 'default' => 'mail', 'gettext_id' => 'reception mode', 'order' => 3 }, 'visibility' => {'format' => ['conceal','noconceal'], 'default' => 'noconceal', 'gettext_id' => "visibility", 'order' => 5 } }, 'occurrence' => '0-n', 'gettext_id' => 'Moderators defined in an external datasource', 'group' => 'description', }, 'expire_task' => {'task' => 'expire', 'gettext_id' => "Periodical subscription expiration task", 'group' => 'other' }, 'family_name' => {'format' => &tools::get_regexp('family_name'), 'occurrence' => '0-1', 'gettext_id' => 'Family name', 'internal' => 1, 'group' => 'description' }, 'footer_type' => {'format' => ['mime','append'], 'default' => 'mime', 'gettext_id' => "Attachment type", 'group' => 'sending' }, 'forced_reply_to' => {'format' => '\S+', 'gettext_id' => "Forced reply address", 'obsolete' => 1 }, 'host' => {'format' => &tools::get_regexp('host'), 'length' => 20, 'default' => {'conf' => 'host'}, 'gettext_id' => "Internet domain", 'group' => 'description' }, 'include_file' => {'format' => '\S+', 'length' => 20, 'occurrence' => '0-n', 'gettext_id' => "File inclusion", 'group' => 'data_source' }, 'include_remote_file' => {'format' => {'url' => {'format' => '.+', 'gettext_id' => "data location URL", 'occurrence' => '1', 'length' => 50, 'order' => 2 }, 'user' => {'format' => '.+', 'gettext_id' => "remote user", 'order' => 3, 'occurrence' => '0-1' }, 'passwd' => {'format' => '.+', 'length' => 10, 'field_type' => 'password', 'gettext_id' => "remote password", 'order' => 4, 'occurrence' => '0-1' }, 'name' => {'format' => '.+', 'gettext_id' => "short name for this source", 'length' => 15, 'order' => 1 } }, 'gettext_id' => "Remote file inclusion", 'occurrence' => '0-n', 'group' => 'data_source' }, 'include_ldap_query' => {'format' => {'host' => {'format' => &tools::get_regexp('multiple_host_with_port'), 'occurrence' => '1', 'gettext_id' => "remote host", 'order' => 2 }, 'port' => {'format' => '\d+', 'length' => 4, 'gettext_id' => "remote port", 'obsolete' => 1, 'order' => 2 }, 'user' => {'format' => '.+', 'gettext_id' => "remote user", 'order' => 3 }, 'passwd' => {'format' => '.+', 'length' => 10, 'field_type' => 'password', 'gettext_id' => "remote password", 'order' => 3 }, 'suffix' => {'format' => '.+', 'gettext_id' => "suffix", 'order' => 4 }, 'filter' => {'format' => '.+', 'length' => 50, 'occurrence' => '1', 'gettext_id' => "filter", 'order' => 7 }, 'attrs' => {'format' => '\w+', 'length' => 15, 'default' => 'mail', 'gettext_id' => "extracted attribute", 'order' => 8 }, 'select' => {'format' => ['all','first'], 'default' => 'first', 'gettext_id' => "selection (if multiple)", 'order' => 9 }, 'scope' => {'format' => ['base','one','sub'], 'default' => 'sub', 'gettext_id' => "search scope", 'order' => 5 }, 'timeout' => {'format' => '\w+', 'default' => 30, 'unit' => 'seconds', 'gettext_id' => "connection timeout", 'order' => 6 }, 'name' => {'format' => '.+', 'gettext_id' => "short name for this source", 'length' => 15, 'order' => 1 }, 'use_ssl' => {'format' => ['yes','no'], 'default' => 'no', 'gettext_id' => 'use SSL (LDAPS)', 'order' => 2.5, }, 'ssl_version' => {'format' => ['sslv2','sslv3','tls'], 'default' => 'sslv3', 'gettext_id' => 'SSL version', 'order' => 2.5, }, 'ssl_ciphers' => {'format' => '.+', 'default' => 'ALL', 'gettext_id' => 'SSL ciphers used', 'order' => 2.5, }, }, 'occurrence' => '0-n', 'gettext_id' => "LDAP query inclusion", 'group' => 'data_source' }, 'include_ldap_2level_query' => {'format' => {'host' => {'format' => &tools::get_regexp('multiple_host_with_port'), 'occurrence' => '1', 'gettext_id' => "remote host", 'order' => 1 }, 'port' => {'format' => '\d+', 'length' => 4, 'gettext_id' => "remote port", 'obsolete' => 1, 'order' => 2 }, 'user' => {'format' => '.+', 'gettext_id' => "remote user", 'order' => 3 }, 'passwd' => {'format' => '.+', 'length' => 10, 'field_type' => 'password', 'gettext_id' => "remote password", 'order' => 3 }, 'suffix1' => {'format' => '.+', 'gettext_id' => "first-level suffix", 'order' => 4 }, 'filter1' => {'format' => '.+', 'length' => 50, 'occurrence' => '1', 'gettext_id' => "first-level filter", 'order' => 7 }, 'attrs1' => {'format' => '\w+', 'length' => 15, 'gettext_id' => "first-level extracted attribute", 'order' => 8 }, 'select1' => {'format' => ['all','first','regex'], 'default' => 'first', 'gettext_id' => "first-level selection", 'order' => 9 }, 'scope1' => {'format' => ['base','one','sub'], 'default' => 'sub', 'gettext_id' => "first-level search scope", 'order' => 5 }, 'timeout1' => {'format' => '\w+', 'default' => 30, 'unit' => 'seconds', 'gettext_id' => "first-level connection timeout", 'order' => 6 }, 'regex1' => {'format' => '.+', 'length' => 50, 'default' => '', 'gettext_id' => "first-level regular expression", 'order' => 10 }, 'suffix2' => {'format' => '.+', 'gettext_id' => "second-level suffix template", 'order' => 11 }, 'filter2' => {'format' => '.+', 'length' => 50, 'occurrence' => '1', 'gettext_id' => "second-level filter template", 'order' => 14 }, 'attrs2' => {'format' => '\w+', 'length' => 15, 'default' => 'mail', 'gettext_id' => "second-level extracted attribute", 'order' => 15 }, 'select2' => {'format' => ['all','first','regex'], 'default' => 'first', 'gettext_id' => "second-level selection", 'order' => 16 }, 'scope2' => {'format' => ['base','one','sub'], 'default' => 'sub', 'gettext_id' => "second-level search scope", 'order' => 12 }, 'timeout2' => {'format' => '\w+', 'default' => 30, 'unit' => 'seconds', 'gettext_id' => "second-level connection timeout", 'order' => 13 }, 'regex2' => {'format' => '.+', 'length' => 50, 'default' => '', 'gettext_id' => "second-level regular expression", 'order' => 17 }, 'name' => {'format' => '.+', 'gettext_id' => "short name for this source", 'length' => 15, 'order' => 1 }, 'use_ssl' => {'format' => ['yes','no'], 'default' => 'no', 'gettext_id' => 'use SSL (LDAPS)', 'order' => 2.5, }, 'ssl_version' => {'format' => ['sslv2','sslv3','tls'], 'default' => '', 'gettext_id' => 'SSL version', 'order' => 2.5, }, 'ssl_ciphers' => {'format' => '.+', 'default' => 'ALL', 'gettext_id' => 'SSL ciphers used', 'order' => 2.5, }, }, 'occurrence' => '0-n', 'gettext_id' => "LDAP 2-level query inclusion", 'group' => 'data_source' }, 'include_list' => {'format' => &tools::get_regexp('listname').'(\@'.&tools::get_regexp('host').')?', 'occurrence' => '0-n', 'gettext_id' => "List inclusion", 'group' => 'data_source' }, 'include_remote_sympa_list' => {'format' => {'host' => {'format' => &tools::get_regexp('host'), 'occurrence' => '1', 'gettext_id' => "remote host", 'order' => 1 }, 'port' => {'format' => '\d+', 'default' => 443, 'length' => 4, 'gettext_id' => "remote port", 'order' => 2 }, 'path' => {'format' => '\S+', 'length' => 20, 'occurrence' => '1', 'gettext_id' => "remote path of sympa list dump", 'order' => 3 }, 'cert' => {'format' => ['robot','list'], 'gettext_id' => "certificate for authentication by remote Sympa", 'default' => 'list', 'order' => 4 }, 'name' => {'format' => '.+', 'gettext_id' => "short name for this source", 'length' => 15, 'order' => 1 } }, 'occurrence' => '0-n', 'gettext_id' => "remote list inclusion", 'group' => 'data_source' }, 'include_sql_query' => {'format' => {'db_type' => {'format' => '\S+', 'occurrence' => '1', 'gettext_id' => "database type", 'order' => 1 }, 'host' => {'format' => &tools::get_regexp('host'), 'occurrence' => '1', 'gettext_id' => "remote host", 'order' => 2 }, 'db_port' => {'format' => '\d+', 'gettext_id' => "database port", 'order' => 3 }, 'db_name' => {'format' => '\S+', 'occurrence' => '1', 'gettext_id' => "database name", 'order' => 4 }, 'connect_options' => {'format' => '.+', 'gettext_id' => "connection options", 'order' => 4 }, 'db_env' => {'format' => '\w+\=\S+(;\w+\=\S+)*', 'order' => 5, 'gettext_id' => "environment variables for database connexion" }, 'user' => {'format' => '\S+', 'occurrence' => '1', 'gettext_id' => "remote user", 'order' => 6 }, 'passwd' => {'format' => '.+', 'field_type' => 'password', 'gettext_id' => "remote password", 'order' => 7 }, 'sql_query' => {'format' => &tools::get_regexp('sql_query'), 'length' => 50, 'occurrence' => '1', 'gettext_id' => "SQL query", 'order' => 8 }, 'f_dir' => {'format' => '.+', 'gettext_id' => "Directory where the database is stored (used for DBD::CSV only)", 'order' => 9 }, 'name' => {'format' => '.+', 'gettext_id' => "short name for this source", 'length' => 15, 'order' => 1 } }, 'occurrence' => '0-n', 'gettext_id' => "SQL query inclusion", 'group' => 'data_source' }, 'info' => {'scenario' => 'info', 'gettext_id' => "Who can view list information", 'group' => 'command' }, 'invite' => {'scenario' => 'invite', 'gettext_id' => "Who can invite people", 'group' => 'command' }, 'lang' => {'format' => [], ## &Language::GetSupportedLanguages() called later 'file_format' => '\w+', 'default' => {'conf' => 'lang'}, 'gettext_id' => "Language of the list", 'group' => 'description' }, 'latest_instantiation' => {'format' => {'date_epoch' => {'format' => '\d+', 'occurrence' => '1', 'gettext_id' => 'epoch date', 'order' => 3 }, 'date' => {'format' => '.+', 'gettext_id' => 'date', 'order' => 2 }, 'email' => {'format' => 'listmaster|'.&tools::get_regexp('email'), 'occurrence' => '0-1', 'gettext_id' => 'who ran the instantiation', 'order' => 1 } }, 'gettext_id' => 'Latest family instantiation', 'internal' => 1, 'group' => 'other' }, 'loop_prevention_regex' => {'format' => '\S*', 'length' => 70, 'default' => {'conf' => 'loop_prevention_regex'}, 'gettext_id' => "Regular expression applied to prevent loops with robots", 'group' => 'other' }, 'max_size' => {'format' => '\d+', 'length' => 8, 'unit' => 'bytes', 'default' => {'conf' => 'max_size'}, 'gettext_id' => "Maximum message size", 'group' => 'sending' }, 'msg_topic' => {'format' => {'name' => {'format' => '\w+', 'length' => 15, 'occurrence' => '1', 'gettext_id' => "Message topic name", 'order' => 1 }, 'keywords' => {'format' => '[^,\n]+(,[^,\n]+)*', 'occurrence' => '0-1', 'gettext_id' => "Message topic keywords", 'order' => 2 }, 'title' => {'format' => '.+', 'length' => 35, 'occurrence' => '1', 'gettext_id' => "Message topic title", 'order' => 3 } }, 'occurrence' => '0-n', 'gettext_id' => "Topics for message categorization", 'group' => 'sending' }, 'msg_topic_keywords_apply_on' => { 'format' => ['subject','body','subject_and_body'], 'occurrence' => '0-1', 'default' => 'subject', 'gettext_id' => "Defines to which part of messages topic keywords are applied", 'group' => 'sending' }, 'msg_topic_tagging' => { 'format' => ['required_sender','required_moderator','optional'], 'occurrence' => '0-1', 'default' => 'optional', 'gettext_id' => "Message tagging", 'group' => 'sending' }, 'owner' => {'format' => {'email' => {'format' => &tools::get_regexp('email'), 'length' =>30, 'occurrence' => '1', 'gettext_id' => "email address", 'order' => 1 }, 'reception' => {'format' => ['mail','nomail'], 'default' => 'mail', 'gettext_id' => "reception mode", 'order' =>5 }, 'visibility' => {'format' => ['conceal','noconceal'], 'default' => 'noconceal', 'gettext_id' => "visibility", 'order' => 6 }, 'gecos' => {'format' => '.+', 'length' => 30, 'gettext_id' => "name", 'order' => 2 }, 'info' => {'format' => '.+', 'length' => 30, 'gettext_id' => "private informations", 'order' => 3 }, 'profile' => {'format' => ['privileged','normal'], 'default' => 'normal', 'gettext_id' => "profile", 'order' => 4 } }, 'occurrence' => '0-n', 'gettext_id' => "Owner", 'group' => 'description' }, 'owner_include' => {'format' => {'source' => {'datasource' => 1, 'occurrence' => '1', 'gettext_id' => 'the datasource', 'order' => 1 }, 'source_parameters' => {'format' => '.*', 'occurrence' => '0-1', 'gettext_id' => 'datasource parameters', 'order' => 2 }, 'reception' => {'format' => ['mail','nomail'], 'default' => 'mail', 'gettext_id' => 'reception mode', 'order' => 4 }, 'visibility' => {'format' => ['conceal','noconceal'], 'default' => 'noconceal', 'gettext_id' => "visibility", 'order' => 5 }, 'profile' => {'format' => ['privileged','normal'], 'default' => 'normal', 'gettext_id' => 'profile', 'order' => 3 } }, 'occurrence' => '0-n', 'gettext_id' => 'Owners defined in an external datasource', 'group' => 'description', }, 'priority' => {'format' => [0..9,'z'], 'length' => 1, 'default' => {'conf' => 'default_list_priority'}, 'gettext_id' => "Priority", 'group' => 'description' }, 'remind' => {'scenario' => 'remind', 'gettext_id' => "Who can start a remind process", 'group' => 'command' }, 'remind_return_path' => {'format' => ['unique','owner'], 'default' => {'conf' => 'remind_return_path'}, 'gettext_id' => "Return-path of the REMIND command", 'group' => 'bounces' }, 'remind_task' => {'task' => 'remind', 'gettext_id' => 'Periodical subscription reminder task', 'default' => {'conf' => 'default_remind_task'}, 'group' => 'other' }, 'remove_headers' => {'format' => '\S+', 'gettext_id' => 'Incoming SMTP headers fields to be removed', 'default' => {'conf' => 'remove_headers'}, 'group' => 'sending', 'occurrence' => '0-n', 'split_char' => ',', }, 'remove_outgoing_headers' => {'format' => '\S+', 'gettext_id' => 'Outgoing SMTP headers fields to be removed', 'default' => {'conf' => 'remove_outgoing_headers'}, 'group' => 'sending', 'occurrence' => '0-n', 'split_char' => ',', }, 'reply_to' => {'format' => '\S+', 'default' => 'sender', 'gettext_id' => "Reply address", 'group' => 'sending', 'obsolete' => 1 }, 'reply_to_header' => {'format' => {'value' => {'format' => ['sender','list','all','other_email'], 'default' => 'sender', 'gettext_id' => "value", 'occurrence' => '1', 'order' => 1 }, 'other_email' => {'format' => &tools::get_regexp('email'), 'gettext_id' => "other email address", 'order' => 2 }, 'apply' => {'format' => ['forced','respect'], 'default' => 'respect', 'gettext_id' => "respect of existing header field", 'order' => 3 } }, 'gettext_id' => "Reply address", 'group' => 'sending' }, 'review' => {'scenario' => 'review', 'synonym' => {'open' => 'public'}, 'gettext_id' => "Who can review subscribers", 'group' => 'command' }, 'rfc2369_header_fields' => {'format' => ['help','subscribe','unsubscribe','post','owner','archive'], 'default' => {'conf' => 'rfc2369_header_fields'}, 'occurrence' => '0-n', 'split_char' => ',', 'gettext_id' => "RFC 2369 Header fields", 'group' => 'sending' }, 'send' => {'scenario' => 'send', 'gettext_id' => "Who can send messages", 'group' => 'sending' }, 'serial' => {'format' => '\d+', 'default' => 0, 'length' => 3, 'default' => 0, 'gettext_id' => "Serial number of the config", 'internal' => 1, 'group' => 'other' }, 'shared_doc' => {'format' => {'d_read' => {'scenario' => 'd_read', 'gettext_id' => "Who can view", 'order' => 1 }, 'd_edit' => {'scenario' => 'd_edit', 'gettext_id' => "Who can edit", 'order' => 2 }, 'quota' => {'format' => '\d+', 'default' => {'conf' => 'default_shared_quota'}, 'length' => 8, 'unit' => 'Kbytes', 'gettext_id' => "quota", 'order' => 3 } }, 'gettext_id' => "Shared documents", 'group' => 'command' }, 'spam_protection' => {'format' => ['at','javascript','none'], 'default' => 'javascript', 'gettext_id' => "email address protection method", 'group' => 'other' }, 'web_archive_spam_protection' => {'format' => ['cookie','javascript','at','none'], 'default' => {'conf' => 'web_archive_spam_protection'}, 'gettext_id' => "email address protection method", 'group' => 'archives' }, 'status' => {'format' => ['open','closed','pending','error_config','family_closed'], 'default' => 'open', 'gettext_id' => "Status of the list", 'internal' => 1, 'group' => 'other' }, 'subject' => {'format' => '.+', 'length' => 50, 'occurrence' => '1', 'gettext_id' => "Subject of the list", 'group' => 'description' }, 'subscribe' => {'scenario' => 'subscribe', 'gettext_id' => "Who can subscribe to the list", 'group' => 'command' }, 'topics' => {'format' => '\w+(\/\w+)?', 'split_char' => ',', 'occurrence' => '0-n', 'gettext_id' => "Topics for the list", 'group' => 'description' }, 'ttl' => {'format' => '\d+', 'length' => 6, 'unit' => 'seconds', 'default' => 3600, 'gettext_id' => "Inclusions timeout", 'group' => 'data_source' }, 'unsubscribe' => {'scenario' => 'unsubscribe', 'gettext_id' => "Who can unsubscribe", 'group' => 'command' }, 'update' => {'format' => {'date_epoch' => {'format' => '\d+', 'length' => 8, 'occurrence' => '1', 'gettext_id' => 'epoch date', 'order' => 3 }, 'date' => {'format' => '.+', 'length' => 30, 'gettext_id' => 'date', 'order' => 2 }, 'email' => {'format' => '(listmaster|automatic|'.&tools::get_regexp('email').')', 'length' => 30, 'occurrence' => '1', 'gettext_id' => 'who updated the config', 'order' => 1 } }, 'gettext_id' => "Last update of config", 'internal' => 1, 'group' => 'other' }, 'user_data_source' => {'format' => ['database','file','include','include2'], 'default' => 'include2', 'obsolete_values'=> ['database','file','include'], 'gettext_id' => "User data source", 'group' => 'data_source' }, 'pictures_feature' => {'format' => ['on','off'], 'occurence' => '0-1', 'default' => {'conf' => 'pictures_feature'}, 'gettext_id' => "Allow picture display ? (must be enabled for the current robot)", 'group' => 'other' }, 'visibility' => {'scenario' => 'visibility', 'synonym' => {'public' => 'noconceal', 'private' => 'conceal'}, 'gettext_id' => "Visibility of the list", 'group' => 'description' }, 'web_archive' => {'format' => {'access' => {'scenario' => 'access_web_archive', 'gettext_id' => "access right", 'order' => 1 }, 'quota' => {'format' => '\d+', 'default' => {'conf' => 'default_archive_quota'}, 'length' => 8, 'unit' => 'Kbytes', 'gettext_id' => "quota", 'order' => 2 }, 'max_month' => {'format' => '\d+', 'length' => 3, 'gettext_id' => "Maximum number of month archived", 'order' => 3 } }, 'gettext_id' => "Web archives", 'group' => 'archives' }, 'welcome_return_path' => {'format' => ['unique','owner'], 'default' => {'conf' => 'welcome_return_path'}, 'gettext_id' => "Welcome return-path", 'group' => 'bounces' }, 'verp_rate' => {'format' => ['100%','50%','33%','25%','20%','10%','5%','2%','0%'], 'default' => {'conf' => 'verp_rate'}, 'gettext_id' => "percentage of list members in VERP mode", 'group' => 'bounces' }, ); ## This is the generic hash which keeps all lists in memory. my %list_of_lists = (); my %list_of_robots = (); our %list_of_topics = (); my %edit_list_conf = (); ## Last modification times my %mtime; use Fcntl; use DB_File; $DB_BTREE->{compare} = \&_compare_addresses; ## Connect to Database sub db_connect { my $option = shift; do_log('debug2', 'List::db_connect'); my $connect_string; ## Check if already connected if ($dbh && $dbh->ping()) { &do_log('notice', 'List::db_connect(): Db handle already available'); return 1; } ## We keep trying to connect if this is the first attempt ## Unless in a web context, because we can't afford long response time on the web interface unless ( $dbh = &SQLSource::connect(\%Conf, {'keep_trying'=>($option ne 'just_try' && ( !$db_connected && !$ENV{'HTTP_HOST'})), 'warn'=>1 } )) { return undef; } do_log('debug3','Connected to Database %s',$Conf{'db_name'}); $db_connected = 1; return 1; } ## Disconnect from Database sub db_disconnect { do_log('debug3', 'List::db_disconnect'); unless ($dbh->disconnect()) { do_log('notice','Can\'t disconnect from Database %s : %s',$Conf{'db_name'}, $dbh->errstr); return undef; } return 1; } ## Get database handler sub db_get_handler { do_log('debug3', 'List::db_get_handler'); return $dbh; } ## Creates an object. sub new { my($pkg, $name, $robot, $options) = @_; my $list={}; do_log('debug2', 'List::new(%s, %s, %s)', $name, $robot, join('/',keys %$options)); ## Allow robot in the name if ($name =~ /\@/) { my @parts = split /\@/, $name; $robot ||= $parts[1]; $name = $parts[0]; } ## Look for the list if no robot was provided $robot ||= &search_list_among_robots($name); unless ($robot) { &do_log('err', 'Missing robot parameter, cannot create list object for %s', $name) unless ($options->{'just_try'}); return undef; } $options = {} unless (defined $options); ## Only process the list if the name is valid. my $listname_regexp = &tools::get_regexp('listname'); unless ($name and ($name =~ /^$listname_regexp$/io) ) { &do_log('err', 'Incorrect listname "%s"', $name) unless ($options->{'just_try'}); return undef; } ## Lowercase the list name. $name =~ tr/A-Z/a-z/; ## Reject listnames with reserved list suffixes my $regx = &Conf::get_robot_conf($robot,'list_check_regexp'); if ( $regx ) { if ($name =~ /^(\S+)-($regx)$/) { &do_log('err', 'Incorrect name: listname "%s" matches one of service aliases', $name) unless ($options->{'just_try'}); return undef; } } my $status ; if ($list_of_lists{$robot}{$name}){ # use the current list in memory and update it $list=$list_of_lists{$robot}{$name}; $status = $list->load($name, $robot, $options); }else{ # create a new object list bless $list, $pkg; $options->{'first_access'} = 1; $status = $list->load($name, $robot, $options); } unless (defined $status) { return undef; } ## Config file was loaded or reloaded if (($status == 1 && ! $options->{'skip_sync_admin'}) || $options->{'force_sync_admin'}) { ## Update admin_table unless (defined $list->sync_include_admin()) { &do_log('err','List::new() : sync_include_admin_failed') unless ($options->{'just_try'}); } if ($list->get_nb_owners() < 1 && $list->{'admin'}{'status'} ne 'error_config') { &do_log('err', 'The list "%s" has got no owner defined',$list->{'name'}) ; $list->set_status_error_config('no_owner_defined',$list->{'name'}); } } return $list; } ## When no robot is specified, look for a list among robots sub search_list_among_robots { my $listname = shift; unless ($listname) { &do_log('err', 'List::search_list_among_robots() : Missing list parameter'); return undef; } ## Search in default robot if (-d $Conf{'home'}.'/'.$listname) { return $Conf{'host'}; } foreach my $r (keys %{$Conf{'robots'}}) { if (-d $Conf{'home'}.'/'.$r.'/'.$listname) { return $r; } } return 0; } ## set the list in status error_config and send a notify to listmaster sub set_status_error_config { my ($self, $message, @param) = @_; &do_log('debug3', 'List::set_status_error_config'); unless ($self->{'admin'}{'status'} eq 'error_config'){ $self->{'admin'}{'status'} = 'error_config'; my $host = &Conf::get_robot_conf($self->{'robot'}, 'host'); ## No more save config in error... #$self->save_config("listmaster\@$host"); #$self->savestats(); &do_log('err', 'The list "%s" is set in status error_config',$self->{'name'}); unless (&List::send_notify_to_listmaster($message, $self->{'domain'},\@param)) { &do_log('notice',"Unable to send notify '$message' to listmaster"); }; } } ## set the list in status family_closed and send a notify to owners sub set_status_family_closed { my ($self, $message, @param) = @_; &do_log('debug2', 'List::set_status_family_closed'); unless ($self->{'admin'}{'status'} eq 'family_closed'){ my $host = &Conf::get_robot_conf($self->{'robot'}, 'host'); unless ($self->close("listmaster\@$host",'family_closed')) { &do_log('err','Impossible to set the list %s in status family_closed'); return undef; } &do_log('err', 'The list "%s" is set in status family_closed',$self->{'name'}); unless ($self->send_notify_to_owner($message,\@param)){ &do_log('err','Impossible to send notify to owner informing status family_closed for the list %s',$self->{'name'}); } # messages : close_list } return 1; } ## Saves the statistics data to disk. sub savestats { my $self = shift; do_log('debug2', 'List::savestats'); ## Be sure the list has been loaded. my $name = $self->{'name'}; my $dir = $self->{'dir'}; return undef unless ($list_of_lists{$self->{'domain'}}{$name}); ## Lock file my $lock = new Lock ($dir.'/stats'); unless (defined $lock) { &do_log('err','Could not create new lock'); return undef; } $lock->set_timeout(2); unless ($lock->lock('write')) { return undef; } _save_stats_file("$dir/stats", $self->{'stats'}, $self->{'total'}, $self->{'last_sync'}, $self->{'last_sync_admin_user'}); ## Release the lock unless ($lock->unlock()) { return undef; } ## Changed on disk $self->{'mtime'}[2] = time; return 1; } ## msg count. sub increment_msg_count { my $self = shift; do_log('debug2', "List::increment_msg_count($self->{'name'})"); ## Be sure the list has been loaded. my $name = $self->{'name'}; my $file = "$self->{'dir'}/msg_count"; my %count ; if (open(MSG_COUNT, $file)) { while (){ if ($_ =~ /^(\d+)\s(\d+)$/) { $count{$1} = $2; } } close MSG_COUNT ; } my $today = int(time / 86400); if ($count{$today}) { $count{$today}++; }else{ $count{$today} = 1; } unless (open(MSG_COUNT, ">$file.$$")) { do_log('err', "Unable to create '%s.%s' : %s", $file,$$, $!); return undef; } foreach my $key (sort {$a <=> $b} keys %count) { printf MSG_COUNT "%d\t%d\n",$key,$count{$key} ; } close MSG_COUNT ; unless (rename("$file.$$", $file)) { do_log('err', "Unable to write '%s' : %s", $file, $!); return undef; } return 1; } ## last date of distribution message . sub get_latest_distribution_date { my $self = shift; do_log('debug3', "List::latest_distribution_date($self->{'name'})"); ## Be sure the list has been loaded. my $name = $self->{'name'}; my $file = "$self->{'dir'}/msg_count"; my %count ; my $latest_date = 0 ; unless (open(MSG_COUNT, $file)) { do_log('debug2',"get_latest_distribution_date: unable to open $file"); return undef ; } while (){ if ($_ =~ /^(\d+)\s(\d+)$/) { $latest_date = $1 if ($1 > $latest_date); } } close MSG_COUNT ; return undef if ($latest_date == 0); return $latest_date ; } ## Update the stats struct ## Input : num of bytes of msg ## Output : num of msgs sent sub update_stats { my($self, $bytes) = @_; do_log('debug2', 'List::update_stats(%d)', $bytes); my $stats = $self->{'stats'}; $stats->[0]++; $stats->[1] += $self->{'total'}; $stats->[2] += $bytes; $stats->[3] += $bytes * $self->{'total'}; ## Update 'msg_count' file, used for bounces management $self->increment_msg_count(); return $stats->[0]; } ## Extract a set of rcpt for which verp must be use from a rcpt_tab. ## Input : percent : the rate of subscribers that must be threaded using verp ## xseq : the message sequence number ## @rcpt : a tab of emails ## return : a tab of rcpt for which rcpt must be use depending on the message sequence number, this way every subscriber is "verped" from time to time ## input table @rcpt is spliced : rcpt for which verp must be used are extracted from this table sub extract_verp_rcpt() { my $percent = shift; my $xseq = shift; my $refrcpt = shift; my $refrcptverp = shift; &do_log('debug','&extract_verp(%s,%s,%s,%s)',$percent,$xseq,$refrcpt,$refrcptverp) ; if ($percent == '0%') { return (); } my $nbpart ; if ( $percent =~ /^(\d+)\%/ ) { $nbpart = 100/$1; } else { &do_log ('err', 'Wrong format for parameter extract_verp: %s. Can\'t process VERP.',$percent); return undef; } my $modulo = $xseq % $nbpart ; my $lenght = int (($#{$refrcpt} + 1) / $nbpart) + 1; &do_log('debug','&extract_verp(%s,%s,%s,%s)',$percent,$xseq,$refrcpt,$refrcptverp) ; my @result = splice @$refrcpt, $lenght*$modulo, $lenght ; foreach my $verprcpt (@$refrcptverp) { push @result, $verprcpt; } return ( @result ) ; } ## Dumps a copy of lists to disk, in text format sub dump { my $self = shift; do_log('debug2', 'List::dump(%s)', $self->{'name'}); unless (defined $self) { &do_log('err','Unknown list'); return undef; } my $user_file_name = "$self->{'dir'}/subscribers.db.dump"; unless ($self->_save_users_file($user_file_name)) { &do_log('err', 'Failed to save file %s', $user_file_name); return undef; } $self->{'mtime'} = [ (stat("$self->{'dir'}/config"))[9], (stat("$self->{'dir'}/subscribers"))[9], (stat("$self->{'dir'}/stats"))[9] ]; return 1; } ## Saves the configuration file to disk sub save_config { my ($self, $email) = @_; do_log('debug3', 'List::save_config(%s,%s)', $self->{'name'}, $email); return undef unless ($self); my $config_file_name = "$self->{'dir'}/config"; ## Lock file my $lock = new Lock ($self->{'dir'}.'/config'); unless (defined $lock) { &do_log('err','Could not create new lock'); return undef; } $lock->set_timeout(5); unless ($lock->lock('write')) { return undef; } my $name = $self->{'name'}; my $old_serial = $self->{'admin'}{'serial'}; my $old_config_file_name = "$self->{'dir'}/config.$old_serial"; ## Update management info $self->{'admin'}{'serial'}++; $self->{'admin'}{'update'} = {'email' => $email, 'date_epoch' => time, 'date' => (gettext_strftime "%d %b %Y at %H:%M:%S", localtime(time)), }; unless (&_save_admin_file($config_file_name, $old_config_file_name, $self->{'admin'})) { &do_log('info', 'unable to save config file %s', $config_file_name); $lock->unlock(); return undef; } ## Also update the binary version of the data structure if (&Conf::get_robot_conf($self->{'robot'}, 'cache_list_config') eq 'binary_file') { eval {&Storable::store($self->{'admin'},"$self->{'dir'}/config.bin")}; if ($@) { &do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@); } } # $self->{'mtime'}[0] = (stat("$list->{'dir'}/config"))[9]; ## Release the lock unless ($lock->unlock()) { return undef; } return 1; } ## Loads the administrative data for a list sub load { my ($self, $name, $robot, $options) = @_; do_log('debug2', 'List::load(%s, %s, %s)', $name, $robot, join('/',keys %$options)); my $users; ## Set of initializations ; only performed when the config is first loaded if ($options->{'first_access'}) { ## Search robot if none was provided unless ($robot) { foreach my $r (keys %{$Conf{'robots'}}) { if (-d "$Conf{'home'}/$r/$name") { $robot=$r; last; } } ## Try default robot unless ($robot) { if (-d "$Conf{'home'}/$name") { $robot = $Conf{'host'}; } } } if ($robot && (-d "$Conf{'home'}/$robot")) { $self->{'dir'} = "$Conf{'home'}/$robot/$name"; }elsif (lc($robot) eq lc($Conf{'host'})) { $self->{'dir'} = "$Conf{'home'}/$name"; }else { &do_log('err', 'No such robot (virtual domain) %s', $robot) unless ($options->{'just_try'}); return undef ; } $self->{'domain'} = $robot ; # default list host is robot domain $self->{'admin'}{'host'} ||= $self->{'domain'}; $self->{'name'} = $name ; } unless ((-d $self->{'dir'}) && (-f "$self->{'dir'}/config")) { &do_log('debug2', 'Missing directory (%s) or config file for %s', $self->{'dir'}, $name) unless ($options->{'just_try'}); return undef ; } my ($m1, $m2, $m3) = (0, 0, 0); ($m1, $m2, $m3) = @{$self->{'mtime'}} if (defined $self->{'mtime'}); my $time_config = (stat("$self->{'dir'}/config"))[9]; my $time_config_bin = (stat("$self->{'dir'}/config.bin"))[9]; my $time_subscribers; my $time_stats = (stat("$self->{'dir'}/stats"))[9]; my $config_reloaded = 0; my $admin; if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file' && $time_config_bin > $self->{'mtime'}->[0] && $time_config <= $time_config_bin && ! $options->{'reload_config'}) { ## Get a shared lock on config file first my $lock = new Lock ($self->{'dir'}.'/config'); unless (defined $lock) { &do_log('err','Could not create new lock'); return undef; } $lock->set_timeout(5); unless ($lock->lock('read')) { return undef; } ## Load a binary version of the data structure ## unless config is more recent than config.bin eval {$admin = &Storable::retrieve("$self->{'dir'}/config.bin")}; if ($@) { &do_log('err', 'Failed to load the binary config %s, error: %s', "$self->{'dir'}/config.bin",$@); $lock->unlock(); return undef; } $config_reloaded = 1; $m1 = $time_config_bin; $lock->unlock(); }elsif ($self->{'name'} ne $name || $time_config > $self->{'mtime'}->[0] || $options->{'reload_config'}) { $admin = _load_admin_file($self->{'dir'}, $self->{'domain'}, 'config'); ## Get a shared lock on config file first my $lock = new Lock ($self->{'dir'}.'/config'); unless (defined $lock) { &do_log('err','Could not create new lock'); return undef; } $lock->set_timeout(5); unless ($lock->lock('write')) { return undef; } ## update the binary version of the data structure if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file') { eval {&Storable::store($admin,"$self->{'dir'}/config.bin")}; if ($@) { &do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@); } } $config_reloaded = 1; unless (defined $admin) { &do_log('err', 'Impossible to load list config file for list % set in status error_config',$self->{'name'}); $self->set_status_error_config('load_admin_file_error',$self->{'name'}); $lock->unlock(); return undef; } $m1 = $time_config; $lock->unlock(); } ## If config was reloaded... if ($admin) { $self->{'admin'} = $admin; ## check param_constraint.conf if belongs to a family and the config has been loaded if (defined $admin->{'family_name'} && ($admin->{'status'} ne 'error_config')) { my $family; unless ($family = $self->get_family()) { &do_log('err', 'Impossible to get list %s family : %s. The list is set in status error_config',$self->{'name'},$self->{'admin'}{'family_name'}); $self->set_status_error_config('no_list_family',$self->{'name'}, $admin->{'family_name'}); return undef; } my $error = $family->check_param_constraint($self); unless($error) { &do_log('err', 'Impossible to check parameters constraint for list % set in status error_config',$self->{'name'}); $self->set_status_error_config('no_check_rules_family',$self->{'name'}, $family->{'name'}); } if (ref($error) eq 'ARRAY') { &do_log('err', 'The list "%s" does not respect the rules from its family %s',$self->{'name'}, $family->{'name'}); $self->set_status_error_config('no_respect_rules_family',$self->{'name'}, $family->{'name'}); } } } $self->{'as_x509_cert'} = 1 if ((-r "$self->{'dir'}/cert.pem") || (-r "$self->{'dir'}/cert.pem.enc")); if ($self->{'admin'}{'user_data_source'} eq 'database') { }elsif($self->{'admin'}->{'user_data_source'} eq 'file') { $time_subscribers = (stat("$self->{'dir'}/subscribers"))[9] if (-f "$self->{'dir'}/subscribers"); ## Touch subscribers file if not exists unless ( -r "$self->{'dir'}/subscribers") { open L, ">$self->{'dir'}/subscribers" or return undef; close L; do_log('info','No subscribers file, creating %s',"$self->{'dir'}/subscribers"); } if ($self->{'name'} ne $name || $time_subscribers > $self->{'mtime'}[1]) { $users = _load_users("$self->{'dir'}/subscribers"); unless (defined $users) { do_log('err', 'Could not load subscribers for list %s', $self->{'name'}); #return undef; } $m2 = $time_subscribers; } }elsif ($self->{'admin'}{'user_data_source'} eq 'include2') { ## currently no check }elsif($self->{'admin'}{'user_data_source'} eq 'include') { ## include other subscribers as defined in include directives (list|ldap|sql|file|owners|editors) unless ( $self->has_include_data_sources()) { &do_log('err', 'Include paragraph missing in configuration file %s', "$self->{'dir'}/config"); # return undef; } $time_subscribers = (stat("$self->{'dir'}/subscribers.db"))[9] if (-f "$self->{'dir'}/subscribers.db"); ## Update 'subscriber.db' if ( ## 'config' is more recent than 'subscribers.db' ($time_config > $time_subscribers) || ## 'ttl'*2 is NOT over (time > ($time_subscribers + $self->{'admin'}{'ttl'} * 2)) || ## 'ttl' is over AND not Web context ((time > ($time_subscribers + $self->{'admin'}{'ttl'})) && !($ENV{'HTTP_HOST'} && (-f "$self->{'dir'}/subscribers.db")))) { $users = $self->_load_users_include("$self->{'dir'}/subscribers.db", 0); unless (defined $users) { do_log('err', 'Could not load subscribers for list %s', $self->{'name'}); #return undef; } $m2 = time; }elsif (## First new() ! $self->{'users'} || ## 'subscribers.db' is more recent than $self->{'users'} ($time_subscribers > $self->{'mtime'}->[1])) { ## Use cache $users = $self->_load_users_include("$self->{'dir'}/subscribers.db", 1); unless (defined $users) { return undef; } $m2 = $time_subscribers; } }else { do_log('notice','Wrong value for user_data_source'); return undef; } ## Load stats file if first new() or stats file changed my ($stats, $total); if (! $self->{'mtime'}[2] || ($time_stats > $self->{'mtime'}[2])) { ($stats, $total, $self->{'last_sync'}, $self->{'last_sync_admin_user'}) = _load_stats_file("$self->{'dir'}/stats"); $m3 = $time_stats; $self->{'stats'} = $stats if (defined $stats); $self->{'total'} = $total if (defined $total); } $self->{'users'} = $users->{'users'} if ($users); $self->{'ref'} = $users->{'ref'} if ($users); if ($users && defined($users->{'total'})) { $self->{'total'} = $users->{'total'}; } ## We have updated %users, Total may have changed if ($m2 > $self->{'mtime'}[1]) { $self->savestats(); } $self->{'mtime'} = [ $m1, $m2, $m3]; $list_of_lists{$self->{'domain'}}{$name} = $self; return $config_reloaded; } ## Return a list of hash's owners and their param sub get_owners { my($self) = @_; &do_log('debug3', 'List::get_owners(%s)', $self->{'name'}); my $owners = (); # owners are in the admin_table ; they might come from an include data source for (my $owner = $self->get_first_admin_user('owner'); $owner; $owner = $self->get_next_admin_user()) { push(@{$owners},$owner); } return $owners; } sub get_nb_owners { my($self) = @_; &do_log('debug3', 'List::get_nb_owners(%s)', $self->{'name'}); my $resul = 0; my $owners = $self->get_owners; if (defined $owners) { $resul = $#{$owners} + 1; } return $resul; } ## Return a hash of list's editors and their param(empty if there isn't any editor) sub get_editors { my($self) = @_; &do_log('debug3', 'List::get_editors(%s)', $self->{'name'}); my $editors = (); # editors are in the admin_table ; they might come from an include data source for (my $editor = $self->get_first_admin_user('editor'); $editor; $editor = $self->get_next_admin_user()) { push(@{$editors},$editor); } return $editors; } ## Returns an array of owners' email addresses sub get_owners_email { my($self,$param) = @_; do_log('debug3', 'List::get_owners_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'}); my @rcpt; my $owners = (); $owners = $self->get_owners(); if ($param -> {'ignore_nomail'}) { foreach my $o (@{$owners}) { push (@rcpt, lc($o->{'email'})); } } else { foreach my $o (@{$owners}) { next if ($o->{'reception'} eq 'nomail'); push (@rcpt, lc($o->{'email'})); } } unless (@rcpt) { &do_log('notice','Warning : no owner found for list %s', $self->{'name'} ); } return @rcpt; } ## Returns an array of editors' email addresses # or owners if there isn't any editors'email adress sub get_editors_email { my($self,$param) = @_; do_log('debug3', 'List::get_editors_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'}); my @rcpt; my $editors = (); $editors = $self->get_editors(); if ($param -> {'ignore_nomail'}) { foreach my $e (@{$editors}) { push (@rcpt, lc($e->{'email'})); } } else { foreach my $e (@{$editors}) { next if ($e->{'reception'} eq 'nomail'); push (@rcpt, lc($e->{'email'})); } } unless (@rcpt) { &do_log('notice','Warning : no editor found for list %s, getting owners', $self->{'name'} ); @rcpt = $self->get_owners_email($param); } return @rcpt; } ## Returns an object Family if the list belongs to a family # or undef sub get_family { my $self = shift; &do_log('debug3', 'List::get_family(%s)', $self->{'name'}); if (ref($self->{'family'}) eq 'Family') { return $self->{'family'}; } my $family_name; my $robot = $self->{'domain'}; unless (defined $self->{'admin'}{'family_name'}) { &do_log('err', 'List::get_family(%s) : this list has not got any family', $self->{'name'}); return undef; } my $family_name = $self->{'admin'}{'family_name'}; my $family; unless ($family = new Family($family_name,$robot) ) { &do_log('err', 'List::get_family(%s) : new Family(%s) impossible', $self->{'name'},$family_name); return undef; } $self->{'family'} = $family; return $family; } ## return the config_changes hash ## Used ONLY with lists belonging to a family. sub get_config_changes { my $self = shift; &do_log('debug3', 'List::get_config_changes(%s)', $self->{'name'}); unless ($self->{'admin'}{'family_name'}) { &do_log('err', 'List::get_config_changes(%s) is called but there is no family_name for this list.',$self->{'name'}); return undef; } ## load config_changes my $time_file = (stat("$self->{'dir'}/config_changes"))[9]; unless (defined $self->{'config_changes'} && ($self->{'config_changes'}{'mtime'} >= $time_file)) { unless ($self->{'config_changes'} = $self->_load_config_changes_file()) { &do_log('err','Impossible to load file config_changes from list %s',$self->{'name'}); return undef; } } return $self->{'config_changes'}; } ## update file config_changes if the list belongs to a family by # writing the $what(file or param) name sub update_config_changes { my $self = shift; my $what = shift; # one param or a ref on array of param my $name = shift; &do_log('debug2', 'List::update_config_changes(%s,%s)', $self->{'name'},$what); unless ($self->{'admin'}{'family_name'}) { &do_log('err', 'List::update_config_changes(%s,%s,%s) is called but there is no family_name for this list.',$self->{'name'},$what); return undef; } unless (($what eq 'file') || ($what eq 'param')){ &do_log('err', 'List::update_config_changes(%s,%s) : %s is wrong : must be "file" or "param".',$self->{'name'},$what); return undef; } # status parameter isn't updating set in config_changes if (($what eq 'param') && ($name eq 'status')) { return 1; } ## load config_changes my $time_file = (stat("$self->{'dir'}/config_changes"))[9]; unless (defined $self->{'config_changes'} && ($self->{'config_changes'}{'mtime'} >= $time_file)) { unless ($self->{'config_changes'} = $self->_load_config_changes_file()) { &do_log('err','Impossible to load file config_changes from list %s',$self->{'name'}); return undef; } } if (ref($name) eq 'ARRAY' ) { foreach my $n (@{$name}) { $self->{'config_changes'}{$what}{$n} = 1; } } else { $self->{'config_changes'}{$what}{$name} = 1; } $self->_save_config_changes_file(); return 1; } ## return a hash of config_changes file sub _load_config_changes_file { my $self = shift; &do_log('debug3', 'List::_load_config_changes_file(%s)', $self->{'name'}); my $config_changes = {}; unless (-e "$self->{'dir'}/config_changes") { &do_log('err','No file %s/config_changes. Assuming no changes', $self->{'dir'}); return $config_changes; } unless (open (FILE,"$self->{'dir'}/config_changes")) { &do_log('err','File %s/config_changes exists, but unable to open it: %s', $self->{'dir'},$_); return undef; } while () { next if /^\s*(\#.*|\s*)$/; if (/^param\s+(.+)\s*$/) { $config_changes->{'param'}{$1} = 1; }elsif (/^file\s+(.+)\s*$/) { $config_changes->{'file'}{$1} = 1; }else { &do_log ('err', 'List::_load_config_changes_file(%s) : bad line : %s',$self->{'name'},$_); next; } } close FILE; $config_changes->{'mtime'} = (stat("$self->{'dir'}/config_changes"))[9]; return $config_changes; } ## save config_changes file in the list directory sub _save_config_changes_file { my $self = shift; &do_log('debug3', 'List::_save_config_changes_file(%s)', $self->{'name'}); unless ($self->{'admin'}{'family_name'}) { &do_log('err', 'List::_save_config_changes_file(%s) is called but there is no family_name for this list.',$self->{'name'}); return undef; } unless (open (FILE,">$self->{'dir'}/config_changes")) { &do_log('err','List::_save_config_changes_file(%s) : unable to create file %s/config_changes : %s',$self->{'name'},$self->{'dir'},$_); return undef; } foreach my $what ('param','file') { foreach my $name (keys %{$self->{'config_changes'}{$what}}) { print FILE "$what $name\n"; } } close FILE; return 1; } sub _get_param_value_anywhere { my $new_admin = shift; my $param = shift; &do_log('debug3', '_get_param_value_anywhere(%s %s)',$param); my $minor_p; my @values; if ($param =~ /^([\w-]+)\.([\w-]+)$/) { $param = $1; $minor_p = $2; } ## Multiple parameter (owner, custom_header, ...) if ((ref ($new_admin->{$param}) eq 'ARRAY') && !($::pinfo{$param}{'split_char'})) { foreach my $elt (@{$new_admin->{$param}}) { my $val = &List::_get_single_param_value($elt,$param,$minor_p); if (defined $val) { push @values,$val; } } }else { my $val = &List::_get_single_param_value($new_admin->{$param},$param,$minor_p); if (defined $val) { push @values,$val; } } return \@values; } ## Returns the list parameter value from $list->{'admin'} # the parameter is simple ($param) or composed ($param & $minor_param) # the value is a scalar or a ref on an array of scalar # (for parameter digest : only for days) sub get_param_value { my $self = shift; my $param = shift; &do_log('debug3', 'List::get_param_value(%s,%s)', $self->{'name'},$param); my $minor_param; my $value; if ($param =~ /^([\w-]+)\.([\w-]+)$/) { $param = $1; $minor_param = $2; } ## Multiple parameter (owner, custom_header, ...) if ((ref ($self->{'admin'}{$param}) eq 'ARRAY') && ! $::pinfo{$param}{'split_char'}) { my @values; foreach my $elt (@{$self->{'admin'}{$param}}) { push @values,&_get_single_param_value($elt,$param,$minor_param) } $value = \@values; }else { $value = &_get_single_param_value($self->{'admin'}{$param},$param,$minor_param); } return $value; } ## Returns the single list parameter value from struct $p, with $key entrie, # $k is optionnal # the single value can be a ref on a list when the parameter value is a list sub _get_single_param_value { my ($p,$key,$k) = @_; &do_log('debug4', 'List::_get_single_value(%s %s)',$key,$k); if (defined ($::pinfo{$key}{'scenario'}) || defined ($::pinfo{$key}{'task'})) { return $p->{'name'}; }elsif (ref($::pinfo{$key}{'file_format'})) { if (defined ($::pinfo{$key}{'file_format'}{$k}{'scenario'})) { return $p->{$k}{'name'}; }elsif (($::pinfo{$key}{'file_format'}{$k}{'occurrence'} =~ /n$/) && $::pinfo{$key}{'file_format'}{$k}{'split_char'}) { return $p->{$k}; # ref on an array }else { return $p->{$k}; } }else { if (($::pinfo{$key}{'occurrence'} =~ /n$/) && $::pinfo{$key}{'split_char'}) { return $p; # ref on an array }elsif ($key eq 'digest') { return $p->{'days'}; # ref on an array }else { return $p; } } } ######################################################################################## # FUNCTIONS FOR MESSAGE SENDING # ######################################################################################## # # # -list distribution # -template sending # # -service messages # -notification sending(listmaster, owner, editor, user) # # # ######################### LIST DISTRIBUTION ######################################### #################################################### # distribute_msg #################################################### # prepares and distributes a message to a list, do # some of these : # stats, hidding sender, adding custom subject, # archive, changing the replyto, removing headers, # adding headers, storing message in digest # # # IN : -$self (+): ref(List) # -$message (+): ref(Message) # OUT : -$numsmtp : number of sendmail process #################################################### sub distribute_msg { my($self, $message) = @_; do_log('debug2', 'List::distribute_msg(%s, %s, %s, %s, %s)', $self->{'name'}, $message->{'msg'}, $message->{'size'}, $message->{'filename'}, $message->{'smime_crypted'}); my $hdr = $message->{'msg'}->head; my ($name, $host) = ($self->{'name'}, $self->{'admin'}{'host'}); my $robot = $self->{'domain'}; ## Update the stats, and returns the new X-Sequence, if any. my $sequence = $self->update_stats($message->{'size'}); ## Loading info msg_topic file if exists, add X-Sympa-Topic my $info_msg_topic; if ($self->is_there_msg_topic()) { my $msg_id = $hdr->get('Message-ID'); chomp($msg_id); $info_msg_topic = $self->load_msg_topic_file($msg_id,$robot); # add X-Sympa-Topic header if (ref($info_msg_topic) eq "HASH") { $message->add_topic($info_msg_topic->{'topic'}); } } ## Hide the sender if the list is anonymoused if ( $self->{'admin'}{'anonymous_sender'} ) { foreach my $field (@{$Conf{'anonymous_header_fields'}}) { $hdr->delete($field); } $hdr->add('From',"$self->{'admin'}{'anonymous_sender'}"); my $new_id = "$self->{'name'}.$sequence\@anonymous"; $hdr->add('Message-id',"<$new_id>"); # rename msg_topic filename if ($info_msg_topic) { my $queuetopic = &Conf::get_robot_conf($robot, 'queuetopic'); my $listname = "$self->{'name'}\@$robot"; rename("$queuetopic/$info_msg_topic->{'filename'}","$queuetopic/$listname.$new_id"); $info_msg_topic->{'filename'} = "$listname.$new_id"; } ## xxxxxx Virer eventuelle signature S/MIME } ## Add Custom Subject if ($self->{'admin'}{'custom_subject'}) { my $subject_field = $message->{'decoded_subject'}; $subject_field =~ s/^\s*(.*)\s*$/$1/; ## Remove leading and trailing blanks ## Search previous subject tagging in Subject my $custom_subject = $self->{'admin'}{'custom_subject'}; ## tag_regexp will be used to remove the custom subject if it is already present in the message subject. ## Remember that the value of custom_subject can be "dude number [%list.sequence"%]" whereas the actual ## subject will contain "dude number 42". my $tag_regexp = $custom_subject; $tag_regexp =~ s/([\[\]\*\-\(\)\+\{\}\?])/\\$1/g; ## cleanup, just in case dangerous chars were left $tag_regexp =~ s/\\\[%\S+%\\\]/[^\]]\+/g; ## Replaces variables declarations by "[^\]]+" $tag_regexp =~ s/\s+/\\s+/g; ## Takes spaces into account ## Add subject tag $message->{'msg'}->head->delete('Subject'); my $parsed_tag; &tt2::parse_tt2({'list' => {'name' => $self->{'name'}, 'sequence' => $self->{'stats'}->[0] }}, [$custom_subject], \$parsed_tag); ## If subject is tagged, replace it with new tag ## Splitting the subject in two parts : ## - what is before the custom subject (probably some "Re:") ## - what is after it : the orginal subject sent to the list. ## The custom subject is not kept. my $before_tag = ''; my $after_tag = $subject_field; $after_tag =~ s/.*\[$tag_regexp\]//; if($subject_field =~ /(.*)\s*\[$tag_regexp\](.*)/) { $before_tag = $1; $after_tag = $2; $after_tag =~ s/^\s*(.*)\s*$/$1/; ## Remove leading and trailing blanks } ## Encode subject using initial charset ## Don't try to encode the subject if it was not originaly encoded non-ASCII. if ($message->{'subject_charset'} or $subject_field !~ /[^\x00-\x7E]/) { $subject_field = MIME::EncWords::encode_mimewords([ [Encode::decode('utf8', $before_tag), $message->{'subject_charset'}], [Encode::decode('utf8', '['.$parsed_tag.'] '), &Language::GetCharset()], [Encode::decode('utf8', $after_tag), $message->{'subject_charset'}] ], Encoding=>'A', Field=>'Subject'); }else { $subject_field = $before_tag . ' ' . MIME::EncWords::encode_mimewords([ [Encode::decode('utf8', '['.$parsed_tag.']'), &Language::GetCharset()] ], Encoding=>'A', Field=>'Subject') . ' ' . $after_tag; } $message->{'msg'}->head->add('Subject', $subject_field); } ## Remove unwanted headers if present. if ($self->{'admin'}{'remove_headers'}) { foreach my $field (@{$self->{'admin'}{'remove_headers'}}) { $hdr->delete($field); } } ## Archives my $msgtostore = $message->{'msg'}; if (($message->{'smime_crypted'} eq 'smime_crypted') && ($self->{admin}{archive_crypted_msg} eq 'original')) { $msgtostore = $message->{'orig_msg'}; } $self->archive_msg($msgtostore); ## Change the reply-to header if necessary. if ($self->{'admin'}{'reply_to_header'}) { unless ($hdr->get('Reply-To') && ($self->{'admin'}{'reply_to_header'}{'apply'} ne 'forced')) { my $reply; $hdr->delete('Reply-To'); if ($self->{'admin'}{'reply_to_header'}{'value'} eq 'list') { $reply = "$name\@$host"; }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'sender') { $reply = undef; }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'all') { $reply = "$name\@$host,".$hdr->get('From'); }elsif ($self->{'admin'}{'reply_to_header'}{'value'} eq 'other_email') { $reply = $self->{'admin'}{'reply_to_header'}{'other_email'}; } $hdr->add('Reply-To',$reply) if $reply; } } ## Add useful headers $hdr->add('X-Loop', "$name\@$host"); $hdr->add('X-Sequence', $sequence); $hdr->add('Errors-to', $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$host); $hdr->add('Precedence', 'list'); $hdr->add('Precedence', 'bulk'); $hdr->add('X-no-archive', 'yes'); foreach my $i (@{$self->{'admin'}{'custom_header'}}) { $hdr->add($1, $2) if ($i=~/^([\S\-\:]*)\s(.*)$/); } ## Add RFC 2919 header field if ($hdr->get('List-Id')) { &do_log('notice', 'Found List-Id: %s', $hdr->get('List-Id')); $hdr->delete('List-ID'); } $hdr->add('List-Id', sprintf ('<%s.%s>', $self->{'name'}, $self->{'admin'}{'host'})); ## Add RFC 2369 header fields foreach my $field (@{$self->{'admin'}{'rfc2369_header_fields'}}) { if ($field eq 'help') { $hdr->add('List-Help', sprintf ('', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host'))); }elsif ($field eq 'unsubscribe') { $hdr->add('List-Unsubscribe', sprintf ('', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host'), $self->{'name'})); }elsif ($field eq 'subscribe') { $hdr->add('List-Subscribe', sprintf ('', &Conf::get_robot_conf($robot, 'email'), &Conf::get_robot_conf($robot, 'host'), $self->{'name'})); }elsif ($field eq 'post') { $hdr->add('List-Post', sprintf ('', $self->{'name'}, $self->{'admin'}{'host'})); }elsif ($field eq 'owner') { $hdr->add('List-Owner', sprintf ('', $self->{'name'}, $self->{'admin'}{'host'})); }elsif ($field eq 'archive') { if (&Conf::get_robot_conf($robot, 'wwsympa_url') and $self->is_web_archived()) { $hdr->add('List-Archive', sprintf ('<%s/arc/%s>', &Conf::get_robot_conf($robot, 'wwsympa_url'), $self->{'name'})); } } } ## Remove outgoing header fileds ## Useful to remove some header fields that Sympa has set if ($self->{'admin'}{'remove_outgoing_headers'}) { foreach my $field (@{$self->{'admin'}{'remove_outgoing_headers'}}) { $hdr->delete($field); } } ## store msg in digest if list accept digest mode (encrypted message can't be included in digest) if (($self->is_digest()) and ($message->{'smime_crypted'} ne 'smime_crypted')) { $self->archive_msg_digest($msgtostore); } ## Synchronize list members, required if list uses include sources ## unless sync_include has been performed recently. if ($self->has_include_data_sources()) { $self->on_the_fly_sync_include('use_ttl' => 1); } ## Blindly send the message to all users. my $numsmtp = $self->send_msg($message); unless (defined ($numsmtp)) { return $numsmtp; } $self->savestats(); return $numsmtp; } #################################################### # send_msg_digest #################################################### # Send a digest message to the subscribers with # reception digest, digestplain or summary # # IN : -$self(+) : ref(List) # # OUT : 1 : ok # | 0 if no subscriber for sending digest # | undef #################################################### sub send_msg_digest { my ($self) = @_; my $listname = $self->{'name'}; my $robot = $self->{'domain'}; do_log('debug2', 'List:send_msg_digest(%s)', $listname); my $filename; ## Backward compatibility concern if (-f "$Conf{'queuedigest'}/$listname") { $filename = "$Conf{'queuedigest'}/$listname"; }else { $filename = $Conf{'queuedigest'}.'/'.$self->get_list_id(); } my $param = {'replyto' => "$self->{'name'}-request\@$self->{'admin'}{'host'}", 'to' => $self->get_list_address(), 'table_of_content' => sprintf(gettext("Table of contents:")), 'boundary1' => '----------=_'.&tools::get_message_id($robot), 'boundary2' => '----------=_'.&tools::get_message_id($robot), }; if ($self->get_reply_to() =~ /^list$/io) { $param->{'replyto'}= "$param->{'to'}"; } my @tabrcpt ; my @tabrcptsummary; my @tabrcptplain; my $i; my (@list_of_mail); ## Create the list of subscribers in various digest modes for (my $user = $self->get_first_user(); $user; $user = $self->get_next_user()) { if ($user->{'reception'} eq "digest") { push @tabrcpt, $user->{'email'}; }elsif ($user->{'reception'} eq "summary") { ## Create the list of subscribers in summary mode push @tabrcptsummary, $user->{'email'}; }elsif ($user->{'reception'} eq "digestplain") { push @tabrcptplain, $user->{'email'}; } } if (($#tabrcptsummary == -1) and ($#tabrcpt == -1) and ($#tabrcptplain == -1)) { &do_log('info', 'No subscriber for sending digest in list %s', $listname); return 0; } my $old = $/; local $/ = "\n\n" . &tools::get_separator() . "\n\n"; ## Digest split in individual messages open DIGEST, $filename or return undef; foreach (){ my @text = split /\n/; pop @text; pop @text; ## Restore carriage returns foreach $i (0 .. $#text) { $text[$i] .= "\n"; } my $parser = new MIME::Parser; $parser->output_to_core(1); $parser->extract_uuencode(1); $parser->extract_nested_messages(1); # $parser->output_dir($Conf{'spool'} ."/tmp"); my $mail = $parser->parse_data(\@text); next unless (defined $mail); push @list_of_mail, $mail; } close DIGEST; local $/ = $old; ## Deletes the introduction part splice @list_of_mail, 0, 1; ## Digest index my @all_msg; foreach $i (0 .. $#list_of_mail){ my $mail = $list_of_mail[$i]; my $subject = &MIME::EncWords::decode_mimewords($mail->head->get('Subject'), Charset=>'utf8'); chomp $subject; my $from = &MIME::EncWords::decode_mimewords($mail->head->get('From'), Charset=>'utf8'); chomp $from; my $date = &MIME::EncWords::decode_mimewords($mail->head->get('Date'), Charset=>'utf8'); chomp $date; my $msg = {}; $msg->{'id'} = $i+1; $msg->{'subject'} = $subject; $msg->{'from'} = $from; $msg->{'date'} = $date; #$mail->tidy_body; ## Commented because one Spam made Sympa die (MIME::tools 5.413) #$mail->remove_sig; $msg->{'full_msg'} = $mail->as_string; $msg->{'body'} = $mail->body_as_string; $msg->{'plain_body'} = $mail->PlainDigest::plain_body_as_string(); #$msg->{'body'} = $mail->bodyhandle->as_string(); chomp $msg->{'from'}; $msg->{'month'} = &POSIX::strftime("%Y-%m", localtime(time)); ## Should be extracted from Date: $msg->{'message_id'} = &tools::clean_msg_id($mail->head->get('Message-Id')); ## Clean up Message-ID $msg->{'message_id'} = &tools::escape_chars($msg->{'message_id'}); #push @{$param->{'msg_list'}}, $msg ; push @all_msg, $msg ; } my @now = localtime(time); $param->{'datetime'} = gettext_strftime "%a, %d %b %Y %H:%M:%S", @now; $param->{'date'} = gettext_strftime "%a, %d %b %Y", @now; ## Split messages into groups of digest_max_size size my @group_of_msg; while (@all_msg) { my @group = splice @all_msg, 0, $self->{'admin'}{'digest_max_size'}; push @group_of_msg, \@group; } $param->{'current_group'} = 0; $param->{'total_group'} = $#group_of_msg + 1; ## Foreach set of digest_max_size messages... foreach my $group (@group_of_msg) { $param->{'current_group'}++; $param->{'msg_list'} = $group; ## Prepare Digest if (@tabrcpt) { ## Send digest unless ($self->send_file('digest', \@tabrcpt, $robot, $param)) { &do_log('notice',"Unable to send template 'digest' to $self->{'name'} list subscribers"); } } ## Prepare Plain Text Digest if (@tabrcptplain) { ## Send digest-plain unless ($self->send_file('digest_plain', \@tabrcptplain, $robot, $param)) { &do_log('notice',"Unable to send template 'digest_plain' to $self->{'name'} list subscribers"); } } ## send summary if (@tabrcptsummary) { unless ($self->send_file('summary', \@tabrcptsummary, $robot, $param)) { &do_log('notice',"Unable to send template 'summary' to $self->{'name'} list subscribers"); } } } return 1; } ######################### TEMPLATE SENDING ########################################## #################################################### # send_global_file #################################################### # Send a global (not relative to a list) # message to a user. # Find the tt2 file according to $tpl, set up # $data for the next parsing (with $context and # configuration ) # # IN : -$tpl (+): template file name (file.tt2), # without tt2 extension # -$who (+): SCALAR |ref(ARRAY) - recepient(s) # -$robot (+): robot # -$context : ref(HASH) - for the $data set up # to parse file tt2, keys can be : # -user : ref(HASH), keys can be : # -email # -lang # -password # -... # -$options : ref(HASH) - options # OUT : 1 | undef # #################################################### sub send_global_file { my($tpl, $who, $robot, $context, $options) = @_; do_log('debug2', 'List::send_global_file(%s, %s, %s)', $tpl, $who, $robot); my $data = $context; unless ($data->{'user'}) { $data->{'user'} = &get_user_db($who) unless ($options->{'skip_db'}); $data->{'user'}{'email'} = $who unless (defined $data->{'user'});; } unless ($data->{'user'}{'lang'}) { $data->{'user'}{'lang'} = $Language::default_lang; } unless ($data->{'user'}{'password'}) { $data->{'user'}{'password'} = &tools::tmp_passwd($who); } ## Lang $data->{'lang'} = $data->{'lang'} || $data->{'user'}{'lang'} || &Conf::get_robot_conf($robot, 'lang'); ## What file my $lang = &Language::Lang2Locale($data->{'lang'}); my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2',$lang,''); foreach my $d (@{$tt2_include_path}) { &tt2::add_include_path($d); } my @path = &tt2::get_include_path(); my $filename = &tools::find_file($tpl.'.tt2',@path); unless (defined $filename) { &do_log('err','Could not find template %s.tt2 in %s', $tpl, join(':',@path)); return undef; } foreach my $p ('email','host','sympa','request','listmaster','wwsympa_url','title','listmaster_email') { $data->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p); } $data->{'sender'} = $who; $data->{'conf'}{'version'} = $main::Version; $data->{'from'} = "$data->{'conf'}{'email'}\@$data->{'conf'}{'host'}" unless ($data->{'from'}); $data->{'robot_domain'} = $robot; $data->{'return_path'} = &Conf::get_robot_conf($robot, 'request'); $data->{'boundary'} = '----------=_'.&tools::get_message_id($robot) unless ($data->{'boundary'}); unless (&mail::mail_file($filename, $who, $data, $robot)) { &do_log('err',"List::send_global_file, could not send template $filename to $who"); return undef; } return 1; } #################################################### # send_file #################################################### # Send a message to a user, relative to a list. # Find the tt2 file according to $tpl, set up # $data for the next parsing (with $context and # configuration) # Message is signed if the list as a key and a # certificat # # IN : -$self (+): ref(List) # -$tpl (+): template file name (file.tt2), # without tt2 extension # -$who (+): SCALAR |ref(ARRAY) - recepient(s) # -$robot (+): robot # -$context : ref(HASH) - for the $data set up # to parse file tt2, keys can be : # -user : ref(HASH), keys can be : # -email # -lang # -password # -... # OUT : 1 | undef #################################################### sub send_file { my($self, $tpl, $who, $robot, $context) = @_; do_log('debug2', 'List::send_file(%s, %s, %s)', $tpl, $who, $robot); my $name = $self->{'name'}; my $sign_mode; my $data = $context; ## Any recepients if ((ref ($who) && ($#{$who} < 0)) || (!ref ($who) && ($who eq ''))) { &do_log('err', 'No recipient for sending %s', $tpl); return undef; } ## Unless multiple recepients unless (ref ($who)) { unless ($data->{'user'}) { unless ($data->{'user'} = &get_user_db($who)) { $data->{'user'}{'email'} = $who; $data->{'user'}{'lang'} = $self->{'admin'}{'lang'}; } } $data->{'subscriber'} = $self->get_subscriber($who); if ($data->{'subscriber'}) { $data->{'subscriber'}{'date'} = gettext_strftime "%d %b %Y", localtime($data->{'subscriber'}{'date'}); $data->{'subscriber'}{'update_date'} = gettext_strftime "%d %b %Y", localtime($data->{'subscriber'}{'update_date'}); if ($data->{'subscriber'}{'bounce'}) { $data->{'subscriber'}{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/; $data->{'subscriber'}{'first_bounce'} = gettext_strftime "%d %b %Y", localtime($1); } } unless ($data->{'user'}{'password'}) { $data->{'user'}{'password'} = &tools::tmp_passwd($who); } ## Unique return-path VERP if ((($self->{'admin'}{'welcome_return_path'} eq 'unique') && ($tpl eq 'welcome')) || (($self->{'admin'}{'remind_return_path'} eq 'unique') && ($tpl eq 'remind'))) { my $escapercpt = $who ; $escapercpt =~ s/\@/\=\=a\=\=/; $data->{'return_path'} = "$Conf{'bounce_email_prefix'}+$escapercpt\=\=$name"; $data->{'return_path'} .= '==w' if ($tpl eq 'welcome'); $data->{'return_path'} .= '==r' if ($tpl eq 'remind'); $data->{'return_path'} .= "\@$self->{'domain'}"; } } $data->{'return_path'} ||= $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$self->{'admin'}{'host'}; ## Lang $data->{'lang'} = $data->{'user'}{'lang'} || $self->{'admin'}{'lang'} || &Conf::get_robot_conf($robot, 'lang'); ## Trying to use custom_vars if (defined $self->{'admin'}{'custom_vars'}) { $data->{'custom_vars'} = {}; foreach my $var (@{$self->{'admin'}{'custom_vars'}}) { $data->{'custom_vars'}{$var->{'name'}} = $var->{'value'}; } } ## What file my $lang = &Language::Lang2Locale($data->{'lang'}); my $tt2_include_path = &tools::make_tt2_include_path($robot,'mail_tt2',$lang,$self); push @{$tt2_include_path},$self->{'dir'}; ## list directory to get the 'info' file push @{$tt2_include_path},$self->{'dir'}.'/archives'; ## list archives to include the last message foreach my $d (@{$tt2_include_path}) { &tt2::add_include_path($d); } foreach my $p ('email','host','sympa','request','listmaster','wwsympa_url','title','listmaster_email') { $data->{'conf'}{$p} = &Conf::get_robot_conf($robot, $p); } my @path = &tt2::get_include_path(); my $filename = &tools::find_file($tpl.'.tt2',@path); unless (defined $filename) { &do_log('err','Could not find template %s.tt2 in %s', $tpl, join(':',@path)); return undef; } $data->{'sender'} = $who; $data->{'list'}{'lang'} = $self->{'admin'}{'lang'}; $data->{'list'}{'name'} = $name; $data->{'list'}{'domain'} = $data->{'robot_domain'} = $robot; $data->{'list'}{'host'} = $self->{'admin'}{'host'}; $data->{'list'}{'subject'} = $self->{'admin'}{'subject'}; $data->{'list'}{'owner'} = $self->get_owners(); $data->{'list'}{'dir'} = $self->{'dir'}; ## Sign mode if ($Conf{'openssl'} && (-r $self->{'dir'}.'/cert.pem') && (-r $self->{'dir'}.'/private_key')) { $sign_mode = 'smime'; } # if the list have it's private_key and cert sign the message # . used only for the welcome message, could be usefull in other case ? # . a list should have several certificats and use if possible a certificat # issued by the same CA as the receipient CA if it exists if ($sign_mode eq 'smime') { $data->{'fromlist'} = "$name\@$data->{'list'}{'host'}"; $data->{'replyto'} = "$name"."-request\@$data->{'list'}{'host'}"; }else{ $data->{'fromlist'} = "$name"."-request\@$data->{'list'}{'host'}"; } $data->{'from'} = $data->{'fromlist'} unless ($data->{'from'}); $data->{'boundary'} = '----------=_'.&tools::get_message_id($robot) unless ($data->{'boundary'}); unless (&mail::mail_file($filename, $who, $data, $self->{'domain'}, $sign_mode)) { &do_log('err',"List::send_file, could not send template $filename to $who"); return undef; } return 1; } #################################################### # send_msg #################################################### # selects subscribers according to their reception # mode in order to distribute a message to a list # and sends the message to them. For subscribers in reception mode 'mail', # and in a msg topic context, selects only one who are subscribed to the topic # of the message. # # # IN : -$self (+): ref(List) # -$message (+): ref(Message) # OUT : -$numsmtp : number of sendmail process # | 0 : no subscriber for sending message in list # | undef #################################################### sub send_msg { my($self, $message) = @_; do_log('debug2', 'List::send_msg(%s, %s)', $message->{'filename'}, $message->{'smime_crypted'}); my $hdr = $message->{'msg'}->head; my $name = $self->{'name'}; my $robot = $self->{'domain'}; my $admin = $self->{'admin'}; my $total = $self->get_total('nocache'); my $sender_line = $hdr->get('From'); my @sender_hdr = Mail::Address->parse($sender_line); my %sender_hash; foreach my $email (@sender_hdr) { $sender_hash{lc($email->address)} = 1; } unless ($total > 0) { &do_log('info', 'No subscriber in list %s', $name); return 0; } ## Bounce rate my $rate = $self->get_total_bouncing() * 100 / $total; if ($rate > $self->{'admin'}{'bounce'}{'warn_rate'}) { unless ($self->send_notify_to_owner('bounce_rate',{'rate' => $rate})) { &do_log('notice',"Unable to send notify 'bounce_rate' to $self->{'name'} listowner"); } } ## Who is the enveloppe sender ? my $host = $self->{'admin'}{'host'}; my $from = $name.&Conf::get_robot_conf($robot, 'return_path_suffix').'@'.$host; # separate subscribers depending on user reception option and also if verp a dicovered some bounce for them. my (@tabrcpt, @tabrcpt_notice, @tabrcpt_txt, @tabrcpt_html, @tabrcpt_url, @tabrcpt_verp, @tabrcpt_notice_verp, @tabrcpt_txt_verp, @tabrcpt_html_verp, @tabrcpt_url_verp); my $mixed = ($message->{'msg'}->head->get('Content-Type') =~ /multipart\/mixed/i); my $alternative = ($message->{'msg'}->head->get('Content-Type') =~ /multipart\/alternative/i); for ( my $user = $self->get_first_user(); $user; $user = $self->get_next_user() ){ unless ($user->{'email'}) { &do_log('err','Skipping user with no email address in list %s', $name); next; } if ($user->{'reception'} =~ /^digest|digestplain|summary|nomail$/i) { next; } elsif ($user->{'reception'} eq 'notice') { if ($user->{'bounce_address'}) { push @tabrcpt_notice_verp, $user->{'email'}; }else{ push @tabrcpt_notice, $user->{'email'}; } } elsif ($alternative and ($user->{'reception'} eq 'txt')) { if ($user->{'bounce_address'}) { push @tabrcpt_txt_verp, $user->{'email'}; }else{ push @tabrcpt_txt, $user->{'email'}; } } elsif ($alternative and ($user->{'reception'} eq 'html')) { if ($user->{'bounce_address'}) { push @tabrcpt_html_verp, $user->{'email'}; }else{ if ($user->{'bounce_address'}) { push @tabrcpt_html_verp, $user->{'email'}; }else{ push @tabrcpt_html, $user->{'email'}; } } } elsif ($mixed and ($user->{'reception'} eq 'urlize')) { if ($user->{'bounce_address'}) { push @tabrcpt_url_verp, $user->{'email'}; }else{ push @tabrcpt_url, $user->{'email'}; } } elsif ($message->{'smime_crypted'} && (! -r $Conf{'ssl_cert_dir'}.'/'.&tools::escape_chars($user->{'email'}) && ! -r $Conf{'ssl_cert_dir'}.'/'.&tools::escape_chars($user->{'email'}.'@enc' ))) { ## Missing User certificate unless ($self->send_file('x509-user-cert-missing', $user->{'email'}, $robot, {'mail' => {'subject' => $message->{'msg'}->head->get('Subject'), 'sender' => $message->{'msg'}->head->get('From')}})) { &do_log('notice',"Unable to send template 'x509-user-cert-missing' to $user->{'email'}"); } }else{ if ($user->{'bounce_address'}) { push @tabrcpt_verp, $user->{'email'} unless ($sender_hash{$user->{'email'}})&&($user->{'reception'} eq 'not_me'); }else{ push @tabrcpt, $user->{'email'} unless ($sender_hash{$user->{'email'}})&&($user->{'reception'} eq 'not_me');} } } ## sa return 0 = Pb ? unless (@tabrcpt || @tabrcpt_notice || @tabrcpt_txt || @tabrcpt_html || @tabrcpt_url || @tabrcpt_verp || @tabrcpt_notice_verp || @tabrcpt_txt_verp || @tabrcpt_html_verp || @tabrcpt_url_verp) { &do_log('info', 'No subscriber for sending msg in list %s', $name); return 0; } #save the message before modifying it my $saved_msg = $message->{'msg'}->dup; my $nbr_smtp; my $nbr_verp; # prepare verp parameter my $verp_rate = $self->{'admin'}{'verp_rate'}; my $xsequence = $self->{'stats'}->[0] ; ##Send message for normal reception mode if (@tabrcpt) { ## Add a footer unless ($message->{'protected'}) { my $new_msg = $self->add_parts($message->{'msg'}); if (defined $new_msg) { $message->{'msg'} = $new_msg; $message->{'altered'} = '_ALTERED_'; } } ## TOPICS my @selected_tabrcpt; if ($self->is_there_msg_topic()){ @selected_tabrcpt = $self->select_subscribers_for_topic($message->get_topic(),\@tabrcpt); } else { @selected_tabrcpt = @tabrcpt; } my @verp_selected_tabrcpt = &extract_verp_rcpt($verp_rate, $xsequence,\@selected_tabrcpt, \@tabrcpt_verp); my $result = &mail::mail_message($message, $self, {'enable' => 'off'}, @selected_tabrcpt); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)"); return undef; } $nbr_smtp = $result; $result = &mail::mail_message($message, $self, {'enable' => 'on'}, @verp_selected_tabrcpt); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)"); return undef; } $nbr_smtp += $result; $nbr_verp = $result; } ##Prepare and send message for notice reception mode if (@tabrcpt_notice) { my $notice_msg = $saved_msg->dup; $notice_msg->bodyhandle(undef); $notice_msg->parts([]); my $new_message = new Message($notice_msg); my @verp_tabrcpt_notice = &extract_verp_rcpt($verp_rate, $xsequence,\@tabrcpt_notice, \@tabrcpt_notice_verp); my $result = &mail::mail_message($new_message, $self, {'enable' => 'off'}, @tabrcpt_notice); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)"); return undef; } $nbr_smtp += $result; $result = &mail::mail_message($new_message, $self , {'enable' => 'on'}, @verp_tabrcpt_notice); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)"); return undef; } $nbr_smtp += $result; $nbr_verp += $result; } ##Prepare and send message for txt reception mode if (@tabrcpt_txt) { my $txt_msg = $saved_msg->dup; if (&tools::as_singlepart($txt_msg, 'text/plain')) { do_log('notice', 'Multipart message changed to singlepart'); } ## Add a footer my $new_msg = $self->add_parts($txt_msg); if (defined $new_msg) { $txt_msg = $new_msg; } my $new_message = new Message($txt_msg); my @verp_tabrcpt_txt = &extract_verp_rcpt($verp_rate, $xsequence,\@tabrcpt_txt, \@tabrcpt_txt_verp); my $result = &mail::mail_message($new_message, $self, {'enable' => 'off'}, @tabrcpt_txt); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)"); return undef; } $nbr_smtp += $result; $result = &mail::mail_message($new_message, $self , {'enable' => 'on'}, @verp_tabrcpt_txt); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)"); return undef; } $nbr_smtp += $result; $nbr_verp += $result; } ##Prepare and send message for html reception mode if (@tabrcpt_html) { my $html_msg = $saved_msg->dup; if (&tools::as_singlepart($html_msg, 'text/html')) { do_log('notice', 'Multipart message changed to singlepart'); } ## Add a footer my $new_msg = $self->add_parts($html_msg); if (defined $new_msg) { $html_msg = $new_msg; } my $new_message = new Message($html_msg); my @verp_tabrcpt_html = &extract_verp_rcpt($verp_rate, $xsequence,\@tabrcpt_html, \@tabrcpt_html_verp); my $result = &mail::mail_message($new_message, $self , {'enable' => 'off'}, @tabrcpt_html); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)"); return undef; } $nbr_smtp += $result; $result = &mail::mail_message($new_message, $self , {'enable' => 'on'}, @verp_tabrcpt_html); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)"); return undef; } $nbr_smtp += $result; $nbr_verp += $result; } ##Prepare and send message for urlize reception mode if (@tabrcpt_url) { my $url_msg = $saved_msg->dup; my $expl = $self->{'dir'}.'/urlized'; unless ((-d $expl) ||( mkdir $expl, 0775)) { do_log('err', "Unable to create urlize directory $expl"); return undef; } my $dir1 = &tools::clean_msg_id($url_msg->head->get('Message-ID')); ## Clean up Message-ID $dir1 = &tools::escape_chars($dir1); $dir1 = '/'.$dir1; unless ( mkdir ("$expl/$dir1", 0775)) { do_log('err', "Unable to create urlize directory $expl/$dir1"); printf "Unable to create urlized directory $expl/$dir1"; return 0; } my $mime_types = &tools::load_mime_types(); my @parts = $url_msg->parts(); foreach my $i (0..$#parts) { my $entity = &_urlize_part ($url_msg->parts ($i), $self, $dir1, $i, $mime_types, &Conf::get_robot_conf($robot, 'wwsympa_url')) ; if (defined $entity) { $parts[$i] = $entity; } } ## Replace message parts $url_msg->parts (\@parts); ## Add a footer my $new_msg = $self->add_parts($url_msg); if (defined $new_msg) { $url_msg = $new_msg; } my $new_message = new Message($url_msg); my @verp_tabrcpt_url = &extract_verp_rcpt($verp_rate, $xsequence,\@tabrcpt_url, \@tabrcpt_url_verp); my $result = &mail::mail_message($new_message, $self , {'enable' => 'off'}, @tabrcpt_url); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp desabled)"); return undef; } $nbr_smtp += $result; $result = &mail::mail_message($new_message, $self , {'enable' => 'on'}, @verp_tabrcpt_url); unless (defined $result) { &do_log('err',"List::send_msg, could not send message to distribute from $from (verp enabled)"); return undef; } $nbr_smtp += $result; $nbr_verp += $result; } return $nbr_smtp; } ######################### SERVICE MESSAGES ########################################## ############################################################### # send_to_editor ############################################################### # Sends a message to the list editor to ask him for moderation # ( in moderation context : editor or editorkey). The message # to moderate is set in spool queuemod with name containing # a key (reference send to editor for moderation) # In context of msg_topic defined the editor must tag it # for the moderation (on Web interface) # # IN : -$self(+) : ref(List) # -$method : 'md5' - for "editorkey" | 'smtp' - for "editor" # -$message(+) : ref(Message) - the message to moderatte # OUT : $modkey : the moderation key for naming message waiting # for moderation in spool queuemod # | undef ################################################################# sub send_to_editor { my($self, $method, $message) = @_; my ($msg, $file, $encrypt) = ($message->{'msg'}, $message->{'filename'}); my $encrypt; $encrypt = 'smime_crypted' if ($message->{'smime_crypted'}); do_log('debug3', "List::send_to_editor, msg: $msg, file: $file method : $method, encrypt : $encrypt"); my($i, @rcpt); my $admin = $self->{'admin'}; my $name = $self->{'name'}; my $host = $admin->{'host'}; my $robot = $self->{'domain'}; my $modqueue = $Conf{'queuemod'}; return unless ($name && $admin); my @now = localtime(time); my $messageid=$now[6].$now[5].$now[4].$now[3].$now[2].$now[1]."." .int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6))."\@".$host; my $modkey=Digest::MD5::md5_hex(join('/', $self->get_cookie(),$messageid)); my $boundary ="__ \<$messageid\>"; ## Keeps a copy of the message if ($method eq 'md5'){ my $mod_file = $modqueue.'/'.$self->get_list_id().'_'.$modkey; unless (open(OUT, ">$mod_file")) { do_log('notice', 'Could Not open %s', $mod_file); return undef; } unless (open (MSG, $file)) { do_log('notice', 'Could not open %s', $file); return undef; } print OUT ; close MSG ; close(OUT); my $tmp_dir = $modqueue.'/.'.$self->get_list_id().'_'.$modkey; unless (-d $tmp_dir) { unless (mkdir ($tmp_dir, 0777)) { &do_log('err','Unable to create %s', $tmp_dir); return undef; } my $mhonarc_ressources = &tools::get_filename('etc',{},'mhonarc-ressources.tt2', $robot, $self); unless ($mhonarc_ressources) { do_log('notice',"Cannot find any MhOnArc ressource file"); return undef; } ## generate HTML chdir $tmp_dir; my $mhonarc = &Conf::get_robot_conf($robot, 'mhonarc'); open ARCMOD, "$mhonarc -single -rcfile $mhonarc_ressources -definevars listname=$name -definevars hostname=$host $mod_file|"; open MSG, ">msg00000.html"; &do_log('debug', "$mhonarc -single -rcfile $mhonarc_ressources -definevars listname=$name -definevars hostname=$host $mod_file"); print MSG ; close MSG; close ARCMOD; chdir $Conf{'home'}; } } @rcpt = $self->get_editors_email(); ## Did we find a recipient? if ($#rcpt < 0) { &do_log('notice', "No editor found for list %s. Trying to proceed ignoring nomail option", $self->{'name'}); my $hdr = $message->{'msg'}->head; my $messageid = $hdr->get('Message-Id'); @rcpt = $self->get_editors_email({'ignore_nomail',1}); &do_log('notice', 'Warning : no owner and editor defined at all in list %s', $name ) unless (@rcpt); ## Could we find a recipient by ignoring the "nomail" option? if ($#rcpt >= 0) { &do_log('notice', 'All the intended recipients of message %s in list %s have set the "nomail" option. Ignoring it and sending it to all of them.', $messageid, $self->{'name'} ); } else { &do_log ('err','Impossible to send the moderation request for message %s to editors of list %s. Neither editor nor owner defined!',$messageid,$self->{'name'}) ; return undef; } } my $param = {'modkey' => $modkey, 'boundary' => $boundary, 'msg_from' => $message->{'sender'}, 'mod_spool_size' => $self->get_mod_spool_size(), 'method' => $method}; if ($self->is_there_msg_topic()) { $param->{'request_topic'} = 1; } if ($encrypt eq 'smime_crypted') { ## Send a different crypted message to each moderator foreach my $recipient (@rcpt) { ## $msg->body_as_string respecte-t-il le Base64 ?? my $cryptedmsg = &tools::smime_encrypt($msg->head, $msg->body_as_string, $recipient); unless ($cryptedmsg) { &do_log('notice', 'Failed encrypted message for moderator'); # xxxx send a generic error message : X509 cert missing return undef; } my $crypted_file = $Conf{'tmpdir'}.'/'.$self->get_list_id().'.moderate.'.$$; unless (open CRYPTED, ">$crypted_file") { &do_log('notice', 'Could not create file %s', $crypted_file); return undef; } print CRYPTED $cryptedmsg; close CRYPTED; $param->{'msg_path'} = $crypted_file; &tt2::allow_absolute_path(); unless ($self->send_file('moderate', $recipient, $self->{'domain'}, $param)) { &do_log('notice',"Unable to send template 'moderate' to $recipient"); return undef; } } }else{ $param->{'msg_path'} = $file; &tt2::allow_absolute_path(); unless ($self->send_file('moderate', \@rcpt, $self->{'domain'}, $param)) { &do_log('notice',"Unable to send template 'moderate' to $self->{'name'} editors"); return undef; } } return $modkey; } #################################################### # send_auth #################################################### # Sends an authentication request for a sent message to distribute. # The message for distribution is copied in the authqueue # spool in order to wait for confirmation by its sender. # This message is named with a key. # In context of msg_topic defined, the sender must tag it # for the confirmation # # IN : -$self (+): ref(List) # -$message (+): ref(Message) # # OUT : $authkey : the key for naming message waiting # for confirmation (or tagging) in spool queueauth # | undef #################################################### sub send_auth { my($self, $message) = @_; my ($sender, $msg, $file) = ($message->{'sender'}, $message->{'msg'}, $message->{'filename'}); &do_log('debug3', 'List::send_auth(%s, %s)', $sender, $file); ## Ensure 1 second elapsed since last message sleep (1); my($i, @rcpt); my $admin = $self->{'admin'}; my $name = $self->{'name'}; my $host = $admin->{'host'}; my $robot = $self->{'domain'}; my $authqueue = $Conf{'queueauth'}; return undef unless ($name && $admin); my @now = localtime(time); my $messageid = $now[6].$now[5].$now[4].$now[3].$now[2].$now[1]."." .int(rand(6)).int(rand(6)).int(rand(6)).int(rand(6)) .int(rand(6)).int(rand(6))."\@".$host; my $authkey = Digest::MD5::md5_hex(join('/', $self->get_cookie(),$messageid)); my $auth_file = $authqueue.'/'.$self->get_list_id().'_'.$authkey; unless (open OUT, ">$auth_file") { &do_log('notice', 'Cannot create file %s', $auth_file); return undef; } unless (open IN, $file) { &do_log('notice', 'Cannot open file %s', $file); return undef; } print OUT ; close IN; close OUT; my $param = {'authkey' => $authkey, 'boundary' => "----------------- Message-Id: \<$messageid\>", 'file' => $file}; if ($self->is_there_msg_topic()) { $param->{'request_topic'} = 1; } &tt2::allow_absolute_path(); unless ($self->send_file('send_auth',$sender,$robot,$param)) { &do_log('notice',"Unable to send template 'send_auth' to $sender"); return undef; } return $authkey; } #################################################### # request_auth #################################################### # sends an authentification request for a requested # command . # # # IN : -$self : ref(List) if is present # -$email(+) : recepient (the personn who asked # for the command) # -$cmd : -signoff|subscribe|add|del|remind if $self # -remind else # -$robot(+) : robot # -@param : 0 : used if $cmd = subscribe|add|del|invite # 1 : used if $cmd = add # # OUT : 1 | undef # #################################################### sub request_auth { do_log('debug2', 'List::request_auth(%s, %s, %s, %s)', @_); my $first_param = shift; my ($self, $email, $cmd, $robot, @param); if (ref($first_param) eq 'List') { $self = $first_param; $email= shift; }else { $email = $first_param; } $cmd = shift; $robot = shift; @param = @_; &do_log('debug3', 'List::request_auth() List : %s,$email: %s cmd : %s',$self->{'name'},$email,$cmd); my $keyauth; my $data = {'to' => $email}; if (ref($self) eq 'List') { my $listname = $self->{'name'}; $data->{'list_context'} = 1; if ($cmd =~ /signoff$/){ $keyauth = $self->compute_auth ($email, 'signoff'); $data->{'command'} = "auth $keyauth $cmd $listname $email"; $data->{'type'} = 'signoff'; }elsif ($cmd =~ /subscribe$/){ $keyauth = $self->compute_auth ($email, 'subscribe'); $data->{'command'} = "auth $keyauth $cmd $listname $param[0]"; $data->{'type'} = 'subscribe'; }elsif ($cmd =~ /add$/){ $keyauth = $self->compute_auth ($param[0],'add'); $data->{'command'} = "auth $keyauth $cmd $listname $param[0] $param[1]"; $data->{'type'} = 'add'; }elsif ($cmd =~ /del$/){ my $keyauth = $self->compute_auth($param[0], 'del'); $data->{'command'} = "auth $keyauth $cmd $listname $param[0]"; $data->{'type'} = 'del'; }elsif ($cmd eq 'remind'){ my $keyauth = $self->compute_auth('','remind'); $data->{'command'} = "auth $keyauth $cmd $listname"; $data->{'type'} = 'remind'; }elsif ($cmd eq 'invite'){ my $keyauth = $self->compute_auth($param[0],'invite'); $data->{'command'} = "auth $keyauth $cmd $listname $param[0]"; $data->{'type'} = 'invite'; } $data->{'command_escaped'} = &tt2::escape_url($data->{'command'}); unless ($self->send_file('request_auth',$email,$robot,$data)) { &do_log('notice',"Unable to send template 'request_auth' to $email"); return undef; } }else { if ($cmd eq 'remind'){ my $keyauth = &List::compute_auth('',$cmd); $data->{'command'} = "auth $keyauth $cmd *"; $data->{'command_escaped'} = &tt2::escape_url($data->{'command'}); $data->{'type'} = 'remind'; } unless (&send_global_file('request_auth',$email,$robot,$data)) { &do_log('notice',"Unable to send template 'request_auth' to $email"); return undef; } } return 1; } #################################################### # archive_send #################################################### # sends an archive file to someone (text archive # file : independant from web archives) # # IN : -$self(+) : ref(List) # -$who(+) : recepient # -file(+) : name of the archive file to send # OUT : - | undef # ###################################################### sub archive_send { my($self, $who, $file) = @_; do_log('debug', 'List::archive_send(%s, %s)', $who, $file); return unless ($self->is_archived()); my $dir = &Conf::get_robot_conf($self->{'domain'},'arc_path').'/'.$self->get_list_id(); my $msg_list = Archive::scan_dir_archive($dir, $file); my $subject = 'File '.$self->{'name'}.' '.$file ; my $param = {'to' => $who, 'subject' => $subject, 'msg_list' => $msg_list } ; $param->{'boundary1'} = &tools::get_message_id($self->{'domain'}); $param->{'boundary2'} = &tools::get_message_id($self->{'domain'}); $param->{'from'} = &Conf::get_robot_conf($self->{'domain'},'sympa'); # open TMP2, ">/tmp/digdump"; &tools::dump_var($param, 0, \*TMP2); close TMP2; unless ($self->send_file('get_archive',$who,$self->{'domain'},$param)) { &do_log('notice',"Unable to send template 'archive_send' to $who"); return undef; } } #################################################### # archive_send_last #################################################### # sends last archive file # # IN : -$self(+) : ref(List) # -$who(+) : recepient # OUT : - | undef # ###################################################### sub archive_send_last { my($self, $who) = @_; do_log('debug', 'List::archive_send_last(%s, %s)',$self->{'listname'}, $who); return unless ($self->is_archived()); my $dir = $self->{'dir'}.'/archives' ; my $mail = new Message("$dir/last_message",'noxsympato'); unless (defined $mail) { &do_log('err', 'Unable to create Message object %s', "$dir/last_message"); return undef; } my @msglist; my $msg = {}; $msg->{'id'} = 1; $msg->{'subject'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Subject'), Charset=>'utf8'); chomp $msg->{'subject'}; $msg->{'from'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('From'), Charset=>'utf8'); chomp $msg->{'from'}; $msg->{'date'} = &MIME::EncWords::decode_mimewords($mail->{'msg'}->head->get('Date'), Charset=>'utf8'); chomp $msg->{'date'}; $msg->{'full_msg'} = $mail->{'msg'}->as_string; push @msglist,$msg; my $subject = 'File '.$self->{'name'}.'.last_message' ; my $param = {'to' => $who, 'subject' => $subject, 'msg_list' => \@msglist } ; $param->{'boundary1'} = &tools::get_message_id($self->{'domain'}); $param->{'boundary2'} = &tools::get_message_id($self->{'domain'}); $param->{'from'} = &Conf::get_robot_conf($self->{'domain'},'sympa'); # open TMP2, ">/tmp/digdump"; &tools::dump_var($param, 0, \*TMP2); close TMP2; unless ($self->send_file('get_archive',$who,$self->{'domain'},$param)) { &do_log('notice',"Unable to send template 'archive_send' to $who"); return undef; } } ######################### NOTIFICATION SENDING ###################################### #################################################### # send_notify_to_listmaster #################################################### # Sends a notice to listmaster by parsing # listmaster_notification.tt2 template # # IN : -$operation (+): notification type # -$robot (+): robot # -$param(+) : ref(HASH) | ref(ARRAY) # values for template parsing # # OUT : 1 | undef # ###################################################### sub send_notify_to_listmaster { my ($operation, $robot, $param) = @_; unless ($operation eq 'logs_failed') { &do_log('debug2', 'List::send_notify_to_listmaster(%s,%s )', $operation, $robot ); } unless ($operation eq 'logs_failed') { unless (defined $operation) { &do_log('err','List::send_notify_to_listmaster(%s) : missing incoming parameter "$operation"'); return undef; } unless (defined $robot) { &do_log('err','List::send_notify_to_listmaster(%s) : missing incoming parameter "$robot"'); return undef; } } my $host = &Conf::get_robot_conf($robot, 'host'); my $listmaster = &Conf::get_robot_conf($robot, 'listmaster'); my $to = "$Conf{'listmaster_email'}\@$host"; my $options = {}; ## options for send_global_file() if ($operation eq 'logs_failed') { my $data = {'to' => $to, 'type' => $operation}; for my $i(0..$#{$param}) { $data->{"param$i"} = $param->[$i]; } unless (&send_global_file('listmaster_notification', $listmaster, $robot, $data, $options)) { return undef; } return 1; } if (ref($param) eq 'HASH') { $param->{'to'} = $to; $param->{'type'} = $operation; ## Prepare list-related data if ($param->{'list'} && ref($param->{'list'}) eq 'List') { my $list = $param->{'list'}; $param->{'list'} = {'name' => $list->{'name'}, 'host' => $list->{'domain'}, 'subject' => $list->{'admin'}{'subject'}}; } ## Automatic action done on bouncing adresses if ($operation eq 'automatic_bounce_management') { my $list = new List ($param->{'listname'}, $robot); unless (defined $list) { &do_log('err','Parameter %s is not a valid list', $param->{'listname'}); return undef; } unless ($list->send_file('listmaster_notification',$listmaster, $robot, $param, $options)) { &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster"); return undef; } }else { ## No DataBase | DataBase restored if (($operation eq 'no_db')||($operation eq 'db_restored')) { $param->{'db_name'} = &Conf::get_robot_conf($robot, 'db_name'); $options->{'skip_db'} = 1; ## Skip DB access because DB is not accessible ## Loop detected in Sympa }elsif ($operation eq 'loop_command') { $param->{'boundary'} = '----------=_'.&tools::get_message_id($robot); &tt2::allow_absolute_path(); } unless (&send_global_file('listmaster_notification', $listmaster, $robot, $param, $options)) { &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster"); return undef; } } }elsif(ref($param) eq 'ARRAY') { my $data = {'to' => $to, 'type' => $operation}; for my $i(0..$#{$param}) { $data->{"param$i"} = $param->[$i]; } unless (&send_global_file('listmaster_notification', $listmaster, $robot, $data, $options)) { &do_log('notice',"Unable to send template 'listmaster_notification' to $listmaster"); return undef; } }else { &do_log('err','List::send_notify_to_listmaster(%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY', $operation, $robot ); return undef; } return 1; } #################################################### # send_notify_to_owner #################################################### # Sends a notice to list owner(s) by parsing # listowner_notification.tt2 template # # IN : -$self (+): ref(List) # -$operation (+): notification type # -$param(+) : ref(HASH) | ref(ARRAY) # values for template parsing # # OUT : 1 | undef # ###################################################### sub send_notify_to_owner { my ($self,$operation,$param) = @_; &do_log('debug2', 'List::send_notify_to_owner(%s, %s)', $self->{'name'}, $operation); my $host = $self->{'admin'}{'host'}; my @to = $self->get_owners_email(); my $robot = $self->{'domain'}; unless (@to) { do_log('notice', 'No owner defined or all of them use nomail option in list %s ; using listmasters as default', $self->{'name'} ); @to = split /,/, &Conf::get_robot_conf($robot, 'listmaster'); } unless (defined $operation) { &do_log('err','List::send_notify_to_owner(%s) : missing incoming parameter "$operation"', $self->{'name'}); return undef; } if (ref($param) eq 'HASH') { $param->{'to'} =join(',', @to); $param->{'type'} = $operation; if ($operation eq 'subrequest') { $param->{'escaped_gecos'} = $param->{'gecos'}; $param->{'escaped_gecos'} =~ s/\s/\%20/g; $param->{'escaped_who'} = $param->{'who'}; $param->{'escaped_who'} =~ s/\s/\%20/g; }elsif ($operation eq 'sigrequest') { $param->{'escaped_who'} = $param->{'who'}; $param->{'escaped_who'} =~ s/\s/\%20/g; $param->{'sympa'} = &Conf::get_robot_conf($self->{'domain'}, 'sympa'); }elsif ($operation eq 'bounce_rate') { $param->{'rate'} = int ($param->{'rate'} * 10) / 10; } unless ($self->send_file('listowner_notification',\@to, $robot,$param)) { &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner"); return undef; } }elsif(ref($param) eq 'ARRAY') { my $data = {'to' => join(',', @to), 'type' => $operation}; for my $i(0..$#{$param}) { $data->{"param$i"} = $param->[$i]; } unless ($self->send_file('listowner_notification', \@to, $robot, $data)) { &do_log('notice',"Unable to send template 'listowner_notification' to $self->{'name'} list owner"); return undef; } }else { &do_log('err','List::send_notify_to_owner(%s,%s) : error on incoming parameter "$param", it must be a ref on HASH or a ref on ARRAY', $self->{'name'},$operation); return undef; } return 1; } ######################### ## Delete a pictures file ######################### # remove picture from user $2 in list $1 ######################### sub delete_user_picture { my ($self,$email) = @_; do_log('debug2', 'delete_user_picture(%s)', $email); my $fullfilename; my $filename = &tools::md5_fingerprint($email); my $name = $self->{'name'}; my $robot = $self->{'domain'}; my $fullfilename = undef; foreach my $ext ('.gif','.jpg','.jpeg','.png') { if(-f &Conf::get_robot_conf($robot,'pictures_path').'/'.$name.'@'.$robot.'/'.$filename.$ext) { my $file = &Conf::get_robot_conf($robot,'pictures_path').'/'.$name.'@'.$robot.'/'.$filename.$ext; $fullfilename = $file; last; } } if (defined $fullfilename) { unless(unlink($fullfilename)) { do_log('err', 'delete_user_picture() : Failed to delete '.$fullfilename); return undef; } do_log('notice', 'delete_user_picture() : File deleted successfull '.$fullfilename); } return 1; } #################################################### # send_notify_to_editor #################################################### # Sends a notice to list editor(s) or owner (if no editor) # by parsing listeditor_n