List.pm 352 KB
Newer Older
1
2
3
4
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$

5
# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
10
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
# Copyright (c) 2011, 2012, 2013, 2014 GIP RENATER
11
12
13
14
15
16
17
18
19
20
21
#
# 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.
#
22
23
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
root's avatar
root committed
24
25
26
27

package List;

use strict;
28
use warnings;
29
use Exporter;
30
31
use Encode;
use HTML::Entities qw(encode_entities);
32
33
use IO::Scalar;
use MIME::EncWords;
34
use MIME::Entity;
35
use MIME::Parser;
36
37
38
use POSIX qw(strftime);
use Storable;
use Time::Local qw(timelocal);
39

40
use Archive;
41
42
use Conf;
use Sympa::Constants;
43
use Datasource;
44
use Family;
45
use Fetch;
46
use Sympa::Language;
47
use LDAPSource;
48
use Sympa::ListDef;
49
use Sympa::LockedFile;
50
51
52
53
use Log;
use mail;
use Message;
use PlainDigest;
54
55
56
57
58
59
use Sympa::Regexps;
use Scenario;
use SDM;
use SQLSource;
use Task;
use tools;
60
use tt2;
61
62
use Sympa::User;
use WebAgent;
63

64
65
our @ISA = qw(Exporter);
our @EXPORT = qw(%list_of_lists);
root's avatar
root committed
66

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
my @sources_providing_listmembers = qw/
  include_file
  include_ldap_2level_query
  include_ldap_query  
  include_list
  include_remote_file
  include_remote_sympa_list  
  include_sql_query  
 /;

#XXX include_admin  
my @more_data_sources = qw/
  editor_include  
  owner_include
  /;

# All non-pluggable sources are in the admin user file
my %config_in_admin_user_file = map +($_ => 1), @sources_providing_listmembers;

86
87
88
89
90
# Language context
my $language = Sympa::Language->instance;

=encoding utf-8

root's avatar
root committed
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
=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 )
129
    
root's avatar
root committed
130
131
132
133
134
135
136
137
138
139
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.

140
=item delete_list_member ( ARRAY )
root's avatar
root committed
141
142
143

Delete the indicated users from the list.
 
144
=item delete_list_admin ( ROLE, ARRAY )
145
146
147

Delete the indicated admin user with the predefined role from the list.

root's avatar
root committed
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
=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.

168

169
=item get_global_user ( USER )
root's avatar
root committed
170

171
Returns a hash with the information regarding the indicated
root's avatar
root committed
172
173
user.

174
=item get_list_member ( USER )
175
176

Returns a subscriber of the list.
david.verdin's avatar
david.verdin committed
177

178
=item get_list_admin ( ROLE, USER)
179
180
181

Return an admin user of the list with predefined role

182
=item get_first_list_member ()
root's avatar
root committed
183
184
185

Returns a hash to the first user on the list.

186
=item get_first_list_admin ( ROLE )
187

188
Returns a hash to the first admin user with predefined role on the list.
189

190
=item get_next_list_member ()
root's avatar
root committed
191
192
193
194

Returns a hash to the next users, until we reach the end of
the list.

195
=item get_next_list_admin ()
196
197
198
199

Returns a hash to the next admin users, until we reach the end of
the list.

200
=item update_list_member ( USER, HASHPTR )
root's avatar
root committed
201
202
203

Sets the new values given in the hash for the user.

204
=item update_list_admin ( USER, ROLE, HASHPTR )
205
206
207

Sets the new values given in the hash for the admin user.

208
=item add_list_member ( USER, HASHPTR )
root's avatar
root committed
209
210
211
212

Adds a new user to the list. May overwrite existing
entries.

213
214
215
216
217
=item add_admin_user ( USER, ROLE, HASHPTR )

Adds a new admin user to the list. May overwrite existing
entries.

218
=item is_list_member ( USER )
root's avatar
root committed
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268

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 )

269
Print the list information to the given file descriptor, or the
root's avatar
root committed
270
271
272
273
274
currently selected descriptor.

=cut

## Database and SQL statement handlers
275
my ($sth, @sth_stack);
276
277
278

my %list_cache;

279
280
281
## DB fields with numeric type
## We should not do quote() for these while inserting data
my %numeric_field = ('cookie_delay_user' => 1,
282
283
284
285
286
287
		     'bounce_score_subscriber' => 1,
		     'subscribed_subscriber' => 1,
		     'included_subscriber' => 1,
		     'subscribed_admin' => 1,
		     'included_admin' => 1,
		     'wrong_login_count' => 1,
288
289
		      );
		      
root's avatar
root committed
290

291
292
293
294
295
296
297
298
299
300
301
302
303
304
## List parameter values except for parameters below.
my %list_option = (

    # reply_to_header.apply
    'forced'  => {'gettext_id' => 'overwrite Reply-To: header field'},
    'respect' => {'gettext_id' => 'preserve existing header field'},

    # reply_to_header.value
    'sender' => {'gettext_id' => 'sender'},

    # reply_to_header.value, include_remote_sympa_list.cert
    'list' => {'gettext_id' => 'list'},

    # include_ldap_2level_query.select2, include_ldap_2level_query.select1,
305
    # include_ldap_query.select, reply_to_header.value, dmarc_protection.mode
306
307
308
309
310
311
312
313
314
315
316
317
    'all' => {'gettext_id' => 'all'},

    # reply_to_header.value
    'other_email' => {'gettext_id' => 'other email address'},

    # msg_topic_keywords_apply_on
    'subject'          => {'gettext_id' => 'subject field'},
    'body'             => {'gettext_id' => 'message body'},
    'subject_and_body' => {'gettext_id' => 'subject and body'},

    # bouncers_level2.notification, bouncers_level2.action,
    # bouncers_level1.notification, bouncers_level1.action,
318
319
    # spam_protection, dkim_signature_apply_on, web_archive_spam_protection,
    # dmarc_protection.mode
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
    'none' => {'gettext_id' => 'do nothing'},

    # bouncers_level2.notification, bouncers_level1.notification,
    # welcome_return_path, remind_return_path, rfc2369_header_fields,
    # archive.access
    'owner' => {'gettext_id' => 'owner'},

    # bouncers_level2.notification, bouncers_level1.notification
    'listmaster' => {'gettext_id' => 'listmaster'},

    # bouncers_level2.action, bouncers_level1.action
    'remove_bouncers' => {'gettext_id' => 'remove bouncing users'},
    'notify_bouncers' => {'gettext_id' => 'send notify to bouncing users'},

    # pictures_feature, dkim_feature, merge_feature,
335
336
    # inclusion_notification_feature, tracking.delivery_status_notification,
    # tracking.message_delivery_notification
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
    'on'  => {'gettext_id' => 'enabled'},
    'off' => {'gettext_id' => 'disabled'},

    # include_remote_sympa_list.cert
    'robot' => {'gettext_id' => 'robot'},

    # include_ldap_2level_query.select2, include_ldap_2level_query.select1,
    # include_ldap_query.select
    'first' => {'gettext_id' => 'first entry'},

    # include_ldap_2level_query.select2, include_ldap_2level_query.select1
    'regex' => {'gettext_id' => 'entries matching regular expression'},

    # include_ldap_2level_query.scope2, include_ldap_2level_query.scope1,
    # include_ldap_query.scope
    'base' => {'gettext_id' => 'base'},
    'one'  => {'gettext_id' => 'one level'},
    'sub'  => {'gettext_id' => 'subtree'},

    # include_ldap_2level_query.use_ssl, include_ldap_query.use_ssl
    'yes' => {'gettext_id' => 'yes'},
    'no'  => {'gettext_id' => 'no'},

    # include_ldap_2level_query.ssl_version, include_ldap_query.ssl_version
    'sslv2' => {'gettext_id' => 'SSL version 2'},
    'sslv3' => {'gettext_id' => 'SSL version 3'},
    'tls'   => {'gettext_id' => 'TLS'},

    # editor.reception, owner_include.reception, owner.reception,
    # editor_include.reception
    'mail'   => {'gettext_id' => 'receive notification email'},
    'nomail' => {'gettext_id' => 'no notifications'},

    # editor.visibility, owner_include.visibility, owner.visibility,
    # editor_include.visibility
    'conceal'   => {'gettext_id' => 'concealed from list menu'},
    'noconceal' => {'gettext_id' => 'listed on the list menu'},

    # welcome_return_path, remind_return_path
    'unique' => {'gettext_id' => 'bounce management'},

    # owner_include.profile, owner.profile
    'privileged' => {'gettext_id' => 'privileged owner'},
    'normal'     => {'gettext_id' => 'normal owner'},

    # priority
    '0' => {'gettext_id' => '0 - highest priority'},
    '9' => {'gettext_id' => '9 - lowest priority'},
    'z' => {'gettext_id' => 'queue messages only'},

    # spam_protection, web_archive_spam_protection
    'at'         => {'gettext_id' => 'replace @ characters'},
    'javascript' => {'gettext_id' => 'use JavaScript'},

    # msg_topic_tagging
    'required_sender' => {'gettext_id' => 'required to post message'},
    'required_moderator' =>
	{'gettext_id' => 'required to distribute message'},

    # msg_topic_tagging, custom_attribute.optional
    'optional' => {'gettext_id' => 'optional'},

    # custom_attribute.optional
    'required' => {'gettext_id' => 'required'},

    # custom_attribute.type
    'string'  => {'gettext_id' => 'string'},
    'text'    => {'gettext_id' => 'multi-line text'},
    'integer' => {'gettext_id' => 'number'},
    'enum'    => {'gettext_id' => 'set of keywords'},

    # footer_type
    'mime'   => {'gettext_id' => 'add a new MIME part'},
    'append' => {'gettext_id' => 'append to message body'},

    # archive.access
    'open'    => {'gettext_id' => 'open'},
    'closed'  => {'gettext_id' => 'closed'},
    'private' => {'gettext_id' => 'subscribers only'},
    'public'  => {'gettext_id' => 'public'},

##    ## user_data_source
##    'database' => {'gettext_id' => 'RDBMS'},
##    'file'     => {'gettext_id' => 'include from local file'},
##    'include'  => {'gettext_id' => 'include from external source'},
##    'include2' => {'gettext_id' => 'general datasource'},

    # rfc2369_header_fields
    'help'        => {'gettext_id' => 'help'},
    'subscribe'   => {'gettext_id' => 'subscription'},
    'unsubscribe' => {'gettext_id' => 'unsubscription'},
    'post'        => {'gettext_id' => 'posting address'},
    'archive'     => {'gettext_id' => 'list archive'},

    # dkim_signature_apply_on
    'md5_authenticated_messages' =>
	{'gettext_id' => 'authenticated by password'},
    'smime_authenticated_messages' =>
	{'gettext_id' => 'authenticated by S/MIME signature'},
    'dkim_authenticated_messages' =>
	{'gettext_id' => 'authenticated by DKIM signature'},
    'editor_validated_messages' => {'gettext_id' => 'approved by editor'},
    'any'                       => {'gettext_id' => 'any messages'},

    # archive.period
    'day'     => {'gettext_id' => 'daily'},
    'week'    => {'gettext_id' => 'weekly'},
    'month'   => {'gettext_id' => 'monthly'},
    'quarter' => {'gettext_id' => 'quarterly'},
    'year'    => {'gettext_id' => 'yearly'},

    # web_archive_spam_protection
    'cookie' => {'gettext_id' => 'use HTTP cookie'},

    # verp_rate
    '100%' => {'gettext_id' => '100% - always'},
    '0%'   => {'gettext_id' => '0% - never'},

    # archive_crypted_msg
    'original'  => {'gettext_id' => 'original messages'},
    'decrypted' => {'gettext_id' => 'decrypted messages'},
458
459
460

    # tracking.message_delivery_notification
    'on_demand' => {'gettext_id' => 'on demand'},
461
462
463

    # dmarc_protection.mode
    'dkim_signature' => {'gettext_id' => 'DKIM signature exists'},
464
    'dmarc_any'      => {'gettext_id' => 'DMARC policy exists'},
465
    'dmarc_reject'   => {'gettext_id' => 'DMARC policy suggests rejection'},
466
    'dmarc_quarantine' => {'gettext_id' => 'DMARC policy suggests quarantine'},
467
468
469
470
471
    'domain_regex'   => {'gettext_id' => 'domain matching regular expression'},

    # dmarc_protection.phrase
    'display_name'   => {'gettext_id' => 'display name'},
    'name_and_email' => {'gettext_id' => 'display name and e-mail'},
472
473
    'name_via_list'  => {'gettext_id' => 'name "via Mailing List"'},
    'name_email_via_list' => {'gettext_id' => 'e-mail "via Mailing List"'},
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
);

## Values for subscriber reception mode.
my %reception_mode = (
    'mail'        => {'gettext_id' => 'standard (direct reception)'},
    'digest'      => {'gettext_id' => 'digest MIME format'},
    'digestplain' => {'gettext_id' => 'digest plain text format'},
    'summary'     => {'gettext_id' => 'summary mode'},
    'notice'      => {'gettext_id' => 'notice mode'},
    'txt'         => {'gettext_id' => 'text-only mode'},
    'html'        => {'gettext_id' => 'html-only mode'},
    'urlize'      => {'gettext_id' => 'urlize mode'},
    'nomail'      => {'gettext_id' => 'no mail'},
    'not_me'      => {'gettext_id' => 'you do not receive your own posts'}
);

## Values for subscriber visibility mode.
my %visibility_mode = (
    'noconceal' => {'gettext_id' => 'listed in the list review page'},
    'conceal'   => {'gettext_id' => 'concealed'}
);

## Values for list status.
my %list_status = (
    'open'          => {'gettext_id' => 'in operation'},
    'pending'       => {'gettext_id' => 'list not yet activated'},
    'error_config'  => {'gettext_id' => 'erroneous configuration'},
    'family_closed' => {'gettext_id' => 'closed family instance'},
    'closed'        => {'gettext_id' => 'closed list'},
);

root's avatar
root committed
505
506
## This is the generic hash which keeps all lists in memory.
my %list_of_lists = ();
salaun's avatar
salaun committed
507
my %list_of_robots = ();
508
our %list_of_topics = ();
salaun's avatar
salaun committed
509
510
511
512
my %edit_list_conf = ();

## Last modification times
my %mtime;
root's avatar
root committed
513
514

use DB_File;
515
$DB_BTREE->{compare} = \&_compare_addresses;
root's avatar
root committed
516

517
518
our %listmaster_messages_stack;

root's avatar
root committed
519
520
## Creates an object.
sub new {
521
    my($pkg, $name, $robot, $options) = @_;
522
    my $list={};
523
    &Log::do_log('debug2', 'List::new(%s, %s, %s)', $name, $robot, join('/',keys %$options));
524
525
526
527
528
529
530
    
    ## Allow robot in the name
    if ($name =~ /\@/) {
	my @parts = split /\@/, $name;
	$robot ||= $parts[1];
	$name = $parts[0];
    }
root's avatar
root committed
531

532
533
534
    ## Look for the list if no robot was provided
    $robot ||= &search_list_among_robots($name);

535
    unless ($robot) {
536
	&Log::do_log('err', 'Missing robot parameter, cannot create list object for %s',  $name) unless ($options->{'just_try'});
537
538
539
	return undef;
    }

540
541
    $options = {} unless (defined $options);

root's avatar
root committed
542
    ## Only process the list if the name is valid.
543
    my $listname_regexp = Sympa::Regexps::listname();
544
    unless ($name and ($name =~ /^($listname_regexp)$/io) ) {
545
	&Log::do_log('err', 'Incorrect listname "%s"',  $name) unless ($options->{'just_try'});
root's avatar
root committed
546
547
548
	return undef;
    }
    ## Lowercase the list name.
549
    $name = $1;
root's avatar
root committed
550
    $name =~ tr/A-Z/a-z/;
551
    
552
553
554
555
    ## Reject listnames with reserved list suffixes
    my $regx = &Conf::get_robot_conf($robot,'list_check_regexp');
    if ( $regx ) {
	if ($name =~ /^(\S+)-($regx)$/) {
556
	    &Log::do_log('err', 'Incorrect name: listname "%s" matches one of service aliases',  $name) unless ($options->{'just_try'});
557
	    return undef;
558
559
560
	}
    }

561
    my $status ;
562
563
    ## If list already in memory and not previously purged by another process
    if ($list_of_lists{$robot}{$name} and -d $list_of_lists{$robot}{$name}{'dir'}){
root's avatar
root committed
564
	# use the current list in memory and update it
565
	$list=$list_of_lists{$robot}{$name};
566
567
	
	$status = $list->load($name, $robot, $options);
root's avatar
root committed
568
569
    }else{
	# create a new object list
570
	bless $list, $pkg;
571
572
573
574

	$options->{'first_access'} = 1;
	$status = $list->load($name, $robot, $options);
    }   
575
576
577
578
579
    unless (defined $status) {
	return undef;
    }

    ## Config file was loaded or reloaded
580
581
582
583
584
585
586
587
    my $pertinent_ttl = $list->{'admin'}{'distribution_ttl'}||$list->{'admin'}{'ttl'};
    if (
	$status == 1
	&& (! $options->{'skip_sync_admin'}
	|| ($options->{'optional_sync_admin'} && $list->{'last_sync'} < time - $pertinent_ttl)
	|| $options->{'force_sync_admin'})
	)
    {
588
589
	## Update admin_table
	unless (defined $list->sync_include_admin()) {
590
	    &Log::do_log('err','List::new() : sync_include_admin_failed') unless ($options->{'just_try'});
591
592
593
	}
	if ($list->get_nb_owners() < 1 &&
	    $list->{'admin'}{'status'} ne 'error_config') {
594
	    &Log::do_log('err', 'The list "%s" has got no owner defined',$list->{'name'}) ;
595
596
	    $list->set_status_error_config('no_owner_defined',$list->{'name'});
	}
root's avatar
root committed
597
598
    }

599
600
601
    return $list;
}

602
603
604
605
606
## When no robot is specified, look for a list among robots
sub search_list_among_robots {
    my $listname = shift;
    
    unless ($listname) {
607
 	&Log::do_log('err', 'List::search_list_among_robots() : Missing list parameter');
608
609
610
611
 	return undef;
    }
    
    ## Search in default robot
612
    if (-d $Conf::Conf{'home'}.'/'.$listname) {
613
 	return $Conf::Conf{'domain'};
614
615
    }
    
616
617
     foreach my $r (keys %{$Conf::Conf{'robots'}}) {
	 if (-d $Conf::Conf{'home'}.'/'.$r.'/'.$listname) {
618
619
620
621
622
623
624
	     return $r;
	 }
     }
    
     return 0;
}

625
626
627
## set the list in status error_config and send a notify to listmaster
sub set_status_error_config {
    my ($self, $message, @param) = @_;
628
    &Log::do_log('debug3', 'List::set_status_error_config');
629
630
631

    unless ($self->{'admin'}{'status'} eq 'error_config'){
	$self->{'admin'}{'status'} = 'error_config';
632

633
	#my $host = &Conf::get_robot_conf($self->{'domain'}, 'host');
634
635
636
	## No more save config in error...
	#$self->save_config("listmaster\@$host");
	#$self->savestats();
637
	&Log::do_log('err', 'The list "%s" is set in status error_config',$self->{'name'});
638
	unless (&List::send_notify_to_listmaster($message, $self->{'domain'},\@param)) {
639
	    &Log::do_log('notice',"Unable to send notify '$message' to listmaster");
640
	};
641
642
643
644
645
646
    }
}

## set the list in status family_closed and send a notify to owners
sub set_status_family_closed {
    my ($self, $message, @param) = @_;
647
    &Log::do_log('debug2', 'List::set_status_family_closed');
648
    
649
    unless ($self->{'admin'}{'status'} eq 'family_closed'){
650
	
651
	my $host = &Conf::get_robot_conf($self->{'domain'}, 'host');	
652
	
653
	unless ($self->close_list("listmaster\@$host",'family_closed')) {
654
	    &Log::do_log('err','Impossible to set the list %s in status family_closed');
655
656
	    return undef;
	}
657
	&Log::do_log('info', 'The list "%s" is set in status family_closed',$self->{'name'});
658
	unless ($self->send_notify_to_owner($message,\@param)){
659
	    &Log::do_log('err','Impossible to send notify to owner informing status family_closed for the list %s',$self->{'name'});
660
	}
661
# messages : close_list
662
663
    }
    return 1;
root's avatar
root committed
664
665
666
667
668
}

## Saves the statistics data to disk.
sub savestats {
    my $self = shift;
669
    &Log::do_log('debug2', 'List::savestats');
root's avatar
root committed
670
671
672
   
    ## Be sure the list has been loaded.
    my $name = $self->{'name'};
salaun's avatar
salaun committed
673
    my $dir = $self->{'dir'};
674
    return undef unless ($list_of_lists{$self->{'domain'}}{$name});
675
676
677

    unless (ref($self->{'stats'}) eq 'ARRAY') {
	Log::do_log('err', 'incorrect parameter');
678
679
	return undef;
    }
680
681
682
683
684

    ## Lock file
    my $lock_fh = Sympa::LockedFile->new($dir . '/stats', 2, '>');
    unless ($lock_fh) {
	Log::do_log('err','Could not create new lock');
olivier.salaun's avatar
olivier.salaun committed
685
686
687
	return undef;
    }   

688
689
690
691
    printf $lock_fh "%d %.0f %.0f %.0f %d %d %d\n",
	@{$self->{'stats'}}, $self->{'total'}, $self->{'last_sync'},
	$self->{'last_sync_admin_user'};

olivier.salaun's avatar
olivier.salaun committed
692
    ## Release the lock
693
    unless ($lock_fh->close) {
olivier.salaun's avatar
olivier.salaun committed
694
695
696
	return undef;
    }

root's avatar
root committed
697
698
699
700
701
702
    ## Changed on disk
    $self->{'mtime'}[2] = time;

    return 1;
}

703
704
705
## msg count.
sub increment_msg_count {
    my $self = shift;
706
    &Log::do_log('debug2', "List::increment_msg_count($self->{'name'})");
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
   
    ## 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 (<MSG_COUNT>){
	    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.$$")) {
729
	&Log::do_log('err', "Unable to create '%s.%s' : %s", $file,$$, $!);
730
731
	return undef;
    }
732
    foreach my $key (sort {$a <=> $b} keys %count) {
733
734
735
736
737
	printf MSG_COUNT "%d\t%d\n",$key,$count{$key} ;
    }
    close MSG_COUNT ;
    
    unless (rename("$file.$$", $file)) {
738
	&Log::do_log('err', "Unable to write '%s' : %s", $file, $!);
739
740
741
742
743
	return undef;
    }
    return 1;
}

744
745
746
# Returns the number of messages sent to the list
sub get_msg_count {
    my $self = shift;
747
    &Log::do_log('debug3', "Getting the number of messages for list %s",$self->{'name'});
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765

    ## Be sure the list has been loaded.
    my $name = $self->{'name'};
    my $file = "$self->{'dir'}/stats";
    
    my $count = 0 ;
    if (open(MSG_COUNT, $file)) {	
	while (<MSG_COUNT>){
	    if ($_ =~ /^(\d+)\s+(.*)$/) {
		$count=$1;	
	    }
	}
	close MSG_COUNT ;
    }

    return $count;

}
766
767
768
## last date of distribution message .
sub get_latest_distribution_date {
    my $self = shift;
769
    &Log::do_log('debug3', "List::latest_distribution_date($self->{'name'})");
770
771
772
773
774
775
   
    ## Be sure the list has been loaded.
    my $name = $self->{'name'};
    my $file = "$self->{'dir'}/msg_count";
    
    my %count ; 
salaun's avatar
salaun committed
776
777
    my $latest_date = 0 ; 
    unless (open(MSG_COUNT, $file)) {
778
	&Log::do_log('debug2',"get_latest_distribution_date: unable to open $file");
salaun's avatar
salaun committed
779
780
	return undef ;
    }
781
782
783
784
785
786
787
788

    while (<MSG_COUNT>){
	if ($_ =~ /^(\d+)\s(\d+)$/) {
	    $latest_date = $1 if ($1 > $latest_date);
	}
    }
    close MSG_COUNT ;

salaun's avatar
salaun committed
789
    return undef if ($latest_date == 0); 
790
791
792
    return $latest_date ;
}

root's avatar
root committed
793
794
795
796
797
## Update the stats struct 
## Input  : num of bytes of msg
## Output : num of msgs sent
sub update_stats {
    my($self, $bytes) = @_;
798
    &Log::do_log('debug2', 'List::update_stats(%d)', $bytes);
root's avatar
root committed
799
800
801
802
803
804

    my $stats = $self->{'stats'};
    $stats->[0]++;
    $stats->[1] += $self->{'total'};
    $stats->[2] += $bytes;
    $stats->[3] += $bytes * $self->{'total'};
805
806
807
808

    ## Update 'msg_count' file, used for bounces management
    $self->increment_msg_count();

root's avatar
root committed
809
810
811
    return $stats->[0];
}

812
813
814
815
816
817
## 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
818
sub extract_verp_rcpt {
819
820
821
822
823
    my $percent = shift;
    my $xseq = shift;
    my $refrcpt = shift;
    my $refrcptverp = shift;

824
    &Log::do_log('debug','&extract_verp(%s,%s,%s,%s)',$percent,$xseq,$refrcpt,$refrcptverp)  ;
825

826
    my @result;
827

828
    if ($percent ne '0%') {
829
830
	my $nbpart ; 
	if ( $percent =~ /^(\d+)\%/ ) {
831
832
833
	    $nbpart = 100/$1;  
	}
	else {
834
	    &Log::do_log ('err', 'Wrong format for parameter extract_verp: %s. Can\'t process VERP.',$percent);
835
836
837
838
839
840
841
842
	    return undef;
	}
	
	my $modulo = $xseq % $nbpart ;
	my $lenght = int (($#{$refrcpt} + 1) / $nbpart) + 1;
	
	@result = splice @$refrcpt, $lenght*$modulo, $lenght ;
    }
843
844
845
846
847
848
849
850
    foreach my $verprcpt (@$refrcptverp) {
	push @result, $verprcpt;
    }
    return ( @result ) ;
}



root's avatar
root committed
851
852
## Dumps a copy of lists to disk, in text format
sub dump {
853
    my $self = shift;
854
    &Log::do_log('debug2', 'List::dump(%s)', $self->{'name'});
855

856
    unless (defined $self) {
857
	&Log::do_log('err','Unknown list');
858
859
	return undef;
    }
860

861
    my $user_file_name = "$self->{'dir'}/subscribers.db.dump";
862

863
    unless ($self->_save_list_members_file($user_file_name)) {
864
	&Log::do_log('err', 'Failed to save file %s', $user_file_name);
865
	return undef;
root's avatar
root committed
866
    }
867
868
869
870
    
    $self->{'mtime'} = [ (stat("$self->{'dir'}/config"))[9], (stat("$self->{'dir'}/subscribers"))[9], (stat("$self->{'dir'}/stats"))[9] ];

    return 1;
root's avatar
root committed
871
872
873
874
875
}

## Saves the configuration file to disk
sub save_config {
    my ($self, $email) = @_;
876
    &Log::do_log('debug3', 'List::save_config(%s,%s)', $self->{'name'}, $email);
root's avatar
root committed
877

878
879
880
881
882
883
    return undef 
	unless ($self);

    my $config_file_name = "$self->{'dir'}/config";

    ## Lock file
884
885
886
    my $lock_fh = Sympa::LockedFile->new($config_file_name, 5, '+<');
    unless ($lock_fh) {
	Log::do_log('err', 'Could not create new lock');
887
888
889
	return undef;
    }

root's avatar
root committed
890
891
    my $name = $self->{'name'};    
    my $old_serial = $self->{'admin'}{'serial'};
salaun's avatar
salaun committed
892
    my $old_config_file_name = "$self->{'dir'}/config.$old_serial";
root's avatar
root committed
893
894
895

    ## Update management info
    $self->{'admin'}{'serial'}++;
896
897
898
899
900
901
    $self->{'admin'}{'update'} = {
	'email' => $email,
	'date_epoch' => time,
	'date' => $language->gettext_strftime(
	    "%d %b %Y at %H:%M:%S", localtime time),
    };
902

903
    unless ($self->_save_list_config_file($config_file_name, $old_config_file_name)) {
904
	&Log::do_log('info', 'unable to save config file %s', $config_file_name);
905
	$lock_fh->close();
root's avatar
root committed
906
907
	return undef;
    }
908
909
    
    ## Also update the binary version of the data structure
910
    if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file') {
911
912
	eval {&Storable::store($self->{'admin'},"$self->{'dir'}/config.bin")};
	if ($@) {
913
	    &Log::do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@);
914
	}
915
916
    }

salaun's avatar
salaun committed
917
#    $self->{'mtime'}[0] = (stat("$list->{'dir'}/config"))[9];
root's avatar
root committed
918
    
919
    ## Release the lock
920
    unless ($lock_fh->close()) {
921
922
923
	return undef;
    }

924
    if ($SDM::use_db) {
925
        unless (&_update_list_db) {
926
            &Log::do_log('err', "Unable to update list_table");
927
928
929
        }
    }

root's avatar
root committed
930
931
932
933
934
    return 1;
}

## Loads the administrative data for a list
sub load {
935
    my ($self, $name, $robot, $options) = @_;
936
    &Log::do_log('debug2', 'List::load(%s, %s, %s)', $name, $robot, join('/',keys %$options));
salaun's avatar
salaun committed
937
    
salaun's avatar
salaun committed
938
    my $users;
939

940
941
942
943
944
    ## Set of initializations ; only performed when the config is first loaded
    if ($options->{'first_access'}) {

	## Search robot if none was provided
	unless ($robot) {
945
946
	    foreach my $r (keys %{$Conf::Conf{'robots'}}) {
		if (-d "$Conf::Conf{'home'}/$r/$name") {
947
948
949
950
951
952
953
		    $robot=$r;
		    last;
		}
	    }
	    
	    ## Try default robot
	    unless ($robot) {
954
		if (-d "$Conf::Conf{'home'}/$name") {
955
		    $robot = $Conf::Conf{'domain'};
956
		}
957
958
959
	    }
	}
	
960
961
	if ($robot && (-d "$Conf::Conf{'home'}/$robot")) {
	    $self->{'dir'} = "$Conf::Conf{'home'}/$robot/$name";
962
	}elsif (lc($robot) eq lc($Conf::Conf{'domain'})) {
963
	    $self->{'dir'} = "$Conf::Conf{'home'}/$name";
964
	}else {
965
	    &Log::do_log('err', 'No such robot (virtual domain) %s', $robot) unless ($options->{'just_try'});
966
	    return undef ;
salaun's avatar
salaun committed
967
	}
968
969
	
	$self->{'domain'} = $robot ;
970

971
972
973
	# default list host is robot domain
	$self->{'admin'}{'host'} ||= $self->{'domain'};
	$self->{'name'}  = $name ;
974
    }
975

976
    unless ((-d $self->{'dir'}) && (-f "$self->{'dir'}/config")) {
977
	&Log::do_log('debug2', 'Missing directory (%s) or config file for %s', $self->{'dir'}, $name) unless ($options->{'just_try'});
978
979
	return undef ;
    }
salaun's avatar
salaun committed
980

981
982
    my ($m1, $m2, $m3) = (0, 0, 0);
    ($m1, $m2, $m3) = @{$self->{'mtime'}} if (defined $self->{'mtime'});
983
984

    my $time_config = (stat("$self->{'dir'}/config"))[9];
985
    my $time_config_bin = (stat("$self->{'dir'}/config.bin"))[9];
986
987
    my $time_subscribers; 
    my $time_stats = (stat("$self->{'dir'}/stats"))[9];
988
    my $config_reloaded = 0;
root's avatar
root committed
989
    my $admin;
salaun's avatar
salaun committed
990
    
991
    if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file' &&
992
	$time_config_bin > $self->{'mtime'}->[0] &&
993
994
	$time_config <= $time_config_bin &&
	! $options->{'reload_config'}) { 
995
996

	## Get a shared lock on config file first 
997
998
999
1000
	my $lock_fh =
	    Sympa::LockedFile->new($self->{'dir'} . '/config', 5, '<');
	unless ($lock_fh) {
	    Log::do_log('err', 'Could not create new lock');
1001
1002
1003
	    return undef;
	}

1004
	## Load a binary version of the data structure
sympa-authors's avatar
sympa-authors committed
1005
	## unless config is more recent than config.bin
1006
1007
	eval {$admin = &Storable::retrieve("$self->{'dir'}/config.bin")};
	if ($@) {
1008
	    &Log::do_log('err', 'Failed to load the binary config %s, error: %s', "$self->{'dir'}/config.bin",$@);
1009
	    $lock_fh->close();
1010
	    return undef;
1011
	}	    
1012

1013
	$config_reloaded = 1;
1014
	$m1 = $time_config_bin;
1015
	$lock_fh->close();
1016

1017
1018
    }elsif ($self->{'name'} ne $name || $time_config > $self->{'mtime'}->[0] ||
	    $options->{'reload_config'}) {	
1019
	$admin = _load_list_config_file($self->{'dir'}, $self->{'domain'}, 'config');
1020

1021
	## Get a shared lock on config file first 
1022
1023
1024
1025
	my $lock_fh =
	    Sympa::LockedFile->new($self->{'dir'} . '/config', 5, '+<');
	unless ($lock_fh) {
	    Log::do_log('err','Could not create new lock');
1026
1027
1028
	    return undef;
	}

1029
	## update the binary version of the data structure
1030
	if (&Conf::get_robot_conf($self->{'domain'}, 'cache_list_config') eq 'binary_file') {
1031
1032
	    eval {&Storable::store($admin,"$self->{'dir'}/config.bin")};
	    if ($@) {
1033
		&Log::do_log('err', 'Failed to save the binary config %s. error: %s', "$self->{'dir'}/config.bin",$@);
1034
	    }
1035
	}
1036

1037
1038
	$config_reloaded = 1;
 	unless (defined $admin) {
1039
 	    &Log::do_log('err', 'Impossible to load list config file for list % set in status error_config',$self->{'name'});
1040
 	    $self->set_status_error_config('load_admin_file_error',$self->{'name'});
1041
	    $lock_fh->close();
1042
1043
1044
 	    return undef;	    
 	}

1045
	$m1 = $time_config;
1046
	$lock_fh->close();
root's avatar
root committed
1047
    }
salaun's avatar
salaun committed
1048
    
1049
1050
    ## If config was reloaded...
    if ($admin) {
1051
1052
1053
 	$self->{'admin'} = $admin;
 	
 	## check param_constraint.conf if belongs to a family and the config has been loaded
1054
 	if (defined $admin->{'family_name'} && ($admin->{'status'} ne 'error_config')) {
1055
1056
 	    my $family;
 	    unless ($family = $self->get_family()) {
1057
 		&Log::do_log('err', 'Impossible to get list %s family : %s. The list is set in status error_config',$self->{'name'},$self->{'admin'}{'family_name'});
1058
 		$self->set_status_error_config('no_list_family',$self->{'name'}, $admin->{'family_name'});
1059
		return undef;
1060
1061
1062
 	    }  
 	    my $error = $family->check_param_constraint($self);
 	    unless($error) {
1063
 		&Log::do_log('err', 'Impossible to check parameters constraint for list % set in status error_config',$self->{'name'});
1064
1065
1066
 		$self->set_status_error_config('no_check_rules_family',$self->{'name'}, $family->{'name'});
 	    }
	    if (ref($error) eq 'ARRAY') {
1067
 		&Log::do_log('err', 'The list "%s" does not respect the rules from its family %s',$self->{'name'}, $family->{'name'});
1068
1069
1070
1071
 		$self->set_status_error_config('no_respect_rules_family',$self->{'name'}, $family->{'name'});
 	    }
 	}
     } 
1072

salaun's avatar
salaun committed
1073
    $self->{'as_x509_cert'} = 1  if ((-r "$self->{'dir'}/cert.pem") || (-r "$self->{'dir'}/cert.pem.enc"));
1074
1075

   ## Load stats file if first new() or stats file changed
1076
    my ($stats, $total);
1077
    if (! $self->{'mtime'}[2] || ($time_stats > $self->{'mtime'}[2])) {
1078
	($stats, $total, $self->{'last_sync'}, $self->{'last_sync_admin_user'}) = _load_stats_file("$self->{'dir'}/stats");
1079
1080
	$m3 = $time_stats;

1081
1082
1083
	$self->{'stats'} = $stats if (defined $stats);	
	$self->{'total'} = $total if (defined $total);	
    }
salaun's avatar
salaun committed
1084
    
root's avatar
root committed
1085
1086
    $self->{'users'} = $users->{'users'} if ($users);
    $self->{'ref'}   = $users->{'ref'} if ($users);
1087
    
1088
1089
    if ($users && defined($users->{'total'})) {
	$self->{'total'} = $users->{'total'};
1090
    }
1091

1092
1093
1094
1095
1096
    ## We have updated %users, Total may have changed
    if ($m2 > $self->{'mtime'}[1]) {
	$self->savestats();
    }

1097
    $self->{'mtime'} = [ $m1, $m2, $m3];
root's avatar
root committed
1098

1099
    $list_of_lists{$self->{'domain'}}{$name} = $self;
1100
    return $config_reloaded;
root's avatar
root committed
1101
1102
}

1103
## Return a list of hash's owners and their param
1104
1105
sub get_owners {
    my($self) = @_;
1106
    &Log::do_log('debug3', 'List::get_owners(%s)', $self->{'name'});
1107
1108
1109
  
    my $owners = ();

1110
    # owners are in the admin_table ; they might come from an include data source
1111
    for (my $owner = $self->get_first_list_admin('owner'); $owner; $owner = $self->get_next_list_admin()) {
1112
1113
	push(@{$owners},$owner);
    } 
1114
1115
1116
1117
1118
1119

    return $owners;
}

sub get_nb_owners {
    my($self) = @_;
1120
    &Log::do_log('debug3', 'List::get_nb_owners(%s)', $self->{'name'});
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
    
    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) = @_;
1134
    &Log::do_log('debug3', 'List::get_editors(%s)', $self->{'name'});
1135
1136
1137
  
    my $editors = ();

1138
    # editors are in the admin_table ; they might come from an include data source
1139
    for (my $editor = $self->get_first_list_admin('editor'); $editor; $editor = $self->get_next_list_admin()) {
1140
1141
	push(@{$editors},$editor);
    } 
1142
1143
1144
1145
1146

    return $editors;
}


1147
## Returns an array of owners' email addresses
salaun's avatar
salaun committed
1148
sub get_owners_email {
1149
    my($self,$param) = @_;
1150
    &Log::do_log('debug3', 'List::get_owners_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'});
salaun's avatar
salaun committed
1151
    
1152
1153
    my @rcpt;
    my $owners = ();
salaun's avatar
salaun committed
1154

1155
    $owners = $self->get_owners();
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165

    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'}));
salaun's avatar
salaun committed
1166
	}
1167
1168
    }
    unless (@rcpt) {
1169
	&Log::do_log('notice','Warning : no owner found for list %s', $self->{'name'} );
1170
    }
1171
1172
1173
    return @rcpt;
}

1174
## Returns an array of editors' email addresses
1175
1176
#  or owners if there isn't any editors'email adress
sub get_editors_email {
1177
    my($self,$param) = @_;
1178
    &Log::do_log('debug3', 'List::get_editors_email(%s,%s)', $self->{'name'}, $param -> {'ignore_nomail'});
1179
    
1180
1181
    my @rcpt;
    my $editors = ();
1182

1183
    $editors = $self->get_editors();
1184

1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
    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'}));
	}
    }
1196
    unless (@rcpt) {
1197
	&Log::do_log('notice','Warning : no editor found for list %s, getting owners', $self->{'name'} );
1198
	@rcpt = $self->get_owners_email($param);
1199
1200
1201
1202
    }
    return @rcpt;
}

1203
1204
1205
1206
## Returns an object Family if the list belongs to a family
#  or undef
sub get_family {
    my $self = shift;
1207
    &Log::do_log('debug3', 'List::get_family(%s)', $self->{'name'});
1208
1209
1210
1211
1212
1213
1214
1215
1216
    
    if (ref($self->{'family'}) eq 'Family') {
	return $self->{'family'};
    }

    my $family_name;
    my $robot = $self->{'domain'};

    unless (defined $self->{'admin'}{'family_name'}) {
1217
	&Log::do_log('err', 'List::get_family(%s) : this list has not got any family', $self->{'name'});
1218
1219
1220
	return undef;
    }
        
1221
    $family_name = $self->{'admin'}{'family_name'};
1222
1223
	    
    my $family;
1224
    unless ($family = new Family($family_name,$robot) ) {
1225
	&Log::do_log('err', 'List::get_family(%s) : new Family(%s) impossible', $self->{'name'},$family_name);
1226
1227
1228
1229
1230
1231
1232
1233
	return undef;
    }
  	
    $self->{'family'} = $family;
    return $family;
}

## return the config_changes hash
1234
## Used ONLY with lists belonging to a family.
1235
1236
sub get_config_changes {
    my $self = shift;
1237
    &Log::do_log('debug3', 'List::get_config_changes(%s)', $self->{'name'});
1238
1239
    
    unless ($self->{'admin'}{'family_name'}) {
1240
	&Log::do_log('err', 'List::get_config_changes(%s) is called but there is no family_name for this list.',$self->{'name'});
1241
1242
1243
1244
1245
1246
1247
	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()) {
1248
	    &Log::do_log('err','Impossible to load file config_changes from list %s',$self->{'name'});
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
	    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;
1263
    &Log::do_log('debug2', 'List::update_config_changes(%s,%s)', $self->{'name'},$what);
1264
1265
    
    unless ($self->{'admin'}{'family_name'}) {