#! --PERL-- # task_manager.pl - This script runs as a daemon and processes periodical Sympa tasks # RCS Identication ; $Revision: 10713 $ ; $Date: 2014-05-23 11:18:40 +0200 (ven. 23 mai 2014) $ # # Sympa - SYsteme de Multi-Postage Automatique # # 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 # # 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, see . ## Options : F -> do not detach TTY ## : d -> debug -d is equiv to -dF use lib '--modulesdir--'; use strict "vars"; use Task; use List; use Conf; use Log; use Getopt::Long; use Time::Local; use Digest::MD5; use Scenario; use SympaSession; use Bulk; use mail; use wwslib; use tt2; use tools; use Sympa::Constants; my $opt_d; my $opt_F; my %options; unless (&GetOptions(\%main::options, 'debug|d', 'log_level=s', 'foreground')) { &fatal_err("Unknown options."); } # $main::options{'debug2'} = 1 if ($main::options{'debug'}); if ($main::options{'debug'}) { $main::options{'log_level'} = 2 unless ($main::options{'log_level'}); } # Some option force foreground mode $main::options{'foreground'} = 1 if ($main::options{'debug'}); $main::options{'log_to_stderr'} = 1 if ($main::options{'debug'} || $main::options{'foreground'}); my $Version = '0.1'; my $wwsympa_conf = Sympa::Constants::WWSCONFIG; my $sympa_conf_file = Sympa::Constants::CONFIG; my $wwsconf = {}; my $adrlist = {}; # Load WWSympa configuration unless ($wwsconf = &wwslib::load_config($wwsympa_conf)) { &fatal_err('error : unable to load config file'); } # Load sympa.conf unless (Conf::load($sympa_conf_file)) { &fatal_err("error : unable to load sympa configuration, file $sympa_conf_file has errors."); } ## Check databse connectivity unless (&List::check_db_connect()) { &fatal_err('Database %s defined in sympa.conf has not the right structure or is unreachable.', $Conf{'db_name'}); } ## Check that the data structure is uptodate unless (&Upgrade::data_structure_uptodate()) { &fatal_err("error : data structure was not updated ; you should run sympa.pl to run the upgrade process."); } ## 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")) { ioctl(TTY, 0x20007471, 0); # s/b &TIOCNOTTY # ioctl(TTY, &TIOCNOTTY, 0); close(TTY); } setpgrp(0, 0); if ((my $child_pid = fork) != 0) { print STDOUT "Starting task_manager daemon, pid $_\n"; exit(0); } } ## If process is running in foreground, don't write STDERR to a dedicated file my $options; $options->{'stderr_to_tty'} = 1 if ($main::options{'foreground'}); tools::write_pid('task_manager', $$, $options); $wwsconf->{'log_facility'}||= $Conf{'syslog'}; do_openlog($wwsconf->{'log_facility'}, $Conf{'log_socket_type'}, 'task_manager'); # setting log_level using conf unless it is set by calling option if ($main::options{'log_level'}) { &Log::set_log_level($main::options{'log_level'}); do_log('info', "Configuration file read, log level set using options : $main::options{'log_level'}"); }else{ &Log::set_log_level($Conf{'log_level'}); do_log('info', "Configuration file read, default log level $Conf{'log_level'}"); } ## Set the UserID & GroupID for the process $( = $) = (getgrnam(Sympa::Constants::GROUP))[2]; $< = $> = (getpwnam(Sympa::Constants::USER))[2]; ## Required on FreeBSD to change ALL IDs(effective UID + real UID + saved UID) &POSIX::setuid((getpwnam(Sympa::Constants::USER))[2]); &POSIX::setgid((getgrnam(Sympa::Constants::GROUP))[2]); ## Check if the UID has correctly been set (usefull on OS X) unless (($( == (getgrnam(Sympa::Constants::GROUP))[2]) && ($< == (getpwnam(Sympa::Constants::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."); } ## Sets the UMASK umask(oct($Conf{'umask'})); ## Change to list root unless (chdir($Conf{'home'})) { &do_log('err',"error : unable to change to directory $Conf{'home'}"); 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'}; my $cert_dir = $Conf{'ssl_cert_dir'}; my @tasks; # list of tasks in the spool undef my $log; # won't execute send_msg and delete_subs commands if true, only log #$log = 1; ## list of list task models #my @list_models = ('expire', 'remind', 'sync_include'); my @list_models = ('sync_include','remind'); ## hash of the global task models my %global_models = (#'crl_update_task' => 'crl_update', #'chk_cert_expiration_task' => 'chk_cert_expiration', 'expire_bounce_task' => 'expire_bounce', 'purge_user_table_task' => 'purge_user_table', 'purge_logs_table_task' => 'purge_logs_table', 'purge_session_table_task' => 'purge_session_table', 'purge_tables_task' => 'purge_tables', 'purge_one_time_ticket_table_task' => 'purge_one_time_ticket_table', 'purge_orphan_bounces_task' => 'purge_orphan_bounces', 'eval_bouncers_task' => 'eval_bouncers', 'process_bouncers_task' =>'process_bouncers', #,'global_remind_task' => 'global_remind' ); ## 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'; 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)?'; my $var_regexp ='@\w+'; my $subarg_regexp = '(\w+)(|\((.*)\))'; # for argument with sub argument (ie arg(sub_arg)) # regular commands my %commands = ('next' => ['date', '\w*'], # date label 'stop' => [], 'create' => ['subarg', '\w+', '\w+'], #object model model choice 'exec' => ['.+'], #script 'update_crl' => ['\w+', 'date'], #file #delay 'expire_bounce' => ['\d+'], #Number of days (delay) 'chk_cert_expiration' => ['\w+', 'date'], #template date 'sync_include' => [], 'purge_user_table' => [], 'purge_logs_table' => [], 'purge_session_table' => [], 'purge_tables' => [], 'purge_one_time_ticket_table' => [], 'purge_orphan_bounces' => [], 'eval_bouncers' => [], 'process_bouncers' => [] ); # commands which use a variable. If you add such a command, the first parameter must be the variable my %var_commands = ('delete_subs' => ['var'], # variable 'send_msg' => ['var', '\w+' ], #variable template 'rm_file' => ['var'], # variable ); foreach (keys %var_commands) { $commands{$_} = $var_commands{$_}; } # commands which are used for assignments my %asgn_commands = ('select_subs' => ['subarg'], # condition 'delete_subs' => ['var'], # variable ); foreach (keys %asgn_commands) { $commands{$_} = $asgn_commands{$_}; } ###### INFINITE LOOP SCANING THE QUEUE (unless a sig TERM is received) ###### while (!$end) { my $current_date = time; # current epoch date my $rep = &tools::adate ($current_date); ## Empty cache of the List.pm module &List::init_list_cache(); ## List all tasks unless (&Task::list_tasks($spool_task)) { &List::send_notify_to_listmaster('intern_error',$Conf{'domain'},{'error' => "Failed to list task files in $spool_task"}); &do_log ('err', "Failed to list task files in %s", $spool_task); exit -1; } my %used_models; # models for which a task exists foreach my $model (&Task::get_used_models) { $used_models{$model} = 1; } ### creation of required tasks my %default_data = ('creation_date' => $current_date, # hash of datas necessary to the creation of tasks 'execution_date' => 'execution_date'); ## global tasks foreach my $key (keys %global_models) { unless ($used_models{$global_models{$key}}) { if ($Conf{$key}) { my %data = %default_data; # hash of datas necessary to the creation of tasks create ($current_date, '', $global_models{$key}, $Conf{$key}, \%data); $used_models{$1} = 1; } } } ## list tasks foreach my $robot (keys %{$Conf{'robots'}}) { my $all_lists = &List::get_lists($robot); foreach my $list ( @$all_lists ) { my %data = %default_data; $data{'list'} = {'name' => $list->{'name'}, 'robot' => $list->{'domain'}}; my %used_list_models; # stores which models already have a task foreach (@list_models) { $used_list_models{$_} = undef; } foreach my $model (&Task::get_used_models($list->get_list_id())) { $used_list_models{$model} = 1; } foreach my $model (@list_models) { unless ($used_list_models{$model}) { my $model_task_parameter = "$model".'_task'; if ( $model eq 'sync_include') { next unless ($list->has_include_data_sources() && ($list->{'admin'}{'status'} eq 'open')); create ($current_date, 'INIT', $model, 'ttl', \%data); }elsif (defined $list->{'admin'}{$model_task_parameter} && defined $list->{'admin'}{$model_task_parameter}{'name'} && ($list->{'admin'}{'status'} eq 'open')) { create ($current_date, '', $model, $list->{'admin'}{$model_task_parameter}{'name'}, \%data); } } } } } my $current_date = time; # current epoch date my $rep = &tools::adate ($current_date); ## Execute existing tasks ## List all tasks unless (&Task::list_tasks($spool_task)) { &List::send_notify_to_listmaster('intern_error',$Conf{'domain'},{'error' => "Failed to list task files in $spool_task"}); &do_log ('err', "Failed to list task files in %s", $spool_task); exit -1; } ## processing of tasks anterior to the current date &do_log ('debug3', 'processing of tasks anterior to the current date'); foreach my $task ( &Task::get_task_list() ) { last if $end; my $task_file = $task->{'filepath'}; &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')) { &do_log('notice','Removing task file %s because the list is not opened', $task_file); 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'}{'status'} eq 'open') { &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, $!); next; } next; } }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, $!); next; } next; } } } execute ($task); } sleep 60; #$end = 1; ## Free zombie sendmail processes &mail::reaper; } &do_log ('notice', 'task_manager exited normally due to signal'); tools::remove_pid('task_manager', $$); exit(0); ####### SUBROUTINES ####### ## task creations sub create { my $date = shift; my $label = shift; my $model = shift; my $model_choice = shift; my $Rdata = shift; &do_log ('debug2', "create date : $date label : $label model $model : $model_choice Rdata :$Rdata"); my $task_file; my $list_name; my $robot; my $object; if (defined $Rdata->{'list'}) { $list_name = $Rdata->{'list'}{'name'}; $robot = $Rdata->{'list'}{'robot'}; $task_file = "$spool_task/$date.$label.$model.$list_name\@$robot"; $object = 'list'; } else { $object = '_global'; $task_file = $spool_task.'/'.$date.'.'.$label.'.'.$model.'.'.$object; } ## model recovery my $model_file; my $model_name = $model.'.'.$model_choice.'.'.'task'; &do_log ('notice', "creation of $task_file"); # for global model if ($object eq '_global') { unless ($model_file = &tools::get_filename('etc',{},"global_task_models/$model_name", $Conf{'host'})) { &do_log ('err', "error : unable to find $model_name, creation aborted"); return undef; } } # for a list if ($object eq 'list') { my $list = new List($list_name, $robot); $Rdata->{'list'}{'ttl'} = $list->{'admin'}{'ttl'}; unless ($model_file = &tools::get_filename('etc', {},"list_task_models/$model_name", $list->{'domain'}, $list)) { &do_log ('err', "error : unable to find $model_name, for list $list_name creation aborted"); return undef; } } &do_log ('notice', "with model $model_file"); close (MODEL); ## creation open (TASK, ">$task_file"); my $tt2 = Template->new({'START_TAG' => quotemeta('['),'END_TAG' => quotemeta(']'), 'ABSOLUTE' => 1}); unless (defined $tt2 && $tt2->process($model_file, $Rdata, \*TASK)) { &do_log('err', "Failed to parse task template '%s' : %s", $model_file, $tt2->error()); } #&parser::parse_tpl($Rdata, $model_file, \*TASK); close (TASK); if (!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 { my $task_file = shift; # the task to check &do_log ('debug2', "check($task_file)" ); my %result; # stores the result of the chk_line subroutine my $lnb = 0; # line number 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 unless ( open (TASK, $task_file) ) { &do_log ('err', "error : unable to read $task_file, checking is impossible"); return undef; } while () { chomp; $lnb++; next if ( $_ =~ /^\s*\#/ ); unless (chk_line ($_, \%result)) { &do_log ('err', "error at line $lnb : $_"); &do_log ('err', "$result{'error'}"); return undef; } if ( $result{'nature'} eq 'assignment' ) { if (chk_cmd ($result{'command'}, $lnb, $result{'Rarguments'}, \%used_labels, \%used_vars)) { $vars{$result{'var'}} = 1; } else { return undef;} } if ( $result{'nature'} eq 'command' ) { return undef unless (chk_cmd ($result{'command'}, $lnb, $result{'Rarguments'}, \%used_labels, \%used_vars)); } $labels{$result{'label'}} = 1 if ( $result{'nature'} eq 'label' ); } # are all labels used ? foreach my $label (keys %labels) { &do_log ('debug3', "warning : label $label exists but is not used") unless ($used_labels{$label}); } # do all used labels exist ? foreach my $label (keys %used_labels) { unless ($labels{$label}) { &do_log ('err', "error : label $label is used but does not exist"); return undef; } } # are all variables used ? foreach my $var (keys %vars) { &do_log ('notice', "warning : var $var exists but is not used") unless ($used_vars{$var}); } # do all used variables exist ? foreach my $var (keys %used_vars) { unless ($vars{$var}) { &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...) ## just in case... chomp $line; &do_log('debug2', 'chk_line(%s, %s)', $line, $Rhash->{'nature'}); $Rhash->{'nature'} = undef; # empty line if (! $line) { $Rhash->{'nature'} = 'empty line'; return 1; } # comment if ($line =~ /^\s*\#.*/) { $Rhash->{'nature'} = 'comment'; return 1; } # title if ($line =~ /^\s*title\...\s*(.*)\s*/i) { $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 ) { my $command = lc ($1); my @args = split (/,/, $2); foreach (@args) { s/\s//g;} unless ($commands{$command}) { $Rhash->{'nature'} = 'error'; $Rhash->{'error'} = "unknown command $command"; 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); unless ( $asgn_commands{$hash2{'command'}} ) { $Rhash->{'nature'} = 'error'; $Rhash->{'error'} = "non valid assignment $2"; 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]; &do_log('debug2', 'chk_cmd(%s, %d, %s)', $cmd, $lnb, join(',',@{$Rargs})); if (defined $commands{$cmd}) { 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"); return undef; } $Rused_labels->{$args[1]} = 1 if ($cmd eq 'next' && ($args[1])); $Rused_vars->{$args[0]} = 1 if ($var_commands{$cmd}); } } return 1; } ### TASK EXECUTION SUBROUTINES ### sub execute { my $task = shift; my $task_file = $task->{'filepath'}; # task to execute my %result; # stores the result of the chk_line subroutine my %vars; # list of task vars my $lnb = 0; # line number &do_log('notice', 'Running task %s, line %d with vars %s)', $task_file, $lnb, join('/', %vars)); unless ( open (TASK, $task_file) ) { &do_log ('err', "error : can't read the task $task_file"); return undef; } my $label = $task->{'label'}; return undef if ($label eq 'ERROR'); &do_log ('debug2', "* execution of the task $task_file"); unless ($label eq '') { while ( ) { chomp; $lnb++; chk_line ($_, \%result); last if ($result{'label'} eq $label); } } # execution my $status; while ( ) { chomp; $lnb++; unless ( chk_line ($_, \%result) ) { &do_log ('err', "error : $result{'error'}"); return undef; } # processing of the assignments if ($result{'nature'} eq 'assignment') { $status = $vars{$result{'var'}} = &cmd_process ($result{'command'}, $result{'Rarguments'}, $task, \%vars, $lnb); last unless defined($status); } # processing of the commands if ($result{'nature'} eq 'command') { $status = &cmd_process ($result{'command'}, $result{'Rarguments'}, $task, \%vars, $lnb); last unless (defined($status) && $status >= 0); } } close (TASK); 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; } unless ($status >= 0) { &do_log('notice', 'The task %s is now useless. Removing it.', $task_file); unless (unlink($task_file)) { &do_log('err', 'Unable to remove task file %s : %s', $task_file, $!); return undef; } } return 1; } sub cmd_process { my $command = $_[0]; # command name my $Rarguments = $_[1]; # command arguments my $task = $_[2]; # task my $Rvars = $_[3]; # variable list of the task my $lnb = $_[4]; # line number my $task_file = $task->{'filepath'}; &do_log('debug2', 'cmd_process(%s, %s, %d)', $command, $task_file, $lnb); # building of %context my %context = ('line_number' => $lnb); &do_log('debug2','Current task : %s', join(':',%$task)); # regular commands 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'); return purge_logs_table ($task, \%context) if ($command eq 'purge_logs_table'); return purge_session_table ($task, \%context) if ($command eq 'purge_session_table'); return purge_tables ($task, \%context) if ($command eq 'purge_tables'); return purge_one_time_ticket_table ($task, \%context) if ($command eq 'purge_one_time_ticket_table'); 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'); # commands which use a variable return send_msg ($task, $Rarguments, $Rvars, \%context) if ($command eq 'send_msg'); return rm_file ($task, $Rarguments, $Rvars, \%context) if ($command eq 'rm_file'); # commands which return a variable return select_subs ($task, $Rarguments, \%context) if ($command eq 'select_subs'); return chk_cert_expiration ($task, $Rarguments, \%context) if ($command eq 'chk_cert_expiration'); # commands which return and use a variable return delete_subs_cmd ($task, $Rarguments, $Rvars, \%context) if ($command eq 'delete_subs'); } ### command subroutines ### # remove files whose name is given in the key 'file' of the hash sub rm_file { my ($task, $Rarguments,$Rvars, $context) = @_; 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)) { error ($task->{'filepath'}, "error in rm_file command : unable to remove $file"); return undef; } } return 1; } sub stop { my ($task, $context) = @_; my $task_file = $spool_task.'/'.$task->{'filename'}; &do_log ('notice', "$context->{'line_number'} : stop $task_file"); unlink ($task_file) ? &do_log ('notice', "--> $task_file deleted") : error ($task_file, "error in stop command : unable to delete task file"); return 0; } sub send_msg { my ($task, $Rarguments, $Rvars, $context) = @_; my @tab = @{$Rarguments}; my $template = $tab[1]; my $var = $tab[0]; &do_log ('notice', "line $context->{'line_number'} : send_msg (@{$Rarguments})"); if ($task->{'object'} eq '_global') { foreach my $email (keys %{$Rvars->{$var}}) { &do_log ('notice', "--> message sent to $email"); if (!$log) { unless (&List::send_global_file ($template, $email, ,'',$Rvars->{$var}{$email}) ) { &do_log ('notice', "Unable to send template $template to $email"); } } } } else { my $list = $task->{'list_object'}; foreach my $email (keys %{$Rvars->{$var}}) { &do_log ('notice', "--> message sent to $email"); if (!$log) { unless ($list->send_file ($template, $email, $list->{'domain'}, $Rvars->{$var}{$email})) { &do_log ('notice', "Unable to send template $template to $email"); } } } } return 1; } sub next_cmd { my ($task, $Rarguments, $context) = @_; my @tab = @{$Rarguments}; my $date = &tools::epoch_conv ($tab[0], $task->{'date'}); # conversion of the date argument into epoch format my $label = $tab[1]; &do_log ('notice', "line $context->{'line_number'} of $task->{'model'} : next ($date, $label)"); my $listname = $task->{'object'}; my $model = $task->{'model'}; my $filename = $task->{'filepath'}; ## Determine type my ($type, $model_choice); my %data = ('creation_date' => $task->{'date'}, 'execution_date' => 'execution_date'); if ($listname eq '_global') { $type = '_global'; foreach my $key (keys %global_models) { if ($global_models{$key} eq $model) { $model_choice = $Conf{$key}; last; } } }else { $type = 'list'; my $list = $task->{'list_object'}; $data{'list'}{'name'} = $list->{'name'}; $data{'list'}{'robot'} = $list->{'domain'}; if ( $model eq 'sync_include') { $data{'list'}{'ttl'} = $list->{'admin'}{'ttl'}; $model_choice = 'ttl'; }else { unless (defined $list->{'admin'}{"$model\_task"}) { error ($filename, "List $list->{'name'} no more require $model task"); return undef; } $model_choice = $list->{'admin'}{"$model\_task"}{'name'}; } } unless (create ($date, $tab[1], $model, $model_choice, \%data)) { error ($filename, "error in create command : creation subroutine failure"); return undef; } # my $new_task = "$date.$label.$name[2].$name[3]"; my $human_date = &tools::adate ($date); # my $new_task_file = "$spool_task/$new_task"; # unless (rename ($filename, $new_task_file)) { # error ($filename, "error in next command : unable to rename task file into $new_task"); # return undef; # } unless (unlink ($filename)) { error ($filename, "error in next command : unable to remove task file $filename"); return undef; } &do_log ('notice', "--> new task $model ($human_date)"); return 0; } sub select_subs { my ($task, $Rarguments, $context) = @_; my @tab = @{$Rarguments}; my $condition = $tab[0]; &do_log ('debug2', "line $context->{'line_number'} : select_subs ($condition)"); $condition =~ /(\w+)\(([^\)]*)\)/; if ($2) { # conversion of the date argument into epoch format my $date = &tools::epoch_conv ($2, $task->{'date'}); $condition = "$1($date)"; } my @users; # the subscribers of the list my %selection; # hash of subscribers who match the condition my $list = $task->{'list_object'}; for ( my $user = $list->get_first_user(); $user; $user = $list->get_next_user() ) { push (@users, $user); } # parameter of subroutine Scenario::verify my $verify_context = {'sender' => 'nobody', 'email' => 'nobody', 'remote_host' => 'unknown_host', 'listname' => $task->{'object'}}; 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+)\)/ ); if (&Scenario::verify ($verify_context, $new_condition) == 1) { $selection{$user->{'email'}} = undef; &do_log ('notice', "--> user $user->{'email'} has been selected"); } } return \%selection; } sub delete_subs_cmd { my ($task, $Rarguments, $Rvars, $context) = @_; my @tab = @{$Rarguments}; my $var = $tab[0]; &do_log ('notice', "line $context->{'line_number'} : delete_subs ($var)"); my $list = $task->{'list_object'}; my %selection; # hash of subscriber emails who are successfully deleted foreach my $email (keys %{$Rvars->{$var}}) { &do_log ('notice', "email : $email"); my $result = $list->check_list_authz('del', 'smime', {'sender' => $Conf{'listmaster'}, 'email' => $email, }); my $action; $action = $result->{'action'} if (ref($result) eq 'HASH'); if ($action =~ /reject/i) { error ($task->{'filepath'}, "error in delete_subs command : deletion of $email not allowed"); } else { my $u = $list->delete_user ($email) if (!$log); &do_log ('notice', "--> $email deleted"); $selection{$email} = {}; } } return \%selection; } sub create_cmd { my ($task, $Rarguments, $context) = @_; 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 ($arg =~ /$subarg_regexp/) { $type = $1; $object = $3; } else { error ($task->{'filepath'}, "error in create command : don't know how to create $arg"); return undef; } # building of the data hash necessary to the create subroutine my %data = ('creation_date' => $task->{'date'}, 'execution_date' => 'execution_date'); if ($type eq 'list') { my $list = new List ($object); $data{'list'}{'name'} = $list->{'name'}; } $type = '_global'; unless (create ($task->{'date'}, '', $model, $model_choice, \%data)) { error ($task->{'filepath'}, "error in create command : creation subroutine failure"); return undef; } return 1; } sub exec_cmd { my ($task, $Rarguments, $context) = @_; my @tab = @{$Rarguments}; my $file = $tab[0]; do_log ('notice', "line $context->{'line_number'} : exec ($file)"); system ($file); return 1; } sub purge_logs_table { # If a log is older then $list->get_latest_distribution_date()-$delai expire the log my ($task, $Rarguments, $context) = @_; my $date; my $execution_date = $task->{'date'}; do_log('debug2','purge_logs_table()'); unless(&Log::db_log_del()) { &do_log('err','purge_logs_table(): Failed to delete logs'); return undef; } &do_log('notice','purge_logs_table(): logs purged'); return 1; } ## remove sessions from session_table if older than $Conf{'session_table_ttl'} sub purge_session_table { do_log('info','task_manager::purge_session_table()'); my $removed = &SympaSession::purge_old_sessions('*'); unless(defined $removed) { &do_log('err','&SympaSession::purge_old_sessions(): Failed to remove old sessions'); return undef; } &do_log('notice','purge_session_table(): %s row removed in session_table',$removed); return 1; } ## remove messages from bulkspool table when no more packet have any pointer to this message sub purge_tables { do_log('info','task_manager::purge_tables()'); my $removed = &Bulk::purge_bulkspool(); unless(defined $removed) { &do_log('err','Failed to purge bulkspool'); return undef; } &do_log('notice','%s rows removed in bulkspool_table',$removed); return 1; } ## remove one time ticket table if older than $Conf{'one_time_ticket_table_ttl'} sub purge_one_time_ticket_table { do_log('info','task_manager::purge_one_time_ticket_table()'); my $removed = &SympaSession::purge_old_tickets('*'); unless(defined $removed) { &do_log('err','&SympaSession::purge_old_tickets(): Failed to remove old tickets'); return undef; } &do_log('notice','purge_one_time_ticket_table(): %s row removed in one_time_ticket_table',$removed); return 1; } sub purge_user_table { my ($task, $Rarguments, $context) = @_; do_log('debug2','purge_user_table()'); ## Load user_table entries my @users = &List::get_all_user_db(); ## Load known subscribers/owners/editors my %known_people; ## Listmasters foreach my $l (@{$Conf{'listmasters'}}) { $known_people{$l} = 1; } foreach my $r (keys %{$Conf{'robots'}}) { ## To prevent information loss by misconfiguration, we won't use ## list_table cache! my $all_lists = &List::get_lists($r, { 'use_files' => 1 }); foreach my $list (@$all_lists){ ## Owners my $owners = $list->get_owners(); if (defined $owners) { foreach my $o (@{$owners}) { $known_people{$o->{'email'}} = 1; } } ## Editors my $editors = $list->get_editors(); if (defined $editors) { foreach my $e (@{$editors}) { $known_people{$e->{'email'}} = 1; } } ## Subscribers for (my $user = $list->get_first_user(); $user; $user = $list->get_next_user()) { $known_people{$user->{'email'}} = 1; } } } ## Look for unused entries my @purged_users; foreach (@users) { unless ($known_people{$_}) { &do_log('debug2','User to purge: %s', $_); push @purged_users, $_; } } unless ($#purged_users < 0) { unless (&List::delete_user_db(@purged_users)) { &do_log('err', 'purge_user_table error: Failed to delete users'); return undef; } } return $#purged_users + 1; } ## Subroutine which remove bounced message of no-more known users sub purge_orphan_bounces { my($task, $context) = @_; do_log('info','purge_orphan_bounces()'); ## Hash {'listname' => 'bounced address' => 1} my %bounced_users; my $all_lists; unless ($all_lists = &List::get_lists('*')) { &do_log('notice','No list available'); return 1; } foreach my $list (@$all_lists) { my $listname = $list->{'name'}; ## first time: loading DB entries into %bounced_users for (my $user_ref = $list->get_first_bouncing_user(); $user_ref; $user_ref = $list->get_next_bouncing_user()){ my $user_id = $user_ref->{'email'}; $bounced_users{$listname}{$user_id} = 1; } my $bounce_dir = $list->get_bounce_dir(); unless (-d $bounce_dir) { &do_log('notice', 'No bouncing subscribers in list %s', $listname); next; } ## then reading Bounce directory & compare with %bounced_users unless (opendir(BOUNCE,$bounce_dir)) { &do_log('err','Error while opening bounce directory %s',$bounce_dir); return undef; } ## Finally removing orphan files foreach my $bounce (readdir(BOUNCE)) { if ($bounce =~ /\@/){ unless (defined($bounced_users{$listname}{$bounce})) { &do_log('info','removing orphan Bounce for user %s in list %s',$bounce,$listname); unless (unlink($bounce_dir.'/'.$bounce)) { &do_log('err','Error while removing file %s/%s', $bounce_dir, $bounce); } } } } closedir BOUNCE; } return 1; } sub expire_bounce { # If a bounce is older then $list->get_latest_distribution_date()-$delai expire the bounce # Is this variable my be set in to task modele ? my ($task, $Rarguments, $context) = @_; my $execution_date = $task->{'date'}; my @tab = @{$Rarguments}; my $delay = $tab[0]; do_log('debug2','expire_bounce(%d)',$delay); my $all_lists = &List::get_lists('*'); foreach my $list (@$all_lists ) { my $listname = $list->{'name'}; # the reference date is the date until which we expire bounces in second # the latest_distribution_date is the date of last distribution #days from 01 01 1970 unless ($list->get_latest_distribution_date()) { do_log('debug2','bounce expiration : skipping list %s because could not get latest distribution date',$listname); next; } my $refdate = (($list->get_latest_distribution_date() - $delay) * 3600 * 24); for (my $u = $list->get_first_bouncing_user(); $u ; $u = $list->get_next_bouncing_user()) { $u->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/; $u->{'last_bounce'} = $2; if ($u->{'last_bounce'} < $refdate) { my $email = $u->{'email'}; unless ( $list->is_user($email) ) { do_log('info','expire_bounce: %s not subscribed', $email); next; } unless( $list->update_user($email, {'bounce' => 'NULL'},{'bounce_address' => 'NULL'})) { do_log('info','expire_bounce: failed update database for %s', $email); next; } my $escaped_email = &tools::escape_chars($email); my $bounce_dir = $list->get_bounce_dir(); unless (unlink $bounce_dir.'/'.$escaped_email) { &do_log('info','expire_bounce: failed deleting %s', $bounce_dir.'/'.$escaped_email); next; } do_log('info','expire bounces for subscriber %s of list %s (last distribution %s, last bounce %s )', $email,$listname, &POSIX::strftime("%d %b %Y", localtime($list->get_latest_distribution_date() * 3600 * 24)), &POSIX::strftime("%d %b %Y", localtime($u->{'last_bounce'}))); } } } return 1; } sub chk_cert_expiration { my ($task, $Rarguments, $context) = @_; my $execution_date = $task->{'date'}; my @tab = @{$Rarguments}; my $template = $tab[0]; my $limit = &tools::duration_conv ($tab[1], $execution_date); &do_log ('notice', "line $context->{'line_number'} : chk_cert_expiration (@{$Rarguments})"); ## building of certificate list unless (opendir(DIR, $cert_dir)) { error ($task->{'filepath'}, "error in chk_cert_expiration command : can't open dir $cert_dir"); return undef; } my @certificates = grep !/^(\.\.?)|(.+expired)$/, readdir DIR; closedir (DIR); foreach (@certificates) { my $soon_expired_file = $_.'.soon_expired'; # an empty .soon_expired file is created when a user is warned that his certificate is soon expired # recovery of the certificate expiration date open (ENDDATE, "openssl x509 -enddate -in $cert_dir/$_ -noout |"); my $date = ; # expiration date close (ENDDATE); chomp ($date); unless ($date) { &do_log ('err', "error in chk_cert_expiration command : can't get expiration date for $_ by using the x509 openssl command"); next; } $date =~ /notAfter=(\w+)\s*(\d+)\s[\d\:]+\s(\d+).+/; my @date = (0, 0, 0, $2, $months{$1}, $3 - 1900); $date =~ s/notAfter=//; my $expiration_date = timegm (@date); # epoch expiration date my $rep = &tools::adate ($expiration_date); # no near expiration nor expiration processing if ($expiration_date > $limit) { # deletion of unuseful soon_expired file if it is existing if (-e $soon_expired_file) { unlink ($soon_expired_file) || &do_log ('err', "error : can't delete $soon_expired_file"); } next; } # expired certificate processing if ($expiration_date < $execution_date) { &do_log ('notice', "--> $_ certificate expired ($date), certificate file deleted"); if (!$log) { unlink ("$cert_dir/$_") || &do_log ('notice', "error : can't delete certificate file $_"); } if (-e $soon_expired_file) { unlink ("$cert_dir/$soon_expired_file") || &do_log ('err', "error : can't delete $soon_expired_file"); } next; } # soon expired certificate processing if ( ($expiration_date > $execution_date) && ($expiration_date < $limit) && !(-e $soon_expired_file) ) { unless (open (FILE, ">$cert_dir/$soon_expired_file")) { &do_log ('err', "error in chk_cert_expiration : can't create $soon_expired_file"); next; } else {close (FILE);} my %tpl_context; # datas necessary to the template open (ID, "openssl x509 -subject -in $cert_dir/$_ -noout |"); my $id = ; # expiration date close (ID); chomp ($id); unless ($id) { &do_log ('err', "error in chk_cert_expiration command : can't get expiration date for $_ by using the x509 openssl command"); next; } $id =~ s/subject= //; do_log ('notice', "id : $id"); $tpl_context{'expiration_date'} = &tools::adate ($expiration_date); $tpl_context{'certificate_id'} = $id; $tpl_context{'auto_submitted'} = 'auto-generated'; if (!$log) { unless (&List::send_global_file ($template, $_,'', \%tpl_context)) { &do_log ('notice', "Unable to send template $template to $_"); } } &do_log ('notice', "--> $_ certificate soon expired ($date), user warned"); } } return 1; } ## attention, j'ai n'ai pas pu comprendre les retours d'erreurs des commandes wget donc pas de verif sur le bon fonctionnement de cette commande sub update_crl { my ($task, $Rarguments, $context) = @_; my @tab = @{$Rarguments}; my $limit = &tools::epoch_conv ($tab[1], $task->{'date'}); my $CA_file = "$Conf{'home'}/$tab[0]"; # file where CA urls are stored ; &do_log ('notice', "line $context->{'line_number'} : update_crl (@tab)"); # building of CA list my @CA; unless (open (FILE, $CA_file)) { error ($task->{'filepath'}, "error in update_crl command : can't open $CA_file file"); return undef; } while () { chomp; push (@CA, $_); } close (FILE); # updating of crl files my $crl_dir = "$Conf{'crl_dir'}"; unless (-d $Conf{'crl_dir'}) { if ( mkdir ($Conf{'crl_dir'}, 0775)) { do_log('notice', "creating spool $Conf{'crl_dir'}"); }else{ do_log('err', "Unable to create CRLs directory $Conf{'crl_dir'}"); return undef; } } foreach my $url (@CA) { my $crl_file = &tools::escape_chars ($url); # convert an URL into a file name my $file = "$crl_dir/$crl_file"; ## create $file if it doesn't exist unless (-e $file) { my $cmd = "wget -O \'$file\' \'$url\'"; open CMD, "| $cmd"; close CMD; } # recovery of the crl expiration date open (ID, "openssl crl -nextupdate -in \'$file\' -noout -inform der|"); my $date = ; # expiration date close (ID); chomp ($date); unless ($date) { &do_log ('err', "error in update_crl command : can't get expiration date for $file crl file by using the crl openssl command"); next; } $date =~ /nextUpdate=(\w+)\s*(\d+)\s(\d\d)\:(\d\d)\:\d\d\s(\d+).+/; my @date = (0, $4, $3 - 1, $2, $months{$1}, $5 - 1900); my $expiration_date = timegm (@date); # epoch expiration date my $rep = &tools::adate ($expiration_date); ## check if the crl is soon expired or expired #my $file_date = $task->{'date'} - (-M $file) * 24 * 60 * 60; # last modification date my $condition = "newer($limit, $expiration_date)"; my $verify_context; $verify_context->{'sender'} = 'nobody'; if (&Scenario::verify ($verify_context, $condition) == 1) { unlink ($file); &do_log ('notice', "--> updating of the $file crl file"); my $cmd = "wget -O \'$file\' \'$url\'"; open CMD, "| $cmd"; close CMD; next; } } return 1; } ## Subroutine for bouncers evaluation: # give a score for each bouncing user sub eval_bouncers { ################# my ($task, $context) = @_; my $all_lists = &List::get_lists('*'); foreach my $list (@$all_lists) { my $listname = $list->{'name'}; my $list_traffic = {}; &do_log('info','eval_bouncers(%s)',$listname); ## Analizing file Msg-count and fill %$list_traffic unless (open(COUNT,$list->{'dir'}.'/msg_count')){ &do_log('debug','** Could not open msg_count FILE for list %s',$listname); next; } while () { if ( /^(\w+)\s+(\d+)/) { my ($a, $b) = ($1, $2); $list_traffic->{$a} = $b; } } close(COUNT); #for each bouncing user for (my $user_ref = $list->get_first_bouncing_user(); $user_ref; $user_ref = $list->get_next_bouncing_user()){ my $score = &get_score($user_ref,$list_traffic) || 0; ## copying score into DataBase unless ($list->update_user($user_ref->{'email'},{'score' => $score }) ) { &do_log('err','Task eval_bouncers :Error while updating DB for user %s',$user_ref->{'email'}); next; } } } return 1; } sub none { 1; } ## Routine for automatic bouncing users management ## sub process_bouncers { ################### my ($task,$context) = @_; &do_log('info','Processing automatic actions on bouncing users'); ########################################################################### # This sub apply a treatment foreach category of bouncing-users # # The relation between possible actions and correponding subroutines # is indicated by the following hash (%actions). # It's possible to add actions by completing this hash and the one in list # config (file List.pm, in sections "bouncers_levelX"). Then you must write # the code for your action: # The action subroutines have two parameter : # - the name of the current list # - a reference on users email list: # Look at the "remove_bouncers" sub in List.pm for an example ########################################################################### ## possible actions my %actions = ('remove_bouncers' => \&List::remove_bouncers, 'notify_bouncers' => \&List::notify_bouncers, 'none' => \&none ); my $all_lists = &List::get_lists(); foreach my $list (@$all_lists) { my $listname = $list->{'name'}; my @bouncers; # @bouncers = ( ['email1', 'email2', 'email3',....,], There is one line # ['email1', 'email2', 'email3',....,], foreach bounce # ['email1', 'email2', 'email3',....,],) level. next unless ($list); my $max_level; for (my $level = 1;defined ($list->{'admin'}{'bouncers_level'.$level});$level++) { $max_level = $level; } ## first, bouncing email are sorted in @bouncer for (my $user_ref = $list->get_first_bouncing_user(); $user_ref; $user_ref = $list->get_next_bouncing_user()) { ## Skip included users (cannot be removed) next if ($user_ref->{'is_included'}); for ( my $level = $max_level;($level >= 1) ;$level--) { if ($user_ref->{'bounce_score'} >= $list->{'admin'}{'bouncers_level'.$level}{'rate'}){ push(@{$bouncers[$level]}, $user_ref->{'email'}); $level = ($level-$max_level); } } } ## then, calling action foreach level for ( my $level = $max_level;($level >= 1) ;$level--) { my $action = $list->{'admin'}{'bouncers_level'.$level}{'action'}; my $notification = $list->{'admin'}{'bouncers_level'.$level}{'notification'}; if (@{$bouncers[$level]}){ ## calling action subroutine with (list,email list) in parameter unless ($actions{$action}->($list,$bouncers[$level])){ &do_log('err','error while calling action sub for bouncing users in list %s',$listname); return undef; } ## calling notification subroutine with (list,action, email list) in parameter my $param = {'listname' => $listname, 'action' => $action, 'user_list' => \@{$bouncers[$level]}, 'total' => $#{$bouncers[$level]} + 1}; if ($notification eq 'listmaster'){ unless(&List::send_notify_to_listmaster('automatic_bounce_management',$list->{'domain'},$param)){ &do_log('err','error while notifying listmaster'); } }elsif ($notification eq 'owner'){ unless ($list->send_notify_to_owner('automatic_bounce_management',$param)){ &do_log('err','error while notifying owner'); } } } } } return 1; } sub get_score { my $user_ref = shift; my $list_traffic = shift; &do_log('debug','Get_score(%s) ',$user_ref->{'email'}); my $min_period = $Conf{'minimum_bouncing_period'}; my $min_msg_count = $Conf{'minimum_bouncing_count'}; # Analizing bounce_subscriber_field and keep usefull infos for notation $user_ref->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/; my $BO_period = int($1 / 86400) - $Conf{'bounce_delay'}; my $EO_period = int($2 / 86400) - $Conf{'bounce_delay'}; my $bounce_count = $3; my $bounce_type = $4; my $msg_count = 0; my $min_day = $EO_period; unless ($bounce_count >= $min_msg_count){ #not enough messages distributed to keep score &do_log('debug','Not enough messages for evaluation of user %s',$user_ref->{'email'}); return undef ; } unless (($EO_period - $BO_period) >= $min_period){ #too short bounce period to keep score &do_log('debug','Too short period for evaluate %s',$user_ref->{'email'}); return undef; } # calculate number of messages distributed in list while user was bouncing foreach my $date (sort {$b <=> $a} keys (%$list_traffic)) { if (($date >= $BO_period) && ($date <= $EO_period)) { $min_day = $date; $msg_count += $list_traffic->{$date}; } } #Adjust bounce_count when msg_count file is too recent, compared to the bouncing period my $tmp_bounce_count = $bounce_count; unless ($EO_period == $BO_period) { my $ratio = (($EO_period - $min_day) / ($EO_period - $BO_period)); $tmp_bounce_count *= $ratio; } ## Regularity rate tells how much user has bounced compared to list traffic $msg_count ||= 1; ## Prevents "Illegal division by zero" error my $regularity_rate = $tmp_bounce_count / $msg_count; ## type rate depends on bounce type (5 = permanent ; 4 =tewmporary) my $type_rate = 1; $bounce_type =~ /(\d)\.(\d)\.(\d)/; if ($1 == 4) { # if its a temporary Error: score = score/2 $type_rate = .5; } my $note = $bounce_count * $regularity_rate * $type_rate; ## Note should be an integer $note = int($note + 0.5); # $note = 100 if ($note > 100); # shift between message ditrib & bounces => note > 100 return $note; } ### MISCELLANEOUS SUBROUTINES ### ## when we catch SIGTERM, just change the value of the loop variable. sub sigterm { $end = 1; } ## sort task name by their epoch date sub epoch_sort { $a =~ /(\d+)\..+/; my $date1 = $1; $b =~ /(\d+)\..+/; my $date2 = $1; $date1 <=> $date2; } ## change the label of a task file sub change_label { my $task_file = $_[0]; my $new_label = $_[1]; my $new_task_file = $task_file; $new_task_file =~ s/(.+\.)(\w*)(\.\w+\.\w+$)/$1$new_label$3/; if (rename ($task_file, $new_task_file)) { &do_log ('notice', "$task_file renamed in $new_task_file"); } else { &do_log ('err', "error ; can't rename $task_file in $new_task_file"); } } ## send a error message to list-master, log it, and change the label task into 'ERROR' sub error { my $task_file = $_[0]; my $message = $_[1]; my @param; $param[0] = "An error has occurred during the execution of the task $task_file : $message"; do_log ('err', "$message"); change_label ($task_file, 'ERROR') unless ($task_file eq ''); unless (&List::send_notify_to_listmaster ('error in task', $Conf{'domain'}, \@param)) { &do_log('notice','error while notifying listmaster about "error_in_task"'); } } sub sync_include { my ($task, $context) = @_; &do_log('debug2', 'sync_include(%s)', $task->{'id'}); my $list = $task->{'list_object'}; $list->sync_include(); $list->sync_include_admin() if ((defined $list->{'admin'}{'editor_include'} && $#{$list->{'admin'}{'editor_include'}}>-1) || (defined $list->{'admin'}{'owner_include'} && $#{$list->{'admin'}{'owner_include'}}>-1)); if (! $list->has_include_data_sources() && (!$list->{'last_sync'} || ($list->{'last_sync'} > (stat("$list->{'dir'}/config"))[9]))) { &do_log('debug', "List $list->{'name'} no more require sync_include task"); return -1; } }