task_manager.pl 53.3 KB
Newer Older
1
2
#! --PERL--

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
# task_manager.pl - This script runs as a daemon and processes periodical Sympa tasks
# RCS Identication ; $Revision$ ; $Date$ 
#
# Sympa - SYsteme de Multi-Postage Automatique
# Copyright (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.
23
24
25
26
27

## Options :  F         -> do not detach TTY
##         :  d		-> debug -d is equiv to -dF

## Change this to point to your Sympa bin directory
28
use lib '--LIBDIR--';
29
30
use strict vars;

31
use Task;
32
33
34
35
36
use List;
use Conf;
use Log;
use Getopt::Long;
use Time::Local;
salaun's avatar
salaun committed
37
use Digest::MD5;
38
use Scenario;
39
use SympaSession;
40
use mail;
41
use wwslib;
42
 
43
44
require 'tt2.pl';
require 'parser.pl';
45
46
47
48
49
require 'tools.pl';

my $opt_d;
my $opt_F;
my %options;
salaun's avatar
salaun committed
50

51
&GetOptions(\%main::options, 'debug|d', 'log_level=s', 'foreground');
52

salaun's avatar
salaun committed
53
# $main::options{'debug2'} = 1 if ($main::options{'debug'});
54
55
56
57
58

if ($main::options{'debug'}) {
    $main::options{'log_level'} = 2 unless ($main::options{'log_level'});
}
# Some option force foreground mode
59
60
$main::options{'foreground'} = 1 if ($main::options{'debug'});
$main::options{'log_to_stderr'} = 1 if ($main::options{'debug'} || $main::options{'foreground'});
61

62
63
64
65
66
67
68
69
70
71
my $Version = '0.1';

my $wwsympa_conf = "--WWSCONFIG--";
my $sympa_conf_file = '--CONFIG--';

my $wwsconf = {};
my $adrlist = {};

# Load WWSympa configuration
unless ($wwsconf = &wwslib::load_config($wwsympa_conf)) {
salaun's avatar
salaun committed
72
    &fatal_err('error : unable to load config file');
73
74
75
76
}

# Load sympa.conf
unless (Conf::load($sympa_conf_file)) {
salaun's avatar
salaun committed
77
    &fatal_err("error : unable to load sympa configuration, file $sympa_conf_file has errors.");
78
79
80
}

## Check databse connectivity
81
unless (&List::check_db_connect()) {
82
    &fatal_err('Database %s defined in sympa.conf has not the right structure or is unreachable.', $Conf{'db_name'});
83
}
84

85
## Check that the data structure is uptodate
86
unless (&Upgrade::data_structure_uptodate()) {
87
88
89
    &fatal_err("error : data structure was not updated ; you should run sympa.pl to run the upgrade process.");
}

salaun's avatar
salaun committed
90
91
92
93
94
95
96
97
98
99
100
101
## Check for several files.
unless (&Conf::checkfiles()) {
    fatal_err("Missing files. Aborting.");
    ## No return.                                         
}

## Put ourselves in background if not in debug mode. 
                                             
unless ($main::options{'debug'} || $main::options{'foreground'}) {
     open(STDERR, ">> /dev/null");
     open(STDOUT, ">> /dev/null");
     if (open(TTY, "/dev/tty")) {
102
         ioctl(TTY, 0x20007471, 0);         #  s/b &TIOCNOTTY
salaun's avatar
salaun committed
103
104
105
106
107
108
#       ioctl(TTY, &TIOCNOTTY, 0);                                             
         close(TTY);
     }
                                       
     setpgrp(0, 0);
     if ((my $child_pid = fork) != 0) {                                        
salaun's avatar
salaun committed
109
         print STDOUT "Starting task_manager daemon, pid $_\n";	 
salaun's avatar
salaun committed
110
111
112
113
         exit(0);
     }     
 }

114
115
&tools::write_pid($wwsconf->{'task_manager_pidfile'}, $$);

116
117
118
$wwsconf->{'log_facility'}||= $Conf{'syslog'};
do_openlog($wwsconf->{'log_facility'}, $Conf{'log_socket_type'}, 'task_manager');

salaun's avatar
salaun committed
119
120
# setting log_level using conf unless it is set by calling option
if ($main::options{'log_level'}) {
121
122
    &Log::set_log_level($main::options{'log_level'});
    do_log('info', "Configuration file read, log level set using options : $main::options{'log_level'}"); 
salaun's avatar
salaun committed
123
}else{
124
125
    &Log::set_log_level($Conf{'log_level'});
    do_log('info', "Configuration file read, default log level $Conf{'log_level'}"); 
salaun's avatar
salaun committed
126
127
}

128
## Set the UserID & GroupID for the process
129
130
$( = $) = (getgrnam('--GROUP--'))[2];
$< = $> = (getpwnam('--USER--'))[2];
131

132
133
## Required on FreeBSD to change ALL IDs(effective UID + real UID + saved UID)
&POSIX::setuid((getpwnam('--USER--'))[2]);
134
&POSIX::setgid((getgrnam('--GROUP--'))[2]);
135

136
137
138
139
140
## Check if the UID has correctly been set (usefull on OS X)
unless (($( == (getgrnam('--GROUP--'))[2]) && ($< == (getpwnam('--USER--'))[2])) {
    &fatal_err("Failed to change process userID and groupID. Note that on some OS Perl scripts can't change their real UID. In such circumstances Sympa should be run via SUDO.");
}

141
## Sets the UMASK
142
umask(oct($Conf{'umask'}));
143
144
145

## Change to list root
unless (chdir($Conf{'home'})) {
146
    &do_log('err',"error : unable to change to directory $Conf{'home'}");
147
148
149
150
151
152
153
154
155
156
157
158
    exit (-1);
}

my $pinfo = &List::_apply_defaults();

## Catch SIGTERM, in order to exit cleanly, whenever possible.
$SIG{'TERM'} = 'sigterm';
my $end = 0;

###### VARIABLES DECLARATION ######

my $spool_task = $Conf{'queuetask'};
159
my $cert_dir = $Conf{'ssl_cert_dir'};
160
161
my @tasks; # list of tasks in the spool

162
undef my $log; # won't execute send_msg and delete_subs commands if true, only log
163
164
#$log = 1;

165
## list of list task models
166
#my @list_models = ('expire', 'remind', 'sync_include');
167
my @list_models = ('sync_include','remind');
168

169
## hash of the global task models
salaun's avatar
salaun committed
170
171
my %global_models = (#'crl_update_task' => 'crl_update', 
		     #'chk_cert_expiration_task' => 'chk_cert_expiration',
172
		     'expire_bounce_task' => 'expire_bounce',
salaun's avatar
salaun committed
173
		     'purge_user_table_task' => 'purge_user_table',
174
		     'purge_logs_table_task' => 'purge_logs_table',
175
		     'purge_session_table_task' => 'purge_session_table',
176
		     'purge_one_time_ticket_table_task' => 'purge_one_time_ticket_table',
salaun's avatar
salaun committed
177
178
179
		     'purge_orphan_bounces_task' => 'purge_orphan_bounces',
		     'eval_bouncers_task' => 'eval_bouncers',
		     'process_bouncers_task' =>'process_bouncers',
180
		     #,'global_remind_task' => 'global_remind'
salaun's avatar
salaun committed
181
		     );
182

183
184
185
186
187
188
189
## month hash used by epoch conversion routines
my %months = ('Jan', 0, 'Feb', 1, 'Mar', 2, 'Apr', 3, 'May', 4,  'Jun', 5, 
	      'Jul', 6, 'Aug', 7, 'Sep', 8, 'Oct', 9, 'Nov', 10, 'Dec', 11);

###### DEFINITION OF AVAILABLE COMMANDS FOR TASKS ######

my $date_arg_regexp1 = '\d+|execution_date';
salaun's avatar
salaun committed
190
191
192
my $date_arg_regexp2 = '(\d\d\d\dy)(\d+m)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?'; 
my $date_arg_regexp3 = '(\d+|execution_date)(\+|\-)(\d+y)?(\d+m)?(\d+w)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?';
my $delay_regexp = '(\d+y)?(\d+m)?(\d+w)?(\d+d)?(\d+h)?(\d+min)?(\d+sec)?';
193
my $var_regexp ='@\w+'; 
194
my $subarg_regexp = '(\w+)(|\((.*)\))'; # for argument with sub argument (ie arg(sub_arg))
195
196
197
198
199
200
201
202
203
                 
# regular commands
my %commands = ('next'                  => ['date', '\w*'],
		                           # date   label
                'stop'                  => [],
		'create'                => ['subarg', '\w+', '\w+'],
		                           #object    model  model choice
		'exec'                  => ['.+'],
		                           #script
204
		'update_crl'            => ['\w+', 'date'], 
salaun's avatar
salaun committed
205
206
207
		                           #file    #delay
		'expire_bounce'         => ['\d+'],
		                           #Number of days (delay)
208
		'chk_cert_expiration'   => ['\w+', 'date'],
salaun's avatar
salaun committed
209
		                           #template  date
salaun's avatar
salaun committed
210
		'sync_include'          => [],
salaun's avatar
salaun committed
211
		'purge_user_table'      => [],
212
		'purge_logs_table'      => [],
213
		'purge_session_table'   => [],
214
		'purge_one_time_ticket_table'   => [],
salaun's avatar
salaun committed
215
216
217
		'purge_orphan_bounces'  => [],
		'eval_bouncers'         => [],
		'process_bouncers'      => []
218
219
220
		);

# commands which use a variable. If you add such a command, the first parameter must be the variable
221
222
223
224
225
226
my %var_commands = ('delete_subs'      => ['var'],
		                          # variable 
		    'send_msg'         => ['var',  '\w+' ],
		                          #variable template
		    'rm_file'          => ['var'],
		                          # variable
227
228
		    );

229
230
231
232
foreach (keys %var_commands) {
    $commands{$_} = $var_commands{$_};
}                                     
 
233
# commands which are used for assignments
234
235
236
237
my %asgn_commands = ('select_subs'      => ['subarg'],
		                            # condition
		     'delete_subs'      => ['var'],
		                            # variable
238
239
		     );

240
241
242
243
foreach (keys %asgn_commands) {
    $commands{$_} = $asgn_commands{$_};
}                                    
     
244
245
###### INFINITE LOOP SCANING THE QUEUE (unless a sig TERM is received) ######
while (!$end) {
salaun's avatar
salaun committed
246

247
248
249
    my $current_date = time; # current epoch date
    my $rep = &tools::adate ($current_date);

250

251
252
253
254
    ## Empty cache of the List.pm module
    &List::init_list_cache();

   ## List all tasks
255
    unless (&Task::list_tasks($spool_task)) {
olivier.salaun's avatar
olivier.salaun committed
256
	&List::send_notify_to_listmaster('intern_error',$Conf{'domain'},{'error' => "Failed to list task files in $spool_task"});
257
258
	&do_log ('err', "Failed to list task files in %s", $spool_task);
	exit -1;
259
260
    }

261
    my %used_models; # models for which a task exists
262
263
    foreach my $model (&Task::get_used_models) {
	$used_models{$model} = 1;
264
265
266
267
268
269
    }

    ### creation of required tasks 
    my %default_data = ('creation_date' => $current_date, # hash of datas necessary to the creation of tasks
			'execution_date' => 'execution_date');

270
    ## global tasks
271
    foreach my $key (keys %global_models) {	
272
	unless ($used_models{$global_models{$key}}) {
273
274
	    if ($Conf{$key}) { 
		my %data = %default_data; # hash of datas necessary to the creation of tasks
275
		create ($current_date, '', $global_models{$key}, $Conf{$key}, \%data);
276
		$used_models{$1} = 1;
277
278
	    }
	}
279
    }    
salaun's avatar
salaun committed
280

281
    
282
    ## list tasks
283
    foreach my $robot (keys %{$Conf{'robots'}}) {
284
285
	my $all_lists = &List::get_lists($robot);
	foreach my $list ( @$all_lists ) {
286
287
	    
	    my %data = %default_data;
288
	
289
290
	    $data{'list'} = {'name' => $list->{'name'},
			     'robot' => $list->{'domain'}};
291
	
292
	    my %used_list_models; # stores which models already have a task 
sympa-authors's avatar
sympa-authors committed
293
	    foreach (@list_models) { $used_list_models{$_} = undef; }
294
	    
295
	    foreach my $model (&Task::get_used_models($list->get_list_id())) {
296
		$used_list_models{$model} = 1; 
salaun's avatar
salaun committed
297
	    }
298
	    
299
	    foreach my $model (@list_models) {
300
301
		unless ($used_list_models{$model}) {
		    my $model_task_parameter = "$model".'_task';
salaun's avatar
salaun committed
302
		    
303
304
305
306
307
308
309
310
		    if ( $model eq 'sync_include') {
			next unless (($list->{'admin'}{'user_data_source'} eq 'include2') &&
				     $list->has_include_data_sources() &&
				     ($list->{'admin'}{'status'} eq 'open'));
			
			create ($current_date, 'INIT', $model, 'ttl', \%data);
			
		    }elsif (defined $list->{'admin'}{$model_task_parameter} && 
311
312
			    defined $list->{'admin'}{$model_task_parameter}{'name'} &&
			    ($list->{'admin'}{'status'} eq 'open')) {
313
314
315
			
			create ($current_date, '', $model, $list->{'admin'}{$model_task_parameter}{'name'}, \%data);
		    }
316
317
318
319
		}
	    }
	}
    }
320
321
322
323
324

    my $current_date = time; # current epoch date
    my $rep = &tools::adate ($current_date);

    ## Execute existing tasks
325
326
    ## List all tasks
    unless (&Task::list_tasks($spool_task)) {
olivier.salaun's avatar
olivier.salaun committed
327
	&List::send_notify_to_listmaster('intern_error',$Conf{'domain'},{'error' => "Failed to list task files in $spool_task"});
328
329
	&do_log ('err', "Failed to list task files in %s", $spool_task);
	exit -1;
330
331
332
333
    }

    ## processing of tasks anterior to the current date
    &do_log ('debug3', 'processing of tasks anterior to the current date');
334
    foreach my $task ( &Task::get_task_list() ) {
335
336
337
	
	last if $end;

338
	my $task_file = $task->{'filepath'};
339

340
341
342
343
344
345
346
	&do_log ('debug3', "procesing %s", $task_file);
	last unless ($task->{'date'} < $current_date);
	if ($task->{'object'} ne '_global') { # list task
	    my $list = $task->{'list_object'};
	    
	    ## Skip closed lists
	    unless (defined $list && ($list->{'admin'}{'status'} eq 'open')) {
347
		&do_log('notice','Removing task file %s because the list is not opened', $task_file);
348
349
350
351
352
353
354
355
356
357
358
359
		unless (unlink $task_file) {
		    &do_log('err', 'Unable to remove task file %s : %s', $task_file, $!);
		    next;
		}
		next;
	    }
	    
	    ## Skip if parameter is not defined
	    if ( $task->{'model'} eq 'sync_include') {
		unless (($list->{'admin'}{'user_data_source'} eq 'include2') &&
			$list->has_include_data_sources() &&
			($list->{'admin'}{'status'} eq 'open')) {
360
		    &do_log('notice','Removing task file %s', $task_file);
361
		    unless (unlink $task_file) {
362
363
364
365
366
			&do_log('err', 'Unable to remove task file %s : %s', $task_file, $!);
			next;
		    }
		    next;
		}
367
368
369
370
371
372
	    }else {
		unless (defined $list->{'admin'}{$task->{'model'}} && 
			defined $list->{'admin'}{$task->{'model'}}{'name'}) {
		    &do_log('notice','Removing task file %s', $task_file);
		    unless (unlink $task_file) {
			&do_log('err', 'Unable to remove task file %s : %s', $task_file, $!);
373
374
			next;
		    }
375
376
		    next;
		}		
salaun's avatar
salaun committed
377
	    }
378
	}
379
	execute ($task);
380
381
    }

382
    sleep 60;
383
    #$end = 1;
384
385

    ## Free zombie sendmail processes
386
    &mail::reaper;
387
388
}

389
&do_log ('notice', 'task_manager exited normally due to signal'); 
390
391
&tools::remove_pid($wwsconf->{'task_manager_pidfile'}, $$);

392
393
394
395
396
397
398
exit(0);

####### SUBROUTINES #######

## task creations
sub create {
        
399
400
401
402
403
404
    my $date          = shift;
    my $label         = shift;
    my $model         = shift;
    my $model_choice  = shift;
    my $Rdata         = shift;

405
    &do_log ('debug2', "create date : $date label : $label model $model : $model_choice Rdata :$Rdata");
406
407
408

    my $task_file;
    my $list_name;
409
410
411
    my $robot;
    my $object;
    if (defined $Rdata->{'list'}) { 
412
	$list_name = $Rdata->{'list'}{'name'};
413
	$robot = $Rdata->{'list'}{'robot'};
414
	$task_file  = "$spool_task/$date.$label.$model.$list_name\@$robot";
415
416
417
418
419
	$object = 'list';
    }
    else {
	$object = '_global';
	$task_file  = $spool_task.'/'.$date.'.'.$label.'.'.$model.'.'.$object;
420
421
422
423
424
425
426
427
    }

    ## model recovery
    my $model_file;
    my $model_name = $model.'.'.$model_choice.'.'.'task';
 
    &do_log ('notice', "creation of $task_file");

428
     # for global model
429
    if ($object eq '_global') {
430
	unless ($model_file = &tools::get_filename('etc',{},"global_task_models/$model_name", $Conf{'host'})) {
431
432
433
434
435
	    &do_log ('err', "error : unable to find $model_name, creation aborted");
	    return undef;
	}
    }

salaun's avatar
salaun committed
436
    # for a list
437
    if ($object  eq 'list') {
438
	my $list = new List($list_name, $robot);
salaun's avatar
salaun committed
439

salaun's avatar
salaun committed
440
441
	$Rdata->{'list'}{'ttl'} = $list->{'admin'}{'ttl'};

442
	unless ($model_file = &tools::get_filename('etc', {},"list_task_models/$model_name", $list->{'domain'}, $list)) {
443
	    &do_log ('err', "error : unable to find $model_name, for list $list_name creation aborted");
444
445
446
447
448
449
450
451
452
	    return undef;
	}
    }
   
    &do_log ('notice', "with model $model_file");
    close (MODEL);

    ## creation
    open (TASK, ">$task_file");
453
    &parser::parse_tpl($Rdata, $model_file, \*TASK);
454
455
    close (TASK);
    
456
    # special checking for list whose user_data_source config parmater is include. The task won't be created if there is a delete_subs command
457
458
    my $ok = 1;
    if ($object eq 'list') {
459
	my $list = new List($list_name, $robot);
460
461
462
463
464
465
466
	if ($list->{'admin'}{'user_data_source'} eq 'include') {
	    unless ( open (TASK, $task_file) ) {
		&do_log ('err', "error : unable to read $task_file, checking is impossible");
		return undef;
	    }
	    while (<TASK>) {
		chomp;
467
		if (/.*delete_subs.*/) {
468
469
		    close (TASK);
		    undef $ok;
470
		    &do_log ('err', "error : you are not allowed to use the delete_subs command on a list whose subscribers are included, creation aborted");
471
		    return undef;
472
473
474
475
476
477
		}
	    }
	    close (TASK);
	} 
    } # end of special checking

478
479
480
481
    if (!$ok) {
	&do_log ('err', "$task_file is unappropriate for a list with include");
    }
    
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
    if  (!$ok or !check ($task_file)) {
	&do_log ('err', "error : syntax error in $task_file, you should check $model_file");
	unlink ($task_file) ? 
	    &do_log ('notice', "$task_file deleted") 
		: &do_log ('err', "error : unable to delete $task_file");	
	return undef;
    }
    return 1;
}

### SYNTAX CHECKING SUBROUTINES ###

## check the syntax of a task
sub check {

497
498
499
    my $task_file = shift; # the task to check

    &do_log ('debug2', "check($task_file)" );
500
501
    my %result; # stores the result of the chk_line subroutine
    my $lnb = 0; # line number
502
503
504
505
    my %used_labels; # list of labels used as parameter in commands
    my %labels; # list of declared labels
    my %used_vars; # list of vars used as parameter in commands
    my %vars; # list of declared vars
506
507
508
509
510
511
512
513
514
515
516
517

    unless ( open (TASK, $task_file) ) {
	&do_log ('err', "error : unable to read $task_file, checking is impossible");
	return undef;
    }

    
    while (<TASK>) {

	chomp;

	$lnb++;
518
519

	next if ( $_ =~ /^\s*\#/ ); 
520
521
522
523
524
525
526
	unless (chk_line ($_, \%result)) {
	    &do_log ('err', "error at line $lnb : $_");
	    &do_log ('err', "$result{'error'}");
	    return undef;
	}
	
	if ( $result{'nature'} eq 'assignment' ) {
527
528
529
530
	    if (chk_cmd ($result{'command'}, $lnb, $result{'Rarguments'}, \%used_labels, \%used_vars)) {
		$vars{$result{'var'}} = 1;
	    } else {
		return undef;}
531
	}
532
	
533
	if ( $result{'nature'} eq 'command' ) {
534
	    return undef unless (chk_cmd ($result{'command'}, $lnb, $result{'Rarguments'}, \%used_labels, \%used_vars));
535
536
	} 
			 
537
	$labels{$result{'label'}} = 1 if ( $result{'nature'} eq 'label' );
538
539
540
541
	
    }

    # are all labels used ?
542
    foreach my $label (keys %labels) {
543
	&do_log ('debug3', "warning : label $label exists but is not used") unless ($used_labels{$label});
544
545
546
    }

    # do all used labels exist ?
547
548
    foreach my $label (keys %used_labels) {
	unless ($labels{$label}) {
549
550
551
552
553
554
	    &do_log ('err', "error : label $label is used but does not exist");
	    return undef;
	}
    }
    
    # are all variables used ?
555
556
    foreach my $var (keys %vars) {
	&do_log ('notice', "warning : var $var exists but is not used") unless ($used_vars{$var});
557
558
559
    }

    # do all used variables exist ?
560
561
    foreach my $var (keys %used_vars) {
	unless ($vars{$var}) {
562
563
564
565
566
567
568
569
570
571
572
573
574
	    &do_log ('err', "error : var $var is used but does not exist");
	    return undef;
	}
    }

    return 1;
}

## check a task line
sub chk_line {

    my $line = $_[0];
    my $Rhash = $_[1]; # will contain nature of line (label, command, error...)
575

576
577
578
    ## just in case...
    chomp $line;

579
    &do_log('debug2', 'chk_line(%s, %s)', $line, $Rhash->{'nature'});
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
        
    $Rhash->{'nature'} = undef;
  
    # empty line
    if (! $line) {
	$Rhash->{'nature'} = 'empty line';
	return 1;
    }
  
    # comment
    if ($line =~ /^\s*\#.*/) {
	$Rhash->{'nature'} = 'comment';
	return 1;
    } 

    # title
596
    if ($line =~ /^\s*title\...\s*(.*)\s*/i) {
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
	$Rhash->{'nature'} = 'title';
	$Rhash->{'title'} = $1;
	return 1;
    }

    # label
    if ($line =~ /^\s*\/\s*(.*)/) {
	$Rhash->{'nature'} = 'label';
	$Rhash->{'label'} = $1;
	return 1;
    }

    # command
    if ($line =~ /^\s*(\w+)\s*\((.*)\)\s*/i ) { 
    
612
	my $command = lc ($1);
613
614
615
	my @args = split (/,/, $2);
	foreach (@args) { s/\s//g;}

616
	unless ($commands{$command}) { 
617
	    $Rhash->{'nature'} = 'error';
618
	    $Rhash->{'error'} = "unknown command $command";
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
	    return 0;
	}
    
	$Rhash->{'nature'} = 'command';
	$Rhash->{'command'} = $command;

	# arguments recovery. no checking of their syntax !!!
	$Rhash->{'Rarguments'} = \@args;
	return 1;
    }
  
    # assignment
    if ($line =~ /^\s*(@\w+)\s*=\s*(.+)/) {

	my %hash2;
	chk_line ($2, \%hash2);
635
	unless ( $asgn_commands{$hash2{'command'}} ) { 
636
	    $Rhash->{'nature'} = 'error';
637
	    $Rhash->{'error'} = "non valid assignment $2";
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
	    return 0;
	}
	$Rhash->{'nature'} = 'assignment';
	$Rhash->{'var'} = $1;
	$Rhash->{'command'} = $hash2{'command'};
	$Rhash->{'Rarguments'} = $hash2{'Rarguments'};
	return 1;
    }

    $Rhash->{'nature'} = 'error'; 
    $Rhash->{'error'} = 'syntax error';
    return 0;
}

## check the arguments of a command 
sub chk_cmd {
    
    my $cmd = $_[0]; # command name
    my $lnb = $_[1]; # line number
    my $Rargs = $_[2]; # argument list
    my $Rused_labels = $_[3];
    my $Rused_vars = $_[4];
660
661

    &do_log('debug2', 'chk_cmd(%s, %d, %s)', $cmd, $lnb, join(',',@{$Rargs}));
662
    
663
    if (defined $commands{$cmd}) {
664
	
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
	my @expected_args = @{$commands{$cmd}};
	my @args = @{$Rargs};
	
	unless ($#expected_args == $#args) {
	    &do_log ('err', "error at line $lnb : wrong number of arguments for $cmd");
	    &do_log ('err', "args = @args ; expected_args = @expected_args");
	    return undef;
	}
	
	foreach (@args) {
	    
	    undef my $error;
	    my $regexp = $expected_args[0];
	    shift (@expected_args);
	    
	    if ($regexp eq 'date') {
		$error = 1 unless ( (/^$date_arg_regexp1$/i) or (/^$date_arg_regexp2$/i) or (/^$date_arg_regexp3$/i) );
	    }
	    elsif ($regexp eq 'delay') {
		$error = 1 unless (/^$delay_regexp$/i);
	    }
	    elsif ($regexp eq 'var') {
		$error = 1 unless (/^$var_regexp$/i);
	    }
	    elsif ($regexp eq 'subarg') {
		$error = 1 unless (/^$subarg_regexp$/i);
	    }
	    else {
		$error = 1 unless (/^$regexp$/i);
	    }
	    
	    if ($error) {
		&do_log ('err', "error at line $lnb : argument $_ is not valid");
698
699
		return undef;
	    }
700
	    
701
702
	    $Rused_labels->{$args[1]} if ($cmd eq 'next' && ($args[1]));   
	    $Rused_vars->{$args[0]} = 1 if ($var_commands{$cmd});
703
704
705
706
707
708
709
710
711
712
	}
    }
    return 1;
}

    
### TASK EXECUTION SUBROUTINES ###

sub execute {

713
714
715
    my $task = shift;
    my $task_file = $task->{'filepath'}; # task to execute

716
717
718
    my %result; # stores the result of the chk_line subroutine
    my %vars; # list of task vars
    my $lnb = 0; # line number
719

720
    &do_log('notice', 'Running task %s, line %d with vars %s)', $task_file, $lnb, join('/',  %vars));
salaun's avatar
salaun committed
721
    
722
723
724
725
726
    unless ( open (TASK, $task_file) ) {
	&do_log ('err', "error : can't read the task $task_file");
	return undef;
    }

727
    my $label = $task->{'label'};
728
729
    return undef if ($label eq 'ERROR');

aumont's avatar
aumont committed
730
    &do_log ('debug2', "* execution of the task $task_file");
731
732
    unless ($label eq '') {
	while ( <TASK> ) {
733
	    chomp;
734
735
736
737
738
739
740
	    $lnb++;
	    chk_line ($_, \%result);
	    last if ($result{'label'} eq $label);
	}
    }

    # execution
741
    my $status;
742
743
744
745
746
747
    while ( <TASK> ) {
  
	chomp;
	$lnb++;

	unless ( chk_line ($_, \%result) ) {
748
	    &do_log ('err', "error : $result{'error'}");
749
750
	    return undef;
	}
751
	
752
753
	# processing of the assignments
	if ($result{'nature'} eq 'assignment') {
754
	    $status = $vars{$result{'var'}} = &cmd_process ($result{'command'}, $result{'Rarguments'}, $task, \%vars, $lnb);
salaun's avatar
salaun committed
755
	    last unless defined($status);
756
	}
757
	
758
759
	# processing of the commands
	if ($result{'nature'} eq 'command') {
760
	    $status = &cmd_process ($result{'command'}, $result{'Rarguments'}, $task, \%vars, $lnb);
761
	    last unless defined($status);
762
763
764
765
766
	}
    } 

    close (TASK);

767
768
769
770
771
772
773
774
775
    unless (defined $status) {
	&do_log('err', 'Error while processing task, removing %s', $task_file);
	unless (unlink($task_file)) {
	    &do_log('err', 'Unable to remove task file %s : %s', $task_file, $!);
	    return undef;
	}
	return undef;
    }

776
777
778
779
780
781
782
783
    return 1;
}


sub cmd_process {

    my $command = $_[0]; # command name
    my $Rarguments = $_[1]; # command arguments
784
    my $task = $_[2]; # task
785
786
787
    my $Rvars = $_[3]; # variable list of the task
    my $lnb = $_[4]; # line number

788
789
    my $task_file = $task->{'filepath'};

salaun's avatar
salaun committed
790
791
    &do_log('debug2', 'cmd_process(%s, %s, %d)', $command, $task_file, $lnb);

792
     # building of %context
793
794
795
    my %context = ('line_number' => $lnb);

    &do_log('debug2','Current task : %s', join(':',%$task));
796
797

     # regular commands
798
799
800
801
802
803
804
    return stop ($task, \%context) if ($command eq 'stop');
    return next_cmd ($task, $Rarguments, \%context) if ($command eq 'next');
    return create_cmd ($task, $Rarguments, \%context) if ($command eq 'create');
    return exec_cmd ($task, $Rarguments) if ($command eq 'exec');
    return update_crl ($task, $Rarguments, \%context) if ($command eq 'update_crl');
    return expire_bounce ($task, $Rarguments, \%context) if ($command eq 'expire_bounce');
    return purge_user_table ($task, \%context) if ($command eq 'purge_user_table');
805
    return purge_logs_table ($task, \%context) if ($command eq 'purge_logs_table');
806
    return purge_session_table ($task, \%context) if ($command eq 'purge_session_table');
807
    return purge_one_time_ticket_table ($task, \%context) if ($command eq 'purge_one_time_ticket_table');
808
809
810
811
    return sync_include($task, \%context) if ($command eq 'sync_include');
    return purge_orphan_bounces ($task, \%context) if ($command eq 'purge_orphan_bounces');
    return eval_bouncers ($task, \%context) if ($command eq 'eval_bouncers');
    return process_bouncers ($task, \%context) if ($command eq 'process_bouncers');
812
813

     # commands which use a variable
814
815
    return send_msg ($task, $Rarguments, $Rvars, \%context) if ($command eq 'send_msg');       
    return rm_file ($task, $Rarguments, $Rvars, \%context) if ($command eq 'rm_file');
816
817

     # commands which return a variable
818
819
    return select_subs ($task, $Rarguments, \%context) if ($command eq 'select_subs');
    return chk_cert_expiration ($task, $Rarguments, \%context) if ($command eq 'chk_cert_expiration');
820
821

     # commands which return and use a variable
822
    return delete_subs_cmd ($task, $Rarguments, $Rvars, \%context) if ($command eq 'delete_subs');  
823
824
825
826
}


### command subroutines ###
827
828
829
 
 # remove files whose name is given in the key 'file' of the hash
sub rm_file {
830
    
831
    my ($task, $Rarguments,$Rvars, $context) = @_;
832
833
834
835
836
837
838
839
    
    my @tab = @{$Rarguments};
    my $var = $tab[0];

    foreach my $key (keys %{$Rvars->{$var}}) {
	my $file = $Rvars->{$var}{$key}{'file'};
	next unless ($file);
	unless (unlink ($file)) {
840
	    error ($task->{'filepath'}, "error in rm_file command : unable to remove $file");
841
842
843
	    return undef;
	}
    }
844
845

    return 1;
846
}
847
848

sub stop {
849
850
    
    my ($task, $context) = @_;
851
    my $task_file = $spool_task.'/'.$task->{'filename'};
852
853
854

    &do_log ('notice', "$context->{'line_number'} : stop $task_file");
    
855
856
857
858
    unlink ($task_file) ?  
	&do_log ('notice', "--> $task_file deleted")
	    : error ($task_file, "error in stop command : unable to delete task file");

859
    return 0;
860
861
862
863
}

sub send_msg {
        
864
    my ($task, $Rarguments, $Rvars, $context) = @_;
865
866
867
868
869
870
871
    
    my @tab = @{$Rarguments};
    my $template = $tab[1];
    my $var = $tab[0];
    
    &do_log ('notice', "line $context->{'line_number'} : send_msg (@{$Rarguments})");

872

873
    if ($task->{'object'} eq '_global') {
874
875
876

	foreach my $email (keys %{$Rvars->{$var}}) {
	    &do_log ('notice', "--> message sent to $email");
877
878
879
880
881
 	    if (!$log) {
 		unless (&List::send_global_file ($template, $email, ,'',$Rvars->{$var}{$email}) ) {
 		    &do_log ('notice', "Unable to send template $template to $email");
 		}
 	    }
882
883
	}
    } else {
884
	my $list = $task->{'list_object'};
885
	
886
887
	foreach my $email (keys %{$Rvars->{$var}}) {
	    &do_log ('notice', "--> message sent to $email");
888
889
890
891
892
 	    if (!$log) {
 		unless ($list->send_file ($template, $email, $list->{'domain'}, $Rvars->{$var}{$email}))  {
 		    &do_log ('notice', "Unable to send template $template to $email");
 		}
	    }
893
	}
894
895
896
897
898
    }
    return 1;
}

sub next_cmd {
899
900
        
    my ($task, $Rarguments, $context) = @_;
901
902
    
    my @tab = @{$Rarguments};
903
    my $date = &tools::epoch_conv ($tab[0], $task->{'date'}); # conversion of the date argument into epoch format
904
    my $label = $tab[1];
905

906
    &do_log ('notice', "line $context->{'line_number'} of $task->{'model'} : next ($date, $label)");
907

908
909
910
    my $listname = $task->{'object'};
    my $model = $task->{'model'};
    my $filename = $task->{'filepath'};
911
912
913

    ## Determine type
    my ($type, $model_choice);
914
    my %data = ('creation_date'  => $task->{'date'},
915
		'execution_date' => 'execution_date');
916
    if ($listname eq '_global') {
917
	$type = '_global';
918
919
920
921
922
923
924
925
	foreach my $key (keys %global_models) {
	    if ($global_models{$key} eq $model) {
		$model_choice = $Conf{$key};
		last;
	    }
	}
    }else {
	$type = 'list';
926
	my $list = $task->{'list_object'};
927
	$data{'list'}{'name'} = $list->{'name'};
928
	$data{'list'}{'robot'} = $list->{'domain'};
929
930
931
	
	if ( $model eq 'sync_include') {
	    unless ($list->{'admin'}{'user_data_source'} eq 'include2') {
932
		error ($filename, "List $list->{'name'} no more require sync_include task");
933
934
		return undef;
	    }
935

936
937
938
939
	    $data{'list'}{'ttl'} = $list->{'admin'}{'ttl'};
	    $model_choice = 'ttl';
	}else {
	    unless (defined $list->{'admin'}{"$model\_task"}) {
940
		error ($filename, "List $list->{'name'} no more require $model task");
941
942
943
		return undef;
	    }

944
	    $model_choice = $list->{'admin'}{"$model\_task"}{'name'};
945
946
	}
    }
947

948
    unless (create ($date, $tab[1], $model, $model_choice, \%data)) {
949
	error ($filename, "error in create command : creation subroutine failure");
950
951
952
953
	return undef;
    }

#    my $new_task = "$date.$label.$name[2].$name[3]";
954
    my $human_date = &tools::adate ($date);
955
#    my $new_task_file = "$spool_task/$new_task";
956
957
#    unless (rename ($filename, $new_task_file)) {
#	error ($filename, "error in next command : unable to rename task file into $new_task");
958
959
#	return undef;
#    }
960
961
    unless (unlink ($filename)) {
	error ($filename, "error in next command : unable to remove task file $filename");
962
	return undef;
963
    }
964
965

    &do_log ('notice', "--> new task $model ($human_date)");
966
    
967
    return 0;
968
969
970
971
}

sub select_subs {

972
    my ($task, $Rarguments, $context) = @_;
973
974
975
976

    my @tab = @{$Rarguments};
    my $condition = $tab[0];
 
salaun's avatar
salaun committed
977
    &do_log ('debug2', "line $context->{'line_number'} : select_subs ($condition)");
978
979
    $condition =~ /(\w+)\(([^\)]*)\)/;
    if ($2) { # conversion of the date argument into epoch format
980
	my $date = &tools::epoch_conv ($2, $task->{'date'});
981
982
983
984
        $condition = "$1($date)";
    }  
 
    my @users; # the subscribers of the list      
985
    my %selection; # hash of subscribers who match the condition
986
    my $list = $task->{'list_object'};
987
    
salaun's avatar
salaun committed
988
    if ( $list->{'admin'}{'user_data_source'} =~ /database|file|include2/) {
989
990
991
992
993
        for ( my $user = $list->get_first_user(); $user; $user = $list->get_next_user() ) { 
            push (@users, $user);
	}
    }
    
994
    # parameter of subroutine Scenario::verify
995
996
997
    my $verify_context = {'sender' => 'nobody',
			  'email' => 'nobody',
			  'remote_host' => 'unknown_host',
998
			  'listname' => $task->{'object'}};
999
1000
1001
1002
1003
1004
1005
1006
1007
    
    my $new_condition = $condition; # necessary to the older & newer condition rewriting
    # loop on the subscribers of $list_name
    foreach my $user (@users) {

	# AF : voir 'update' do_log ('notice', "date $user->{'date'} & update $user->{'update'}");
	# condition rewriting for older and newer
	$new_condition = "$1($user->{'update_date'}, $2)" if ($condition =~ /(older|newer)\((\d+)\)/ );
	
1008
	if (&Scenario::verify ($verify_context, $new_condition) == 1) {
1009
	    $selection{$user->{'email'}} = undef;
1010
1011
1012
1013
	    &do_log ('notice', "--> user $user->{'email'} has been selected");
	}
    }
    
1014
    return \%selection;
1015
1016
}

1017
sub delete_subs_cmd {
1018

1019
    my ($task, $Rarguments, $Rvars,  $context) = @_;
1020
1021
1022
1023

    my @tab = @{$Rarguments};
    my $var = $tab[0];

1024
    &do_log ('notice', "line $context->{'line_number'} : delete_subs ($var)");
1025
1026

    
1027
    my $list = $task->{'list_object'};
1028
    my %selection; # hash of subscriber emails who are successfully deleted
1029

1030
    foreach my $email (keys %{$Rvars->{$var}}) {
1031
1032

	&do_log ('notice', "email : $email");
1033
1034
1035
1036
	my $result = $list->check_list_authz('del', 'smime',
					     {'sender'   => $Conf{'listmaster'},
					      'email'    => $email,
					  });
1037
1038
	my $action;
	$action = $result->{'action'} if (ref($result) eq 'HASH');
1039
	if ($action =~ /reject/i) {
1040
	    error ($task->{'filepath'}, "error in delete_subs command : deletion of $email not allowed");
1041
	} else {
1042
1043
	    my $u = $list->delete_user ($email) if (!$log);
	    &do_log ('notice', "--> $email deleted");
1044
	    $selection{$email} = {};
1045
1046
1047
	}
    }

1048
    return \%selection;
1049
1050
1051
1052
}

sub create_cmd {

1053
    my ($task, $Rarguments, $context) = @_;
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066

    my @tab = @{$Rarguments};
    my $arg = $tab[0];
    my $model = $tab[1];
    my $model_choice = $tab[2];

    &do_log ('notice', "line $context->{'line_number'} : create ($arg, $model, $model_choice)");

    # recovery of the object type and object
    my $type;
    my $object;
    if (</