← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/libexec/sympa/Sympa/Scenario.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::Scenario::::BEGIN@30Sympa::Scenario::BEGIN@30
0000s0sSympa::Scenario::::BEGIN@31Sympa::Scenario::BEGIN@31
0000s0sSympa::Scenario::::BEGIN@32Sympa::Scenario::BEGIN@32
0000s0sSympa::Scenario::::BEGIN@33Sympa::Scenario::BEGIN@33
0000s0sSympa::Scenario::::BEGIN@34Sympa::Scenario::BEGIN@34
0000s0sSympa::Scenario::::BEGIN@36Sympa::Scenario::BEGIN@36
0000s0sSympa::Scenario::::BEGIN@37Sympa::Scenario::BEGIN@37
0000s0sSympa::Scenario::::BEGIN@38Sympa::Scenario::BEGIN@38
0000s0sSympa::Scenario::::BEGIN@39Sympa::Scenario::BEGIN@39
0000s0sSympa::Scenario::::BEGIN@40Sympa::Scenario::BEGIN@40
0000s0sSympa::Scenario::::BEGIN@41Sympa::Scenario::BEGIN@41
0000s0sSympa::Scenario::::BEGIN@42Sympa::Scenario::BEGIN@42
0000s0sSympa::Scenario::::BEGIN@43Sympa::Scenario::BEGIN@43
0000s0sSympa::Scenario::::BEGIN@44Sympa::Scenario::BEGIN@44
0000s0sSympa::Scenario::::BEGIN@45Sympa::Scenario::BEGIN@45
0000s0sSympa::Scenario::::BEGIN@46Sympa::Scenario::BEGIN@46
0000s0sSympa::Scenario::::BEGIN@47Sympa::Scenario::BEGIN@47
0000s0sSympa::Scenario::::BEGIN@48Sympa::Scenario::BEGIN@48
0000s0sSympa::Scenario::::__ANON__Sympa::Scenario::__ANON__ (xsub)
0000s0sSympa::Scenario::::_compile_actionSympa::Scenario::_compile_action
0000s0sSympa::Scenario::::_compile_conditionSympa::Scenario::_compile_condition
0000s0sSympa::Scenario::::_compile_condition_termSympa::Scenario::_compile_condition_term
0000s0sSympa::Scenario::::_compile_hashrefSympa::Scenario::_compile_hashref
0000s0sSympa::Scenario::::_compile_ruleSympa::Scenario::_compile_rule
0000s0sSympa::Scenario::::_compile_scenarioSympa::Scenario::_compile_scenario
0000s0sSympa::Scenario::::_load_ldap_configurationSympa::Scenario::_load_ldap_configuration
0000s0sSympa::Scenario::::_parse_scenarioSympa::Scenario::_parse_scenario
0000s0sSympa::Scenario::::authzSympa::Scenario::authz
0000s0sSympa::Scenario::::compileSympa::Scenario::compile
0000s0sSympa::Scenario::::do_equalSympa::Scenario::do_equal
0000s0sSympa::Scenario::::do_is_editorSympa::Scenario::do_is_editor
0000s0sSympa::Scenario::::do_is_listmasterSympa::Scenario::do_is_listmaster
0000s0sSympa::Scenario::::do_is_ownerSympa::Scenario::do_is_owner
0000s0sSympa::Scenario::::do_is_subscriberSympa::Scenario::do_is_subscriber
0000s0sSympa::Scenario::::do_less_thanSympa::Scenario::do_less_than
0000s0sSympa::Scenario::::do_matchSympa::Scenario::do_match
0000s0sSympa::Scenario::::do_newerSympa::Scenario::do_newer
0000s0sSympa::Scenario::::do_olderSympa::Scenario::do_older
0000s0sSympa::Scenario::::do_searchSympa::Scenario::do_search
0000s0sSympa::Scenario::::do_verify_customSympa::Scenario::do_verify_custom
0000s0sSympa::Scenario::::do_verify_netmaskSympa::Scenario::do_verify_netmask
0000s0sSympa::Scenario::::dump_all_scenariosSympa::Scenario::dump_all_scenarios
0000s0sSympa::Scenario::::get_current_titleSympa::Scenario::get_current_title
0000s0sSympa::Scenario::::get_idSympa::Scenario::get_id
0000s0sSympa::Scenario::::get_scenariosSympa::Scenario::get_scenarios
0000s0sSympa::Scenario::::is_purely_closedSympa::Scenario::is_purely_closed
0000s0sSympa::Scenario::::message_encryptedSympa::Scenario::message_encrypted
0000s0sSympa::Scenario::::message_is_bccSympa::Scenario::message_is_bcc
0000s0sSympa::Scenario::::newSympa::Scenario::new
0000s0sSympa::Scenario::::request_actionSympa::Scenario::request_action
0000s0sSympa::Scenario::::safe_qrSympa::Scenario::safe_qr
0000s0sSympa::Scenario::::to_stringSympa::Scenario::to_string
Call graph for these subroutines as a Graphviz dot language file.
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 (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11# Copyright 2017, 2018, 2019, 2020 The Sympa Community. See the AUTHORS.md
12# file at the top-level directory of this distribution and at
13# <https://github.com/sympa-community/sympa.git>.
14#
15# This program is free software; you can redistribute it and/or modify
16# it under the terms of the GNU General Public License as published by
17# the Free Software Foundation; either version 2 of the License, or
18# (at your option) any later version.
19#
20# This program is distributed in the hope that it will be useful,
21# but WITHOUT ANY WARRANTY; without even the implied warranty of
22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23# GNU General Public License for more details.
24#
25# You should have received a copy of the GNU General Public License
26# along with this program. If not, see <http://www.gnu.org/licenses/>.
27
28package Sympa::Scenario;
29
30use strict;
31use warnings;
32use English qw(-no_match_vars);
33use Mail::Address;
34use Net::CIDR;
35
36use Sympa;
37use Conf;
38use Sympa::ConfDef;
39use Sympa::Constants;
40use Sympa::Database;
41use Sympa::Language;
42use Sympa::List;
43use Sympa::Log;
44use Sympa::Regexps;
45use Sympa::Tools::Data;
46use Sympa::Tools::File;
47use Sympa::Tools::Time;
48use Sympa::User;
49
50my $log = Sympa::Log->instance;
51
52our %all_scenarios;
53my %persistent_cache;
54
55my $picache = {};
56my $picache_refresh = 10;
57
58#FIXME: should be taken from Sympa::ListDef.
59my %list_ppath_maps = (
60 visibility => 'visibility',
61 send => 'send',
62 info => 'info',
63 subscribe => 'subscribe',
64 add => 'add',
65 unsubscribe => 'unsubscribe',
66 del => 'del',
67 invite => 'invite',
68 remind => 'remind',
69 review => 'review',
70 d_read => 'shared_doc.d_read',
71 d_edit => 'shared_doc.d_edit',
72 archive_web_access => 'archive.web_access',
73 archive_mail_access => 'archive.mail_access',
74 tracking => 'tracking.tracking',
75);
76
77#FIXME: should be taken from Sympa::ConfDef.
78my %domain_ppath_maps = (
79 create_list => 'create_list',
80 family_signoff => 'family_signoff',
81 global_remind => 'global_remind',
82 move_user => 'move_user',
83 automatic_list_creation => 'automatic_list_creation',
84 spam_status => 'spam_status',
85);
86
87# For compatibility to obsoleted use of parameter name instead of function.
88my %compat_function_maps = (
89 'shared_doc.d_read' => 'd_read',
90 'shared_doc.d_edit' => 'd_edit',
91 'archive.access' => 'archive_mail_access', # obsoleted
92 'web_archive.access' => 'archive_web_access', # obsoleted
93 'mail_access' => 'archive_mail_access', # mislead
94 'web_access' => 'archive_web_access', # mislead
95 'archive.mail_access' => 'archive_mail_access',
96 'archive.web_access' => 'archive_web_access',
97 'tracking.tracking' => 'tracking',
98);
99
100## Creates a new object
101## Supported parameters : function, robot, name, directory, file_path, options
102## Output object has the following entries : name, file_path, rules, date,
103## title, struct, data
104sub new {
105 $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
106 my $class = shift;
107 my $that = shift || $Conf::Conf{'domain'}; # List or domain
108 my $function = shift;
109 my %options = @_;
110
111 my $scenario_name_re = Sympa::Regexps::scenario_name();
112
113 # Compatibility for obsoleted use of parameter names.
114 $function = $compat_function_maps{$function} || $function;
115 die 'bug in logic. Ask developer'
116 unless defined $function and $function =~ /\A$scenario_name_re\z/;
117
118 # Determine parameter to get the name of scenario.
119 # 'include' and 'topics_visibility' functions are special: They don't
120 # have corresponding list/domain parameters.
121 my $ppath =
122 (ref $that eq 'Sympa::List')
123 ? $list_ppath_maps{$function}
124 : $domain_ppath_maps{$function};
125 unless ($function eq 'include'
126 or (ref $that ne 'Sympa::List' and $function eq 'topics_visibility')
127 or $ppath) {
128 $log->syslog('err', 'Unknown scenario function "%s"', $function);
129 return undef;
130 }
131
132 my $name;
133 if ($options{name}) {
134 $name = $options{name};
135 } elsif ($function eq 'include') {
136 # {name} option is mandatory.
137 die 'bug in logic. Ask developer';
138 } elsif (ref $that eq 'Sympa::List') {
139 #FIXME: Use Sympa::List::Config.
140 if ($ppath =~ /[.]/) {
141 my ($pname, $key) = split /[.]/, $ppath, 2;
142 $name = ($that->{'admin'}{$pname}{$key} || {})->{name}
143 if $that->{'admin'}{$pname};
144 } else {
145 $name = ($that->{'admin'}{$ppath} || {})->{name};
146 }
147 } elsif ($function eq 'topics_visibility') {
148 # {name} option is mandatory.
149 die 'bug in logic. Ask developer';
150 } else {
151 $name = Conf::get_robot_conf($that, $ppath);
152 }
153
154 unless (
155 defined $name
156 and ( $function eq 'include' and $name =~ m{\A[^/]+\z}
157 or $name =~ /\A$scenario_name_re\z/)
158 ) {
159 $log->syslog(
160 'err',
161 'Unknown or undefined scenario function "%s", scenario name "%s"',
162 $function,
163 $name
164 );
165 return undef;
166 }
167
168 my $data;
169 my $file_path = Sympa::search_fullpath(
170 $that,
171 $function . '.' . $name,
172 subdir => 'scenari'
173 );
174 if ($file_path) {
175 # Load the scenario if previously loaded in memory.
176 if ($all_scenarios{$file_path}
177 and ($options{dont_reload_scenario}
178 or Sympa::Tools::File::get_mtime($file_path) <=
179 $all_scenarios{$file_path}->{date})
180 ) {
181 return bless {
182 context => $that,
183 function => $function,
184 name => $name,
185 file_path => $file_path,
186 _scenario => $all_scenarios{$file_path}
187 } => $class;
188 }
189
190 # Get the data from file.
191 if (open my $ifh, '<', $file_path) {
192 $data = do { local $RS; <$ifh> };
193 close $ifh;
194 } else {
195 $log->syslog('err', 'Failed to open scenario file "%s": %m',
196 $file_path);
197 return undef;
198 }
199 } elsif ($function eq 'include') {
200 # include.xx not found will not raise an error message.
201 return undef;
202 } else {
203 if ($all_scenarios{"ERROR/$function.$name"}) {
204 return bless {
205 context => $that,
206 function => $function,
207 name => $name,
208 file_path => 'ERROR',
209 _scenario => $all_scenarios{"ERROR/$function.$name"}
210 } => $class;
211 }
212
213 $log->syslog('err', 'Unable to find scenario file "%s.%s"',
214 $function, $name);
215 # Default rule is rejecting always.
216 $data = 'true() smtp -> reject';
217 }
218
219 my $parsed = Sympa::Scenario::compile(
220 $that, $data,
221 function => $function,
222 file_path => $file_path
223 );
224 # Keep the scenario in memory.
225 $all_scenarios{$file_path || "ERROR/$function.$name"} = $parsed;
226
227 return bless {
228 context => $that,
229 function => $function,
230 name => $name,
231 file_path => ($file_path || 'ERROR'),
232 _scenario => $parsed,
233 } => $class;
234}
235
236sub compile {
237 my $that = shift;
238 my $data = shift;
239 my %options = @_;
240
241 my $function = $options{function};
242 my $file_path = $options{file_path};
243
244 my $parsed = _parse_scenario($data, $file_path);
245 if ($parsed and not($function and $function eq 'include')) {
246 $parsed->{compiled} = _compile_scenario($that, $function, $parsed);
247 if ($parsed->{compiled}) {
248 $parsed->{sub} = eval $parsed->{compiled};
249 # Bad syntax in compiled Perl code.
250 $log->syslog('err', '%s: %s\n', ($file_path || '(data)'),
251 $EVAL_ERROR)
252 unless ref $parsed->{sub} eq 'CODE';
253 }
254 }
255
256 return $parsed;
257}
258
259# Parse scenario rules. On failure, returns hash with empty rules.
260sub _parse_scenario {
261 $log->syslog('debug3', '(%s, %s)', @_);
262 my $data = shift;
263 my $file_path = shift;
264
265 my (%title, @rules);
266 my @lines = split /\r\n|\r|\n/, $data;
267 my $lineno = 0;
268 foreach my $line (@lines) {
269 $lineno++;
270
271 next if $line =~ /^\s*\w+\s*$/; # skip paragraph name
272 $line =~ s/\#.*$//; # remove comments
273 next if $line =~ /^\s*$/; # skip empty lines
274
275 if ($line =~ /^\s*title\.gettext\s+(.*)\s*$/i) {
276 $title{gettext} = $1;
277 next;
278 } elsif ($line =~ /^\s*title\.(\S+)\s+(.*)\s*$/i) {
279 my ($lang, $title) = ($1, $2);
280 # canonicalize lang if possible.
281 $lang = Sympa::Language::canonic_lang($lang) || $lang;
282 $title{$lang} = $title;
283 next;
284 } elsif ($line =~ /^\s*title\s+(.*)\s*$/i) {
285 $title{default} = $1;
286 next;
287 }
288
289 if ($line =~ /\s*(include\s*\(?\'?(.*)\'?\)?)\s*$/i) {
290 push @rules, {condition => $1, lineno => $lineno};
291 } elsif ($line =~
292 /^\s*(.*?)\s+((\s*(md5|pgp|smtp|smime|dkim)\s*,?)*)\s*->\s*(.*)\s*$/gi
293 ) {
294 my ($condition, $auth_methods, $action) = ($1, $2 || 'smtp', $5);
295 $auth_methods =~ s/\s//g;
296
297 push @rules,
298 {
299 condition => $condition,
300 auth_method => [split /,/, $auth_methods],
301 action => $action,
302 lineno => $lineno,
303 };
304 } else {
305 $log->syslog(
306 'err',
307 'Error parsing %s line %s: "%s"',
308 $file_path || '(file)',
309 $lineno, $line
310 );
311 @rules = ();
312 last;
313 }
314 }
315
316 my $purely_closed =
317 not
318 grep { not($_->{condition} eq 'true' and $_->{action} =~ /reject/) }
319 @rules;
320
321 return {
322 data => $data,
323 title => {%title},
324 rules => [@rules],
325 purely_closed => $purely_closed,
326 # Keep track of the current time ; used later to reload scenario files
327 # when they changed on disk
328 date => ($file_path ? time : 0),
329 };
330}
331
332sub to_string {
333 shift->{_scenario}{data};
334}
335
336sub request_action {
337 my $that = shift;
338 my $function = shift;
339 my $auth_method = shift;
340 my $context = shift;
341 my %options = @_;
342
343 my $self = Sympa::Scenario->new($that, $function, %options);
344 unless ($self) {
345 $log->syslog('err', 'Failed to load scenario for "%s"', $function);
346 return undef;
347 }
348
349 return $self->authz($auth_method, $context, %options);
350}
351
352# Old name: Sympa::Scenario::request_action().
353sub authz {
354 $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
355 my $self = shift;
356 my $auth_method = shift;
357 my $context = shift;
358 my %options = @_;
359
360 my $that = $self->{context};
361 my $function = $self->{function};
362
363 # Pending/closed lists => send/visibility are closed.
364 if ( ref $that eq 'Sympa::List'
365 and not($that->{'admin'}{'status'} eq 'open')
366 and grep { $function eq $_ } qw(send visibility)) {
367 $log->syslog('debug3', '%s rejected reason list not open', $function);
368 return {
369 action => 'reject',
370 reason => 'list-no-open',
371 auth_method => '',
372 condition => '',
373 };
374 }
375
376 # Check that authorization method is one of those known by Sympa.
377 unless ($auth_method =~ /^(smtp|md5|pgp|smime|dkim)/) { #FIXME: regex '$'
378 $log->syslog('info', 'Unknown auth method %s', $auth_method);
379 return {
380 action => 'reject',
381 reason => 'unknown-auth-method',
382 auth_method => $auth_method,
383 condition => '',
384 };
385 }
386
387 # Defining default values for parameters.
388 $context->{'sender'} ||= 'nobody';
389 $context->{'email'} ||= $context->{'sender'};
390 $context->{'remote_host'} ||= 'unknown_host';
391 $context->{'execution_date'} //= time;
392
393 if (ref $that eq 'Sympa::List') {
394 foreach my $var (@{$that->{'admin'}{'custom_vars'} || []}) {
395 $context->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
396 }
397
398 $context->{listname} = $that->{'name'};
399 $context->{domain} = $that->{'domain'};
400 # Compat.<6.2.32
401 $context->{host} = $that->{'domain'};
402 } else {
403 $context->{domain} = Conf::get_robot_conf($that || '*', 'domain');
404 }
405
406 my $sub = ($self->{_scenario} || {})->{sub};
407 my $result = eval { $sub->($that, $context, $auth_method) }
408 if ref $sub eq 'CODE';
409 # Cope with errors.
410 unless ($result) {
411 unless ($sub) {
412 $result = {reason => 'not-compiled'};
413 } elsif (ref $EVAL_ERROR eq 'HASH') {
414 $result = $EVAL_ERROR;
415 } else {
416 # Fatal error will be logged but not be exposed.
417 $log->syslog('err', 'Error in scenario %s, context %s: (%s)',
418 $self, $that, $EVAL_ERROR || 'unknown');
419 $result = {};
420 }
421 $result->{action} ||= 'reject';
422 $result->{reason} ||= 'error-performing-condition';
423 $result->{auth_method} ||= $auth_method;
424 $result->{condition} ||= 'default';
425
426 if ($result->{reason} eq 'not-compiled') {
427 $log->syslog('info', '%s: Not compiled, reject', $self);
428 } elsif ($result->{reason} eq 'no-rule-match') {
429 $log->syslog('info', '%s: No rule match, reject', $self);
430 } else {
431 $log->syslog('info', 'Error in scenario %s, context %s: (%s)',
432 $self, $that, $result->{reason});
433 Sympa::send_notify_to_listmaster($that,
434 'error_performing_condition', {error => $result->{reason}})
435 unless $options{debug};
436 }
437 return $result;
438 }
439
440 my %action = %$result;
441 # Check syntax of returned action
442 if ( $options{debug}
443 or $action{action} =~
444 /^(do_it|reject|request_auth|owner|editor|editorkey|listmaster|ham|spam|unsure)/
445 ) {
446 return {%action, auth_method => $auth_method,};
447 } else {
448 $log->syslog('err', 'Matched unknown action "%s" in scenario',
449 $action{action});
450 return {
451 action => 'reject',
452 reason => 'unknown-action',
453 auth_method => $auth_method,
454 };
455 }
456}
457
458# Old name: Sympa::Scenario::_parse_action().
459sub _compile_action {
460 my $action = shift;
461 my $condition = shift;
462
463 my %action;
464 $action{condition} = $condition if $condition;
465
466 ## reject : get parameters
467 if ($action =~ /^(ham|spam|unsure)/) {
468 $action = $1;
469 }
470 if ($action =~ /^reject(\((.+)\))?(\s?,\s?(quiet))?/) {
471 if ($4) {
472 $action = 'reject,quiet';
473 } else {
474 $action = 'reject';
475 }
476 my @param = split /,/, $2 if defined $2;
477
478 foreach my $p (@param) {
479 if ($p =~ /^reason=\'?(\w+)\'?/) {
480 $action{reason} = $1;
481 next;
482
483 } elsif ($p =~ /^tt2=\'?(\w+)\'?/) {
484 $action{tt2} = $1;
485 next;
486
487 }
488 if ($p =~ /^\'?([^'=]+)\'?/) {
489 $action{tt2} = $1;
490 # keeping existing only, not merging with reject
491 # parameters in scenarios
492 last;
493 }
494 }
495 }
496 $action{action} = $action;
497
498 return _compile_hashref({%action});
499}
500
501## check if email respect some condition
502# Old name: Sympa::Scenario::verify().
503# Deprecated: No longer used.
504#sub _verify;
505
506# Old names: (part of) Sympa::Scenario::authz().
507sub _compile_scenario {
508 $log->syslog('debug2', '(%s, %s, ...)', @_);
509 my $that = shift;
510 my $function = shift;
511 my $parsed = shift;
512
513 my @rules = @{$parsed->{rules} || []};
514
515 # Include include.<function>.header if found.
516 my $include_scenario =
517 Sympa::Scenario->new($that, 'include', name => $function . '.header')
518 if $function;
519 if ($include_scenario) {
520 # Add rules at the beginning.
521 unshift @rules, @{$include_scenario->{_scenario}{rules}};
522 }
523 # Look for 'include' directives amongst rules first.
524 foreach my $index (0 .. $#rules) {
525 if ($rules[$index]{'condition'} =~
526 /^\s*include\s*\(?\'?([\w\.]+)\'?\)?\s*$/i) {
527 my $include_file = $1;
528 my $include_scenario =
529 Sympa::Scenario->new($that, 'include', name => $include_file);
530 if ($include_scenario) {
531 # Replace the include directive with included rules.
532 splice @rules, $index, 1,
533 @{$include_scenario->{_scenario}{rules}};
534 }
535 }
536 }
537
538 ## Include a Blocklist rules if configured for this action
539 if ($function and $Conf::Conf{'blocklist'}{$function}) {
540 ## Add rules at the beginning of the array
541 unshift @rules,
542 {
543 'condition' => "search('blocklist.txt',[sender])",
544 'action' => 'reject,quiet',
545 'auth_method' => ['smtp', 'dkim', 'md5', 'pgp', 'smime'],
546 };
547 }
548
549 my @codes;
550 my %required;
551 foreach my $rule (@rules) {
552 $log->syslog(
553 'debug3',
554 'Verify rule %s, auth %s, action %s',
555 $rule->{'condition'},
556 join(',', @{$rule->{'auth_method'} || []}),
557 $rule->{'action'}
558 );
559
560 my ($code, @required) = _compile_rule($rule);
561 return undef unless defined $code; # Bad syntax.
562 push @codes, $code;
563
564 %required = (%required, map { ($_ => 1) } @required);
565 }
566
567 my $required = join "\n", map {
568 my $req;
569 if ($_ eq 'list_object') {
570 $req =
571 'die "No list context" unless ref $that eq \'Sympa::List\';';
572 } elsif ($_ eq 'message') {
573 $req = '$context->{message} ||= Sympa::Message->new("\n");';
574 } else {
575 $req = sprintf '$context->{\'%s\'} //= \'\';', $_;
576 }
577 " $req";
578 } sort keys %required;
579
580 return sprintf(<<'EOF', $required, join '', @codes);
581sub {
582 my $that = shift;
583 my $context = shift;
584 my $auth_method = shift;
585
586%s
587
588%s
589 die {reason => 'no-rule-match'};
590}
591EOF
592
593}
594
595sub _compile_rule {
596 my $rule = shift;
597
598 my ($cond, @required) = _compile_condition($rule);
599 return unless defined $cond and length $cond;
600
601 my $auth_methods = join ' ', sort @{$rule->{'auth_method'} || []};
602 my $result = _compile_action($rule->{action}, $rule->{condition});
603
604 if (1 == scalar @{$rule->{'auth_method'} || []}) {
605 return (sprintf(<<'EOF', $auth_methods, $result, $cond), @required);
606 if ($auth_method eq '%s') {
607 return %s if %s;
608 }
609EOF
610 } elsif ($auth_methods eq join(' ', sort qw(smtp dkim md5 smime))) {
611 return (sprintf(<<'EOF', $result, $cond), @required);
612 return %s if %s;
613EOF
614 } else {
615 return (sprintf(<<'EOF', $auth_methods, $result, $cond), @required);
616 if (grep {$auth_method eq $_} qw(%s)) {
617 return %s if %s;
618 }
619EOF
620 }
621}
622
623sub _compile_condition {
624 my $rule = shift;
625
626 my $condition = $rule->{condition};
627
628 unless ($condition =~
629 /(\!)?\s*(true|is_listmaster|verify_netmask|is_editor|is_owner|is_subscriber|less_than|match|equal|message|older|newer|all|search|customcondition\:\:\w+)\s*\(\s*(.*)\s*\)\s*/i
630 ) {
631 $log->syslog('err', 'Error rule syntaxe: unknown condition %s',
632 $condition);
633 return undef;
634 }
635 my $negation = ($1 and $1 eq '!') ? '!' : '';
636 my $condition_key = lc $2;
637 my $arguments = $3;
638
639 ## The expression for regexp is tricky because we don't allow the '/'
640 ## character (that indicates the end of the regexp
641 ## but we allow any number of \/ escape sequence)
642 my @args;
643 my %required_keys;
644 pos $arguments = 0;
645 while (
646 $arguments =~ m{
647 \G\s*(
648 (\[\w+(\-\>[\w\-]+)?\](\[[-+]?\d+\])?)
649 |
650 ([\w\-\.]+)
651 |
652 '[^,)]*'
653 |
654 "[^,)]*"
655 |
656 /([^/]*((\\/)*[^/]+))*/
657 |
658 (\w+)\.ldap
659 |
660 (\w+)\.sql
661 )\s*,?
662 }cgx
663 ) {
664 my $value = $1;
665
666 if ($value =~ m{\A/(.+)/\z}) {
667 my $re = $1;
668 # Fix orphan "'" and "\".
669 $re =~ s{(\\.|.)}{($1 eq "'" or $1 eq "\\")? "\\$1" : $1}eg;
670 # regexp w/o interpolates
671 unless (
672 defined
673 do { local $SIG{__DIE__}; eval sprintf "qr'%s'i", $re }
674 ) {
675 $log->syslog('err', 'Bad regexp /%s/: %s', $re, $EVAL_ERROR);
676 return undef;
677 }
678 $value = sprintf 'Sympa::Scenario::safe_qr(\'%s\', $context)',
679 $re;
680 } elsif ($value =~ /\[custom_vars\-\>([\w\-]+)\]/i) {
681 # Custom vars
682 $value = sprintf '$context->{custom_vars}{\'%s\'}', $1;
683 } elsif ($value =~ /\[family\-\>([\w\-]+)\]/i) {
684 # Family vars
685 $value = sprintf '$context->{family}{\'%s\'}', $1;
686 } elsif ($value =~ /\[conf\-\>([\w\-]+)\]/i) {
687 # Config param
688 my $conf_key = $1;
689 # Compat. < 6.2.32
690 $conf_key = 'domain' if $conf_key and $conf_key eq 'host';
691
692 if (grep { $_->{'name'} and $_->{'name'} eq $conf_key }
693 @Sympa::ConfDef::params) {
694 #FIXME: Old or obsoleted names of parameters
695 $value =
696 sprintf
697 'Conf::get_robot_conf(((ref $that eq \'Sympa::List\') ? $that->{domain} : $that), \'%s\')',
698 $conf_key;
699 } else {
700 # a condition related to a undefined context variable is
701 # always false
702 $log->syslog('err', '%s: Unknown key for [conf->%s]',
703 $conf_key);
704 $value = 'undef()';
705 }
706 } elsif ($value =~ /\[list\-\>([\w\-]+)\]/i) {
707 # List param
708 my $param = $1;
709 $required_keys{list_object} = 1;
710
711 if ($param eq 'name') {
712 $value = '$that->{name}';
713 } elsif ($param eq 'total') {
714 $value = '$that->get_total';
715 } elsif ($param eq 'address') {
716 $value = 'Sympa::get_address($that)';
717 } else {
718 my $pinfo = {%Sympa::ListDef::pinfo}; #FIXME
719
720 my $canon_param = $param;
721 if (exists $pinfo->{$param}) {
722 my $alias = $pinfo->{$param}{'obsolete'};
723 if ($alias and exists $pinfo->{$alias}) {
724 $canon_param = $alias;
725 }
726 }
727 if ( exists $pinfo->{$canon_param}
728 and ref $pinfo->{$canon_param}{format} ne 'HASH'
729 and $pinfo->{$canon_param}{occurrence} !~ /n$/) {
730 $value = sprintf '$that->{admin}{\'%s\'}', $canon_param;
731 } else {
732 $log->syslog('err',
733 'Unknown list parameter %s in rule %s',
734 $value, $condition);
735 return undef;
736 }
737 }
738 } elsif ($value =~ /\[env\-\>([\w\-]+)\]/i) {
739 my $env = $1;
740 $value = sprintf '$ENV{\'%s\'}', $env;
741 } elsif ($value =~ /\[user\-\>([\w\-]+)\]/i) {
742 # Sender's user/subscriber attributes (if subscriber)
743 my $key = $1;
744 $value =
745 sprintf
746 '($context->{user} || Sympa::User->new($context->{sender}))->{\'%s\'}',
747 $key;
748 } elsif ($value =~ /\[user_attributes\-\>([\w\-]+)\]/i) {
749 my $key = $1;
750 $value =
751 sprintf
752 '($context->{user} || Sympa::User->new($context->{sender}))->{attributes}{\'%s\'}',
753 $key;
754 } elsif ($value =~ /\[subscriber\-\>([\w\-]+)\]/i) {
755 my $key = $1;
756 $value =
757 sprintf
758 '($context->{subscriber} || $that->get_list_memner($context->{sender}) || {})->{\'%s\'}',
759 $key;
760 } elsif ($value =~
761 /\[(msg_header|header)\-\>([\w\-]+)\](?:\[([-+]?\d+)\])?/i) {
762 ## SMTP header field.
763 ## "[msg_header->field]" returns arrayref of field values,
764 ## preserving order. "[msg_header->field][index]" returns one
765 ## field value.
766 my $field_name = $2;
767 my $index = (defined $3) ? $3 + 0 : undef;
768 ## Defaulting empty or missing fields to '', so that we can
769 ## test their value in Scenario, considering that, for an
770 ## incoming message, a missing field is equivalent to an empty
771 ## field : the information it is supposed to contain isn't
772 ## available.
773 if (defined $index) {
774 $value =
775 sprintf
776 'do { my @h = $context->{message}->get_header(\'%s\'); $h[%s] // \'\' }',
777 $field_name, $index;
778 } else {
779 $value =
780 sprintf
781 'do { my @h = $context->{message}->get_header(\'%s\'); @h ? [@h] : [\'\'] }',
782 $field_name;
783 }
784 $required_keys{message} = 1;
785 } elsif ($value =~ /\[msg_body\]/i) {
786 $value = '$context->{message}->body_as_string';
787 $value =
788 sprintf
789 '((0 == index lc($context->{message}->as_entity->effective_type || "text"), "text") ? %s : undef)',
790 $value;
791 $required_keys{message} = 1;
792 } elsif ($value =~ /\[msg_part\-\>body\]/i) {
793 #FIXME:Should be recurcive...
794 $value =
795 '[map {$_->bodyhandle->as_string} grep { defined $_->bodyhandle and 0 == index ($_->effective_type || "text"), "text" } $context->{message}->as_entity->parts]';
796 $required_keys{message} = 1;
797 } elsif ($value =~ /\[msg_part\-\>type\]/i) {
798 $value =
799 '[map {$_->effective_type} $context->{message}->as_entity->parts]';
800 $required_keys{message} = 1;
801 } elsif ($value =~ /\[msg\-\>(\w+)\]/i) {
802 my $key = $1;
803 $value =
804 sprintf
805 '(exists $context->{message}{%s} ? $context->{message}{%s} : undef)',
806 $key, $key;
807 $required_keys{message} = 1;
808 } elsif ($value =~ /\[is_bcc\]/i) {
809 $value =
810 'Sympa::Scenario::message_is_bcc($that, $context->{message})';
811 $required_keys{list_object} = 1;
812 $required_keys{message} = 1;
813 } elsif ($value =~ /\[msg_encrypted\]/i) {
814 $value =
815 'Sympa::Scenario::message_encrypted($context->{message})';
816 $required_keys{message} = 1;
817 } elsif ($value =~ /\[(topic(?:_\w+)?)\]/i) {
818 # Useful only with send scenario.
819 my $key = $1;
820 $value = sprintf '$context->{%s}', $key;
821 $required_keys{$key} = 1;
822 $required_keys{message} = 1;
823 } elsif ($value =~ /\[current_date\]/i) {
824 $value = 'time()';
825 } elsif ($value =~ /\[listname\]/i) {
826 # Context should be a List from which value will be taken.
827 $value = '$that->{name}';
828 $required_keys{list_object} = 1;
829 } elsif ($value =~ /\[(\w+)\]/i) {
830 my $key = $1;
831 $value = sprintf '$context->{%s}', $key;
832 $required_keys{$key} = 1;
833 } elsif ($value =~ /^'(.*)'$/ || $value =~ /^"(.*)"$/) {
834 # Quoted string
835 my $str = $1;
836 $str =~ s{(\\.|.)}{($1 eq "'" or $1 eq "\\")? "\\\'" : $1}eg;
837 $value = sprintf "'%s'", $str;
838 } else {
839 # Texts with unknown format may be treated as the string constants
840 # for compatibility to loose parsing with earlier ver (<=6.2.48).
841 my $str = $value;
842 $str =~ s/([\\\'])/\\$1/g;
843 $value = sprintf "'%s'", $str;
844 }
845 push(@args, $value);
846 }
847
848 my $term = _compile_condition_term($rule, $condition_key, @args);
849 return unless $term;
850
851 return ("$negation$term", sort keys %required_keys);
852}
853
854sub _compile_condition_term {
855 my $rule = shift;
856 my $condition_key = shift;
857 my @args = @_;
858
859 # Getting rid of spaces.
860 $condition_key =~ s/^\s*//g;
861 $condition_key =~ s/\s*$//g;
862
863 if ($condition_key =~ /^(true|all)$/i) {
864 # condition that require 0 argument
865 if (@args) {
866 $log->syslog(
867 'err',
868 'Syntax error: Incorrect number of argument or incorrect argument syntax in %s',
869 $condition_key
870 );
871 return undef;
872 }
873 return '1';
874 } elsif ($condition_key =~ /^(is_listmaster|verify_netmask)$/) {
875 # condition that require 1 argument
876 unless (scalar @args == 1) {
877 $log->syslog('err',
878 'Syntax error: Incorrect argument number for condition %s',
879 $condition_key);
880 return undef;
881 }
882 } elsif ($condition_key =~ /^search$/o) {
883 # condition that require 1 or 2 args (search : historical reasons)
884 unless (scalar @args == 1 or scalar @args == 2) {
885 $log->syslog('err',
886 'Syntax error: Incorrect argument number for condition %s',
887 $condition_key);
888 return undef;
889 }
890 # We could search in the family if we got ref on Sympa::Family object.
891 return sprintf 'Sympa::Scenario::do_search($that, $context, %s)',
892 join ', ', @args;
893 } elsif (
894 $condition_key =~
895 # condition that require 2 args
896 /^(is_owner|is_editor|is_subscriber|less_than|match|equal|message|newer|older)$/o
897 ) {
898 unless (scalar @args == 2) {
899 $log->syslog(
900 'err',
901 'Syntax error: Incorrect argument number (%d instead of %d) for condition %s',
902 scalar(@args),
903 2,
904 $condition_key
905 );
906 return undef;
907 }
908 if ($condition_key =~ /\A(is_owner|is_editor|is_subscriber)\z/) {
909 # Interpret '[listname]' as $that.
910 $args[0] = '$that' if $args[0] eq '$that->{name}';
911 }
912 } elsif ($condition_key =~ /^customcondition::(\w+)$/) {
913 my $mod = $1;
914 return sprintf 'do_verify_custom($that, %s, \'%s\', %s)',
915 _compile_hashref($rule), $mod, join ', ', @args;
916 } else {
917 $log->syslog('err', 'Syntax error: Unknown condition %s',
918 $condition_key);
919 return undef;
920 }
921
922 return sprintf 'Sympa::Scenario::do_%s($that, \'%s\', %s)',
923 $condition_key, $condition_key, join ', ', @args;
924}
925
926sub _compile_hashref {
927 my $hashref = shift;
928
929 return '{' . join(
930 ', ',
931 map {
932 my ($k, $v) = ($_, $hashref->{$_});
933 if (ref $v eq 'ARRAY') {
934 $v = join(
935 ', ',
936 map {
937 my $i = $_;
938 $i =~ s/([\\\'])/\\$1/g;
939 "'$i'";
940 } @$v
941 );
942 sprintf '%s => [%s]', $k, $v;
943 } else {
944 $v =~ s/([\\\'])/\\$1/g;
945 sprintf "%s => '%s'", $k, $v;
946 }
947 } sort keys %$hashref
948 ) . '}';
949}
950
951sub message_is_bcc {
952 my $that = shift;
953 my $message = shift;
954
955 return '' unless $message;
956 #FIXME: need more accurate test.
957 return (
958 0 <= index(
959 lc join(', ',
960 $message->get_header('To'),
961 $message->get_header('Cc')),
962 lc $that->{'name'}
963 )
964 ) ? 0 : 1;
965}
966
967sub message_encrypted {
968 my $message = shift;
969
970 return ($message and $message->{smime_crypted}) ? 'smime' : '';
971}
972
973sub safe_qr {
974 my $re = shift;
975 my $context = shift;
976
977 my $domain = $context->{domain};
978 $domain =~ s/[.]/[.]/g;
979 $re =~ s/[[](domain|host)[]]/$domain/g;
980 return do { local $SIG{__DIE__}; eval sprintf "qr'%s'i", $re };
981}
982
983##### condition : true
984
985##### condition is_listmaster
986sub do_is_listmaster {
987 my $that = shift;
988 my $condition_key = shift;
989 my @args = @_;
990
991 return 0 if not ref $args[0] and $args[0] eq 'nobody';
992
993 my @arg;
994 my $ok = undef;
995 if (ref $args[0] eq 'ARRAY') {
996 @arg = map { $_->address }
997 grep {$_} map { (Mail::Address->parse($_)) } @{$args[0]};
998 } else {
999 @arg = map { $_->address }
1000 grep {$_} Mail::Address->parse($args[0]);
1001 }
1002 foreach my $arg (@arg) {
1003 if (Sympa::is_listmaster($that, $arg)) {
1004 $ok = $arg;
1005 last;
1006 }
1007 }
1008
1009 return $ok ? 1 : 0;
1010}
1011
1012##### condition verify_netmask
1013sub do_verify_netmask {
1014 my $that = shift;
1015 my $condition_key = shift;
1016 my @args = @_;
1017 ## Check that the IP address of the client is available
1018 ## Means we are in a web context
1019 # always skip this rule because we can't evaluate it.
1020 return 0 unless defined $ENV{'REMOTE_ADDR'};
1021
1022 my @cidr;
1023 if ($args[0] eq 'default' or $args[0] eq 'any') {
1024 # Compatibility with Net::Netmask, adding IPv6 feature.
1025 @cidr = ('0.0.0.0/0', '::/0');
1026 } else {
1027 if ($args[0] =~ /\A(\d+\.\d+\.\d+\.\d+):(\d+\.\d+\.\d+\.\d+)\z/) {
1028 # Compatibility with Net::Netmask.
1029 eval { @cidr = Net::CIDR::range2cidr("$1/$2"); };
1030 } else {
1031 eval { @cidr = Net::CIDR::range2cidr($args[0]); };
1032 }
1033 if ($@ or scalar(@cidr) != 1) {
1034 # Compatibility with Net::Netmask: Should be single range.
1035 @cidr = ();
1036 } else {
1037 @cidr = grep { Net::CIDR::cidrvalidate($_) } @cidr;
1038 }
1039 }
1040 unless (@cidr) {
1041 $log->syslog('err', 'Error rule syntax: failed to parse netmask "%s"',
1042 $args[0]);
1043 die {};
1044 }
1045
1046 $log->syslog('debug3', 'REMOTE_ADDR %s against %s',
1047 $ENV{'REMOTE_ADDR'}, $args[0]);
1048 return Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @cidr) ? 1 : 0;
1049}
1050
1051##### condition older
1052sub do_older {
1053 $log->syslog('debug3', '(%s,%s,%s,%s)', @_);
1054 my $that = shift;
1055 my $condition_key = shift;
1056 my @args = @_;
1057
1058 my $arg0 = Sympa::Tools::Time::epoch_conv($args[0]);
1059 my $arg1 = Sympa::Tools::Time::epoch_conv($args[1]);
1060
1061 if ($condition_key eq 'older') {
1062 return ($arg0 <= $arg1) ? 1 : 0;
1063 } else {
1064 return ($arg0 > $arg1) ? 1 : 0;
1065 }
1066}
1067
1068sub do_newer {
1069 goto &do_older;
1070}
1071
1072##### condition is_owner, is_subscriber and is_editor
1073sub do_is_owner {
1074 my $that = shift;
1075 my $condition_key = shift;
1076 my @args = @_;
1077
1078 return 0 if $args[1] eq 'nobody';
1079
1080 # The list is local or in another local robot
1081 my $list;
1082 if (ref $args[0] eq 'Sympa::List') {
1083 $list = $args[0];
1084 } elsif ($args[0] =~ /\@/) {
1085 $list = Sympa::List->new($args[0]);
1086 } else {
1087 my $robot = (ref $that eq 'Sympa::List') ? $that->{'domain'} : $that;
1088 $list = Sympa::List->new($args[0], $robot);
1089 }
1090
1091 unless ($list) {
1092 $log->syslog('err', 'Unable to create list object "%s"', $args[0]);
1093 return 0;
1094 }
1095
1096 my @arg;
1097 my $ok = undef;
1098 if (ref $args[1] eq 'ARRAY') {
1099 @arg = map { $_->address }
1100 grep {$_} map { (Mail::Address->parse($_)) } @{$args[1]};
1101 } else {
1102 @arg = map { $_->address }
1103 grep {$_} Mail::Address->parse($args[1]);
1104 }
1105
1106 if ($condition_key eq 'is_subscriber') {
1107 foreach my $arg (@arg) {
1108 if ($list->is_list_member($arg)) {
1109 $ok = $arg;
1110 last;
1111 }
1112 }
1113 return $ok ? 1 : 0;
1114 } elsif ($condition_key eq 'is_owner') {
1115 foreach my $arg (@arg) {
1116 if ($list->is_admin('owner', $arg)
1117 or Sympa::is_listmaster($list, $arg)) {
1118 $ok = $arg;
1119 last;
1120 }
1121 }
1122 return $ok ? 1 : 0;
1123 } elsif ($condition_key eq 'is_editor') {
1124 foreach my $arg (@arg) {
1125 if ($list->is_admin('actual_editor', $arg)) {
1126 $ok = $arg;
1127 last;
1128 }
1129 }
1130 return $ok ? 1 : 0;
1131 }
1132}
1133
1134sub do_is_subscriber {
1135 goto &do_is_owner;
1136}
1137
1138sub do_is_editor {
1139 goto &do_is_owner;
1140}
1141
1142##### match
1143sub do_match {
1144 $log->syslog('debug3', '(%s,%s,%s,%s)', @_);
1145 my $that = shift;
1146 my $condition_key = shift;
1147 my @args = @_;
1148
1149 # Nothing can match an empty regexp.
1150 return 0 unless length $args[1];
1151
1152 # wrap matches with eval{} to avoid crash by malformed regexp.
1153 my $r = 0;
1154 if (ref $args[0] eq 'ARRAY') {
1155 eval {
1156 foreach my $arg (@{$args[0]}) {
1157 if ($arg =~ /$args[1]/i) {
1158 $r = 1;
1159 last;
1160 }
1161 }
1162 };
1163 } else {
1164 eval {
1165 if ($args[0] =~ /$args[1]/i) {
1166 $r = 1;
1167 }
1168 };
1169 }
1170 if ($EVAL_ERROR) {
1171 $log->syslog('err', 'Cannot evaluate match: %s', $EVAL_ERROR);
1172 return undef;
1173 }
1174 return $r ? 1 : 0;
1175}
1176
1177## search rule
1178
1179## equal
1180sub do_equal {
1181 $log->syslog('debug3', '(%s,%s,...)', @_);
1182 my $that = shift;
1183 my $condition_key = shift;
1184 my @args = @_;
1185 if (ref $args[0]) {
1186 foreach my $arg (@{$args[0]}) {
1187 return 1 if lc $arg eq lc $args[1];
1188 }
1189 } elsif (lc $args[0] eq lc $args[1]) {
1190 return 1;
1191 }
1192 return 0;
1193}
1194
1195## custom perl module
1196
1197## less_than
1198sub do_less_than {
1199 $log->syslog('debug3', '(%s,%s,,,,)', @_);
1200 my $that = shift;
1201 my $condition_key = shift;
1202 my @args = @_;
1203 if (ref $args[0]) {
1204 foreach my $arg (@{$args[0]}) {
1205 return 1 if Sympa::Tools::Data::smart_lessthan($arg, $args[1]);
1206 }
1207 } else {
1208 return 1 if Sympa::Tools::Data::smart_lessthan($args[0], $args[1]);
1209 }
1210
1211 return 0;
1212}
1213
1214# Verify if a given user is part of an LDAP, SQL or TXT search filter
1215# We could search in the family if we got ref on Sympa::Family object.
1216# Old name: Sympa::Scenario::search(), Sympa::Scenario::_search().
1217sub do_search {
1218 $log->syslog('debug2', '(%s, %s, %s)', @_);
1219 my $that = shift; # List, Family or Robot
1220 my $context = shift;
1221 my $filter_file = shift;
1222
1223 my $sender = $context->{'sender'};
1224
1225 if ($filter_file =~ /\.sql$/) {
1226
1227 my $file = Sympa::search_fullpath($that, $filter_file,
1228 subdir => 'search_filters');
1229
1230 my $timeout = 3600;
1231 my $sql_conf;
1232 my $time = time;
1233
1234 unless ($sql_conf = Conf::load_sql_filter($file)) {
1235 $that->send_notify_to_owner('bad_named_filter',
1236 {'filter' => $filter_file})
1237 if ref $that eq 'Sympa::List';
1238 die {};
1239 }
1240
1241 my $statement = $sql_conf->{'sql_named_filter_query'}->{'statement'};
1242 my $filter = $statement;
1243 my @statement_args; ## Useful to later quote parameters
1244
1245 ## Minimalist variable parser ; only parse [x] or [x->y]
1246 ## should be extended with the code from _verify()
1247 while ($filter =~ /\[(\w+(\-\>[\w\-]+)?)\]/x) {
1248 my ($full_var) = ($1);
1249 my ($var, $key) = split /\-\>/, $full_var;
1250
1251 unless (defined $context->{$var}) {
1252 $log->syslog('err',
1253 'Failed to parse variable "%s" in filter "%s"',
1254 $var, $file);
1255 die {};
1256 }
1257
1258 if (defined $key) { ## Should be a hash
1259 unless (defined $context->{$var}{$key}) {
1260 $log->syslog('err',
1261 'Failed to parse variable "%s.%s" in filter "%s"',
1262 $var, $key, $file);
1263 die {};
1264 }
1265
1266 $filter =~ s/\[$full_var\]/$context->{$var}{$key}/;
1267 $statement =~ s/\[$full_var\]/?/;
1268 push @statement_args, $context->{$var}{$key};
1269 } else { ## Scalar
1270 $filter =~ s/\[$full_var\]/$context->{$var}/;
1271 $statement =~ s/\[$full_var\]/?/;
1272 push @statement_args, $context->{$var};
1273
1274 }
1275 }
1276
1277 # $statement =~ s/\[sender\]/?/g;
1278 # $filter =~ s/\[sender\]/$sender/g;
1279
1280 if (defined($persistent_cache{'named_filter'}{$filter_file}{$filter})
1281 && (time <=
1282 $persistent_cache{'named_filter'}{$filter_file}{$filter}
1283 {'update'} + $timeout)
1284 ) { ## Cache has 1hour lifetime
1285 $log->syslog('notice', 'Using previous SQL named filter cache');
1286 return $persistent_cache{'named_filter'}{$filter_file}{$filter}
1287 {'value'};
1288 }
1289
1290 my $db = Sympa::Database->new(
1291 $sql_conf->{'sql_named_filter_query'}->{db_type},
1292 %{$sql_conf->{'sql_named_filter_query'}}
1293 );
1294 unless ($db and $db->connect()) {
1295 $log->syslog('notice',
1296 'Unable to connect to the SQL server %s', $db);
1297 die {};
1298 }
1299
1300 my $sth;
1301 unless ($sth = $db->do_prepared_query($statement, @statement_args)) {
1302 $log->syslog('debug', '%s named filter cancelled', $file);
1303 die {};
1304 }
1305
1306 my $res = $sth->fetchall_arrayref; #FIXME: Check timeout.
1307 $db->disconnect();
1308 my $first_row = ref($res->[0]) ? $res->[0]->[0] : $res->[0];
1309 $log->syslog('debug2', 'Result of SQL query: %d = %s',
1310 $first_row, $statement);
1311
1312 if ($first_row == 0) {
1313 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'value'}
1314 = 0;
1315 } else {
1316 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'value'}
1317 = 1;
1318 }
1319 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'update'} =
1320 time;
1321 return $persistent_cache{'named_filter'}{$filter_file}{$filter}
1322 {'value'};
1323
1324 } elsif ($filter_file =~ /\.ldap$/) {
1325 ## Determine full path of the filter file
1326 my $file = Sympa::search_fullpath($that, $filter_file,
1327 subdir => 'search_filters');
1328
1329 unless ($file) {
1330 $log->syslog('err', 'Could not find search filter %s',
1331 $filter_file);
1332 die {};
1333 }
1334 my $timeout = 3600;
1335 my %ldap_conf = _load_ldap_configuration($file);
1336
1337 die {} unless %ldap_conf;
1338
1339 my $filter = $ldap_conf{'filter'};
1340
1341 ## Minimalist variable parser ; only parse [x] or [x->y]
1342 ## should be extended with the code from _verify()
1343 while ($filter =~ /\[(\w+(\-\>[\w\-]+)?)\]/x) {
1344 my ($full_var) = ($1);
1345 my ($var, $key) = split /\-\>/, $full_var;
1346
1347 unless (defined $context->{$var}) {
1348 $log->syslog('err',
1349 'Failed to parse variable "%s" in filter "%s"',
1350 $var, $file);
1351 die {};
1352 }
1353
1354 if (defined $key) { ## Should be a hash
1355 unless (defined $context->{$var}{$key}) {
1356 $log->syslog('err',
1357 'Failed to parse variable "%s.%s" in filter "%s"',
1358 $var, $key, $file);
1359 die {};
1360 }
1361
1362 $filter =~ s/\[$full_var\]/$context->{$var}{$key}/;
1363 } else { ## Scalar
1364 $filter =~ s/\[$full_var\]/$context->{$var}/;
1365
1366 }
1367 }
1368
1369 # $filter =~ s/\[sender\]/$sender/g;
1370
1371 if (defined($persistent_cache{'named_filter'}{$filter_file}{$filter})
1372 && (time <=
1373 $persistent_cache{'named_filter'}{$filter_file}{$filter}
1374 {'update'} + $timeout)
1375 ) { ## Cache has 1hour lifetime
1376 $log->syslog('notice', 'Using previous LDAP named filter cache');
1377 return $persistent_cache{'named_filter'}{$filter_file}{$filter}
1378 {'value'};
1379 }
1380
1381 my $db = Sympa::Database->new('LDAP', %ldap_conf);
1382 unless ($db and $db->connect) {
1383 $log->syslog('err', 'Unable to connect to the LDAP server "%s"',
1384 $ldap_conf{'host'});
1385 die {};
1386 }
1387
1388 ## The 1.1 OID correponds to DNs ; it prevents the LDAP server from
1389 ## preparing/providing too much data
1390 my $mesg = $db->do_operation(
1391 'search',
1392 base => "$ldap_conf{'suffix'}",
1393 filter => "$filter",
1394 scope => "$ldap_conf{'scope'}",
1395 attrs => ['1.1']
1396 );
1397 unless ($mesg) {
1398 $log->syslog('err', "Unable to perform LDAP search");
1399 die {};
1400 }
1401
1402 if ($mesg->count() == 0) {
1403 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'value'}
1404 = 0;
1405
1406 } else {
1407 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'value'}
1408 = 1;
1409 }
1410
1411 $db->disconnect()
1412 or $log->syslog('notice', 'Unbind impossible');
1413 $persistent_cache{'named_filter'}{$filter_file}{$filter}{'update'} =
1414 time;
1415
1416 return $persistent_cache{'named_filter'}{$filter_file}{$filter}
1417 {'value'};
1418
1419 } elsif ($filter_file =~ /\.txt$/) {
1420 # $log->syslog('info', 'Eval %s', $filter_file);
1421 my @files = Sympa::search_fullpath(
1422 $that, $filter_file,
1423 subdir => 'search_filters',
1424 'order' => 'all'
1425 );
1426
1427 ## Raise an error except for blocklist.txt
1428 unless (@files) {
1429 if ($filter_file eq 'blocklist.txt') {
1430 return 0;
1431 } else {
1432 $log->syslog('err', 'Could not find search filter %s',
1433 $filter_file);
1434 die {};
1435 }
1436 }
1437
1438 my $sender = lc($sender);
1439 foreach my $file (@files) {
1440 $log->syslog('debug3', 'Found file %s', $file);
1441 my $ifh;
1442 unless (open $ifh, '<', $file) {
1443 $log->syslog('err', 'Could not open file %s', $file);
1444 die {};
1445 }
1446 while (my $pattern = <$ifh>) {
1447 next if $pattern =~ /\A\s*\z/ or $pattern =~ /\A[#;]/;
1448 chomp $pattern;
1449 $pattern =~ s/([^\w\x80-\xFF])/\\$1/g;
1450 $pattern =~ s/\\\*/.*/;
1451 if ($sender =~ /^$pattern$/i) {
1452 close $ifh;
1453 return 1;
1454 }
1455 }
1456 close $ifh;
1457 }
1458 return 0;
1459 } else {
1460 $log->syslog('err', "Unknown filter file type %s", $filter_file);
1461 die {};
1462 }
1463}
1464
1465# eval a custom perl module to verify a scenario condition
1466# Old name: Sympa::Scenario::_verify_custom().
1467sub do_verify_custom {
1468 $log->syslog('debug3', '(%s, %s, %s, ...)', @_);
1469 my $that = shift;
1470 my $rule = shift;
1471 my $condition = shift;
1472 my @args = @_;
1473
1474 my $timeout = 3600;
1475
1476 my $filter = join('*', @args);
1477 if (defined($persistent_cache{'named_filter'}{$condition}{$filter})
1478 && (time <=
1479 $persistent_cache{'named_filter'}{$condition}{$filter}{'update'}
1480 + $timeout)
1481 ) { ## Cache has 1hour lifetime
1482 $log->syslog('notice', 'Using previous custom condition cache %s',
1483 $filter);
1484 return $persistent_cache{'named_filter'}{$condition}{$filter}
1485 {'value'};
1486 }
1487
1488 # use this if your want per list customization (be sure you know what you
1489 # are doing)
1490 #my $file = Sympa::search_fullpath($that, $condition . '.pm',
1491 # subdir => 'custom_conditions');
1492 my $robot = (ref $that eq 'Sympa::List') ? $that->{'domain'} : $that;
1493 my $file = Sympa::search_fullpath(
1494 $robot,
1495 $condition . '.pm',
1496 subdir => 'custom_conditions'
1497 );
1498 unless ($file) {
1499 $log->syslog('err', 'No module found for %s custom condition',
1500 $condition);
1501 die {};
1502 }
1503 $log->syslog('notice', 'Use module %s for custom condition', $file);
1504 eval { require "$file"; };
1505 if ($EVAL_ERROR) {
1506 $log->syslog('err', 'Error requiring %s: %s (%s)',
1507 $condition, "$EVAL_ERROR", ref $EVAL_ERROR);
1508 die {};
1509 }
1510 my $res = do {
1511 local $_ = $rule;
1512 eval sprintf 'CustomCondition::%s::verify(@args)', $condition;
1513 };
1514 if ($EVAL_ERROR) {
1515 $log->syslog('err', 'Error evaluating %s: %s (%s)',
1516 $condition, "$EVAL_ERROR", ref $EVAL_ERROR);
1517 die {};
1518 }
1519
1520 die {} unless defined $res;
1521
1522 $persistent_cache{'named_filter'}{$condition}{$filter}{'value'} =
1523 ($res == 1 ? 1 : 0);
1524 $persistent_cache{'named_filter'}{$condition}{$filter}{'update'} = time;
1525 return $persistent_cache{'named_filter'}{$condition}{$filter}{'value'};
1526}
1527
1528# NEVER USED.
1529sub dump_all_scenarios {
1530 open my $ofh, '>', '/tmp/all_scenarios';
1531 Sympa::Tools::Data::dump_var(\%all_scenarios, 0, $ofh);
1532 close $ofh;
1533}
1534
1535sub get_current_title {
1536 my $self = shift;
1537
1538 my $hash = $self->{_scenario};
1539 my $language = Sympa::Language->instance;
1540
1541 foreach my $lang (Sympa::Language::implicated_langs($language->get_lang))
1542 {
1543 if (exists $hash->{title}{$lang}) {
1544 return $hash->{title}{$lang};
1545 }
1546 }
1547 if (exists $hash->{title}{gettext}) {
1548 return $language->gettext($hash->{title}{gettext});
1549 } elsif (exists $hash->{title}{default}) {
1550 return $hash->{title}{default};
1551 } else {
1552 return $self->{name};
1553 }
1554}
1555
1556sub is_purely_closed {
1557 shift->{_scenario}{purely_closed};
1558}
1559
1560## Loads and parses the configuration file. Reports errors if any.
1561sub _load_ldap_configuration {
1562 $log->syslog('debug3', '(%s)', @_);
1563 my $config = shift;
1564
1565 my $line_num = 0;
1566 my $config_err = 0;
1567 my ($i, %o);
1568
1569 ## Open the configuration file or return and read the lines.
1570 my $ifh;
1571 unless (open $ifh, '<', $config) {
1572 $log->syslog('err', 'Unable to open %s: %m', $config);
1573 return;
1574 }
1575
1576 my @valid_options = qw(host suffix filter scope bind_dn bind_password
1577 use_tls ssl_version ssl_ciphers ssl_cert ssl_key
1578 ca_verify ca_path ca_file);
1579 my @required_options = qw(host suffix filter);
1580
1581 my %valid_options = map { $_ => 1 } @valid_options;
1582 my %required_options = map { $_ => 1 } @required_options;
1583
1584 my %Default_Conf = (
1585 'host' => undef,
1586 'suffix' => undef,
1587 'filter' => undef,
1588 'scope' => 'sub',
1589 'bind_dn' => undef,
1590 'bind_password' => undef
1591 );
1592
1593 my %Ldap = ();
1594
1595 my $folded_line;
1596 while (my $current_line = <$ifh>) {
1597 $line_num++;
1598 next if ($current_line =~ /^\s*$/o || $current_line =~ /^[\#\;]/o);
1599
1600 ## Cope with folded line (ending with '\')
1601 if ($current_line =~ /\\\s*$/) {
1602 $current_line =~ s/\\\s*$//; ## remove trailing \
1603 chomp $current_line;
1604 $folded_line .= $current_line;
1605 next;
1606 } elsif (defined $folded_line) {
1607 $current_line = $folded_line . $current_line;
1608 $folded_line = undef;
1609 }
1610
1611 if ($current_line =~ /^(\S+)\s+(.+)$/io) {
1612 my ($keyword, $value) = ($1, $2);
1613 $value =~ s/\s*$//;
1614
1615 $o{$keyword} = [$value, $line_num];
1616 } else {
1617 #printf STDERR Msg(1, 3, "Malformed line %d: %s"), $config, $_;
1618 $config_err++;
1619 }
1620 }
1621 close $ifh;
1622
1623 ## Check if we have unknown values.
1624 foreach $i (sort keys %o) {
1625 $Ldap{$i} = $o{$i}[0] || $Default_Conf{$i};
1626
1627 unless ($valid_options{$i}) {
1628 $log->syslog('err', 'Line %d, unknown field: %s', $o{$i}[1], $i);
1629 $config_err++;
1630 }
1631 }
1632 ## Do we have all required values ?
1633 foreach $i (keys %required_options) {
1634 unless (defined $o{$i} or defined $Default_Conf{$i}) {
1635 $log->syslog('err', 'Required field not found: %s', $i);
1636 $config_err++;
1637 next;
1638 }
1639 }
1640 return %Ldap;
1641}
1642
1643# Loads all scenari for an function
1644# Old name: Sympa::List::load_scenario_list() which returns hashref.
1645sub get_scenarios {
1646 $log->syslog('debug3', '(%s, %s)', @_);
1647 my $that = shift;
1648 my $function = shift;
1649
1650 my @scenarios;
1651
1652 my %seen;
1653 my %skipped;
1654 my @paths = @{Sympa::get_search_path($that, subdir => 'scenari')};
1655 #XXXunshift @list_of_scenario_dir, $that->{'dir'} . '/scenari';
1656
1657 my $scenario_re = Sympa::Regexps::scenario_name();
1658 foreach my $dir (@paths) {
1659 next unless -d $dir;
1660
1661 while (<$dir/$function.*:ignore>) {
1662 if (/$function\.($scenario_re):ignore$/) {
1663 my $name = $1;
1664 $skipped{$name} = 1;
1665 }
1666 }
1667
1668 while (<$dir/$function.*>) {
1669 next unless /$function\.($scenario_re)$/;
1670 my $name = $1;
1671
1672 # Ignore default setting on <= 6.2.40, using symbolic link.
1673 next if $name eq 'default' and -l "$dir/$function.$name";
1674
1675 next if $seen{$name};
1676 next if $skipped{$name};
1677
1678 my $scenario =
1679 Sympa::Scenario->new($that, $function, name => $name);
1680 $seen{$name} = 1;
1681 next unless (defined $scenario);
1682
1683 push @scenarios, $scenario;
1684 }
1685 }
1686
1687 return [@scenarios];
1688}
1689
1690sub get_id {
1691 my $self = shift;
1692 sprintf '%s.%s;%s', @{$self}{qw(function name file_path)};
1693}
1694
16951;
1696__END__