Filename | /usr/local/libexec/sympa/Sympa/Spindle/ProcessTask.pm |
Statements | Executed 920 statements in 1.76ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
230 | 2 | 1 | 1.90ms | 4.24ms | _init | Sympa::Spindle::ProcessTask::
2 | 2 | 1 | 2µs | 2µs | _distaff (xsub) | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@173 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@26 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@27 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@28 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@30 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@33 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@34 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@35 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@36 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@37 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@38 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@39 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@40 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@41 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@42 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@43 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@44 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@46 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | BEGIN@50 | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | __ANON__[:1145] | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _clean_spool | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _cmd_process | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _db_log_del | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _error | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _execute | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _get_score | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _notify_bouncers | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _remove_bouncers | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | _twist | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_create | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_delete_subs | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_eval_bouncers | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_exec | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_expire_bounce | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_next | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_process_bouncers | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_logs_table | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_one_time_ticket_table | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_orphan_bounces | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_session_table | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_spools | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_tables | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_purge_user_table | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_rm_file | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_select_subs | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_send_msg | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_stop | Sympa::Spindle::ProcessTask::
0 | 0 | 0 | 0s | 0s | do_sync_include | Sympa::Spindle::ProcessTask::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # -*- indent-tabs-mode: nil; -*- | ||||
2 | # vim:ft=perl:et:sw=4 | ||||
3 | # $Id$ | ||||
4 | |||||
5 | # Sympa - SYsteme de Multi-Postage Automatique | ||||
6 | # | ||||
7 | # Copyright 2018, 2019, 2020 The Sympa Community. See the AUTHORS.md | ||||
8 | # file at the top-level directory of this distribution and at | ||||
9 | # <https://github.com/sympa-community/sympa.git>. | ||||
10 | # | ||||
11 | # This program is free software; you can redistribute it and/or modify | ||||
12 | # it under the terms of the GNU General Public License as published by | ||||
13 | # the Free Software Foundation; either version 2 of the License, or | ||||
14 | # (at your option) any later version. | ||||
15 | # | ||||
16 | # This program is distributed in the hope that it will be useful, | ||||
17 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | ||||
18 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||||
19 | # GNU General Public License for more details. | ||||
20 | # | ||||
21 | # You should have received a copy of the GNU General Public License | ||||
22 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | ||||
23 | |||||
24 | package Sympa::Spindle::ProcessTask; | ||||
25 | |||||
26 | use strict; | ||||
27 | use warnings; | ||||
28 | use English qw(-no_match_vars); | ||||
29 | |||||
30 | use Sympa; | ||||
31 | use Conf; | ||||
32 | use Sympa::DatabaseManager; | ||||
33 | use Sympa::List; | ||||
34 | use Sympa::Log; | ||||
35 | use Sympa::Scenario; | ||||
36 | use Sympa::Spool; | ||||
37 | use Sympa::Spool::Listmaster; | ||||
38 | use Sympa::Task; | ||||
39 | use Sympa::Ticket; | ||||
40 | use Sympa::Tools::File; | ||||
41 | use Sympa::Tools::Time; | ||||
42 | use Sympa::Tools::Text; | ||||
43 | use Sympa::Tracking; | ||||
44 | use Sympa::User; | ||||
45 | |||||
46 | use base qw(Sympa::Spindle); | ||||
47 | |||||
48 | my $log = Sympa::Log->instance; | ||||
49 | |||||
50 | use constant _distaff => 'Sympa::Spool::Task'; | ||||
51 | |||||
52 | # spent 4.24ms (1.90+2.34) within Sympa::Spindle::ProcessTask::_init which was called 230 times, avg 18µs/call:
# 229 times (1.90ms+2.34ms) by Sympa::Spindle::spin at line 77 of /usr/local/libexec/sympa/Sympa/Spindle.pm, avg 19µs/call
# once (6µs+0s) by Sympa::Spindle::new at line 59 of /usr/local/libexec/sympa/Sympa/Spindle.pm | ||||
53 | 230 | 69µs | my $self = shift; | ||
54 | 230 | 70µs | my $state = shift; | ||
55 | |||||
56 | 230 | 1.17ms | 458 | 2.34ms | if ($state == 1) { # spent 1.81ms making 229 calls to Sympa::Spool::Listmaster::flush, avg 8µs/call
# spent 525µs making 229 calls to Class::Singleton::instance, avg 2µs/call |
57 | # Process grouped notifications. | ||||
58 | Sympa::Spool::Listmaster->instance->flush; | ||||
59 | } | ||||
60 | |||||
61 | 230 | 446µs | 1; | ||
62 | } | ||||
63 | |||||
64 | sub _twist { | ||||
65 | my $self = shift; | ||||
66 | my $task = shift; | ||||
67 | |||||
68 | my $that = $task->{context}; | ||||
69 | if (ref $that eq 'Sympa::List' and $that->{'admin'}{'status'} ne 'open') { | ||||
70 | # Skip closed lists: Remove task. | ||||
71 | return 1; | ||||
72 | } | ||||
73 | |||||
74 | return _execute($self, $task); | ||||
75 | } | ||||
76 | |||||
77 | ### TASK EXECUTION SUBROUTINES ### | ||||
78 | |||||
79 | my %comm = ( | ||||
80 | stop => 'do_stop', | ||||
81 | next => 'do_next', | ||||
82 | create => 'do_create', | ||||
83 | exec => 'do_exec', | ||||
84 | expire_bounce => 'do_expire_bounce', | ||||
85 | purge_user_table => 'do_purge_user_table', | ||||
86 | purge_logs_table => 'do_purge_logs_table', | ||||
87 | purge_session_table => 'do_purge_session_table', | ||||
88 | purge_spools => 'do_purge_spools', | ||||
89 | purge_tables => 'do_purge_tables', | ||||
90 | purge_one_time_ticket_table => 'do_purge_one_time_ticket_table', | ||||
91 | sync_include => 'do_sync_include', | ||||
92 | purge_orphan_bounces => 'do_purge_orphan_bounces', | ||||
93 | eval_bouncers => 'do_eval_bouncers', | ||||
94 | process_bouncers => 'do_process_bouncers', | ||||
95 | |||||
96 | # commands which use a variable | ||||
97 | send_msg => 'do_send_msg', | ||||
98 | rm_file => 'do_rm_file', | ||||
99 | |||||
100 | # commands which return a variable | ||||
101 | select_subs => 'do_select_subs', | ||||
102 | |||||
103 | # commands which return and use a variable | ||||
104 | delete_subs => 'do_delete_subs', | ||||
105 | ); | ||||
106 | |||||
107 | # Old name: execute() in task_manager.pl. | ||||
108 | sub _execute { | ||||
109 | my $self = shift; | ||||
110 | my $task = shift; | ||||
111 | |||||
112 | $log->syslog('notice', 'Running task %s', $task); | ||||
113 | |||||
114 | die 'bug in logic. Ask developer' unless $task->{_parsed}; | ||||
115 | |||||
116 | my %vars; # list of task vars | ||||
117 | my @lines = $task->lines; | ||||
118 | |||||
119 | my $label = $task->{label}; | ||||
120 | return undef if $label eq 'ERROR'; | ||||
121 | |||||
122 | if (defined $label and length $label) { | ||||
123 | my $line; | ||||
124 | while ($line = shift @lines) { | ||||
125 | next unless defined $line->{label}; | ||||
126 | last if $line->{label} eq $label; | ||||
127 | } | ||||
128 | } | ||||
129 | |||||
130 | # Execution. | ||||
131 | my $status; | ||||
132 | foreach my $line (@lines) { | ||||
133 | if ($line->{nature} eq 'assignment') { | ||||
134 | # Processing of the assignments. | ||||
135 | $status = $vars{$line->{var}} = | ||||
136 | _cmd_process($self, $task, $line, \%vars); | ||||
137 | last if not defined $status; | ||||
138 | } elsif ($line->{nature} eq 'command') { | ||||
139 | # Processing of the commands. | ||||
140 | $status = _cmd_process($self, $task, $line, \%vars); | ||||
141 | last if not defined $status or $status < 0; | ||||
142 | } | ||||
143 | } | ||||
144 | |||||
145 | if (not defined $status) { | ||||
146 | $log->syslog('err', 'Error while processing task %s', $task); | ||||
147 | # Remove task. | ||||
148 | return undef; | ||||
149 | } elsif ($status < 0) { | ||||
150 | $log->syslog('notice', 'The task %s is now useless. Removing it', | ||||
151 | $task); | ||||
152 | # Remove task. | ||||
153 | return 1; | ||||
154 | } else { | ||||
155 | # Keep task. | ||||
156 | return 0; | ||||
157 | } | ||||
158 | } | ||||
159 | |||||
160 | # Old name: cmd_process() in task_manager.pl. | ||||
161 | sub _cmd_process { | ||||
162 | $log->syslog('debug2', '(%s, %s, %s, %s, %s, %s)', @_); | ||||
163 | my $self = shift; | ||||
164 | my $task = shift; | ||||
165 | my $line = shift; | ||||
166 | my $Rvars = shift; # variable list of the task | ||||
167 | |||||
168 | my $command = $line->{command}; # command name | ||||
169 | |||||
170 | unless (defined $comm{$command}) { | ||||
171 | return undef; | ||||
172 | } else { | ||||
173 | no strict 'refs'; | ||||
174 | return $comm{$command}->($self, $task, $line, $Rvars); | ||||
175 | } | ||||
176 | } | ||||
177 | |||||
178 | ### command subroutines ### | ||||
179 | |||||
180 | # remove files whose name is given in the key 'file' of the hash | ||||
181 | # Old name: rm_file() in task_manager.pl. | ||||
182 | sub do_rm_file { | ||||
183 | my $self = shift; | ||||
184 | my $task = shift; | ||||
185 | my $line = shift; | ||||
186 | my $Rvars = shift; | ||||
187 | |||||
188 | my @tab = @{$line->{Rarguments} || []}; | ||||
189 | my $var = $tab[0]; | ||||
190 | |||||
191 | foreach my $key (keys %{$Rvars->{$var}}) { | ||||
192 | my $file = $Rvars->{$var}{$key}{'file'}; | ||||
193 | next unless $file; | ||||
194 | unless (unlink $file) { | ||||
195 | _error($task, | ||||
196 | "error in rm_file command : unable to remove $file"); | ||||
197 | return undef; | ||||
198 | } | ||||
199 | } | ||||
200 | |||||
201 | return 1; | ||||
202 | } | ||||
203 | |||||
204 | # Old name: stop() in task_manager.pl. | ||||
205 | sub do_stop { | ||||
206 | my $self = shift; | ||||
207 | my $task = shift; | ||||
208 | my $line = shift; | ||||
209 | |||||
210 | $log->syslog('notice', '%s: stop %s', $line->{line}, $task); | ||||
211 | return -1; # Remove task. | ||||
212 | } | ||||
213 | |||||
214 | # Old name: send_msg() in task_manager.pl. | ||||
215 | sub do_send_msg { | ||||
216 | my $self = shift; | ||||
217 | my $task = shift; | ||||
218 | my $line = shift; | ||||
219 | my $Rvars = shift; | ||||
220 | |||||
221 | my @tab = @{$line->{Rarguments} || []}; | ||||
222 | my $template = $tab[1]; | ||||
223 | my $var = $tab[0]; | ||||
224 | |||||
225 | $log->syslog('notice', 'Line %s: send_msg (%s)', | ||||
226 | $line->{line}, join(',', @tab)); | ||||
227 | |||||
228 | foreach my $email (keys %{$Rvars->{$var}}) { | ||||
229 | $log->syslog('notice', '--> message sent to %s', $email); | ||||
230 | unless ( | ||||
231 | Sympa::send_file( | ||||
232 | $task->{context}, $template, | ||||
233 | $email, $Rvars->{$var}{$email} | ||||
234 | ) | ||||
235 | ) { | ||||
236 | $log->syslog('notice', 'Unable to send template %s to %s', | ||||
237 | $template, $email); | ||||
238 | } | ||||
239 | } | ||||
240 | |||||
241 | return 1; | ||||
242 | } | ||||
243 | |||||
244 | # Old name: next_cmd() in task_manager.pl. | ||||
245 | sub do_next { | ||||
246 | my $self = shift; | ||||
247 | my $task = shift; | ||||
248 | my $line = shift; | ||||
249 | |||||
250 | my @tab = @{$line->{Rarguments} || []}; | ||||
251 | # conversion of the date argument into epoch format | ||||
252 | my $date = Sympa::Tools::Time::epoch_conv($tab[0]); | ||||
253 | my $label = $tab[1]; | ||||
254 | |||||
255 | $log->syslog('notice', 'line %s of %s: next(%s, %s)', | ||||
256 | $line->{line}, $task->{model}, $date, $label); | ||||
257 | |||||
258 | my $new_task = Sympa::Task->new( | ||||
259 | context => $task->{context}, | ||||
260 | date => $date, | ||||
261 | label => $label, | ||||
262 | model => $task->{model}, | ||||
263 | ); | ||||
264 | unless ($new_task and $self->{distaff}->store($new_task)) { | ||||
265 | _error($task, | ||||
266 | "error in create command : creation subroutine failure"); | ||||
267 | return undef; | ||||
268 | } | ||||
269 | |||||
270 | $log->syslog('notice', '--> new task %s', $new_task); | ||||
271 | |||||
272 | return -1; # Remove older task. | ||||
273 | } | ||||
274 | |||||
275 | # Old name: select_subs() in task_manager.pl. | ||||
276 | sub do_select_subs { | ||||
277 | my $self = shift; | ||||
278 | my $task = shift; | ||||
279 | my $line = shift; | ||||
280 | |||||
281 | my @tab = @{$line->{Rarguments} || []}; | ||||
282 | my $condition = $tab[0]; | ||||
283 | $log->syslog('debug2', 'Line %s: select_subs (%s)', | ||||
284 | $line->{line}, $condition); | ||||
285 | |||||
286 | my ($func, $date); | ||||
287 | if ($condition =~ /(older|newer)[(]([^\)]*)[)]/) { | ||||
288 | ($func, $date) = ($1, $2); | ||||
289 | # Conversion of the date argument into epoch format. | ||||
290 | $date = Sympa::Tools::Time::epoch_conv($date); | ||||
291 | } else { | ||||
292 | $log->syslog('err', 'Illegal condition %s', $condition); | ||||
293 | return {}; | ||||
294 | } | ||||
295 | |||||
296 | my %selection; | ||||
297 | my $list = $task->{context}; | ||||
298 | unless (ref $list eq 'Sympa::List') { | ||||
299 | $log->syslog('err', 'No list'); | ||||
300 | return {}; | ||||
301 | } | ||||
302 | |||||
303 | for ( | ||||
304 | my $user = $list->get_first_list_member(); | ||||
305 | $user; | ||||
306 | $user = $list->get_next_list_member() | ||||
307 | ) { | ||||
308 | if ( $func eq 'newer' and $date < $user->{update_date} | ||||
309 | or $func eq 'older' and $user->{update_date} < $date) { | ||||
310 | $selection{$user->{'email'}} = undef; | ||||
311 | $log->syslog('info', '--> user %s has been selected', | ||||
312 | $user->{'email'}); | ||||
313 | } | ||||
314 | } | ||||
315 | |||||
316 | return \%selection; | ||||
317 | } | ||||
318 | |||||
319 | # Old name: delete_subs_cmd() in task_manager.pl. | ||||
320 | # Not yet used. | ||||
321 | sub do_delete_subs { | ||||
322 | my $self = shift; | ||||
323 | my $task = shift; | ||||
324 | my $line = shift; | ||||
325 | my $Rvars = shift; | ||||
326 | |||||
327 | my @tab = @{$line->{Rarguments} || []}; | ||||
328 | my $var = $tab[0]; | ||||
329 | |||||
330 | $log->syslog('notice', 'Line %s: delete_subs (%s)', $line->{line}, $var); | ||||
331 | |||||
332 | my $list = $task->{context}; | ||||
333 | unless (ref $list eq 'Sympa::List') { | ||||
334 | $log->syslog('err', 'No list'); | ||||
335 | return {}; | ||||
336 | } | ||||
337 | |||||
338 | my %selection; # hash of subscriber emails who are successfully deleted | ||||
339 | |||||
340 | foreach my $email (keys %{$Rvars->{$var}}) { | ||||
341 | $log->syslog('notice', '%s', $email); | ||||
342 | my $result = Sympa::Scenario->new($list, 'del')->authz( | ||||
343 | 'smime', | ||||
344 | { 'sender' => $Conf::Conf{'listmaster'}, #FIXME | ||||
345 | 'email' => $email, | ||||
346 | } | ||||
347 | ); | ||||
348 | my $action; | ||||
349 | $action = $result->{'action'} if (ref($result) eq 'HASH'); | ||||
350 | if ($action =~ /reject/i) { | ||||
351 | #FIXME | ||||
352 | _error($task, | ||||
353 | "error in delete_subs command : deletion of $email not allowed" | ||||
354 | ); | ||||
355 | } else { | ||||
356 | my $u = $list->delete_list_member( | ||||
357 | users => [$email], | ||||
358 | operation => 'auto_del' | ||||
359 | ); | ||||
360 | $log->syslog('notice', '--> %s deleted', $email); | ||||
361 | $selection{$email} = {}; | ||||
362 | } | ||||
363 | } | ||||
364 | |||||
365 | return \%selection; | ||||
366 | } | ||||
367 | |||||
368 | my $subarg_regexp = '(\w+)(|\((.*)\))'; | ||||
369 | |||||
370 | # Old name: create_cmd() in task_manager.pl. | ||||
371 | sub do_create { | ||||
372 | my $self = shift; | ||||
373 | my $task = shift; | ||||
374 | my $line = shift; | ||||
375 | |||||
376 | my @tab = @{$line->{Rarguments} || []}; | ||||
377 | my $arg = $tab[0]; | ||||
378 | my $model = $tab[1]; | ||||
379 | my $model_choice = $tab[2]; | ||||
380 | |||||
381 | $log->syslog('notice', 'line %s: create(%s, %s, %s)', | ||||
382 | $line->{line}, $arg, $model, $model_choice); | ||||
383 | |||||
384 | # recovery of the object type and object | ||||
385 | my $that; | ||||
386 | if ($arg =~ /$subarg_regexp/) { | ||||
387 | my $type = $1; | ||||
388 | my $object = $3; | ||||
389 | |||||
390 | if ($type eq 'list') { | ||||
391 | my ($name, $robot) = split /\@/, $object, 2; | ||||
392 | $that = Sympa::List->new($name, $robot, {just_try => 1}); | ||||
393 | } else { | ||||
394 | $that = '*'; | ||||
395 | } | ||||
396 | } | ||||
397 | unless ($that) { | ||||
398 | _error($task, | ||||
399 | "error in create command : don't know how to create $arg"); | ||||
400 | return undef; | ||||
401 | } | ||||
402 | |||||
403 | my $new_task = Sympa::Task->new( | ||||
404 | context => $that, | ||||
405 | date => $task->{date}, | ||||
406 | model => $model | ||||
407 | ); | ||||
408 | unless ($new_task and $self->{distaff}->store($new_task)) { | ||||
409 | _error($task, | ||||
410 | "error in create command : creation subroutine failure"); | ||||
411 | return undef; | ||||
412 | } | ||||
413 | |||||
414 | return 1; | ||||
415 | } | ||||
416 | |||||
417 | # Old name: exec_cmd() in task_manager.pl. | ||||
418 | sub do_exec { | ||||
419 | my $self = shift; | ||||
420 | my $task = shift; | ||||
421 | my $line = shift; | ||||
422 | |||||
423 | my @tab = @{$line->{Rarguments} || []}; | ||||
424 | my $file = $tab[0]; | ||||
425 | |||||
426 | $log->syslog('notice', 'Line %s: exec (%s)', $line->{line}, $file); | ||||
427 | system($file); | ||||
428 | |||||
429 | return 1; | ||||
430 | } | ||||
431 | |||||
432 | # Old name: purge_logs_table() in task_manager.pl. | ||||
433 | sub do_purge_logs_table { | ||||
434 | my $self = shift; | ||||
435 | my $task = shift; | ||||
436 | my $line = shift; | ||||
437 | |||||
438 | unless (_db_log_del()) { | ||||
439 | $log->syslog('err', 'Failed to delete logs'); | ||||
440 | return undef; | ||||
441 | } | ||||
442 | |||||
443 | $log->syslog('notice', 'Logs purged'); | ||||
444 | |||||
445 | if ($log->aggregate_stat) { | ||||
446 | $log->syslog('notice', 'Stats aggregated'); | ||||
447 | } | ||||
448 | |||||
449 | return 1; | ||||
450 | } | ||||
451 | |||||
452 | # Deletes logs in RDBMS. | ||||
453 | # If a log is older than $list->get_latest_distribution_date() - $delay | ||||
454 | # expire the log. | ||||
455 | # Old name: _db_log_del() in task_manager.pl. | ||||
456 | sub _db_log_del { | ||||
457 | my ($exp, $date); | ||||
458 | |||||
459 | my $sdm = Sympa::DatabaseManager->instance; | ||||
460 | |||||
461 | $exp = Conf::get_robot_conf('*', 'logs_expiration_period'); | ||||
462 | $date = time - ($exp * 31 * 24 * 60 * 60); | ||||
463 | unless ( | ||||
464 | $sdm | ||||
465 | and $sdm->do_prepared_query( | ||||
466 | q{DELETE FROM logs_table | ||||
467 | WHERE date_logs <= ?}, | ||||
468 | $date | ||||
469 | ) | ||||
470 | ) { | ||||
471 | $log->syslog('err', | ||||
472 | 'Unable to delete db_log entry from the database'); | ||||
473 | return undef; | ||||
474 | } | ||||
475 | |||||
476 | $exp = Conf::get_robot_conf('*', 'stats_expiration_period'); | ||||
477 | $date = time - ($exp * 31 * 24 * 60 * 60); | ||||
478 | unless ( | ||||
479 | $sdm->do_prepared_query( | ||||
480 | q{DELETE FROM stat_table | ||||
481 | WHERE date_stat <= ?}, | ||||
482 | $date | ||||
483 | ) | ||||
484 | ) { | ||||
485 | $log->syslog('err', | ||||
486 | 'Unable to delete db_log entry from the database'); | ||||
487 | return undef; | ||||
488 | } | ||||
489 | unless ( | ||||
490 | $sdm->do_prepared_query( | ||||
491 | q{DELETE FROM stat_counter_table | ||||
492 | WHERE end_date_counter <= ?}, | ||||
493 | $date | ||||
494 | ) | ||||
495 | ) { | ||||
496 | $log->syslog('err', | ||||
497 | 'Unable to delete db_log entry from the database'); | ||||
498 | return undef; | ||||
499 | } | ||||
500 | |||||
501 | return 1; | ||||
502 | } | ||||
503 | |||||
504 | # Remove sessions from session_table if older than session_table_ttl or | ||||
505 | # anonymous_session_table_ttl. | ||||
506 | # Old name: Sympa::Session::purge_old_sessions(), | ||||
507 | # purge_session_table() in task_manager.pl. | ||||
508 | sub do_purge_session_table { | ||||
509 | my $self = shift; | ||||
510 | my $task = shift; | ||||
511 | my $line = shift; | ||||
512 | |||||
513 | my $delay = | ||||
514 | Sympa::Tools::Time::duration_conv($Conf::Conf{'session_table_ttl'}); | ||||
515 | my $anonymous_delay = Sympa::Tools::Time::duration_conv( | ||||
516 | $Conf::Conf{'anonymous_session_table_ttl'}); | ||||
517 | |||||
518 | unless ($delay) { | ||||
519 | $log->syslog('info', 'Exit with delay null'); | ||||
520 | return undef; | ||||
521 | } | ||||
522 | unless ($anonymous_delay) { | ||||
523 | $log->syslog('info', 'Exit with anonymous delay null'); | ||||
524 | return undef; | ||||
525 | } | ||||
526 | |||||
527 | my @sessions; | ||||
528 | my $sth; | ||||
529 | my $sdm = Sympa::DatabaseManager->instance; | ||||
530 | unless ($sdm) { | ||||
531 | $log->syslog('err', 'Unavailable database connection'); | ||||
532 | return undef; | ||||
533 | } | ||||
534 | |||||
535 | my (@conditions, @anonymous_conditions); | ||||
536 | push @conditions, sprintf('%d > date_session', time - $delay) if $delay; | ||||
537 | push @anonymous_conditions, | ||||
538 | sprintf('%d > date_session', time - $anonymous_delay) | ||||
539 | if $anonymous_delay; | ||||
540 | |||||
541 | my $condition = join ' AND ', @conditions; | ||||
542 | my $anonymous_condition = join ' AND ', @anonymous_conditions, | ||||
543 | "email_session = 'nobody'", 'hit_session = 1'; | ||||
544 | |||||
545 | my $count_statement = | ||||
546 | sprintf q{SELECT COUNT(*) FROM session_table WHERE %s}, $condition; | ||||
547 | my $anonymous_count_statement = | ||||
548 | sprintf q{SELECT COUNT(*) FROM session_table WHERE %s}, | ||||
549 | $anonymous_condition; | ||||
550 | |||||
551 | my $statement = sprintf q{DELETE FROM session_table WHERE %s}, $condition; | ||||
552 | my $anonymous_statement = sprintf q{DELETE FROM session_table WHERE %s}, | ||||
553 | $anonymous_condition; | ||||
554 | |||||
555 | unless ($sth = $sdm->do_query($count_statement)) { | ||||
556 | $log->syslog('err', 'Unable to count old session'); | ||||
557 | return undef; | ||||
558 | } | ||||
559 | |||||
560 | my $total = $sth->fetchrow; | ||||
561 | if ($total == 0) { | ||||
562 | $log->syslog('debug', 'No sessions to expire'); | ||||
563 | } else { | ||||
564 | unless ($sth = $sdm->do_query($statement)) { | ||||
565 | $log->syslog('err', 'Unable to purge old sessions'); | ||||
566 | return undef; | ||||
567 | } | ||||
568 | } | ||||
569 | unless ($sth = $sdm->do_query($anonymous_count_statement)) { | ||||
570 | $log->syslog('err', 'Unable to count anonymous sessions'); | ||||
571 | return undef; | ||||
572 | } | ||||
573 | my $anonymous_total = $sth->fetchrow; | ||||
574 | if ($anonymous_total == 0) { | ||||
575 | $log->syslog('debug', 'No anonymous sessions to expire'); | ||||
576 | } else { | ||||
577 | unless ($sth = $sdm->do_query($anonymous_statement)) { | ||||
578 | $log->syslog('err', 'Unable to purge anonymous sessions'); | ||||
579 | return undef; | ||||
580 | } | ||||
581 | } | ||||
582 | |||||
583 | $log->syslog( | ||||
584 | 'notice', | ||||
585 | '%s row removed in session_table', | ||||
586 | $total + $anonymous_total | ||||
587 | ); | ||||
588 | return 1; | ||||
589 | } | ||||
590 | |||||
591 | # Remove messages from spools if older than duration given by configuration. | ||||
592 | # Old name: purge_spools() in task_manager.pl. | ||||
593 | sub do_purge_spools { | ||||
594 | my $self = shift; | ||||
595 | my $task = shift; | ||||
596 | my $line = shift; | ||||
597 | |||||
598 | # Expiring bad messages in incoming spools and archive spool. | ||||
599 | foreach my $queue (qw(queue queueautomatic queuebounce queueoutgoing)) { | ||||
600 | my $directory = $Conf::Conf{$queue} . '/bad'; | ||||
601 | my $clean_delay = $Conf::Conf{'clean_delay_' . $queue}; | ||||
602 | if (-e $directory) { | ||||
603 | _clean_spool($directory, $clean_delay); | ||||
604 | } | ||||
605 | } | ||||
606 | |||||
607 | # Expiring bad messages in digest spool. | ||||
608 | if (opendir my $dh, $Conf::Conf{'queuedigest'}) { | ||||
609 | my $base_dir = $Conf::Conf{'queuedigest'}; | ||||
610 | my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh; | ||||
611 | closedir $dh; | ||||
612 | foreach my $subdir (@dirs) { | ||||
613 | my $directory = $base_dir . '/' . $subdir . '/bad'; | ||||
614 | my $clean_delay = $Conf::Conf{'clean_delay_queuedigest'}; | ||||
615 | if (-e $directory) { | ||||
616 | _clean_spool($directory, $clean_delay); | ||||
617 | } | ||||
618 | } | ||||
619 | } | ||||
620 | |||||
621 | # Expiring bad packets and messages in bulk spool. | ||||
622 | foreach my $subdir (qw(pct msg)) { | ||||
623 | my $directory = $Conf::Conf{'queuebulk'} . '/bad/' . $subdir; | ||||
624 | my $clean_delay = $Conf::Conf{'clean_delay_queuebulk'}; | ||||
625 | if (-e $directory) { | ||||
626 | _clean_spool($directory, $clean_delay); | ||||
627 | } | ||||
628 | } | ||||
629 | |||||
630 | # Expiring moderation spools except mod, topic spool and temporary files. | ||||
631 | foreach my $queue ( | ||||
632 | qw(queueauth queueautomatic queuesubscribe queuetopic tmpdir)) { | ||||
633 | my $directory = $Conf::Conf{$queue}; | ||||
634 | my $clean_delay = $Conf::Conf{'clean_delay_' . $queue}; | ||||
635 | if (-e $directory) { | ||||
636 | _clean_spool($directory, $clean_delay); | ||||
637 | } | ||||
638 | } | ||||
639 | |||||
640 | # Expiring mod spool. | ||||
641 | my $modqueue = $Conf::Conf{'queuemod'}; | ||||
642 | if (opendir my $dh, $modqueue) { | ||||
643 | my @qfiles = sort readdir $dh; | ||||
644 | closedir $dh; | ||||
645 | foreach my $i (@qfiles) { | ||||
646 | next if $i =~ /\A[.]/; | ||||
647 | next unless -f $modqueue . '/' . $i; | ||||
648 | |||||
649 | $i =~ /\A(.+)_[.\w]+\z/; | ||||
650 | my $list = Sympa::List->new($1, '*', {just_try => 1}) if $1; | ||||
651 | my $moddelay; | ||||
652 | if (ref $list eq 'Sympa::List') { | ||||
653 | $moddelay = $list->{'admin'}{'clean_delay_queuemod'}; | ||||
654 | } else { | ||||
655 | $moddelay = $Conf::Conf{'clean_delay_queuemod'}; | ||||
656 | } | ||||
657 | if ($moddelay) { | ||||
658 | my $mtime = | ||||
659 | Sympa::Tools::File::get_mtime($modqueue . '/' . $i); | ||||
660 | if ($mtime < time - $moddelay * 86400) { | ||||
661 | unlink($modqueue . '/' . $i); | ||||
662 | $log->syslog('notice', | ||||
663 | 'Deleting unmoderated message %s, too old', $i); | ||||
664 | } | ||||
665 | } | ||||
666 | } | ||||
667 | } | ||||
668 | |||||
669 | # Expiring formatted held messages. | ||||
670 | if (opendir my $dh, $Conf::Conf{'viewmail_dir'} . '/mod') { | ||||
671 | my $base_dir = $Conf::Conf{'viewmail_dir'} . '/mod'; | ||||
672 | my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh; | ||||
673 | closedir $dh; | ||||
674 | foreach my $list_id (@dirs) { | ||||
675 | my $clean_delay; | ||||
676 | my $list = Sympa::List->new($list_id, '*', {just_try => 1}); | ||||
677 | if (ref $list eq 'Sympa::List') { | ||||
678 | $clean_delay = $list->{'admin'}{'clean_delay_queuemod'}; | ||||
679 | } else { | ||||
680 | $clean_delay = $Conf::Conf{'clean_delay_queuemod'}; | ||||
681 | } | ||||
682 | my $directory = $base_dir . '/' . $list_id; | ||||
683 | if ($clean_delay and -e $directory) { | ||||
684 | _clean_spool($directory, $clean_delay); | ||||
685 | } | ||||
686 | } | ||||
687 | } | ||||
688 | |||||
689 | # Removing messages in bulk spool with no more packet. | ||||
690 | my $pct_directory = $Conf::Conf{'queuebulk'} . '/pct'; | ||||
691 | my $msg_directory = $Conf::Conf{'queuebulk'} . '/msg'; | ||||
692 | if (opendir my $dh, $pct_directory) { | ||||
693 | my $msgpath; | ||||
694 | while ($msgpath = readdir $dh) { | ||||
695 | next if $msgpath =~ /\A\./; | ||||
696 | next unless -d $pct_directory . '/' . $msgpath; | ||||
697 | next | ||||
698 | if time - 3600 < Sympa::Tools::File::get_mtime( | ||||
699 | $pct_directory . '/' . $msgpath); | ||||
700 | |||||
701 | # If packet directory is empty, remove message also. | ||||
702 | unlink($msg_directory . '/' . $msgpath) | ||||
703 | if rmdir($pct_directory . '/' . $msgpath); | ||||
704 | } | ||||
705 | closedir $dh; | ||||
706 | } | ||||
707 | |||||
708 | return 1; | ||||
709 | } | ||||
710 | |||||
711 | # Old name: tools::CleanSpool(), Sympa::Tools::File::CleanDir(), | ||||
712 | # _clean_spool() in task_manager.pl. | ||||
713 | sub _clean_spool { | ||||
714 | $log->syslog('debug2', '(%s, %s)', @_); | ||||
715 | my ($directory, $clean_delay) = @_; | ||||
716 | |||||
717 | return 1 unless $clean_delay; | ||||
718 | |||||
719 | my $dh; | ||||
720 | unless (opendir $dh, $directory) { | ||||
721 | $log->syslog('err', 'Unable to open "%s" spool: %m', $directory); | ||||
722 | return undef; | ||||
723 | } | ||||
724 | my @qfile = sort grep { !/\A\.+\z/ and !/\Abad\z/ } readdir $dh; | ||||
725 | closedir $dh; | ||||
726 | |||||
727 | my ($curlist, $moddelay); | ||||
728 | foreach my $f (@qfile) { | ||||
729 | if (Sympa::Tools::File::get_mtime("$directory/$f") < | ||||
730 | time - $clean_delay * 60 * 60 * 24) { | ||||
731 | if (-f "$directory/$f") { | ||||
732 | unlink("$directory/$f"); | ||||
733 | $log->syslog('notice', 'Deleting old file %s', | ||||
734 | "$directory/$f"); | ||||
735 | } elsif (-d "$directory/$f") { | ||||
736 | unless (Sympa::Tools::File::remove_dir("$directory/$f")) { | ||||
737 | $log->syslog('err', 'Cannot remove old directory %s: %m', | ||||
738 | "$directory/$f"); | ||||
739 | next; | ||||
740 | } | ||||
741 | $log->syslog('notice', 'Deleting old directory %s', | ||||
742 | "$directory/$f"); | ||||
743 | } | ||||
744 | } | ||||
745 | } | ||||
746 | |||||
747 | return 1; | ||||
748 | } | ||||
749 | |||||
750 | ## remove messages from bulkspool table when no more packet have any pointer | ||||
751 | ## to this message | ||||
752 | # Old name: purge_tables() in task_manager.pl. | ||||
753 | sub do_purge_tables { | ||||
754 | my $self = shift; | ||||
755 | my $task = shift; | ||||
756 | my $line = shift; | ||||
757 | |||||
758 | my $removed; | ||||
759 | |||||
760 | $removed = 0; | ||||
761 | foreach my $robot (Sympa::List::get_robots()) { | ||||
762 | my $all_lists = Sympa::List::get_lists($robot); | ||||
763 | |||||
764 | foreach my $list (@{$all_lists || []}) { | ||||
765 | my $tracking = Sympa::Tracking->new(context => $list); | ||||
766 | next unless $tracking; | ||||
767 | |||||
768 | $removed += | ||||
769 | $tracking->remove_message_by_period( | ||||
770 | $list->{'admin'}{'tracking'}{'retention_period'}); | ||||
771 | } | ||||
772 | } | ||||
773 | $log->syslog('notice', "%s rows removed in tracking table", $removed); | ||||
774 | |||||
775 | return 1; | ||||
776 | } | ||||
777 | |||||
778 | ## remove one time ticket table if older than | ||||
779 | ## $Conf::Conf{'one_time_ticket_table_ttl'} | ||||
780 | # Old name: purge_one_time_ticket_table() in task_manager.pl. | ||||
781 | sub do_purge_one_time_ticket_table { | ||||
782 | my $self = shift; | ||||
783 | my $task = shift; | ||||
784 | my $line = shift; | ||||
785 | |||||
786 | $log->syslog('info', ''); | ||||
787 | my $removed = Sympa::Ticket::purge_old_tickets('*'); | ||||
788 | unless (defined $removed) { | ||||
789 | $log->syslog('err', 'Failed to remove old tickets'); | ||||
790 | return undef; | ||||
791 | } | ||||
792 | $log->syslog('notice', '%s row removed in one_time_ticket_table', | ||||
793 | $removed); | ||||
794 | return 1; | ||||
795 | } | ||||
796 | |||||
797 | # Old name: purge_user_table() in task_manager.pl. | ||||
798 | sub do_purge_user_table { | ||||
799 | my $self = shift; | ||||
800 | my $task = shift; | ||||
801 | my $line = shift; | ||||
802 | |||||
803 | my $sdm = Sympa::DatabaseManager->instance; | ||||
804 | |||||
805 | my $time = time; | ||||
806 | |||||
807 | # Marking super listmasters | ||||
808 | foreach my $l (Sympa::get_listmasters_email('*')) { | ||||
809 | unless ( | ||||
810 | $sdm | ||||
811 | and $sdm->do_prepared_query( | ||||
812 | q{UPDATE user_table | ||||
813 | SET last_active_date_user = ? | ||||
814 | WHERE email_user = ?}, | ||||
815 | $time, lc $l | ||||
816 | ) | ||||
817 | ) { | ||||
818 | $log->syslog('err', 'Failed to check activity of users'); | ||||
819 | return undef; | ||||
820 | } | ||||
821 | } | ||||
822 | # Marking per-robot listmasters. | ||||
823 | foreach my $robot_id (Sympa::List::get_robots()) { | ||||
824 | foreach my $l (Sympa::get_listmasters_email($robot_id)) { | ||||
825 | unless ( | ||||
826 | $sdm->do_prepared_query( | ||||
827 | q{UPDATE user_table | ||||
828 | SET last_active_date_user = ? | ||||
829 | WHERE email_user = ?}, | ||||
830 | $time, lc $l | ||||
831 | ) | ||||
832 | ) { | ||||
833 | $log->syslog('err', 'Failed to check activity of users'); | ||||
834 | return undef; | ||||
835 | } | ||||
836 | } | ||||
837 | } | ||||
838 | # Marking new users, owners/editors and subscribers. | ||||
839 | unless ( | ||||
840 | $sdm->do_prepared_query( | ||||
841 | q{UPDATE user_table | ||||
842 | SET last_active_date_user = ? | ||||
843 | WHERE last_active_date_user IS NULL | ||||
844 | OR EXISTS ( | ||||
845 | SELECT 1 | ||||
846 | FROM admin_table | ||||
847 | WHERE admin_table.user_admin = user_table.email_user | ||||
848 | ) | ||||
849 | OR EXISTS ( | ||||
850 | SELECT 1 | ||||
851 | FROM subscriber_table | ||||
852 | WHERE subscriber_table.user_subscriber = user_table.email_user | ||||
853 | )}, | ||||
854 | $time | ||||
855 | ) | ||||
856 | ) { | ||||
857 | $log->syslog('err', 'Failed to check activity of users'); | ||||
858 | return undef; | ||||
859 | } | ||||
860 | |||||
861 | # Look for unused entries. | ||||
862 | my @purged_users; | ||||
863 | my $sth; | ||||
864 | unless ( | ||||
865 | $sth = $sdm->do_prepared_query( | ||||
866 | q{SELECT email_user | ||||
867 | FROM user_table | ||||
868 | WHERE last_active_date_user IS NOT NULL AND | ||||
869 | last_active_date_user < ?}, | ||||
870 | $time | ||||
871 | ) | ||||
872 | ) { | ||||
873 | $log->syslog('err', 'Failed to get inactive users'); | ||||
874 | return undef; | ||||
875 | } | ||||
876 | @purged_users = | ||||
877 | grep {$_} map { $_->[0] } @{$sth->fetchall_arrayref || []}; | ||||
878 | $sth->finish; | ||||
879 | |||||
880 | # Purge unused entries. | ||||
881 | foreach my $email (@purged_users) { | ||||
882 | my $user = Sympa::User->new($email); | ||||
883 | next unless $user; | ||||
884 | |||||
885 | unless ($user->expire) { | ||||
886 | $log->syslog('err', 'Failed to purge inactive user %s', $user); | ||||
887 | return undef; | ||||
888 | } else { | ||||
889 | $log->syslog('info', 'User %s was expired', $user); | ||||
890 | } | ||||
891 | } | ||||
892 | |||||
893 | return scalar @purged_users; | ||||
894 | } | ||||
895 | |||||
896 | ## Subroutine which remove bounced message of no-more known users | ||||
897 | # Old name: purge_orphan_bounces() in task_manager.pl. | ||||
898 | sub do_purge_orphan_bounces { | ||||
899 | my $self = shift; | ||||
900 | my $task = shift; | ||||
901 | my $line = shift; | ||||
902 | |||||
903 | my $all_lists = Sympa::List::get_lists('*'); | ||||
904 | foreach my $list (@{$all_lists || []}) { | ||||
905 | # First time: loading DB entries into %bounced_users, | ||||
906 | # hash {'bounced address' => 1} | ||||
907 | my %bounced_users; | ||||
908 | |||||
909 | for ( | ||||
910 | my $user_ref = $list->get_first_bouncing_list_member(); | ||||
911 | $user_ref; | ||||
912 | $user_ref = $list->get_next_bouncing_list_member() | ||||
913 | ) { | ||||
914 | my $user_id = $user_ref->{'email'}; | ||||
915 | $bounced_users{Sympa::Tools::Text::escape_chars($user_id)} = 1; | ||||
916 | } | ||||
917 | |||||
918 | my $bounce_dir = $list->get_bounce_dir(); | ||||
919 | unless (-d $bounce_dir) { | ||||
920 | $log->syslog('notice', 'No bouncing subscribers in list %s', | ||||
921 | $list); | ||||
922 | next; | ||||
923 | } | ||||
924 | |||||
925 | # Then reading Bounce directory & compare with %bounced_users | ||||
926 | my $dh; | ||||
927 | unless (opendir $dh, $bounce_dir) { | ||||
928 | $log->syslog('err', 'Error while opening bounce directory %s', | ||||
929 | $bounce_dir); | ||||
930 | return undef; | ||||
931 | } | ||||
932 | |||||
933 | # Finally removing orphan files | ||||
934 | my $marshalled; | ||||
935 | while ($marshalled = readdir $dh) { | ||||
936 | my $metadata = | ||||
937 | Sympa::Spool::unmarshal_metadata($bounce_dir, $marshalled, | ||||
938 | qr/\A([^\s\@]+\@[\w\.\-*]+?)(?:_(\w+))?\z/, | ||||
939 | [qw(recipient envid)]); | ||||
940 | next unless $metadata; | ||||
941 | # Skip <email>_<envid> which is used by tracking feature. | ||||
942 | next if defined $metadata->{envid}; | ||||
943 | |||||
944 | unless ($bounced_users{$marshalled}) { | ||||
945 | $log->syslog('info', | ||||
946 | 'Removing orphan Bounce for user %s in list %s', | ||||
947 | $marshalled, $list); | ||||
948 | unless (unlink($bounce_dir . '/' . $marshalled)) { | ||||
949 | $log->syslog('err', 'Error while removing file %s/%s', | ||||
950 | $bounce_dir, $marshalled); | ||||
951 | } | ||||
952 | } | ||||
953 | } | ||||
954 | |||||
955 | closedir $dh; | ||||
956 | } | ||||
957 | return 1; | ||||
958 | } | ||||
959 | |||||
960 | # If a bounce is older than $list->get_latest_distribution_date() - $delay | ||||
961 | # expire the bounce. | ||||
962 | # Old name: expire_bounce() in task_manager.pl. | ||||
963 | sub do_expire_bounce { | ||||
964 | my $self = shift; | ||||
965 | my $task = shift; | ||||
966 | my $line = shift; | ||||
967 | |||||
968 | my @tab = @{$line->{Rarguments} || []}; | ||||
969 | my $delay = $tab[0]; | ||||
970 | |||||
971 | my $all_lists = Sympa::List::get_lists('*'); | ||||
972 | foreach my $list (@{$all_lists || []}) { | ||||
973 | my $listname = $list->{'name'}; | ||||
974 | |||||
975 | # the reference date is the date until which we expire bounces in | ||||
976 | # second | ||||
977 | # the latest_distribution_date is the date of last distribution #days | ||||
978 | # from 01 01 1970 | ||||
979 | |||||
980 | unless ($list->get_latest_distribution_date()) { | ||||
981 | $log->syslog( | ||||
982 | 'debug2', | ||||
983 | 'Bounce expiration: skipping list %s because could not get latest distribution date', | ||||
984 | $listname | ||||
985 | ); | ||||
986 | next; | ||||
987 | } | ||||
988 | my $refdate = | ||||
989 | (($list->get_latest_distribution_date() - $delay) * 3600 * 24); | ||||
990 | |||||
991 | for ( | ||||
992 | my $u = $list->get_first_bouncing_list_member(); | ||||
993 | $u; | ||||
994 | $u = $list->get_next_bouncing_list_member() | ||||
995 | ) { | ||||
996 | $u->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/; | ||||
997 | $u->{'last_bounce'} = $2; | ||||
998 | if ($u->{'last_bounce'} < $refdate) { | ||||
999 | my $email = $u->{'email'}; | ||||
1000 | |||||
1001 | unless ($list->is_list_member($email)) { | ||||
1002 | $log->syslog('info', '%s not subscribed', $email); | ||||
1003 | next; | ||||
1004 | } | ||||
1005 | |||||
1006 | unless ( | ||||
1007 | $list->update_list_member( | ||||
1008 | $email, | ||||
1009 | bounce => undef, | ||||
1010 | bounce_address => undef | ||||
1011 | ) | ||||
1012 | ) { | ||||
1013 | $log->syslog('info', 'Failed update database for %s', | ||||
1014 | $email); | ||||
1015 | next; | ||||
1016 | } | ||||
1017 | my $escaped_email = Sympa::Tools::Text::escape_chars($email); | ||||
1018 | |||||
1019 | my $bounce_dir = $list->get_bounce_dir(); | ||||
1020 | |||||
1021 | unless (unlink $bounce_dir . '/' . $escaped_email) { | ||||
1022 | $log->syslog( | ||||
1023 | 'info', | ||||
1024 | 'Failed deleting %s', | ||||
1025 | $bounce_dir . '/' . $escaped_email | ||||
1026 | ); | ||||
1027 | next; | ||||
1028 | } | ||||
1029 | $log->syslog( | ||||
1030 | 'info', | ||||
1031 | 'Expire bounces for subscriber %s of list %s (last distribution %s, last bounce %s)', | ||||
1032 | $email, | ||||
1033 | $listname, | ||||
1034 | POSIX::strftime( | ||||
1035 | "%Y-%m-%d", | ||||
1036 | localtime( | ||||
1037 | $list->get_latest_distribution_date() * 3600 * 24 | ||||
1038 | ) | ||||
1039 | ), | ||||
1040 | POSIX::strftime( | ||||
1041 | "%Y-%m-%d", localtime($u->{'last_bounce'}) | ||||
1042 | ) | ||||
1043 | ); | ||||
1044 | } | ||||
1045 | } | ||||
1046 | } | ||||
1047 | |||||
1048 | # Expiring formatted bounce messages. | ||||
1049 | if (opendir my $dh, $Conf::Conf{'viewmail_dir'} . '/bounce') { | ||||
1050 | my $base_dir = $Conf::Conf{'viewmail_dir'} . '/bounce'; | ||||
1051 | my @dirs = grep { !/\A\./ and -d $base_dir . '/' . $_ } readdir $dh; | ||||
1052 | closedir $dh; | ||||
1053 | foreach my $list_id (@dirs) { | ||||
1054 | my $directory = $base_dir . '/' . $list_id; | ||||
1055 | if (-e $directory) { | ||||
1056 | _clean_spool($directory, $delay); | ||||
1057 | } | ||||
1058 | } | ||||
1059 | } | ||||
1060 | |||||
1061 | return 1; | ||||
1062 | } | ||||
1063 | |||||
1064 | # Removed because not yet fully implemented. See r11771. | ||||
1065 | #sub chk_cert_expiration; | ||||
1066 | |||||
1067 | # Removed becuase not yet fully implemented. See r11771. | ||||
1068 | #sub update_crl; | ||||
1069 | |||||
1070 | ## Subroutine for bouncers evaluation: | ||||
1071 | # give a score for each bouncing user | ||||
1072 | # Old name: eval_bouncers() in task_manager.pl. | ||||
1073 | sub do_eval_bouncers { | ||||
1074 | my $self = shift; | ||||
1075 | my $task = shift; | ||||
1076 | my $line = shift; | ||||
1077 | |||||
1078 | my $all_lists = Sympa::List::get_lists('*'); | ||||
1079 | foreach my $list (@{$all_lists || []}) { | ||||
1080 | my $listname = $list->{'name'}; | ||||
1081 | my $list_traffic = {}; | ||||
1082 | |||||
1083 | $log->syslog('info', '(%s)', $listname); | ||||
1084 | |||||
1085 | ## Analizing file Msg-count and fill %$list_traffic | ||||
1086 | unless (open(COUNT, $list->{'dir'} . '/msg_count')) { | ||||
1087 | $log->syslog('debug', | ||||
1088 | '** Could not open msg_count FILE for list %s', $listname); | ||||
1089 | next; | ||||
1090 | } | ||||
1091 | while (<COUNT>) { | ||||
1092 | if (/^(\w+)\s+(\d+)/) { | ||||
1093 | my ($a, $b) = ($1, $2); | ||||
1094 | $list_traffic->{$a} = $b; | ||||
1095 | } | ||||
1096 | } | ||||
1097 | close(COUNT); | ||||
1098 | |||||
1099 | #for each bouncing user | ||||
1100 | for ( | ||||
1101 | my $user_ref = $list->get_first_bouncing_list_member(); | ||||
1102 | $user_ref; | ||||
1103 | $user_ref = $list->get_next_bouncing_list_member() | ||||
1104 | ) { | ||||
1105 | my $score = _get_score($user_ref, $list_traffic) || 0; | ||||
1106 | |||||
1107 | # Copying score into database. | ||||
1108 | unless ( | ||||
1109 | $list->update_list_member( | ||||
1110 | $user_ref->{'email'}, bounce_score => $score | ||||
1111 | ) | ||||
1112 | ) { | ||||
1113 | $log->syslog('err', 'Error while updating DB for user %s', | ||||
1114 | $user_ref->{'email'}); | ||||
1115 | next; | ||||
1116 | } | ||||
1117 | } | ||||
1118 | } | ||||
1119 | return 1; | ||||
1120 | } | ||||
1121 | |||||
1122 | # Routine for automatic bouncing users management | ||||
1123 | # | ||||
1124 | # This sub apply a treatment foreach category of bouncing-users | ||||
1125 | # | ||||
1126 | # The relation between possible actions and correponding subroutines | ||||
1127 | # is indicated by the following hash (%actions). | ||||
1128 | # It's possible to add actions by completing this hash and the one in list | ||||
1129 | # config (file List.pm, in sections "bouncers_levelX"). Then you must write | ||||
1130 | # the code for your action: | ||||
1131 | # The action subroutines have two parameters: | ||||
1132 | # - current list | ||||
1133 | # - a reference on users email list | ||||
1134 | # Look at the _remove_bouncers() for an example. | ||||
1135 | # Old name: process_bouncers() in task_manager.pl. | ||||
1136 | sub do_process_bouncers { | ||||
1137 | my $self = shift; | ||||
1138 | my $task = shift; | ||||
1139 | my $line = shift; | ||||
1140 | |||||
1141 | ## possible actions | ||||
1142 | my %actions = ( | ||||
1143 | 'remove_bouncers' => \&_remove_bouncers, | ||||
1144 | 'notify_bouncers' => \&_notify_bouncers, | ||||
1145 | 'none' => sub {1}, | ||||
1146 | ); | ||||
1147 | |||||
1148 | my $all_lists = Sympa::List::get_lists('*'); | ||||
1149 | foreach my $list (@{$all_lists || []}) { | ||||
1150 | my @bouncers; | ||||
1151 | # @bouncers = ( | ||||
1152 | # ['email1', 'email2', 'email3',....,], There is one line | ||||
1153 | # ['email1', 'email2', 'email3',....,], foreach bounce | ||||
1154 | # ['email1', 'email2', 'email3',....,], level. | ||||
1155 | # ); | ||||
1156 | |||||
1157 | my $max_level; | ||||
1158 | for ( | ||||
1159 | my $level = 1; | ||||
1160 | defined($list->{'admin'}{'bouncers_level' . $level}); | ||||
1161 | $level++ | ||||
1162 | ) { | ||||
1163 | $max_level = $level; | ||||
1164 | } | ||||
1165 | |||||
1166 | ## first, bouncing email are sorted in @bouncer | ||||
1167 | for ( | ||||
1168 | my $user_ref = $list->get_first_bouncing_list_member(); | ||||
1169 | $user_ref; | ||||
1170 | $user_ref = $list->get_next_bouncing_list_member() | ||||
1171 | ) { | ||||
1172 | # Skip included users (cannot be removed) | ||||
1173 | next if defined $user_ref->{'inclusion'}; | ||||
1174 | |||||
1175 | for (my $level = $max_level; ($level >= 1); $level--) { | ||||
1176 | if ($user_ref->{'bounce_score'} >= | ||||
1177 | $list->{'admin'}{'bouncers_level' . $level}{'rate'}) { | ||||
1178 | push(@{$bouncers[$level]}, $user_ref->{'email'}); | ||||
1179 | $level = ($level - $max_level); | ||||
1180 | } | ||||
1181 | } | ||||
1182 | } | ||||
1183 | |||||
1184 | ## then, calling action foreach level | ||||
1185 | for (my $level = $max_level; ($level >= 1); $level--) { | ||||
1186 | my $action = | ||||
1187 | $list->{'admin'}{'bouncers_level' . $level}{'action'}; | ||||
1188 | my $notification = | ||||
1189 | $list->{'admin'}{'bouncers_level' . $level}{'notification'}; | ||||
1190 | my $robot_id = $list->{'domain'}; | ||||
1191 | |||||
1192 | if (@{$bouncers[$level] || []}) { | ||||
1193 | ## calling action subroutine with (list,email list) in | ||||
1194 | ## parameter | ||||
1195 | unless ($actions{$action}->($list, $bouncers[$level])) { | ||||
1196 | $log->syslog( | ||||
1197 | 'err', | ||||
1198 | 'Error while calling action sub for bouncing users in list %s', | ||||
1199 | $list | ||||
1200 | ); | ||||
1201 | return undef; | ||||
1202 | } | ||||
1203 | |||||
1204 | # Notify owner or listmaster with list, action, email list. | ||||
1205 | my $param = { | ||||
1206 | #'listname' => $listname, # No longer used (<=6.1) | ||||
1207 | 'action' => $action, | ||||
1208 | 'user_list' => \@{$bouncers[$level]}, | ||||
1209 | 'total' => scalar(@{$bouncers[$level]}), | ||||
1210 | }; | ||||
1211 | if ($notification eq 'owner') { | ||||
1212 | $list->send_notify_to_owner('automatic_bounce_management', | ||||
1213 | $param); | ||||
1214 | } elsif ($notification eq 'listmaster') { | ||||
1215 | Sympa::send_notify_to_listmaster($list, | ||||
1216 | 'automatic_bounce_management', $param); | ||||
1217 | } | ||||
1218 | } | ||||
1219 | } | ||||
1220 | } | ||||
1221 | return 1; | ||||
1222 | } | ||||
1223 | |||||
1224 | # Old name: get_score() in task_manager.pl. | ||||
1225 | sub _get_score { | ||||
1226 | |||||
1227 | my $user_ref = shift; | ||||
1228 | my $list_traffic = shift; | ||||
1229 | |||||
1230 | $log->syslog('debug', '(%s)', $user_ref->{'email'}); | ||||
1231 | |||||
1232 | my $min_period = $Conf::Conf{'minimum_bouncing_period'}; | ||||
1233 | my $min_msg_count = $Conf::Conf{'minimum_bouncing_count'}; | ||||
1234 | |||||
1235 | # Analizing bounce_subscriber_field and keep useful infos for notation | ||||
1236 | $user_ref->{'bounce'} =~ /^(\d+)\s+(\d+)\s+(\d+)(\s+(.*))?$/; | ||||
1237 | |||||
1238 | my $BO_period = int($1 / 86400) - $Conf::Conf{'bounce_delay'}; | ||||
1239 | my $EO_period = int($2 / 86400) - $Conf::Conf{'bounce_delay'}; | ||||
1240 | my $bounce_count = $3; | ||||
1241 | my $bounce_type = $4; | ||||
1242 | |||||
1243 | my $msg_count = 0; | ||||
1244 | my $min_day = $EO_period; | ||||
1245 | |||||
1246 | unless ($bounce_count >= $min_msg_count) { | ||||
1247 | #not enough messages distributed to keep score | ||||
1248 | $log->syslog('debug', 'Not enough messages for evaluation of user %s', | ||||
1249 | $user_ref->{'email'}); | ||||
1250 | return undef; | ||||
1251 | } | ||||
1252 | |||||
1253 | unless (($EO_period - $BO_period) >= $min_period) { | ||||
1254 | #too short bounce period to keep score | ||||
1255 | $log->syslog('debug', 'Too short period for evaluate %s', | ||||
1256 | $user_ref->{'email'}); | ||||
1257 | return undef; | ||||
1258 | } | ||||
1259 | |||||
1260 | # calculate number of messages distributed in list while user was bouncing | ||||
1261 | foreach my $date (sort { $b <=> $a } keys(%$list_traffic)) { | ||||
1262 | if (($date >= $BO_period) && ($date <= $EO_period)) { | ||||
1263 | $min_day = $date; | ||||
1264 | $msg_count += $list_traffic->{$date}; | ||||
1265 | } | ||||
1266 | } | ||||
1267 | |||||
1268 | # Adjust bounce_count when msg_count file is too recent, compared to the | ||||
1269 | # bouncing period | ||||
1270 | my $tmp_bounce_count = $bounce_count; | ||||
1271 | unless ($EO_period == $BO_period) { | ||||
1272 | my $ratio = (($EO_period - $min_day) / ($EO_period - $BO_period)); | ||||
1273 | $tmp_bounce_count *= $ratio; | ||||
1274 | } | ||||
1275 | |||||
1276 | ## Regularity rate tells how much user has bounced compared to list | ||||
1277 | ## traffic | ||||
1278 | $msg_count ||= 1; ## Prevents "Illegal division by zero" error | ||||
1279 | my $regularity_rate = $tmp_bounce_count / $msg_count; | ||||
1280 | |||||
1281 | ## type rate depends on bounce type (5 = permanent ; 4 =tewmporary) | ||||
1282 | my $type_rate = 1; | ||||
1283 | $bounce_type =~ /(\d)\.(\d)\.(\d)/; | ||||
1284 | if ($1 == 4) { # if its a temporary Error: score = score/2 | ||||
1285 | $type_rate = .5; | ||||
1286 | } | ||||
1287 | |||||
1288 | my $note = $bounce_count * $regularity_rate * $type_rate; | ||||
1289 | |||||
1290 | ## Note should be an integer | ||||
1291 | $note = int($note + 0.5); | ||||
1292 | |||||
1293 | # $note = 100 if ($note > 100); # shift between message ditrib & bounces => | ||||
1294 | # note > 100 | ||||
1295 | |||||
1296 | return $note; | ||||
1297 | } | ||||
1298 | |||||
1299 | # Sub for removing user | ||||
1300 | # Old name: Sympa::List::remove_bouncers(). | ||||
1301 | sub _remove_bouncers { | ||||
1302 | $log->syslog('debug2', '(%s, %s)', @_); | ||||
1303 | my $list = shift; | ||||
1304 | my $users = shift; | ||||
1305 | |||||
1306 | foreach my $u (@{$users || []}) { | ||||
1307 | $log->syslog('notice', 'Removing bouncing subsrciber of list %s: %s', | ||||
1308 | $list, $u); | ||||
1309 | } | ||||
1310 | $list->delete_list_member( | ||||
1311 | users => $users, | ||||
1312 | exclude => '1', | ||||
1313 | operation => 'auto_del' | ||||
1314 | ); | ||||
1315 | return 1; | ||||
1316 | } | ||||
1317 | |||||
1318 | # Sub for notifying users: "Be careful, you're bouncing". | ||||
1319 | # Old name: Sympa::List::notify_bouncers(). | ||||
1320 | sub _notify_bouncers { | ||||
1321 | $log->syslog('debug2', '(%s, %s)', @_); | ||||
1322 | my $list = shift; | ||||
1323 | my $users = shift; | ||||
1324 | |||||
1325 | foreach my $u (@{$users || []}) { | ||||
1326 | $log->syslog('notice', 'Notifying bouncing subsrciber of list %s: %s', | ||||
1327 | $list, $u); | ||||
1328 | Sympa::send_notify_to_user($list, 'auto_notify_bouncers', $u); | ||||
1329 | } | ||||
1330 | return 1; | ||||
1331 | } | ||||
1332 | |||||
1333 | # Old name: none() in task_manager.pl. | ||||
1334 | # No longer used. | ||||
1335 | #sub _none; | ||||
1336 | |||||
1337 | # Old name: sync_include() in task_manager.pl. | ||||
1338 | sub do_sync_include { | ||||
1339 | my $self = shift; | ||||
1340 | my $task = shift; | ||||
1341 | my $line = shift; | ||||
1342 | |||||
1343 | my $list = $task->{context}; | ||||
1344 | unless (ref $list eq 'Sympa::List') { | ||||
1345 | $log->syslog('err', 'No list'); | ||||
1346 | return -1; | ||||
1347 | } | ||||
1348 | |||||
1349 | $list->sync_include('member'); | ||||
1350 | $list->sync_include('owner'); | ||||
1351 | $list->sync_include('editor'); | ||||
1352 | |||||
1353 | unless ($list->has_data_sources or $list->has_included_users) { | ||||
1354 | $log->syslog('debug', 'List %s no more require sync_include task', | ||||
1355 | $list); | ||||
1356 | return -1; | ||||
1357 | } | ||||
1358 | } | ||||
1359 | |||||
1360 | ### MISCELLANEOUS SUBROUTINES ### | ||||
1361 | |||||
1362 | ## change the label of a task file | ||||
1363 | # Old name: change_label() in task_manager.pl. | ||||
1364 | # No onger used. | ||||
1365 | #sub _change_label; | ||||
1366 | |||||
1367 | ## send a error message to list-master, log it, and change the label task into | ||||
1368 | ## 'ERROR' | ||||
1369 | sub _error { | ||||
1370 | my $task = shift; | ||||
1371 | my $message = shift; | ||||
1372 | |||||
1373 | my @param = ( | ||||
1374 | sprintf | ||||
1375 | 'An error has occurred during the execution of the task %s: %s', | ||||
1376 | $task->get_id, $message | ||||
1377 | ); | ||||
1378 | $log->syslog('err', '%s', $message); | ||||
1379 | #FIXME: Coresponding mail template would be added. | ||||
1380 | Sympa::send_notify_to_listmaster('*', 'error_in_task', \@param); | ||||
1381 | } | ||||
1382 | |||||
1383 | 1; | ||||
1384 | __END__ | ||||
# spent 2µs within Sympa::Spindle::ProcessTask::_distaff which was called 2 times, avg 1µs/call:
# once (1µs+0s) by Sympa::Spindle::new at line 42 of /usr/local/libexec/sympa/Sympa/Spindle.pm
# once (600ns+0s) by Sympa::Spindle::new at line 41 of /usr/local/libexec/sympa/Sympa/Spindle.pm |