Scenario.pm 56.6 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 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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
my %domain_ppath_maps = (
    create_list             => 'create_list',
    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',
);

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

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

112
113
    # Compatibility for obsoleted use of parameter names.
    $function = $compat_function_maps{$function} || $function;
114
    die 'bug in logic. Ask developer'
115
        unless defined $function and $function =~ /\A$scenario_name_re\z/;
116
117
118
119
120
121
122
123
124
125
126

    # 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) {
127
        $log->syslog('err', 'Unknown scenario function "%s"', $function);
128
        return undef;
129
130
    }

131
132
133
134
135
136
137
138
139
140
141
142
143
144
    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};
145
        }
146
147
148
    } elsif ($function eq 'topics_visibility') {
        # {name} option is mandatory.
        die 'bug in logic. Ask developer';
149
    } else {
150
        $name = Conf::get_robot_conf($that, $ppath);
151
    }
152
153
154
155

    unless (
        defined $name
        and (  $function eq 'include' and $name =~ m{\A[^/]+\z}
156
            or $name =~ /\A$scenario_name_re\z/)
157
    ) {
Luc Didry's avatar
Luc Didry committed
158
159
160
161
162
163
        $log->syslog(
            'err',
            'Unknown or undefined scenario function "%s", scenario name "%s"',
            $function,
            $name
        );
164
        return undef;
165
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
    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);
196
197
            return undef;
        }
198
199
    } elsif ($function eq 'include') {
        # include.xx not found will not raise an error message.
200
201
        return undef;
    } else {
202
203
204
205
206
207
208
209
210
211
212
213
214
215
        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';
216
217
    }

IKEDA Soji's avatar
IKEDA Soji committed
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
    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};

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

            $parsed->{compiled} = $compiled;
            $parsed->{sub}      = $sub;
        }
    }
256

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

260
# Parse scenario rules.  On failure, returns hash with empty rules.
261
sub _parse_scenario {
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
    $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;
278
            next;
279
        } elsif ($line =~ /^\s*title\.(\S+)\s+(.*)\s*$/i) {
280
281
282
            my ($lang, $title) = ($1, $2);
            # canonicalize lang if possible.
            $lang = Sympa::Language::canonic_lang($lang) || $lang;
283
            $title{$lang} = $title;
284
            next;
285
286
        } elsif ($line =~ /^\s*title\s+(.*)\s*$/i) {
            $title{default} = $1;
287
288
289
            next;
        }

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

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

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

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

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

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

344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
    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};
363
364
365
366
367
368
369
370
371
372
373
374

    # 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   => '',
        };
375
    }
376

377
    # Check that authorization method is one of those known by Sympa.
378
    unless ($auth_method =~ /^(smtp|md5|pgp|smime|dkim)/) {  #FIXME: regex '$'
379
380
381
382
383
384
385
386
387
388
        $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.
389
390
391
392
    $context->{'sender'}      ||= 'nobody';
    $context->{'email'}       ||= $context->{'sender'};
    $context->{'remote_host'} ||= 'unknown_host';
    $context->{'msg_encrypted'} = 'smime'
393
        if defined $context->{'message'}
394
        and $context->{'message'}->{'smime_crypted'};
395

IKEDA Soji's avatar
IKEDA Soji committed
396
397
398
    $context->{'execution_date'} = time
        unless defined $context->{'execution_date'};

399
400
401
    if (ref $that eq 'Sympa::List') {
        foreach my $var (@{$that->{'admin'}{'custom_vars'} || []}) {
            $context->{'custom_vars'}{$var->{'name'}} = $var->{'value'};
402
        }
IKEDA Soji's avatar
IKEDA Soji committed
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421

        $context->{listname} = $that->{'name'};
        $context->{domain}   = $that->{'domain'};
        # Compat.<6.2.32
        $context->{host} = $that->{'domain'};

        if ($context->{message}) {
            #FIXME: need more accurate test.
            $context->{is_bcc} = (
                0 <= index(
                    lc join(', ',
                        $context->{message}->get_header('To'),
                        $context->{message}->get_header('Cc')),
                    lc $that->{'name'}
                )
            ) ? 0 : 1;
        }
    } else {
        $context->{domain} = Conf::get_robot_conf($that || '*', 'domain');
422
    }
423
424
425
426

    my $sub = ($self->{_scenario} || {})->{sub};
    my $result = $sub->($that, $context, $auth_method) if ref $sub eq 'CODE';
    # Cope with errors.
IKEDA Soji's avatar
IKEDA Soji committed
427
428
429
430
431
432
433
434
435
    unless ($result) {
        if (ref $EVAL_ERROR eq 'HASH' and not %$EVAL_ERROR) {
            $log->syslog('info', '%s: No rule match, reject', $self);
            return {
                action      => 'reject',
                reason      => 'no-rule-match',
                auth_method => 'default',
                condition   => 'default'
            };
436
        }
IKEDA Soji's avatar
IKEDA Soji committed
437
438
439
440
441
442

        $log->syslog('info', 'Error in scenario %s, context %s: (%s)',
            $self, $that, $EVAL_ERROR || 'unknown');
        Sympa::send_notify_to_listmaster($that, 'error_performing_condition',
            {error => ($EVAL_ERROR || 'unknown')})
            unless $options{debug};
443
444
445
446
447
448
        return {
            action      => 'reject',
            reason      => 'error-performing-condition',
            auth_method => $auth_method,
            condition   => 'default',
        };
449
450
    }

451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
    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,
        };
    }
467
}
468

469
470
471
472
# Old name: Sympa::Scenario::_parse_action().
sub _compile_action {
    my $action    = shift;
    my $condition = shift;
473

474
    my %action;
475
    $action{condition} = $condition if $condition;
476

477
478
479
480
481
482
483
484
485
486
487
    ## 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;
488

489
490
491
492
        foreach my $p (@param) {
            if ($p =~ /^reason=\'?(\w+)\'?/) {
                $action{reason} = $1;
                next;
493

494
495
496
            } elsif ($p =~ /^tt2=\'?(\w+)\'?/) {
                $action{tt2} = $1;
                next;
497

498
            }
IKEDA Soji's avatar
IKEDA Soji committed
499
500
            if ($p =~ /^\'?([^'=]+)\'?/) {
                $action{tt2} = $1;
501
502
503
                # keeping existing only, not merging with reject
                # parameters in scenarios
                last;
504
505
            }
        }
506
    }
507
    $action{action} = $action;
508

IKEDA Soji's avatar
IKEDA Soji committed
509
    return _compile_hashref({%action});
510
511
512
}

## check if email respect some condition
513
# Old name: Sympa::Scenario::verify().
514
515
516
517
518
519
520
521
522
523
524
525
526
527
# 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
528
529
        Sympa::Scenario->new($that, 'include', name => $function . '.header')
        if $function;
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
    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}};
            }
        }
    }

    ## Include a Blacklist rules if configured for this action
IKEDA Soji's avatar
IKEDA Soji committed
550
    if ($function and $Conf::Conf{'blacklist'}{$function}) {
551
552
553
554
555
556
557
558
559
560
        ## Add rules at the beginning of the array
        unshift @rules,
            {
            'condition'   => "search('blacklist.txt',[sender])",
            'action'      => 'reject,quiet',
            'auth_method' => ['smtp', 'dkim', 'md5', 'pgp', 'smime'],
            };
    }

    my @codes;
IKEDA Soji's avatar
IKEDA Soji committed
561
    my %required;
562
563
564
565
566
567
568
569
570
    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
571
        my ($code, @required) = _compile_rule($rule);
572
573
        return undef unless defined $code;    # Bad syntax.
        push @codes, $code;
IKEDA Soji's avatar
IKEDA Soji committed
574
575

        %required = (%required, map { ($_ => 1) } @required);
576
577
    }

IKEDA Soji's avatar
IKEDA Soji committed
578
579
580
581
582
583
584
585
586
587
588
    my $required = join "\n", map {
        my $req;
        if ($_ eq 'list_object') {
            $req = 'return undef unless ref $that eq \'Sympa::List\';';
        } else {
            $req = sprintf 'return undef unless exists $context->{%s};', $_;
        }
        "    $req";
    } sort keys %required;

    return sprintf(<<'EOF', $required, join '', @codes);
589
590
591
592
593
sub {
    my $that        = shift;
    my $context     = shift;
    my $auth_method = shift;

IKEDA Soji's avatar
IKEDA Soji committed
594
595
%s

596
597
598
599
600
601
602
603
604
605
%s
    die {};
}
EOF

}

sub _compile_rule {
    my $rule = shift;

IKEDA Soji's avatar
IKEDA Soji committed
606
    my ($cond, @required) = _compile_condition($rule);
607
608
609
610
611
    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
612
613
614
615
616
617
618
619
    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);
620
621
622
    return %s if %s;
EOF
    } else {
IKEDA Soji's avatar
IKEDA Soji committed
623
        return (sprintf(<<'EOF', $auth_methods, $result, $cond), @required);
624
625
626
627
628
629
630
631
632
633
634
635
    if (grep {$auth_method eq $_} qw(%s)) {
        return %s if %s;
    }
EOF
    }
}

sub _compile_condition {
    my $rule = shift;

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

636
637
    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
638
    ) {
639
        $log->syslog('err', 'Error rule syntaxe: unknown condition %s',
640
            $condition);
641
        return undef;
642
    }
643
644
    my $negation      = ($1 and $1 eq '!') ? '!' : '';
    my $condition_key = lc $2;
645
646
647
648
    my $arguments     = $3;

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

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

701
702
703
704
            if (grep { $_->{'name'} and $_->{'name'} eq $conf_key }
                @Sympa::ConfDef::params) {
                $value =
                    sprintf
IKEDA Soji's avatar
IKEDA Soji committed
705
                    'Conf::get_robot_conf(((ref $that eq \'Sympa::List\') ? $that->{domain} : $that), \'%s\')',
706
                    $conf_key;
707
708
709
            } else {
                # a condition related to a undefined context variable is
                # always false
IKEDA Soji's avatar
IKEDA Soji committed
710
711
                $log->syslog('err', '%s: Unknown key for [conf->%s]',
                    $conf_key);
712
                $value = 'undef()';
713
            }
714
715
        } elsif ($value =~ /\[list\-\>([\w\-]+)\]/i) {
            # List param
716
            my $param = $1;
IKEDA Soji's avatar
IKEDA Soji committed
717
            $required_keys{list_object} = 1;
718

IKEDA Soji's avatar
IKEDA Soji committed
719
720
            if ($param eq 'name') {
                $value = '$that->{name}';
721
            } elsif ($param eq 'total') {
IKEDA Soji's avatar
IKEDA Soji committed
722
                $value = '$that->get_total';
723
            } elsif ($param eq 'address') {
IKEDA Soji's avatar
IKEDA Soji committed
724
                $value = 'Sympa::get_address($that)';
725
            } else {
IKEDA Soji's avatar
IKEDA Soji committed
726
727
                my $pinfo = {%Sympa::ListDef::pinfo};    #FIXME

728
729
730
731
732
733
734
                my $canon_param = $param;
                if (exists $pinfo->{$param}) {
                    my $alias = $pinfo->{$param}{'obsolete'};
                    if ($alias and exists $pinfo->{$alias}) {
                        $canon_param = $alias;
                    }
                }
735
736
737
                if (    exists $pinfo->{$canon_param}
                    and ref $pinfo->{$canon_param}{format} ne 'HASH'
                    and $pinfo->{$canon_param}{occurrence} !~ /n$/) {
IKEDA Soji's avatar
IKEDA Soji committed
738
                    $value = sprintf '$that->{admin}{%s}', $canon_param;
739
                } else {
sikeda's avatar
sikeda committed
740
741
                    $log->syslog('err',
                        'Unknown list parameter %s in rule %s',
742
743
744
                        $value, $condition);
                    return undef;
                }
745
746
            }
        } elsif ($value =~ /\[env\-\>([\w\-]+)\]/i) {
747
748
            my $env = $1;
            $value = sprintf '$ENV{\'%s\'}', $env;
749
        } elsif ($value =~ /\[user\-\>([\w\-]+)\]/i) {
750
            # Sender's user/subscriber attributes (if subscriber)
751
752
753
754
755
            my $key = $1;
            $value =
                sprintf
                '($context->{user} || Sympa::User->new($context->{sender}))->{%s}',
                $key;
756
        } elsif ($value =~ /\[user_attributes\-\>([\w\-]+)\]/i) {
757
758
759
760
761
762
763
764
765
            my $key = $1;
            $value =
                sprintf
                '($context->{user} || Sympa::User->new($context->{sender}))->{attributes}{%s}',
                $key;
        } elsif ($value =~ /\[subscriber\-\>([\w\-]+)\]/i) {
            my $key = $1;
            $value =
                sprintf
IKEDA Soji's avatar
IKEDA Soji committed
766
                '($context->{subscriber} || $that->get_list_memner($context->{sender}) || {})->{%s}',
767
                $key;
768
769
770
        } elsif ($value =~
            /\[(msg_header|header)\-\>([\w\-]+)\](?:\[([-+]?\d+)\])?/i) {
            ## SMTP header field.
771
            ## "[msg_header->field]" returns arrayref of field values,
772
773
774
775
            ## preserving order. "[msg_header->field][index]" returns one
            ## field value.
            my $field_name = $2;
            my $index = (defined $3) ? $3 + 0 : undef;
776
777
778
779
780
781
782
783
784
            ## 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 =
                    sprintf '[$context->{message}->get_header(\'%s\')]->[%s]',
                    $field_name, $index;
785
            } else {
786
787
                $value = sprintf '[$context->{message}->get_header(\'%s\')]',
                    $field_name;
788
            }
789
            $required_keys{message} = 1;
790
        } elsif ($value =~ /\[msg_body\]/i) {
791
792
793
794
795
796
            $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;
797
        } elsif ($value =~ /\[msg_part\-\>body\]/i) {
798
799
800
801
            #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;
802
        } elsif ($value =~ /\[msg_part\-\>type\]/i) {
803
804
805
            $value =
                '[map {$_->effective_type} $context->{message}->as_entity->parts]';
            $required_keys{message} = 1;
806
        } elsif ($value =~ /\[msg\-\>(\w+)\]/i) {
807
808
809
810
811
812
            my $key = $1;
            $value =
                sprintf
                '(exists $context->{message}{%s} ? $context->{message}{%s} : undef)',
                $key;
            $required_keys{message} = 1;
813
        } elsif ($value =~ /\[current_date\]/i) {
814
            $value = 'time()';
815
        } elsif ($value =~ /\[(\w+)\]/i) {
816
817
            # Quoted string
            my $key = $1;
IKEDA Soji's avatar
IKEDA Soji committed
818
819
820
821
822
823
824
            if ($key eq 'listname') {
                $value = sprintf '$that->{name}';
                $required_keys{list_object} = 1;
            } else {
                $value = sprintf '$context->{%s}', $key;
                $required_keys{$key} = 1;
            }
825
        } elsif ($value =~ /^'(.*)'$/ || $value =~ /^"(.*)"$/) {
826
827
828
829
830
            my $str = $1;
            $str =~ s{(\\.|.)}{($1 eq "'" or $1 eq "\\")? "\\\'" : $1}eg;
            $value = sprintf "'%s'", $str;
        } else {
            # Parse error.
831
832
        }
        push(@args, $value);
833
    }
834
835
836
837
838
839
840
841
842
843
844
845

    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          = @_;

846
847
848
    # Getting rid of spaces.
    $condition_key =~ s/^\s*//g;
    $condition_key =~ s/\s*$//g;
849

850
    if ($condition_key =~ /^(true|all)$/i) {
851
852
        # condition that require 0 argument
        if (@args) {
853
854
            $log->syslog(
                'err',
855
856
                'Syntax error: Incorrect number of argument or incorrect argument syntax in %s',
                $condition_key
857
858
859
            );
            return undef;
        }
860
        return '1';
861
    } elsif ($condition_key =~ /^(is_listmaster|verify_netmask)$/) {
862
863
864
865
866
        # condition that require 1 argument
        unless (scalar @args == 1) {
            $log->syslog('err',
                'Syntax error: Incorrect argument number for condition %s',
                $condition_key);
867
868
869
            return undef;
        }
    } elsif ($condition_key =~ /^search$/o) {
870
871
872
873
874
        # 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);
875
876
            return undef;
        }
877
        # We could search in the family if we got ref on Sympa::Family object.
IKEDA Soji's avatar
typos.    
IKEDA Soji committed
878
879
        return sprintf 'Sympa::Scenario::do_search($that, $context, %s)',
            join ', ', @args;
880
881
    } elsif (
        $condition_key =~
882
883
        # 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
884
    ) {
885
        unless (scalar @args == 2) {
886
            $log->syslog(
887
                'err',
888
889
                'Syntax error: Incorrect argument number (%d instead of %d) for condition %s',
                scalar(@args),
890
891
                2,
                $condition_key
892
893
894
            );
            return undef;
        }
IKEDA Soji's avatar
IKEDA Soji committed
895
896
897
898
        if ($condition_key =~ /\A(is_owner|is_editor|is_subscriber)\z/) {
            # Interpret '[listname]' as $that.
            $args[0] = '$that' if $args[0] eq '$that->{name}';
        } elsif ($condition_key eq 'match') {
899
900
901
            return sprintf '(%s =~ %s)', $args[0], $args[1];
        }
    } elsif ($condition_key =~ /^customcondition::(\w+)$/) {
IKEDA Soji's avatar
IKEDA Soji committed
902
903
        return sprintf 'do_verify_custom($that, %s, %s, %s)',
            _compile_hashref($rule), $1, join ', ', @args;
904
905
    } else {
        $log->syslog('err', 'Syntax error: Unknown condition %s',
906
            $condition_key);
907
        return undef;
908
    }
909

IKEDA Soji's avatar
typos.    
IKEDA Soji committed
910
911
    return sprintf 'Sympa::Scenario::do_%s($that, \'%s\', %s)',
        $condition_key, $condition_key, join ', ', @args;
912
}
913

IKEDA Soji's avatar
IKEDA Soji committed
914
915
916
917
918
919
920
921
922
923
924
925
926
sub _compile_hashref {
    my $hashref = shift;

    return '{' . join(
        ', ',
        map {
            my ($k, $v) = ($_, $hashref->{$_});
            $v =~ s/([\\\'])/\\$1/g;
            sprintf "%s => '%s'", $k, $v;
        } sort keys %$hashref
    ) . '}';
}

927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
sub safe_qr {
    my $re      = shift;
    my $context = shift;

    my $domain = $context->{domain};
    $domain =~ s/[.]/[.]/g;
    $re =~ s/[[](domain|host)[]]/$domain/g;
    eval "qr'$re'";
}

##### 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;
960
        }
961
962
    }

963
964
    return $ok ? 1 : 0;
}
965

966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
##### 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"); };
984
        } else {
985
            eval { @cidr = Net::CIDR::range2cidr($args[0]); };
986
        }
987
988
989
        if ($@ or scalar(@cidr) != 1) {
            # Compatibility with Net::Netmask: Should be single range.
            @cidr = ();
990
        } else {
991
            @cidr = grep { Net::CIDR::cidrvalidate($_) } @cidr;
992
        }
993
    }
994
995
996
997
998
    unless (@cidr) {
        $log->syslog('err', 'Error rule syntax: failed to parse netmask "%s"',
            $args[0]);
        die {};
    }
999

1000
1001
1002
1003
    $log->syslog('debug3', 'REMOTE_ADDR %s against %s',
        $ENV{'REMOTE_ADDR'}, $args[0]);
    return Net::CIDR::cidrlookup($ENV{'REMOTE_ADDR'}, @cidr) ? 1 : 0;
}
1004

1005
1006
1007
1008
1009
1010
##### condition older
sub do_older {
    $log->syslog('debug3', '(%s,%s,%s,%s)', @_);
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
1011

1012
1013
1014
1015
1016
1017
1018
    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;
1019
    }
1020
}
1021

1022
1023
1024
sub do_newer {
    goto &do_older;
}
1025

1026
1027
1028
1029
1030
##### condition is_owner, is_subscriber and is_editor
sub do_is_owner {
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
1031

1032
    return 0 if $args[1] eq 'nobody';
1033

IKEDA Soji's avatar
IKEDA Soji committed
1034
1035
1036
1037
1038
1039
    # 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]);
1040
    } else {
IKEDA Soji's avatar
IKEDA Soji committed
1041
1042
        my $robot = (ref $that eq 'Sympa::List') ? $that->{'domain'} : $that;
        $list = Sympa::List->new($args[0], $robot);
1043
    }
1044

IKEDA Soji's avatar
IKEDA Soji committed
1045
    unless ($list) {
1046
1047
1048
        $log->syslog('err', 'Unable to create list object "%s"', $args[0]);
        return 0;
    }
1049

1050
1051
1052
1053
1054
1055
1056
1057
1058
    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]);
    }
1059

1060
1061
    if ($condition_key eq 'is_subscriber') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1062
            if ($list->is_list_member($arg)) {
1063
1064
                $ok = $arg;
                last;
1065
            }
1066
1067
1068
1069
        }
        return $ok ? 1 : 0;
    } elsif ($condition_key eq 'is_owner') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1070
1071
            if ($list->is_admin('owner', $arg)
                or Sympa::is_listmaster($list, $arg)) {
1072
1073
                $ok = $arg;
                last;
1074
1075
            }
        }
1076
1077
1078
        return $ok ? 1 : 0;
    } elsif ($condition_key eq 'is_editor') {
        foreach my $arg (@arg) {
IKEDA Soji's avatar
IKEDA Soji committed
1079
            if ($list->is_admin('actual_editor', $arg)) {
1080
1081
1082
                $ok = $arg;
                last;
            }
1083
        }
1084
1085
1086
        return $ok ? 1 : 0;
    }
}
1087

1088
1089
1090
sub do_is_subscriber {
    goto &do_is_owner;
}
1091

1092
1093
1094
sub do_is_editor {
    goto &do_is_owner;
}
1095

1096
1097
1098
1099
1100
1101
1102
1103
##### match
sub do_match {
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
    unless ($args[1] =~ /^\/(.*)\/$/) {
        $log->syslog('err', 'Match parameter %s is not a regexp', $args[1]);
        return undef;
1104
    }
1105
    my $regexp = $1;
1106

1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
    # Nothing can match an empty regexp.
    return 0 unless length $regexp;

    my $robot = (ref $that eq 'Sympa::List') ? $that->{'domain'} : $that;

    my $reghost = Conf::get_robot_conf($robot, 'domain');
    $reghost =~ s/\./\\./g;
    # "[host]" as alias of "[domain]": Compat. < 6.2.32
    $regexp =~ s/[[](?:domain|host)[]]/$reghost/g;

    # wrap matches with eval{} to avoid crash by malformed regexp.
    my $r = 0;
    if (ref($args[0])) {
        eval {
1121
            foreach my $arg (@{$args[0]}) {
1122
1123
1124
                if ($arg =~ /$regexp/i) {
                    $r = 1;
                    last;
1125
1126
                }
            }
1127
1128
1129
1130
1131
        };
    } else {
        eval {
            if ($args[0] =~ /$regexp/i) {
                $r = 1;
1132
            }
1133
1134
1135
1136
1137
        };
    }
    if ($EVAL_ERROR) {
        $log->syslog('err', 'Cannot evaluate match: %s', $EVAL_ERROR);
        return undef;
1138
    }
1139
1140
    return $r ? 1 : 0;
}
1141

1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
## search rule

## equal
sub do_equal {
    $log->syslog('debug3', '(%s,%s,...)', @_);
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
    if (ref $args[0]) {
        foreach my $arg (@{$args[0]}) {
            return 1 if lc $arg eq lc $args[1];
1153
        }
1154
1155
    } elsif (lc $args[0] eq lc $args[1]) {
        return 1;
1156
    }
1157
1158
    return 0;
}
1159

1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
## custom perl module

## less_than
sub do_less_than {
    $log->syslog('debug3', '(%s,%s,,,,)', @_);
    my $that          = shift;
    my $condition_key = shift;
    my @args          = @_;
    if (ref $args[0]) {
        foreach my $arg (@{$args[0]}) {
            return 1 if Sympa::Tools::Data::smart_lessthan($arg, $args[1]);
1171
        }
1172
1173
    } else {
        return 1 if Sympa::Tools::Data::smart_lessthan($args[0], $args[1]);