Scenario.pm 58.1 KB
Newer Older
1
2
3
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$
4
5

# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11
12
# Copyright 2017, 2018, 2019, 2020, 2021 The Sympa Community. See the
# AUTHORS.md file at the top-level directory of this distribution and at
13
# <https://github.com/sympa-community/sympa.git>.
14
15
16
17
18
19
20
21
22
23
24
25
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
26
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
27

28
package Sympa::Scenario;
29
30

use strict;
31
use warnings;
32
use English qw(-no_match_vars);
33
use Mail::Address;
sikeda's avatar
sikeda committed
34
use Net::CIDR;
35

36
use Sympa;
37
use Conf;
38
use Sympa::ConfDef;
39
use Sympa::Constants;
40
use Sympa::Database;
41
use Sympa::Language;
42
use Sympa::List;
43
use Sympa::Log;
44
use Sympa::Regexps;
45
46
47
use Sympa::Tools::Data;
use Sympa::Tools::File;
use Sympa::Tools::Time;
48
use Sympa::User;
49

50
51
my $log = Sympa::Log->instance;

52
our %all_scenarios;
53
54
my %persistent_cache;

Luc Didry's avatar
Luc Didry committed
55
my $picache         = {};
56
57
my $picache_refresh = 10;

58
#FIXME: should be taken from Sympa::ListDef.
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
my %list_ppath_maps = (
    visibility          => 'visibility',
    send                => 'send',
    info                => 'info',
    subscribe           => 'subscribe',
    add                 => 'add',
    unsubscribe         => 'unsubscribe',
    del                 => 'del',
    invite              => 'invite',
    remind              => 'remind',
    review              => 'review',
    d_read              => 'shared_doc.d_read',
    d_edit              => 'shared_doc.d_edit',
    archive_web_access  => 'archive.web_access',
    archive_mail_access => 'archive.mail_access',
    tracking            => 'tracking.tracking',
);

77
#FIXME: should be taken from Sympa::ConfDef.
78
79
my %domain_ppath_maps = (
    create_list             => 'create_list',
80
    family_signoff          => 'family_signoff',
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
    global_remind           => 'global_remind',
    move_user               => 'move_user',
    automatic_list_creation => 'automatic_list_creation',
    spam_status             => 'spam_status',
);

# For compatibility to obsoleted use of parameter name instead of function.
my %compat_function_maps = (
    'shared_doc.d_read'   => 'd_read',
    'shared_doc.d_edit'   => 'd_edit',
    'archive.access'      => 'archive_mail_access',    # obsoleted
    'web_archive.access'  => 'archive_web_access',     # obsoleted
    'mail_access'         => 'archive_mail_access',    # mislead
    'web_access'          => 'archive_web_access',     # mislead
    'archive.mail_access' => 'archive_mail_access',
    'archive.web_access'  => 'archive_web_access',
    'tracking.tracking'   => 'tracking',
);

100
101
## Creates a new object
## Supported parameters : function, robot, name, directory, file_path, options
102
103
## Output object has the following entries : name, file_path, rules, date,
## title, struct, data
104
sub new {
105
106
107
108
109
110
    $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
    my $class    = shift;
    my $that     = shift || $Conf::Conf{'domain'};    # List or domain
    my $function = shift;
    my %options  = @_;

111
112
    my $scenario_name_re = Sympa::Regexps::scenario_name();

113
114
    # Compatibility for obsoleted use of parameter names.
    $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
119
120
121
122
123
124
125
126
127

    # Determine parameter to get the name of scenario.
    # 'include' and 'topics_visibility' functions are special: They don't
    # have corresponding list/domain parameters.
    my $ppath =
        (ref $that eq 'Sympa::List')
        ? $list_ppath_maps{$function}
        : $domain_ppath_maps{$function};
    unless ($function eq 'include'
        or (ref $that ne 'Sympa::List' and $function eq 'topics_visibility')
        or $ppath) {
128
        $log->syslog('err', 'Unknown scenario function "%s"', $function);
129
        return undef;
130
131
    }

132
133
134
135
136
137
138
139
140
141
142
143
144
145
    my $name;
    if ($options{name}) {
        $name = $options{name};
    } elsif ($function eq 'include') {
        # {name} option is mandatory.
        die 'bug in logic. Ask developer';
    } elsif (ref $that eq 'Sympa::List') {
        #FIXME: Use Sympa::List::Config.
        if ($ppath =~ /[.]/) {
            my ($pname, $key) = split /[.]/, $ppath, 2;
            $name = ($that->{'admin'}{$pname}{$key} || {})->{name}
                if $that->{'admin'}{$pname};
        } else {
            $name = ($that->{'admin'}{$ppath} || {})->{name};
146
        }
147
148
149
    } elsif ($function eq 'topics_visibility') {
        # {name} option is mandatory.
        die 'bug in logic. Ask developer';
150
    } else {
151
        $name = Conf::get_robot_conf($that, $ppath);
152
    }
153
154
155
156

    unless (
        defined $name
        and (  $function eq 'include' and $name =~ m{\A[^/]+\z}
157
            or $name =~ /\A$scenario_name_re\z/)
158
    ) {
Luc Didry's avatar
Luc Didry committed
159
160
161
162
163
164
        $log->syslog(
            'err',
            'Unknown or undefined scenario function "%s", scenario name "%s"',
            $function,
            $name
        );
165
        return undef;
166
167
    }

168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
    my $data;
    my $file_path = Sympa::search_fullpath(
        $that,
        $function . '.' . $name,
        subdir => 'scenari'
    );
    if ($file_path) {
        # Load the scenario if previously loaded in memory.
        if ($all_scenarios{$file_path}
            and ($options{dont_reload_scenario}
                or Sympa::Tools::File::get_mtime($file_path) <=
                $all_scenarios{$file_path}->{date})
        ) {
            return bless {
                context   => $that,
                function  => $function,
                name      => $name,
                file_path => $file_path,
                _scenario => $all_scenarios{$file_path}
            } => $class;
        }

        # Get the data from file.
        if (open my $ifh, '<', $file_path) {
            $data = do { local $RS; <$ifh> };
            close $ifh;
        } else {
            $log->syslog('err', 'Failed to open scenario file "%s": %m',
                $file_path);
197
198
            return undef;
        }
199
200
    } elsif ($function eq 'include') {
        # include.xx not found will not raise an error message.
201
202
        return undef;
    } else {
203
204
205
206
207
208
209
210
211
212
213
214
215
216
        if ($all_scenarios{"ERROR/$function.$name"}) {
            return bless {
                context   => $that,
                function  => $function,
                name      => $name,
                file_path => 'ERROR',
                _scenario => $all_scenarios{"ERROR/$function.$name"}
            } => $class;
        }

        $log->syslog('err', 'Unable to find scenario file "%s.%s"',
            $function, $name);
        # Default rule is rejecting always.
        $data = 'true() smtp -> reject';
217
218
    }

IKEDA Soji's avatar
IKEDA Soji committed
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
    my $parsed = Sympa::Scenario::compile(
        $that, $data,
        function  => $function,
        file_path => $file_path
    );
    # Keep the scenario in memory.
    $all_scenarios{$file_path || "ERROR/$function.$name"} = $parsed;

    return bless {
        context   => $that,
        function  => $function,
        name      => $name,
        file_path => ($file_path || 'ERROR'),
        _scenario => $parsed,
    } => $class;
}

sub compile {
    my $that    = shift;
    my $data    = shift;
    my %options = @_;

    my $function  = $options{function};
    my $file_path = $options{file_path};

244
    my $parsed = _parse_scenario($data, $file_path);
IKEDA Soji's avatar
IKEDA Soji committed
245
    if ($parsed and not($function and $function eq 'include')) {
246
247
248
        $parsed->{compiled} = _compile_scenario($that, $function, $parsed);
        if ($parsed->{compiled}) {
            $parsed->{sub} = eval $parsed->{compiled};
249
            # Bad syntax in compiled Perl code.
250
251
252
            $log->syslog('err', '%s: %s\n', ($file_path || '(data)'),
                $EVAL_ERROR)
                unless ref $parsed->{sub} eq 'CODE';
253
254
        }
    }
255

IKEDA Soji's avatar
IKEDA Soji committed
256
    return $parsed;
257
258
}

259
# Parse scenario rules.  On failure, returns hash with empty rules.
260
sub _parse_scenario {
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
    $log->syslog('debug3', '(%s, %s)', @_);
    my $data      = shift;
    my $file_path = shift;

    my (%title, @rules);
    my @lines = split /\r\n|\r|\n/, $data;
    my $lineno = 0;
    foreach my $line (@lines) {
        $lineno++;

        next if $line =~ /^\s*\w+\s*$/;    # skip paragraph name
        $line =~ s/\#.*$//;                # remove comments
        next if $line =~ /^\s*$/;          # skip empty lines

        if ($line =~ /^\s*title\.gettext\s+(.*)\s*$/i) {
            $title{gettext} = $1;
277
            next;
278
        } elsif ($line =~ /^\s*title\.(\S+)\s+(.*)\s*$/i) {
279
280
281
            my ($lang, $title) = ($1, $2);
            # canonicalize lang if possible.
            $lang = Sympa::Language::canonic_lang($lang) || $lang;
282
            $title{$lang} = $title;
283
            next;
284
285
        } elsif ($line =~ /^\s*title\s+(.*)\s*$/i) {
            $title{default} = $1;
286
287
288
            next;
        }

289
290
291
        if ($line =~ /\s*(include\s*\(?\'?(.*)\'?\)?)\s*$/i) {
            push @rules, {condition => $1, lineno => $lineno};
        } elsif ($line =~
292
            /^\s*(.*?)\s+((\s*(md5|pgp|smtp|smime|dkim)\s*,?)*)\s*->\s*(.*)\s*$/gi
Luc Didry's avatar
Luc Didry committed
293
        ) {
294
            my ($condition, $auth_methods, $action) = ($1, $2 || 'smtp', $5);
295
            $auth_methods =~ s/\s//g;
296

297
298
299
300
301
302
303
            push @rules,
                {
                condition   => $condition,
                auth_method => [split /,/, $auth_methods],
                action      => $action,
                lineno      => $lineno,
                };
304
        } else {
305
306
307
308
309
310
            $log->syslog(
                'err',
                'Error parsing %s line %s: "%s"',
                $file_path || '(file)',
                $lineno, $line
            );
311
312
            @rules = ();
            last;
313
        }
314
    }
315

316
317
318
319
320
    my $purely_closed =
        not
        grep { not($_->{condition} eq 'true' and $_->{action} =~ /reject/) }
        @rules;

321
    return {
322
323
324
325
        data          => $data,
        title         => {%title},
        rules         => [@rules],
        purely_closed => $purely_closed,
326
327
328
329
330
        # Keep track of the current time ; used later to reload scenario files
        # when they changed on disk
        date => ($file_path ? time : 0),
    };
}
331

332
333
sub to_string {
    shift->{_scenario}{data};
334
335
336
}

sub request_action {
337
    my $that        = shift;
338
    my $function    = shift;
339
    my $auth_method = shift;
340
    my $context     = shift;
341
342
    my %options     = @_;

343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
    my $self = Sympa::Scenario->new($that, $function, %options);
    unless ($self) {
        $log->syslog('err', 'Failed to load scenario for "%s"', $function);
        return undef;
    }

    return $self->authz($auth_method, $context, %options);
}

# Old name: Sympa::Scenario::request_action().
sub authz {
    $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
    my $self        = shift;
    my $auth_method = shift;
    my $context     = shift;
    my %options     = @_;

    my $that     = $self->{context};
    my $function = $self->{function};
362
363
364
365
366
367
368
369
370
371
372
373

    # Pending/closed lists => send/visibility are closed.
    if (    ref $that eq 'Sympa::List'
        and not($that->{'admin'}{'status'} eq 'open')
        and grep { $function eq $_ } qw(send visibility)) {
        $log->syslog('debug3', '%s rejected reason list not open', $function);
        return {
            action      => 'reject',
            reason      => 'list-no-open',
            auth_method => '',
            condition   => '',
        };
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
379
380
381
382
383
384
385
386
387
        $log->syslog('info', 'Unknown auth method %s', $auth_method);
        return {
            action      => 'reject',
            reason      => 'unknown-auth-method',
            auth_method => $auth_method,
            condition   => '',
        };
    }

    # Defining default values for parameters.
388
389
390
    $context->{'sender'}      ||= 'nobody';
    $context->{'email'}       ||= $context->{'sender'};
    $context->{'remote_host'} ||= 'unknown_host';
391
    $context->{'execution_date'} //= time;
IKEDA Soji's avatar
IKEDA Soji committed
392

393
394
395
    if (ref $that eq 'Sympa::List') {
        foreach my $var (@{$that->{'admin'}{'custom_vars'} || []}) {
            $context->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
396
        }
IKEDA Soji's avatar
IKEDA Soji committed
397
398
399
400
401
402
403

        $context->{listname} = $that->{'name'};
        $context->{domain}   = $that->{'domain'};
        # Compat.<6.2.32
        $context->{host} = $that->{'domain'};
    } else {
        $context->{domain} = Conf::get_robot_conf($that || '*', 'domain');
404
    }
405
406

    my $sub = ($self->{_scenario} || {})->{sub};
407
408
    my $result = eval { $sub->($that, $context, $auth_method) }
        if ref $sub eq 'CODE';
409
    # Cope with errors.
IKEDA Soji's avatar
IKEDA Soji committed
410
    unless ($result) {
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
        unless ($sub) {
            $result = {reason => 'not-compiled'};
        } elsif (ref $EVAL_ERROR eq 'HASH') {
            $result = $EVAL_ERROR;
        } else {
            # Fatal error will be logged but not be exposed.
            $log->syslog('err', 'Error in scenario %s, context %s: (%s)',
                $self, $that, $EVAL_ERROR || 'unknown');
            $result = {};
        }
        $result->{action}      ||= 'reject';
        $result->{reason}      ||= 'error-performing-condition';
        $result->{auth_method} ||= $auth_method;
        $result->{condition}   ||= 'default';

        if ($result->{reason} eq 'not-compiled') {
            $log->syslog('info', '%s: Not compiled, reject', $self);
        } elsif ($result->{reason} eq 'no-rule-match') {
IKEDA Soji's avatar
IKEDA Soji committed
429
            $log->syslog('info', '%s: No rule match, reject', $self);
430
431
432
433
434
435
        } else {
            $log->syslog('info', 'Error in scenario %s, context %s: (%s)',
                $self, $that, $result->{reason});
            Sympa::send_notify_to_listmaster($that,
                'error_performing_condition', {error => $result->{reason}})
                unless $options{debug};
436
        }
437
        return $result;
438
439
    }

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
    my %action = %$result;
    # Check syntax of returned action
    if (   $options{debug}
        or $action{action} =~
        /^(do_it|reject|request_auth|owner|editor|editorkey|listmaster|ham|spam|unsure)/
    ) {
        return {%action, auth_method => $auth_method,};
    } else {
        $log->syslog('err', 'Matched unknown action "%s" in scenario',
            $action{action});
        return {
            action      => 'reject',
            reason      => 'unknown-action',
            auth_method => $auth_method,
        };
    }
456
}
457

458
459
460
461
# Old name: Sympa::Scenario::_parse_action().
sub _compile_action {
    my $action    = shift;
    my $condition = shift;
462

463
    my %action;
464
    $action{condition} = $condition if $condition;
465

466
467
468
469
470
471
472
473
474
475
476
    ## reject : get parameters
    if ($action =~ /^(ham|spam|unsure)/) {
        $action = $1;
    }
    if ($action =~ /^reject(\((.+)\))?(\s?,\s?(quiet))?/) {
        if ($4) {
            $action = 'reject,quiet';
        } else {
            $action = 'reject';
        }
        my @param = split /,/, $2 if defined $2;
477

478
479
480
481
        foreach my $p (@param) {
            if ($p =~ /^reason=\'?(\w+)\'?/) {
                $action{reason} = $1;
                next;
482

483
484
485
            } elsif ($p =~ /^tt2=\'?(\w+)\'?/) {
                $action{tt2} = $1;
                next;
486

487
            }
IKEDA Soji's avatar
IKEDA Soji committed
488
489
            if ($p =~ /^\'?([^'=]+)\'?/) {
                $action{tt2} = $1;
490
491
492
                # keeping existing only, not merging with reject
                # parameters in scenarios
                last;
493
494
            }
        }
495
    }
496
    $action{action} = $action;
497

IKEDA Soji's avatar
IKEDA Soji committed
498
    return _compile_hashref({%action});
499
500
501
}

## check if email respect some condition
502
# Old name: Sympa::Scenario::verify().
503
504
505
506
507
508
509
510
511
512
513
514
515
516
# Deprecated: No longer used.
#sub _verify;

# Old names: (part of) Sympa::Scenario::authz().
sub _compile_scenario {
    $log->syslog('debug2', '(%s, %s, ...)', @_);
    my $that     = shift;
    my $function = shift;
    my $parsed   = shift;

    my @rules = @{$parsed->{rules} || []};

    # Include include.<function>.header if found.
    my $include_scenario =
IKEDA Soji's avatar
IKEDA Soji committed
517
518
        Sympa::Scenario->new($that, 'include', name => $function . '.header')
        if $function;
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
    if ($include_scenario) {
        # Add rules at the beginning.
        unshift @rules, @{$include_scenario->{_scenario}{rules}};
    }
    # Look for 'include' directives amongst rules first.
    foreach my $index (0 .. $#rules) {
        if ($rules[$index]{'condition'} =~
            /^\s*include\s*\(?\'?([\w\.]+)\'?\)?\s*$/i) {
            my $include_file = $1;
            my $include_scenario =
                Sympa::Scenario->new($that, 'include', name => $include_file);
            if ($include_scenario) {
                # Replace the include directive with included rules.
                splice @rules, $index, 1,
                    @{$include_scenario->{_scenario}{rules}};
            }
        }
    }

538
539
    ## Include a Blocklist rules if configured for this action
    if ($function and $Conf::Conf{'blocklist'}{$function}) {
540
541
542
        ## Add rules at the beginning of the array
        unshift @rules,
            {
543
            'condition'   => "search('blocklist.txt',[sender])",
544
545
546
547
548
549
            'action'      => 'reject,quiet',
            'auth_method' => ['smtp', 'dkim', 'md5', 'pgp', 'smime'],
            };
    }

    my @codes;
IKEDA Soji's avatar
IKEDA Soji committed
550
    my %required;
551
552
553
554
555
556
557
558
559
    foreach my $rule (@rules) {
        $log->syslog(
            'debug3',
            'Verify rule %s, auth %s, action %s',
            $rule->{'condition'},
            join(',', @{$rule->{'auth_method'} || []}),
            $rule->{'action'}
        );

IKEDA Soji's avatar
IKEDA Soji committed
560
        my ($code, @required) = _compile_rule($rule);
561
562
        return undef unless defined $code;    # Bad syntax.
        push @codes, $code;
IKEDA Soji's avatar
IKEDA Soji committed
563
564

        %required = (%required, map { ($_ => 1) } @required);
565
566
    }

IKEDA Soji's avatar
IKEDA Soji committed
567
568
569
    my $required = join "\n", map {
        my $req;
        if ($_ eq 'list_object') {
IKEDA Soji's avatar
IKEDA Soji committed
570
571
            $req =
                'die "No list context" unless ref $that eq \'Sympa::List\';';
572
        } elsif ($_ eq 'message') {
573
            $req = '$context->{message} ||= Sympa::Message->new("\n");';
IKEDA Soji's avatar
IKEDA Soji committed
574
        } else {
575
            $req = sprintf '$context->{\'%s\'} //= \'\';', $_;
IKEDA Soji's avatar
IKEDA Soji committed
576
577
578
579
580
        }
        "    $req";
    } sort keys %required;

    return sprintf(<<'EOF', $required, join '', @codes);
581
582
583
584
585
sub {
    my $that        = shift;
    my $context     = shift;
    my $auth_method = shift;

IKEDA Soji's avatar
IKEDA Soji committed
586
587
%s

588
%s
589
    die {reason => 'no-rule-match'};
590
591
592
593
594
595
596
597
}
EOF

}

sub _compile_rule {
    my $rule = shift;

IKEDA Soji's avatar
IKEDA Soji committed
598
    my ($cond, @required) = _compile_condition($rule);
599
600
601
602
603
    return unless defined $cond and length $cond;

    my $auth_methods = join ' ', sort @{$rule->{'auth_method'} || []};
    my $result = _compile_action($rule->{action}, $rule->{condition});

IKEDA Soji's avatar
IKEDA Soji committed
604
605
606
607
608
609
610
611
    if (1 == scalar @{$rule->{'auth_method'} || []}) {
        return (sprintf(<<'EOF', $auth_methods, $result, $cond), @required);
    if ($auth_method eq '%s') {
        return %s if %s;
    }
EOF
    } elsif ($auth_methods eq join(' ', sort qw(smtp dkim md5 smime))) {
        return (sprintf(<<'EOF', $result, $cond), @required);
612
613
614
    return %s if %s;
EOF
    } else {
IKEDA Soji's avatar
IKEDA Soji committed
615
        return (sprintf(<<'EOF', $auth_methods, $result, $cond), @required);
616
617
618
619
620
621
622
623
624
625
626
627
    if (grep {$auth_method eq $_} qw(%s)) {
        return %s if %s;
    }
EOF
    }
}

sub _compile_condition {
    my $rule = shift;

    my $condition = $rule->{condition};

628
629
    unless ($condition =~
        /(\!)?\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
Luc Didry's avatar
Luc Didry committed
630
    ) {
631
        $log->syslog('err', 'Error rule syntaxe: unknown condition %s',
632
            $condition);
633
        return undef;
634
    }
635
636
    my $negation      = ($1 and $1 eq '!') ? '!' : '';
    my $condition_key = lc $2;
637
638
639
640
    my $arguments     = $3;

    ## The expression for regexp is tricky because we don't allow the '/'
    ## character (that indicates the end of the regexp
641
    ## but we allow any number of \/ escape sequence)
642
643
644
    my @args;
    my %required_keys;
    pos $arguments = 0;
645
    while (
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
646
        $arguments =~ m{
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
        \G\s*(
            (\[\w+(\-\>[\w\-]+)?\](\[[-+]?\d+\])?)
            |
            ([\w\-\.]+)
            |
            '[^,)]*'
            |
            "[^,)]*"
            |
            /([^/]*((\\/)*[^/]+))*/
            |
            (\w+)\.ldap
            |
            (\w+)\.sql
        )\s*,?
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
662
        }cgx
Luc Didry's avatar
Luc Didry committed
663
    ) {
664
665
        my $value = $1;

666
        if ($value =~ m{\A/(.+)/\z}) {
667
            my $re = $1;
IKEDA Soji's avatar
IKEDA Soji committed
668
669
            # Fix orphan "'" and "\".
            $re =~ s{(\\.|.)}{($1 eq "'" or $1 eq "\\")? "\\$1" : $1}eg;
670
            # regexp w/o interpolates
671
672
673
674
            unless (
                defined
                do { local $SIG{__DIE__}; eval sprintf "qr'%s'i", $re }
            ) {
IKEDA Soji's avatar
IKEDA Soji committed
675
676
677
                $log->syslog('err', 'Bad regexp /%s/: %s', $re, $EVAL_ERROR);
                return undef;
            }
IKEDA Soji's avatar
IKEDA Soji committed
678
679
            $value = sprintf 'Sympa::Scenario::safe_qr(\'%s\', $context)',
                $re;
680
681
        } elsif ($value =~ /\[custom_vars\-\>([\w\-]+)\]/i) {
            # Custom vars
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
682
            $value = sprintf '$context->{custom_vars}{\'%s\'}', $1;
683
684
        } elsif ($value =~ /\[family\-\>([\w\-]+)\]/i) {
            # Family vars
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
685
            $value = sprintf '$context->{family}{\'%s\'}', $1;
686
687
        } elsif ($value =~ /\[conf\-\>([\w\-]+)\]/i) {
            # Config param
688
            my $conf_key = $1;
689
690
691
            # Compat. < 6.2.32
            $conf_key = 'domain' if $conf_key and $conf_key eq 'host';

692
693
            if (grep { $_->{'name'} and $_->{'name'} eq $conf_key }
                @Sympa::ConfDef::params) {
694
                #FIXME: Old or obsoleted names of parameters
695
696
                $value =
                    sprintf
IKEDA Soji's avatar
IKEDA Soji committed
697
                    'Conf::get_robot_conf(((ref $that eq \'Sympa::List\') ? $that->{domain} : $that), \'%s\')',
698
                    $conf_key;
699
700
701
            } else {
                # a condition related to a undefined context variable is
                # always false
IKEDA Soji's avatar
IKEDA Soji committed
702
703
                $log->syslog('err', '%s: Unknown key for [conf->%s]',
                    $conf_key);
704
                $value = 'undef()';
705
            }
706
707
        } elsif ($value =~ /\[list\-\>([\w\-]+)\]/i) {
            # List param
708
            my $param = $1;
IKEDA Soji's avatar
IKEDA Soji committed
709
            $required_keys{list_object} = 1;
710

IKEDA Soji's avatar
IKEDA Soji committed
711
712
            if ($param eq 'name') {
                $value = '$that->{name}';
713
            } elsif ($param eq 'total') {
IKEDA Soji's avatar
IKEDA Soji committed
714
                $value = '$that->get_total';
715
            } elsif ($param eq 'address') {
IKEDA Soji's avatar
IKEDA Soji committed
716
                $value = 'Sympa::get_address($that)';
717
            } else {
IKEDA Soji's avatar
IKEDA Soji committed
718
719
                my $pinfo = {%Sympa::ListDef::pinfo};    #FIXME

720
721
722
723
724
725
726
                my $canon_param = $param;
                if (exists $pinfo->{$param}) {
                    my $alias = $pinfo->{$param}{'obsolete'};
                    if ($alias and exists $pinfo->{$alias}) {
                        $canon_param = $alias;
                    }
                }
727
728
729
                if (    exists $pinfo->{$canon_param}
                    and ref $pinfo->{$canon_param}{format} ne 'HASH'
                    and $pinfo->{$canon_param}{occurrence} !~ /n$/) {
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
730
                    $value = sprintf '$that->{admin}{\'%s\'}', $canon_param;
731
                } else {
sikeda's avatar
sikeda committed
732
733
                    $log->syslog('err',
                        'Unknown list parameter %s in rule %s',
734
735
736
                        $value, $condition);
                    return undef;
                }
737
738
            }
        } elsif ($value =~ /\[env\-\>([\w\-]+)\]/i) {
739
740
            my $env = $1;
            $value = sprintf '$ENV{\'%s\'}', $env;
741
        } elsif ($value =~ /\[user\-\>([\w\-]+)\]/i) {
742
            # Sender's user/subscriber attributes (if subscriber)
743
744
745
            my $key = $1;
            $value =
                sprintf
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
746
                '($context->{user} || Sympa::User->new($context->{sender}))->{\'%s\'}',
747
                $key;
748
        } elsif ($value =~ /\[user_attributes\-\>([\w\-]+)\]/i) {
749
750
751
            my $key = $1;
            $value =
                sprintf
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
752
                '($context->{user} || Sympa::User->new($context->{sender}))->{attributes}{\'%s\'}',
753
754
755
756
757
                $key;
        } elsif ($value =~ /\[subscriber\-\>([\w\-]+)\]/i) {
            my $key = $1;
            $value =
                sprintf
IKEDA Soji's avatar
Typos.    
IKEDA Soji committed
758
                '($context->{subscriber} || $that->get_list_memner($context->{sender}) || {})->{\'%s\'}',
759
                $key;
760
761
762
        } elsif ($value =~
            /\[(msg_header|header)\-\>([\w\-]+)\](?:\[([-+]?\d+)\])?/i) {
            ## SMTP header field.
763
            ## "[msg_header->field]" returns arrayref of field values,
764
765
766
767
            ## preserving order. "[msg_header->field][index]" returns one
            ## field value.
            my $field_name = $2;
            my $index = (defined $3) ? $3 + 0 : undef;
768
769
770
771
772
773
774
            ## Defaulting empty or missing fields to '', so that we can
            ## test their value in Scenario, considering that, for an
            ## incoming message, a missing field is equivalent to an empty
            ## field : the information it is supposed to contain isn't
            ## available.
            if (defined $index) {
                $value =
IKEDA Soji's avatar
IKEDA Soji committed
775
776
                    sprintf
                    'do { my @h = $context->{message}->get_header(\'%s\'); $h[%s] // \'\' }',
777
                    $field_name, $index;
778
            } else {
IKEDA Soji's avatar
IKEDA Soji committed
779
                $value =
IKEDA Soji's avatar
IKEDA Soji committed
780
781
                    sprintf
                    '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
787
788
789
790
791
            $value = '$context->{message}->body_as_string';
            $value =
                sprintf
                '((0 == index lc($context->{message}->as_entity->effective_type || "text"), "text") ? %s : undef)',
                $value;
            $required_keys{message} = 1;
792
        } elsif ($value =~ /\[msg_part\-\>body\]/i) {
793
794
795
796
            #FIXME:Should be recurcive...
            $value =
                '[map {$_->bodyhandle->as_string} grep { defined $_->bodyhandle and 0 == index ($_->effective_type || "text"), "text" } $context->{message}->as_entity->parts]';
            $required_keys{message} = 1;
797
        } elsif ($value =~ /\[msg_part\-\>type\]/i) {
798
799
800
            $value =
                '[map {$_->effective_type} $context->{message}->as_entity->parts]';
            $required_keys{message} = 1;
801
        } elsif ($value =~ /\[msg\-\>(\w+)\]/i) {
802
803
804
805
            my $key = $1;
            $value =
                sprintf
                '(exists $context->{message}{%s} ? $context->{message}{%s} : undef)',
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
                $key, $key;
            $required_keys{message} = 1;
        } elsif ($value =~ /\[is_bcc\]/i) {
            $value =
                'Sympa::Scenario::message_is_bcc($that, $context->{message})';
            $required_keys{list_object} = 1;
            $required_keys{message}     = 1;
        } elsif ($value =~ /\[msg_encrypted\]/i) {
            $value =
                'Sympa::Scenario::message_encrypted($context->{message})';
            $required_keys{message} = 1;
        } elsif ($value =~ /\[(topic(?:_\w+)?)\]/i) {
            # Useful only with send scenario.
            my $key = $1;
            $value = sprintf '$context->{%s}', $key;
            $required_keys{$key} = 1;
822
            $required_keys{message} = 1;
823
        } elsif ($value =~ /\[current_date\]/i) {
824
            $value = 'time()';
825
826
827
828
        } elsif ($value =~ /\[listname\]/i) {
            # Context should be a List from which value will be taken.
            $value = '$that->{name}';
            $required_keys{list_object} = 1;
829
        } elsif ($value =~ /\[(\w+)\]/i) {
830
            my $key = $1;
831
832
            $value = sprintf '$context->{%s}', $key;
            $required_keys{$key} = 1;
833
        } elsif ($value =~ /^'(.*)'$/ || $value =~ /^"(.*)"$/) {
834
            # Quoted string
835
836
837
838
            my $str = $1;
            $str =~ s{(\\.|.)}{($1 eq "'" or $1 eq "\\")? "\\\'" : $1}eg;
            $value = sprintf "'%s'", $str;
        } else {
839
840
841
842
843
            # Texts with unknown format may be treated as the string constants
            # for compatibility to loose parsing with earlier ver (<=6.2.48).
            my $str = $value;
            $str =~ s/([\\\'])/\\$1/g;
            $value = sprintf "'%s'", $str;
844
845
        }
        push(@args, $value);
846
    }
847
848
849
850
851
852
853
854
855
856
857
858

    my $term = _compile_condition_term($rule, $condition_key, @args);
    return unless $term;

    return ("$negation$term", sort keys %required_keys);
}

sub _compile_condition_term {
    my $rule          = shift;
    my $condition_key = shift;
    my @args          = @_;

859
860
861
    # Getting rid of spaces.
    $condition_key =~ s/^\s*//g;
    $condition_key =~ s/\s*$//g;
862

863
    if ($condition_key =~ /^(true|all)$/i) {
864
865
        # condition that require 0 argument
        if (@args) {
866
867
            $log->syslog(
                'err',
868
869
                'Syntax error: Incorrect number of argument or incorrect argument syntax in %s',
                $condition_key
870
871
872
            );
            return undef;
        }
873
        return '1';
874
    } elsif ($condition_key =~ /^(is_listmaster|verify_netmask)$/) {
875
876
877
878
879
        # condition that require 1 argument
        unless (scalar @args == 1) {
            $log->syslog('err',
                'Syntax error: Incorrect argument number for condition %s',
                $condition_key);
880
881
882
            return undef;
        }
    } elsif ($condition_key =~ /^search$/o) {
883
884
885
886
887
        # condition that require 1 or 2 args (search : historical reasons)
        unless (scalar @args == 1 or scalar @args == 2) {
            $log->syslog('err',
                'Syntax error: Incorrect argument number for condition %s',
                $condition_key);
888
889
            return undef;
        }
890
        # We could search in the family if we got ref on Sympa::Family object.
IKEDA Soji's avatar
typos.    
IKEDA Soji committed
891
892
        return sprintf 'Sympa::Scenario::do_search($that, $context, %s)',
            join ', ', @args;
893
894
    } elsif (
        $condition_key =~
895
896
        # condition that require 2 args
        /^(is_owner|is_editor|is_subscriber|less_than|match|equal|message|newer|older)$/o
Luc Didry's avatar
Luc Didry committed
897
    ) {
898
        unless (scalar @args == 2) {
899
            $log->syslog(
900
                'err',
901
902
                'Syntax error: Incorrect argument number (%d instead of %d) for condition %s',
                scalar(@args),
903
904
                2,
                $condition_key
905
906
907
            );
            return undef;
        }
IKEDA Soji's avatar
IKEDA Soji committed
908
909
910
        if ($condition_key =~ /\A(is_owner|is_editor|is_subscriber)\z/) {
            # Interpret '[listname]' as $that.
            $args[0] = '$that' if $args[0] eq '$that->{name}';
911
912
        }
    } elsif ($condition_key =~ /^customcondition::(\w+)$/) {
IKEDA Soji's avatar
IKEDA Soji committed
913
914
915
        my $mod = $1;
        return sprintf 'do_verify_custom($that, %s, \'%s\', %s)',
            _compile_hashref($rule), $mod, join ', ', @args;
916
917
    } else {
        $log->syslog('err', 'Syntax error: Unknown condition %s',
918
            $condition_key);
919
        return undef;
920
    }
921

IKEDA Soji's avatar
typos.    
IKEDA Soji committed
922
923
    return sprintf 'Sympa::Scenario::do_%s($that, \'%s\', %s)',
        $condition_key, $condition_key, join ', ', @args;
924
}
925

IKEDA Soji's avatar
IKEDA Soji committed
926
927
928
929
930
931
932
sub _compile_hashref {
    my $hashref = shift;

    return '{' . join(
        ', ',
        map {
            my ($k, $v) = ($_, $hashref->{$_});
IKEDA Soji's avatar
IKEDA Soji committed
933
934
935
936
937
938
939
940
941
942
943
944
945
946
            if (ref $v eq 'ARRAY') {
                $v = join(
                    ', ',
                    map {
                        my $i = $_;
                        $i =~ s/([\\\'])/\\$1/g;
                        "'$i'";
                    } @$v
                );
                sprintf '%s => [%s]', $k, $v;
            } else {
                $v =~ s/([\\\'])/\\$1/g;
                sprintf "%s => '%s'", $k, $v;
            }
IKEDA Soji's avatar
IKEDA Soji committed
947
948
949
950
        } sort keys %$hashref
    ) . '}';
}

951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
sub message_is_bcc {
    my $that    = shift;
    my $message = shift;

    return '' unless $message;
    #FIXME: need more accurate test.
    return (
        0 <= index(
            lc join(', ',
                $message->get_header('To'),
                $message->get_header('Cc')),
            lc $that->{'name'}
        )
    ) ? 0 : 1;
}

sub message_encrypted {
    my $message = shift;

    return ($message and $message->{smime_crypted}) ? 'smime' : '';
}

973
974
975
976
977
978
979
sub safe_qr {
    my $re      = shift;
    my $context = shift;

    my $domain = $context->{domain};
    $domain =~ s/[.]/[.]/g;
    $re =~ s/[[](domain|host)[]]/$domain/g;
980
    return do { local $SIG{__DIE__}; eval sprintf "qr'%s'i", $re };
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
}

##### condition : true

##### condition is_listmaster
sub do_is_listmaster {
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;

    return 0 if not ref $args[0] and $args[0] eq 'nobody';

    my @arg;
    my $ok = undef;
    if (ref $args[0] eq 'ARRAY') {
        @arg = map { $_->address }
            grep {$_} map { (Mail::Address->parse($_)) } @{$args[0]};
    } else {
        @arg = map { $_->address }
            grep {$_} Mail::Address->parse($args[0]);
    }
    foreach my $arg (@arg) {
        if (Sympa::is_listmaster($that, $arg)) {
            $ok = $arg;
            last;
1006
        }
1007
1008
    }

1009
1010
    return $ok ? 1 : 0;
}
1011

1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
##### condition verify_netmask
sub do_verify_netmask {
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
    ## Check that the IP address of the client is available
    ## Means we are in a web context
    # always skip this rule because we can't evaluate it.
    return 0 unless defined $ENV{'REMOTE_ADDR'};

    my @cidr;
    if ($args[0] eq 'default' or $args[0] eq 'any') {
        # Compatibility with Net::Netmask, adding IPv6 feature.
        @cidr = ('0.0.0.0/0', '::/0');
    } else {
        if ($args[0] =~ /\A(\d+\.\d+\.\d+\.\d+):(\d+\.\d+\.\d+\.\d+)\z/) {
            # Compatibility with Net::Netmask.
            eval { @cidr = Net::CIDR::range2cidr("$1/$2"); };
1030
        } else {
1031
            eval { @cidr = Net::CIDR::range2cidr($args[0]); };
1032
        }
1033
1034
1035
        if ($@ or scalar(@cidr) != 1) {
            # Compatibility with Net::Netmask: Should be single range.
            @cidr = ();
1036
        } else {
1037
            @cidr = grep { Net::CIDR::cidrvalidate($_) } @cidr;
1038
        }
1039
    }
1040
1041
1042
1043
1044
    unless (@cidr) {
        $log->syslog('err', 'Error rule syntax: failed to parse netmask "%s"',
            $args[0]);
        die {};
    }
1045

1046
1047
1048
1049
    $log->syslog('debug3', 'REMOTE_ADDR %s against %s',
        $ENV{'REMOTE_ADDR'}, $args[0]);
    return Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @cidr) ? 1 : 0;
}
1050

1051
1052
1053
1054
1055
1056
##### condition older
sub do_older {
    $log->syslog('debug3', '(%s,%s,%s,%s)', @_);
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
1057

1058
1059
1060
1061
1062
1063
1064
    my $arg0 = Sympa::Tools::Time::epoch_conv($args[0]);
    my $arg1 = Sympa::Tools::Time::epoch_conv($args[1]);

    if ($condition_key eq 'older') {
        return ($arg0 <= $arg1) ? 1 : 0;
    } else {
        return ($arg0 > $arg1) ? 1 : 0;
1065
    }
1066
}
1067

1068
1069
1070
sub do_newer {
    goto &do_older;
}
1071

1072
1073
1074
1075
1076
##### condition is_owner, is_subscriber and is_editor
sub do_is_owner {
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
1077

1078
    return 0 if $args[1] eq 'nobody';
1079

IKEDA Soji's avatar
IKEDA Soji committed
1080
1081
1082
1083
1084
1085
    # The list is local or in another local robot
    my $list;
    if (ref $args[0] eq 'Sympa::List') {
        $list = $args[0];
    } elsif ($args[0] =~ /\@/) {
        $list = Sympa::List->new($args[0]);
1086
    } else {
IKEDA Soji's avatar
IKEDA Soji committed
1087
1088
        my $robot = (ref $that eq 'Sympa::List') ? $that->{'domain'} : $that;
        $list = Sympa::List->new($args[0], $robot);
1089
    }
1090

IKEDA Soji's avatar
IKEDA Soji committed
1091
    unless ($list) {
1092
1093
1094
        $log->syslog('err', 'Unable to create list object "%s"', $args[0]);
        return 0;
    }
1095

1096
1097
1098
1099
1100
1101
1102
1103
1104
    my @arg;
    my $ok = undef;
    if (ref $args[1] eq 'ARRAY') {
        @arg = map { $_->address }
            grep {$_} map { (Mail::Address->parse($_)) } @{$args[1]};
    } else {
        @arg = map { $_->address }
            grep {$_} Mail::Address->parse($args[1]);
    }
1105

1106
1107
    if ($condition_key eq 'is_subscriber') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1108
            if ($list->is_list_member($arg)) {
1109
1110
                $ok = $arg;
                last;
1111
            }
1112
1113
1114
1115
        }
        return $ok ? 1 : 0;
    } elsif ($condition_key eq 'is_owner') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1116
1117
            if ($list->is_admin('owner', $arg)
                or Sympa::is_listmaster($list, $arg)) {
1118
1119
                $ok = $arg;
                last;
1120
1121
            }
        }
1122
1123
1124
        return $ok ? 1 : 0;
    } elsif ($condition_key eq 'is_editor') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1125
            if ($list->is_admin('actual_editor', $arg)) {