#! --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;
}
}