tools.pm 113 KB
Newer Older
1
2
3
4
# tools.pl - This module provides various tools for Sympa
# RCS Identication ; $Revision$ ; $Date$ 
#
# Sympa - SYsteme de Multi-Postage Automatique
5
6
7
8
9
#
# 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
10
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.
#
# You should have received a copy of the GNU General Public License
22
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
root's avatar
root committed
23
24
25

package tools;

26
27
use strict;

28
use Digest::MD5;
29
30
use Encode::Guess; ## Useful when encoding should be guessed
use Encode::MIME::Header;
31
use File::Copy::Recursive;
32
33
use File::Find;
use HTML::StripScripts::Parser;
34
use Mail::Header;
35
use MIME::Lite::HTML;
36
use POSIX qw(strftime mkfifo strtod);
37
use Proc::ProcessTable;
38
39
40
use Sys::Hostname;
use Text::LineFold;
use Time::Local;
41
use if (5.008 < $] && $] < 5.016), qw(Unicode::CaseFold fc);
sikeda's avatar
sikeda committed
42
use if (5.016 <= $]), qw(feature fc);
43

44
use Conf;
45
use Language qw(gettext_strftime);
46
use Sympa::LockedFile;
47
48
use Log;
use Sympa::Constants;
49
use Message;
50
use SDM;
51

root's avatar
root committed
52
53
54
## RCS identification.
#my $id = '@(#)$Id$';

55
## global var to store a CipherSaber object 
56
my $cipher;
57

58
my $separator="------- CUT --- CUT --- CUT --- CUT --- CUT --- CUT --- CUT -------";
salaun's avatar
salaun committed
59

60
## Regexps for list params
salaun's avatar
salaun committed
61
62
## Caution : if this regexp changes (more/less parenthesis), then regexp using it should 
## also be changed
63
64
my $time_regexp = '[012]?[0-9](?:\:[0-5][0-9])?';
my $time_range_regexp = $time_regexp.'-'.$time_regexp;
65
my %regexp = ('email' => '([\w\-\_\.\/\+\=\'\&]+|\".*\")\@[\w\-]+(\.[\w\-]+)+',
66
	      'family_name' => '[a-z0-9][a-z0-9\-\.\+_]*', 
67
	      'template_name' => '[a-zA-Z0-9][a-zA-Z0-9\-\.\+_\s]*', ## Allow \s
68
69
	      'host' => '[\w\.\-]+',
	      'multiple_host_with_port' => '[\w\.\-]+(:\d+)?(,[\w\.\-]+(:\d+)?)*',
70
	      'listname' => '[a-z0-9][a-z0-9\-\.\+_]{0,49}',
71
72
73
74
75
	      'sql_query' => '(SELECT|select).*',
	      'scenario' => '[\w,\.\-]+',
	      'task' => '\w+',
	      'datasource' => '[\w-]+',
	      'uid' => '[\w\-\.\+]+',
76
77
	      'time' => $time_regexp,
	      'time_range' => $time_range_regexp,
78
	      'time_ranges' => $time_range_regexp.'(?:\s+'.$time_range_regexp.')*',
79
80
	      're' => '(?i)(?:AW|(?:\xD0\x9D|\xD0\xBD)(?:\xD0\x90|\xD0\xB0)|Re(?:\^\d+|\*\d+|\*\*\d+|\[\d+\])?|Rif|SV|VS|Antw|\xCE\x91(?:\xCE\xA0|\xCF\x80)|\xCE\xA3(?:\xCE\xA7\xCE\x95\xCE\xA4|\xCF\x87\xCE\xB5\xCF\x84)|Odp|YNT)\s*:',
	      # ( de | ru etc. | en, la etc. | it | da, sv | fi | nl | el | el | pl | tr ).
81
	      );
82

83
84
85
86
87
88
my %openssl_errors = (1 => 'an error occurred parsing the command options',
		      2 => 'one of the input files could not be read',
		      3 => 'an error occurred creating the PKCS#7 file or when reading the MIME message',
		      4 => 'an error occurred decrypting or verifying the message',
		      5 => 'the message was verified correctly but an error occurred writing out the signers certificates');

89
## Sets owner and/or access rights on a file.
90
91
92
93
94
95
sub set_file_rights {
    my %param = @_;
    my ($uid, $gid);

    if ($param{'user'}){
	unless ($uid = (getpwnam($param{'user'}))[2]) {
96
	    &Log::do_log('err', "User %s can't be found in passwd file",$param{'user'});
97
	    return undef;
98
99
100
101
	}
    }else {
	$uid = -1;# "A value of -1 is interpreted by most systems to leave that value unchanged".
    }
102
103
    if ($param{'group'}) {
	unless ($gid = (getgrnam($param{'group'}))[2]) {
104
	    &Log::do_log('err', "Group %s can't be found",$param{'group'});
105
	    return undef;
106
107
108
109
	}
    }else {
	$gid = -1;# "A value of -1 is interpreted by most systems to leave that value unchanged".
    }
110
    unless (chown($uid,$gid, $param{'file'})){
111
	&Log::do_log('err', "Can't give ownership of file %s to %s.%s: %s",$param{'file'},$param{'user'},$param{'group'}, $!);
112
	return undef;
113
    }
114
115
    if ($param{'mode'}){
	unless (chmod($param{'mode'}, $param{'file'})){
116
	    &Log::do_log('err', "Can't change rights of file %s: %s",$Conf::Conf{'db_name'}, $!);
117
	    return undef;
118
119
120
121
122
	}
    }
    return 1;
}

123
124
125
## Returns an HTML::StripScripts::Parser object built with  the parameters provided as arguments.
sub _create_xss_parser {
    my %parameters = @_;
126
127
128
129
130
    my $robot = $parameters{'robot'};
    Log::do_log('debug3', '(%s)', $robot);

    my $http_host_re = Conf::get_robot_conf($robot, 'http_host');
    $http_host_re =~ s/([^\s\w\x80-\xFF])/\\$1/g;
131
132
133
134
    my $hss = HTML::StripScripts::Parser->new({ Context => 'Document',
						AllowSrc        => 1,
						Rules => {
						    '*' => {
135
							src => qr{^http://$http_host_re},
136
137
138
139
140
141
						    },
						},
					    });
    return $hss;
}

142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
#*******************************************
# Function : pictures_filename
# Description : return the type of a pictures
#               according to the user
## IN : email, list
#*******************************************
sub pictures_filename {
    my %parameters = @_;
    
    my $login = &md5_fingerprint($parameters{'email'});
    my ($listname, $robot) = ($parameters{'list'}{'name'}, $parameters{'list'}{'domain'});
    
    my $filetype;
    my $filename = undef;
    foreach my $ext ('.gif','.jpg','.jpeg','.png') {
 	if (-f &Conf::get_robot_conf($robot,'pictures_path').'/'.$listname.'@'.$robot.'/'.$login.$ext) {
 	    my $file = $login.$ext;
 	    $filename = $file;
 	    last;
 	}
    }
    return $filename;
}

## Creation of pictures url
## IN : email, list
sub make_pictures_url {
    my %parameters = @_;

    my ($listname, $robot) = ($parameters{'list'}{'name'}, $parameters{'list'}{'domain'});

    my $url;
    if(&pictures_filename('email' => $parameters{'email'}, 'list' => $parameters{'list'})) {
 	$url =  &Conf::get_robot_conf($robot, 'pictures_url').$listname.'@'.$robot.'/'.&pictures_filename('email' => $parameters{'email'}, 'list' => $parameters{'list'});
    }
    else {
 	$url = undef;
    }
    return $url;
}

183
184
185
## Returns sanitized version (using StripScripts) of the string provided as argument.
sub sanitize_html {
    my %parameters = @_;
186
187
188
    my $robot = $parameters{'robot'};
    Log::do_log('debug3', '(string=%s, robot=%s)',
	$parameters{'string'}, $robot);
189
190

    unless (defined $parameters{'string'}) {
191
	&Log::do_log('err',"No string provided.");
192
193
194
	return undef;
    }

195
    my $hss = _create_xss_parser('robot' => $robot);
196
    unless (defined $hss) {
197
	&Log::do_log('err',"Can't create StripScript parser.");
198
199
200
201
202
203
204
205
206
	return undef;
    }
    my $string = $hss -> filter_html($parameters{'string'});
    return $string;
}

## Returns sanitized version (using StripScripts) of the content of the file whose path is provided as argument.
sub sanitize_html_file {
    my %parameters = @_;
207
208
    my $robot = $parameters{'robot'};
    Log::do_log('debug3', '(file=%s, robot=%s)', $parameters{'file'}, $robot);
209
210

    unless (defined $parameters{'file'}) {
211
	&Log::do_log('err',"No path to file provided.");
212
213
214
	return undef;
    }

215
    my $hss = _create_xss_parser('robot' => $robot);
216
    unless (defined $hss) {
217
	&Log::do_log('err',"Can't create StripScript parser.");
218
219
220
221
222
223
224
225
226
	return undef;
    }
    $hss -> parse_file($parameters{'file'});
    return $hss -> filtered_document;
}

## Sanitize all values in the hash $var, starting from $level
sub sanitize_var {
    my %parameters = @_;
227
228
229
    my $robot = $parameters{'robot'};
    Log::do_log('debug3','(var=%s, level=%s, robot=%s)',
	$parameters{'var'}, $parameters{'level'}, $robot);
230
    unless (defined $parameters{'var'}){
231
	Log::do_log('err','Missing var to sanitize.');
232
233
	return undef;
    }
234
    unless (defined $parameters{'htmlAllowedParam'} && $parameters{'htmlToFilter'}){
235
	Log::do_log('err','Missing var *** %s *** %s *** to ignore.',$parameters{'htmlAllowedParam'},$parameters{'htmlToFilter'});
236
237
	return undef;
    }
238
239
240
241
242
243
244
245
246
    my $level = $parameters{'level'};
    $level |= 0;
    
    if(ref($parameters{'var'})) {
	if(ref($parameters{'var'}) eq 'ARRAY') {
	    foreach my $index (0..$#{$parameters{'var'}}) {
		if ((ref($parameters{'var'}->[$index]) eq 'ARRAY') || (ref($parameters{'var'}->[$index]) eq 'HASH')) {
		    &sanitize_var('var' => $parameters{'var'}->[$index],
				  'level' => $level+1,
247
				  'robot' => $robot,
248
249
250
				  'htmlAllowedParam' => $parameters{'htmlAllowedParam'},
				  'htmlToFilter' => $parameters{'htmlToFilter'},
				  );
251
252
253
		} elsif (defined $parameters{'var'}->[$index]) {
		    $parameters{'var'}->[$index] =
			escape_html($parameters{'var'}->[$index]);
254
255
256
257
258
259
260
261
		}
	    }
	}
	elsif(ref($parameters{'var'}) eq 'HASH') {
	    foreach my $key (keys %{$parameters{'var'}}) {
		if ((ref($parameters{'var'}->{$key}) eq 'ARRAY') || (ref($parameters{'var'}->{$key}) eq 'HASH')) {
		    &sanitize_var('var' => $parameters{'var'}->{$key},
				  'level' => $level+1,
262
				  'robot' => $robot,
263
264
265
				  'htmlAllowedParam' => $parameters{'htmlAllowedParam'},
				  'htmlToFilter' => $parameters{'htmlToFilter'},
				  );
266
267
268
269
270
271
272
273
274
275
276
		} elsif (defined $parameters{'var'}->{$key}) {
		    unless ($parameters{'htmlAllowedParam'}{$key} or
			$parameters{'htmlToFilter'}{$key}) {
			$parameters{'var'}->{$key} =
			    escape_html($parameters{'var'}->{$key});
		    }
		    if ($parameters{'htmlToFilter'}{$key}) {
			$parameters{'var'}->{$key} = sanitize_html(
			    'string' => $parameters{'var'}->{$key},
			    'robot' => $robot
			);
277
278
279
280
281
282
283
		    }
		}
		
	    }
	}
    }
    else {
284
	&Log::do_log('err','Variable is neither a hash nor an array.');
285
286
287
288
289
	return undef;
    }
    return 1;
}

root's avatar
root committed
290
291
292
293
294
295
296
297
298
299
300
## Sorts the list of adresses by domain name
## Input : users hash
## Sort by domain.
sub sortbydomain {
   my($x, $y) = @_;
   $x = join('.', reverse(split(/[@\.]/, $x)));
   $y = join('.', reverse(split(/[@\.]/, $y)));
   #print "$x $y\n";
   $x cmp $y;
}

301
302
303
304
305
306
307
308
309
310
311
312
313
## Sort subroutine to order files in sympa spool by date
sub by_date {
    my @a_tokens = split /\./, $a;
    my @b_tokens = split /\./, $b;

    ## File format : list@dom.date.pid
    my $a_time = $a_tokens[$#a_tokens -1];
    my $b_time = $b_tokens[$#b_tokens -1];

    return $a_time <=> $b_time;

}

root's avatar
root committed
314
## Safefork does several tries before it gives up.
315
## Do 3 trials and wait 10 seconds * $i between each.
root's avatar
root committed
316
317
318
319
320
## Exit with a fatal error is fork failed after all
## tests have been exhausted.
sub safefork {
   my($i, $pid);
   
321
   for ($i = 1; $i < 4; $i++) {
root's avatar
root committed
322
323
      my($pid) = fork;
      return $pid if (defined($pid));
324
      &Log::do_log ('warning', "Can't create new process in safefork: %m");
root's avatar
root committed
325
326
327
      ## should send a mail to the listmaster
      sleep(10 * $i);
   }
328
   &Log::fatal_err("Can't create new process in safefork: %m");
root's avatar
root committed
329
330
331
   ## No return.
}

332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
####################################################
# checkcommand                              
####################################################
# Checks for no command in the body of the message.
# If there are some command in it, it return true 
# and send a message to $sender
# 
# IN : -$msg (+): ref(MIME::Entity) - message to check
#      -$sender (+): the sender of $msg
#      -$robot (+) : robot
#
# OUT : -1 if there are some command in $msg
#       -0 else
#
###################################################### 
root's avatar
root committed
347
sub checkcommand {
348
   my($msg, $sender, $robot) = @_;
root's avatar
root committed
349
350
351
352
353
354
355

   my($avoid, $i);

   my $hdr = $msg->head;

   ## Check for commands in the subject.
   my $subject = $msg->head->get('Subject');
356

357
358
   &Log::do_log('debug3', 'tools::checkcommand(msg->head->get(subject): %s,%s)', $subject, $sender);

root's avatar
root committed
359
   if ($subject) {
360
       if ($Conf::Conf{'misaddressed_commands_regexp'} && ($subject =~ /^$Conf::Conf{'misaddressed_commands_regexp'}\b/im)) {
361
362
	   return 1;
       }
root's avatar
root committed
363
   }
364

365
   return 0 if ($#{$msg->body} >= 5);  ## More than 5 lines in the text.
366

root's avatar
root committed
367
   foreach $i (@{$msg->body}) {
368
       if ($Conf::Conf{'misaddressed_commands_regexp'} && ($i =~ /^$Conf::Conf{'misaddressed_commands_regexp'}\b/im)) {
369
370
371
372
373
	   return 1;
       }

       ## Control is only applied to first non-blank line
       last unless $i =~ /^\s*$/;
root's avatar
root committed
374
375
376
377
   }
   return 0;
}

378

root's avatar
root committed
379
380
381

## return a hash from the edit_list_conf file
sub load_edit_list_conf {
382
    my $robot = shift;
383
    my $list = shift;
384
    &Log::do_log('debug2', 'tools::load_edit_list_conf (%s)',$robot);
385

root's avatar
root committed
386
387
388
    my $file;
    my $conf ;
    
salaun's avatar
salaun committed
389
    return undef 
390
	unless ($file = &tools::get_filename('etc',{},'edit_list.conf',$robot,$list));
root's avatar
root committed
391
392

    unless (open (FILE, $file)) {
393
	&Log::do_log('info','Unable to open config file %s', $file);
root's avatar
root committed
394
395
396
	return undef;
    }

397
    my $error_in_conf;
398
    my $roles_regexp = 'listmaster|privileged_owner|owner|editor|subscriber|default';
root's avatar
root committed
399
400
401
    while (<FILE>) {
	next if /^\s*(\#.*|\s*)$/;

402
403
404
405
406
407
	if (/^\s*(\S+)\s+(($roles_regexp)\s*(,\s*($roles_regexp))*)\s+(read|write|hidden)\s*$/i) {
	    my ($param, $role, $priv) = ($1, $2, $6);
	    my @roles = split /,/, $role;
	    foreach my $r (@roles) {
		$r =~ s/^\s*(\S+)\s*$/$1/;
		if ($r eq 'default') {
408
		    $error_in_conf = 1;
409
		    &Log::do_log('notice', '"default" is no more recognised');
410
411
412
413
414
415
416
		    foreach my $set ('owner','privileged_owner','listmaster') {
			$conf->{$param}{$set} = $priv;
		    }
		    next;
		}
		$conf->{$param}{$r} = $priv;
	    }
root's avatar
root committed
417
	}else{
418
	    &Log::do_log ('info', 'unknown parameter in %s  (Ignored) %s', "$Conf::Conf{'etc'}/edit_list.conf",$_ );
root's avatar
root committed
419
420
421
	    next;
	}
    }
422
423

    if ($error_in_conf) {
424
	unless (&List::send_notify_to_listmaster('edit_list_error', $robot, [$file])) {
425
	    &Log::do_log('notice',"Unable to send notify 'edit_list_error' to listmaster");
426
	}
427
    }
root's avatar
root committed
428
429
430
431
432
433
434
435
    
    close FILE;
    return $conf;
}


## return a hash from the edit_list_conf file
sub load_create_list_conf {
salaun's avatar
salaun committed
436
    my $robot = shift;
root's avatar
root committed
437
438
439
440

    my $file;
    my $conf ;
    
441
    $file = &tools::get_filename('etc',{}, 'create_list.conf', $robot);
salaun's avatar
salaun committed
442
    unless ($file) {
443
	&Log::do_log('info', 'unable to read %s', Sympa::Constants::DEFAULTDIR . '/create_list.conf');
root's avatar
root committed
444
445
446
447
	return undef;
    }

    unless (open (FILE, $file)) {
448
	&Log::do_log('info','Unable to open config file %s', $file);
root's avatar
root committed
449
450
451
452
453
454
455
	return undef;
    }

    while (<FILE>) {
	next if /^\s*(\#.*|\s*)$/;

	if (/^\s*(\S+)\s+(read|hidden)\s*$/i) {
456
	    $conf->{$1} = lc($2);
root's avatar
root committed
457
	}else{
458
	    &Log::do_log ('info', 'unknown parameter in %s  (Ignored) %s', "$Conf::Conf{'etc'}/create_list.conf",$_ );
root's avatar
root committed
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
	    next;
	}
    }
    
    close FILE;
    return $conf;
}

sub _add_topic {
    my ($name, $title) = @_;
    my $topic = {};

    my @tree = split '/', $name;
    if ($#tree == 0) {
	return {'title' => $title};
    }else {
	$topic->{'sub'}{$name} = &_add_topic(join ('/', @tree[1..$#tree]), $title);
	return $topic;
    }
}

sub get_list_list_tpl {
salaun's avatar
salaun committed
481
482
    my $robot = shift;

root's avatar
root committed
483
484
    my $list_conf;
    my $list_templates ;
salaun's avatar
salaun committed
485
    unless ($list_conf = &load_create_list_conf($robot)) {
root's avatar
root committed
486
487
	return undef;
    }
488
    
489
490
491
492
493
    foreach my $dir (
        Sympa::Constants::DEFAULTDIR . '/create_list_templates',
        "$Conf::Conf{'etc'}/create_list_templates",
        "$Conf::Conf{'etc'}/$robot/create_list_templates"
    ) {
root's avatar
root committed
494
495
496
	if (opendir(DIR, $dir)) {
	    foreach my $template ( sort grep (!/^\./,readdir(DIR))) {

497
498
499
		my $status = $list_conf->{$template} || $list_conf->{'default'};

		next if ($status eq 'hidden') ;
root's avatar
root committed
500
501
502

		$list_templates->{$template}{'path'} = $dir;

sympa-authors's avatar
sympa-authors committed
503
504
505
506
507
		my $locale = &Language::Lang2Locale( &Language::GetLang());
		## Look for a comment.tt2 in the appropriate locale first
		if (-r $dir.'/'.$template.'/'.$locale.'/comment.tt2') {
		    $list_templates->{$template}{'comment'} = $dir.'/'.$template.'/'.$locale.'/comment.tt2';
		}elsif (-r $dir.'/'.$template.'/comment.tt2') {
salaun's avatar
salaun committed
508
		    $list_templates->{$template}{'comment'} = $dir.'/'.$template.'/comment.tt2';
root's avatar
root committed
509
510
511
512
513
514
515
516
517
		}
	    }
	    closedir(DIR);
	}
    }

    return ($list_templates);
}

518

519
#copy a directory and its content
520
521
522
sub copy_dir {
    my $dir1 = shift;
    my $dir2 = shift;
523
    &Log::do_log('debug','Copy directory %s to %s',$dir1,$dir2);
524

525
    unless (-d $dir1){
526
	&Log::do_log('err',"Directory source '%s' doesn't exist. Copy impossible",$dir1);
527
528
	return undef;
    }
529
530
531
    return (&File::Copy::Recursive::dircopy($dir1,$dir2)) ;
}

532
533
534
#delete a directory and its content
sub del_dir {
    my $dir = shift;
535
    &Log::do_log('debug','del_dir %s',$dir);
536
537
538
539
540
541
542
543
544
    
    if(opendir DIR, $dir){
	for (readdir DIR) {
	    next if /^\.{1,2}$/;
	    my $path = "$dir/$_";
	    unlink $path if -f $path;
	    del_dir($path) if -d $path;
	}
	closedir DIR;
545
	unless(rmdir $dir) {&Log::do_log('err','Unable to delete directory %s: $!',$dir);}
546
    }else{
547
	&Log::do_log('err','Unable to open directory %s to delete the files it contains: $!',$dir);
548
549
550
    }
}

551
#to be used before creating a file in a directory that may not exist already. 
sympa-authors's avatar
   
sympa-authors committed
552
553
554
555
sub mk_parent_dir {
    my $file = shift;
    $file =~ /^(.*)\/([^\/])*$/ ;
    my $dir = $1;
556
557
558

    return 1 if (-d $dir);
    &mkdir_all($dir, 0755);
sympa-authors's avatar
   
sympa-authors committed
559
560
}

561
562
## Recursively create directory and all parent directories
sub mkdir_all {
563
564
565
566
567
568
    my ($path, $mode) = @_;
    my $status = 1;

    ## Change umask to fully apply modes of mkdir()
    my $saved_mask = umask;
    umask 0000;
569
570
571
572
573
574
575
576
577

    return undef if ($path eq '');
    return 1 if (-d $path);

    ## Compute parent path
    my @token = split /\//, $path;
    pop @token;
    my $parent_path = join '/', @token;

578
579
580
581
582
    unless (-d $parent_path) {
	unless (&mkdir_all($parent_path, $mode)) {
	    $status = undef;
	}
    }
583

584
585
586
    if (defined $status) { ## Don't try if parent dir could not be created
	unless (mkdir ($path, $mode)) {
	    $status = undef;
587
588
	}
    }
589
590
591
592
593

    ## Restore umask
    umask $saved_mask;

    return $status;
594
595
}

sympa-authors's avatar
   
sympa-authors committed
596
597
598
599
# shift file renaming it with date. If count is defined, keep $count file and unlink others
sub shift_file {
    my $file = shift;
    my $count = shift;
600
    &Log::do_log('debug', "shift_file ($file,$count)");
sympa-authors's avatar
   
sympa-authors committed
601
602

    unless (-f $file) {
603
	&Log::do_log('info', "shift_file : unknown file $file");
sympa-authors's avatar
   
sympa-authors committed
604
605
606
607
	return undef;
    }
    
    my @date = localtime (time);
608
    my $file_extention = strftime("%Y:%m:%d:%H:%M:%S", @date);
sympa-authors's avatar
   
sympa-authors committed
609
    
610
    unless (rename ($file,$file.'.'.$file_extention)) {
611
	&Log::do_log('err', "shift_file : Cannot rename file $file to $file.$file_extention" );
sympa-authors's avatar
   
sympa-authors committed
612
613
614
615
616
617
618
	return undef;
    }
    if ($count) {
	$file =~ /^(.*)\/([^\/])*$/ ;
	my $dir = $1;

	unless (opendir(DIR, $dir)) {
619
	    &Log::do_log('err', "shift_file : Cannot read dir $dir" );
620
	    return ($file.'.'.$file_extention);
sympa-authors's avatar
   
sympa-authors committed
621
622
623
624
625
626
	}
	my $i = 0 ;
	foreach my $oldfile (reverse (sort (grep (/^$file\./,readdir(DIR))))) {
	    $i ++;
	    if ($count lt $i) {
		if (unlink ($oldfile)) { 
627
		    &Log::do_log('info', "shift_file : unlink $oldfile");
sympa-authors's avatar
   
sympa-authors committed
628
		}else{
629
		    &Log::do_log('info', "shift_file : unable to unlink $oldfile");
sympa-authors's avatar
   
sympa-authors committed
630
631
632
633
		}
	    }
	}
    }
634
    return ($file.'.'.$file_extention);
sympa-authors's avatar
   
sympa-authors committed
635
636
}

sympa-authors's avatar
   
sympa-authors committed
637
638
639
640
sub get_templates_list {

    my $type = shift;
    my $robot = shift;
641
    my $list = shift;
642
    my $options = shift;
643
644

    my $listdir;
sympa-authors's avatar
   
sympa-authors committed
645

646
    &Log::do_log('debug', "get_templates_list ($type, $robot, $list)");
647
    unless (($type eq 'web')||($type eq 'mail')) {
648
	&Log::do_log('info', 'get_templates_list () : internal error incorrect parameter');
sympa-authors's avatar
   
sympa-authors committed
649
650
    }

olivier.salaun's avatar
olivier.salaun committed
651
    my $distrib_dir = Sympa::Constants::DEFAULTDIR . '/'.$type.'_tt2';
652
653
    my $site_dir = $Conf::Conf{'etc'}.'/'.$type.'_tt2';
    my $robot_dir = $Conf::Conf{'etc'}.'/'.$robot.'/'.$type.'_tt2';
sympa-authors's avatar
   
sympa-authors committed
654
655

    my @try;
656
657
658
659
660
661
662
663

    ## The 'ignore_global' option allows to look for files at list level only
    unless ($options->{'ignore_global'}) {
	push @try, $distrib_dir ;
	push @try, $site_dir ;
	push @try, $robot_dir;
    }    

664
665
    if (defined $list) {
	$listdir = $list->{'dir'}.'/'.$type.'_tt2';	
sympa-authors's avatar
   
sympa-authors committed
666
667
	push @try, $listdir ;
    }
668

sympa-authors's avatar
   
sympa-authors committed
669
670
    my $i = 0 ;
    my $tpl;
sympa-authors's avatar
   
sympa-authors committed
671

sympa-authors's avatar
   
sympa-authors committed
672
    foreach my $dir (@try) {
sympa-authors's avatar
   
sympa-authors committed
673
	next unless opendir (DIR, $dir);
674
675
676
677
678
679
680
681
682
683
	foreach my $file ( grep (!/^\./,readdir(DIR))) {	    
	    ## Subdirectory for a lang
	    if (-d $dir.'/'.$file) {
		my $lang = $file;
		next unless opendir (LANGDIR, $dir.'/'.$lang);
		foreach my $file (grep (!/^\./,readdir(LANGDIR))) {
		    next unless ($file =~ /\.tt2$/);
		    if ($dir eq $distrib_dir){$tpl->{$file}{'distrib'}{$lang} = $dir.'/'.$lang.'/'.$file;}
		    if ($dir eq $site_dir)   {$tpl->{$file}{'site'}{$lang} =  $dir.'/'.$lang.'/'.$file;}
		    if ($dir eq $robot_dir)  {$tpl->{$file}{'robot'}{$lang} = $dir.'/'.$lang.'/'.$file;}
684
		    if ($dir eq $listdir)    {$tpl->{$file}{'list'}{$lang} = $dir.'/'.$lang.'/'.$file;}
685
686
687
688
689
690
691
692
		}
		closedir LANGDIR;

	    }else {
		next unless ($file =~ /\.tt2$/);
		if ($dir eq $distrib_dir){$tpl->{$file}{'distrib'}{'default'} = $dir.'/'.$file;}
		if ($dir eq $site_dir)   {$tpl->{$file}{'site'}{'default'} =  $dir.'/'.$file;}
		if ($dir eq $robot_dir)  {$tpl->{$file}{'robot'}{'default'} = $dir.'/'.$file;}
693
		if ($dir eq $listdir)    {$tpl->{$file}{'list'}{'default'}= $dir.'/'.$file;}
694
	    }
sympa-authors's avatar
   
sympa-authors committed
695
696
697
	}
	closedir DIR;
    }
698
    return ($tpl);
sympa-authors's avatar
   
sympa-authors committed
699

sympa-authors's avatar
   
sympa-authors committed
700
701
}

702

sympa-authors's avatar
   
sympa-authors committed
703
704
705
706
707
708
709
# return the path for a specific template
sub get_template_path {

    my $type = shift;
    my $robot = shift;
    my $scope = shift;
    my $tpl = shift;
710
711
    my $lang = shift || 'default';
    my $list = shift;
sympa-authors's avatar
   
sympa-authors committed
712

713
    &Log::do_log('debug', "get_templates_path ($type,$robot,$scope,$tpl,$lang,%s)", $list->{'name'});
714

715
716
717
    my $listdir;
    if (defined $list) {
	$listdir = $list->{'dir'};
sympa-authors's avatar
   
sympa-authors committed
718
    }
sympa-authors's avatar
   
sympa-authors committed
719

sympa-authors's avatar
   
sympa-authors committed
720
    unless (($type == 'web')||($type == 'mail')) {
721
	&Log::do_log('info', 'get_templates_path () : internal error incorrect parameter');
sympa-authors's avatar
   
sympa-authors committed
722
723
    }

olivier.salaun's avatar
olivier.salaun committed
724
    my $distrib_dir = Sympa::Constants::DEFAULTDIR . '/'.$type.'_tt2';
725
    $distrib_dir .= '/' . $lang unless $lang eq 'default';
726
    my $site_dir = $Conf::Conf{'etc'}.'/'.$type.'_tt2';
727
    $site_dir .= '/'.$lang unless ($lang eq 'default');
728
    my $robot_dir = $Conf::Conf{'etc'}.'/'.$robot.'/'.$type.'_tt2';
729
    $robot_dir .= '/'.$lang unless ($lang eq 'default');    
sympa-authors's avatar
   
sympa-authors committed
730
731

    if ($scope eq 'list')  {
732
733
734
735
736
	my $dir = $listdir.'/'.$type.'_tt2';
	$dir .= '/'.$lang unless ($lang eq 'default');
	return $dir.'/'.$tpl ;

    }elsif ($scope eq 'robot')  {
sympa-authors's avatar
   
sympa-authors committed
737
	return $robot_dir.'/'.$tpl;
738
739

    }elsif ($scope eq 'site') {
sympa-authors's avatar
   
sympa-authors committed
740
	return $site_dir.'/'.$tpl;
741
742

    }elsif ($scope eq 'distrib') {
sympa-authors's avatar
   
sympa-authors committed
743
	return $distrib_dir.'/'.$tpl;
744

sympa-authors's avatar
   
sympa-authors committed
745
    }
746
747

    return undef;
sympa-authors's avatar
   
sympa-authors committed
748
749
}

750
751
752
753
754
755
sub get_dkim_parameters {

    my $params = shift;

    my $robot = $params->{'robot'};
    my $listname = $params->{'listname'};
756
    &Log::do_log('debug2',"get_dkim_parameters (%s,%s)",$robot, $listname);
757
758
759
760
761
762

    my $data ; my $keyfile ;
    if ($listname) {
	# fetch dkim parameter in list context
	my $list = new List ($listname,$robot);
	unless ($list){
763
	    &Log::do_log('err',"Could not load list %s@%s",$listname, $robot);
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
	    return undef;
	}

	$data->{'d'} = $list->{'admin'}{'dkim_parameters'}{'signer_domain'};
	if ($list->{'admin'}{'dkim_parameters'}{'signer_identity'}) {
	    $data->{'i'} = $list->{'admin'}{'dkim_parameters'}{'signer_identity'};
	}else{
	    # RFC 4871 (page 21) 
	    $data->{'i'} = $list->{'name'}.'-request@'.$robot;
	}
	
	$data->{'selector'} = $list->{'admin'}{'dkim_parameters'}{'selector'};
	$keyfile = $list->{'admin'}{'dkim_parameters'}{'private_key_path'};
    }else{
	# in robot context
	$data->{'d'} = &Conf::get_robot_conf($robot, 'dkim_signer_domain');
	$data->{'i'} = &Conf::get_robot_conf($robot, 'dkim_signer_identity');
	$data->{'selector'} = &Conf::get_robot_conf($robot, 'dkim_selector');
	$keyfile = &Conf::get_robot_conf($robot, 'dkim_private_key_path');
    }
    unless (open (KEY, $keyfile)) {
785
	&Log::do_log('err',"Could not read dkim private key %s",&Conf::get_robot_conf($robot, 'dkim_signer_selector'));
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
	return undef;
    }
    while (<KEY>){
	$data->{'private_key'} .= $_;
    }
    close (KEY);

    return $data;
}

# input a msg as string, output the dkim status
sub dkim_verifier {
    my $msg_as_string = shift;
    my $dkim;

801
    &Log::do_log('debug',"dkim verifier");
802
    unless (eval "require Mail::DKIM::Verifier") {
803
	&Log::do_log('err', "Failed to load Mail::DKIM::verifier perl module, ignoring DKIM signature");
804
805
806
807
	return undef;
    }
    
    unless ( $dkim = Mail::DKIM::Verifier->new() ){
808
	&Log::do_log('err', 'Could not create Mail::DKIM::Verifier');
809
810
811
812
813
	return undef;
    }
   
    my $temporary_file = $Conf::Conf{'tmpdir'}."/dkim.".$$ ;  
    if (!open(MSGDUMP,"> $temporary_file")) {
814
	&Log::do_log('err', 'Can\'t store message in file %s', $temporary_file);
815
816
817
818
819
	return undef;
    }
    print MSGDUMP $msg_as_string ;

    unless (close(MSGDUMP)){ 
820
	&Log::do_log('err',"unable to dump message in temporary file $temporary_file"); 
821
822
823
824
	return undef; 
    }

    unless (open (MSGDUMP, "$temporary_file")) {
825
	&Log::do_log('err', 'Can\'t read message in file %s', $temporary_file);
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
	return undef;
    }

    # this documented method is pretty but dont validate signatures, why ?
    # $dkim->load(\*MSGDUMP);
    while (<MSGDUMP>){
	chomp;
	s/\015$//;
	$dkim->PRINT("$_\015\012");
    }

    $dkim->CLOSE;
    close(MSGDUMP);
    unlink ($temporary_file);
    
    foreach my $signature ($dkim->signatures) {
	return 1 if  ($signature->result_detail eq "pass");
serge.aumont's avatar
   
serge.aumont committed
843
    }
844
845
846
    return undef;
}

847
848
849
# input a msg as string, output idem without signature if invalid
sub remove_invalid_dkim_signature {

850
    &Log::do_log('debug',"removing invalide dkim signature");
851
852

    my $msg_as_string = shift;
853
854
    # Saving body as string
    my ($header_as_string, $body_as_string) = split("\n\n",$msg_as_string,2);
855
856
857

    unless (&tools::dkim_verifier($msg_as_string)){
	my $parser = new MIME::Parser;
858
	$parser->output_to_core(1);
859
860
	my $entity = $parser->parse_data($msg_as_string);
	unless($entity) {
861
	    &Log::do_log('err','could not parse message');
862
863
864
	    return $msg_as_string ;
	}
	$entity->head->delete('DKIM-Signature');
865
	return $entity->head->as_string."\n".$body_as_string;
866
867
868
869
870
    }else{
	return ($msg_as_string); # sgnature is valid.
    }
}

871
872
873
874
875
876
877
878
879
880
# input object msg and listname, output signed message object
sub dkim_sign {
    # in case of any error, this proc MUST return $msg_as_string NOT undef ; this would cause Sympa to send empty mail 
    my $msg_as_string = shift;
    my $data = shift;
    my $dkim_d = $data->{'dkim_d'};    
    my $dkim_i = $data->{'dkim_i'};
    my $dkim_selector = $data->{'dkim_selector'};
    my $dkim_privatekey = $data->{'dkim_privatekey'};

881
    &Log::do_log('debug2', 'tools::dkim_sign (msg:%s,dkim_d:%s,dkim_i%s,dkim_selector:%s,dkim_privatekey:%s)',substr($msg_as_string,0,30),$dkim_d,$dkim_i,$dkim_selector, substr($dkim_privatekey,0,30));
882
883

    unless ($dkim_selector) {
884
	&Log::do_log('err',"DKIM selector is undefined, could not sign message");
885
886
887
	return $msg_as_string;
    }
    unless ($dkim_privatekey) {
888
	&Log::do_log('err',"DKIM key file is undefined, could not sign message");
889
890
891
	return $msg_as_string;
    }
    unless ($dkim_d) {
892
	&Log::do_log('err',"DKIM d= tag is undefined, could not sign message");
893
894
895
896
897
	return $msg_as_string;
    }
    
    my $temporary_keyfile = $Conf::Conf{'tmpdir'}."/dkimkey.".$$ ;  
    if (!open(MSGDUMP,"> $temporary_keyfile")) {
898
	&Log::do_log('err', 'Can\'t store key in file %s', $temporary_keyfile);
899
900
901
902
903
904
	return $msg_as_string;
    }
    print MSGDUMP $dkim_privatekey ;
    close(MSGDUMP);

    unless (eval "require Mail::DKIM::Signer") {
sikeda's avatar
sikeda committed
905
	&Log::do_log('err', "Failed to load Mail::DKIM::Signer perl module, ignoring DKIM signature");
906
907
	return ($msg_as_string); 
    }
908
909
910
    unless (eval "require Mail::DKIM::TextWrap") {
	&Log::do_log('err', "Failed to load Mail::DKIM::TextWrap perl module, signature will not be pretty");
    }
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
    my $dkim ;
    if ($dkim_i) {
    # create a signer object
	$dkim = Mail::DKIM::Signer->new(
					Algorithm => "rsa-sha1",
					Method    => "relaxed",
					Domain    => $dkim_d,
					Identity  => $dkim_i,
					Selector  => $dkim_selector,
					KeyFile   => $temporary_keyfile,
					);
    }else{
	$dkim = Mail::DKIM::Signer->new(
					Algorithm => "rsa-sha1",
					Method    => "relaxed",
					Domain    => $dkim_d,
					Selector  => $dkim_selector,
					KeyFile   => $temporary_keyfile,
					);
    }
    unless ($dkim) {
932
	&Log::do_log('err', 'Can\'t create Mail::DKIM::Signer');
933
934
935
936
	return ($msg_as_string); 
    }    
    my $temporary_file = $Conf::Conf{'tmpdir'}."/dkim.".$$ ;  
    if (!open(MSGDUMP,"> $temporary_file")) {
937
	&Log::do_log('err', 'Can\'t store message in file %s', $temporary_file);
938
939
940
941
942
943
	return ($msg_as_string); 
    }
    print MSGDUMP $msg_as_string ;
    close(MSGDUMP);

    unless (open (MSGDUMP , $temporary_file)){
944
	&Log::do_log('err', 'Can\'t read temporary file %s', $temporary_file);
945
946
947
	return undef;
    }

948
949
950
951
952
953
954
955
956
    while (<MSGDUMP>)
    {
	# remove local line terminators
	chomp;
	s/\015$//;
	# use SMTP line terminators
	$dkim->PRINT("$_\015\012");
    }
    close MSGDUMP;
957
    unless ($dkim->CLOSE) {
958
	&Log::do_log('err', 'Cannot sign (DKIM) message');
959
960
	return ($msg_as_string); 
    }
961
    my $message = new Message({'file'=>$temporary_file,'noxsympato'=>'noxsympato'});
962
    unless ($message){
963
	&Log::do_log('err',"unable to load $temporary_file as a message objet");
964
965
966
967
	return ($msg_as_string); 
    }

    if ($main::options{'debug'}) {
968
	&Log::do_log('debug',"temporary file is $temporary_file");
969
970
971
972
973
974
975
976
977
978
    }else{
	unlink ($temporary_file);
    }
    unlink ($temporary_keyfile);
    
    $message->{'msg'}->head->add('DKIM-signature',$dkim->signature->as_string);

    return $message->{'msg'}->as_string ;
}

root's avatar
root committed
979
980
981
982
# input object msg and listname, output signed message object
sub smime_sign {
    my $in_msg = shift;
    my $list = shift;
sympa-authors's avatar
sympa-authors committed
983
    my $robot = shift;
root's avatar
root committed
984

985
    &Log::do_log('debug2', 'tools::smime_sign (%s,%s)',$in_msg,$list);
root's avatar
root committed
986

sympa-authors's avatar
sympa-authors committed
987
    my $self = new List($list, $robot);
988
    my($cert, $key) = &smime_find_keys($self->{dir}, 'sign');
989
990
    my $temporary_file = $Conf::Conf{'tmpdir'}."/".$self->get_list_id().".".$$ ;    
    my $temporary_pwd = $Conf::Conf{'tmpdir'}.'/pass.'.$$;
root's avatar
root committed
991

992
    my ($signed_msg,$pass_option );
993
    $pass_option = "-passin file:$temporary_pwd" if ($Conf::Conf{'key_passwd'} ne '') ;
994
995
996
997
998

    ## Keep a set of header fields ONLY
    ## OpenSSL only needs content type & encoding to generate a multipart/signed msg
    my $dup_msg = $in_msg->dup;
    foreach my $field ($dup_msg->head->tags) {
999
         next if ($field =~ /^(content-type|content-transfer-encoding)$/i);
1000
         $dup_msg->head->delete($field);
For faster browsing, not all history is shown. View entire blame