Message.pm 130 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 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::Message;
29
30

use strict;
31
use warnings;
32
use DateTime;
33
use Encode qw();
34
use English;    # FIXME: drop $PREMATCH usage
35
use HTML::TreeBuilder;
36
use Mail::Address;
37
use MIME::Charset;
38
use MIME::EncWords;
39
use MIME::Entity;
40
use MIME::Field::ParamVal;
41
use MIME::Parser;
42
use MIME::Tools;
43
use Scalar::Util qw();
44
use Text::LineFold;
45
use URI::Escape qw();
46

47
BEGIN { eval 'use Crypt::SMIME'; }
48
BEGIN { eval 'use Net::DNS'; }
49

50
use Sympa;
51
use Conf;
sikeda's avatar
sikeda committed
52
use Sympa::Constants;
53
use Sympa::HTML::FormatText;
54
use Sympa::HTMLSanitizer;
55
use Sympa::Language;
56
use Sympa::Log;
57
use Sympa::Scenario;
58
use Sympa::Spool;
59
use Sympa::Template;
60
61
use Sympa::Tools::Data;
use Sympa::Tools::File;
62
use Sympa::Tools::Password;
63
use Sympa::Tools::SMIME;
64
use Sympa::Tools::Text;
65
use Sympa::User;
66

67
my $language = Sympa::Language->instance;
68
my $log      = Sympa::Log->instance;
69

70
sub new {
71
    $log->syslog('debug2', '(%s, ...)', @_);
sikeda's avatar
sikeda committed
72
73
    my $class      = shift;
    my $serialized = shift;
74

75
    my $self = bless {@_} => $class;
76

sikeda's avatar
sikeda committed
77
    unless (defined $serialized and length $serialized) {
78
        $log->syslog('err', 'Empty message');
79
        return undef;
80
    }
81

82
83
    # Get attributes from pseudo-header fields at the top of serialized
    # message.  Note that field names are case-sensitive.
84

sikeda's avatar
sikeda committed
85
86
    pos($serialized) = 0;
    while ($serialized =~ /\G(X-Sympa-[-\w]+): (.*?)\n(?![ \t])/cgs) {
sikeda's avatar
sikeda committed
87
88
89
90
91
        my ($k, $v) = ($1, $2);
        next unless length $v;

        if ($k eq 'X-Sympa-To') {
            $self->{'rcpt'} = join ',', split(/\s*,\s*/, $v);
92
        } elsif ($k eq 'X-Sympa-Checksum') {    # To migrate format <= 6.2a.40
sikeda's avatar
sikeda committed
93
94
95
96
97
            $self->{'checksum'} = $v;
        } elsif ($k eq 'X-Sympa-Family') {
            $self->{'family'} = $v;
        } elsif ($k eq 'X-Sympa-From') {    # Compatibility. Use Return-Path:
            $self->{'envelope_sender'} = $v;
98
        } elsif ($k eq 'X-Sympa-Auth-Level') {    # New in 6.2a.41
99
100
101
            if ($v eq 'md5') {
                $self->{'md5_check'} = 1;
            } else {
102
                $log->syslog('err',
103
104
                    'Unknown authentication level "%s", ignored', $v);
            }
105
106
        } elsif ($k eq 'X-Sympa-Message-ID') {    # New in 6.2a.41
            $self->{'message_id'} = $v;
107
108
        } elsif ($k eq 'X-Sympa-Sender') {        # New in 6.2a.41
            $self->{'sender'} = $v;
109
110
111
        } elsif ($k eq 'X-Sympa-Display-Name') {    # New in 6.2a.41
            $self->{'gecos'} = $v;
        } elsif ($k eq 'X-Sympa-Shelved') {         # New in 6.2a.41
112
113
114
115
            $self->{'shelved'} = {
                map {
                    my ($ak, $av) = split /=/, $_, 2;
                    ($ak => ($av || 1))
116
                } split(/\s*;\s*/, $v)
117
            };
118
        } elsif ($k eq 'X-Sympa-Spam-Status') {     # New in 6.2a.41
119
            $self->{'spam_status'} = $v;
sikeda's avatar
sikeda committed
120
        } else {
121
            $log->syslog('err', 'Unknown attribute information: "%s: %s"',
122
                $k, $v);
123
        }
sikeda's avatar
sikeda committed
124
125
    }
    # Ignore Unix From_
sikeda's avatar
sikeda committed
126
    $serialized =~ /\GFrom (.*?)\n(?![ \t])/cgs;
sikeda's avatar
sikeda committed
127
128
129
130
    # Get envelope sender from Return-Path:.
    # If old style X-Sympa-From: has been found, omit Return-Path:.
    #
    # We trust in "Return-Path:" header field only at the top of message
131
    # to prevent forgery.  See CAVEAT.
sikeda's avatar
sikeda committed
132
    if ($serialized =~ /\GReturn-Path: (.*?)\n(?![ \t])/cgs
sikeda's avatar
sikeda committed
133
134
135
136
137
138
        and not exists $self->{'envelope_sender'}) {
        my $addr = $1;
        if ($addr =~ /<>/) {    # special: null envelope sender
            $self->{'envelope_sender'} = '<>';
        } else {
            my @addrs = Mail::Address->parse($addr);
139
140
            if (@addrs
                and Sympa::Tools::Text::valid_email($addrs[0]->address)) {
sikeda's avatar
sikeda committed
141
                $self->{'envelope_sender'} = $addrs[0]->address;
142
143
            }
        }
sikeda's avatar
sikeda committed
144
145
    }
    # Strip attributes.
sikeda's avatar
sikeda committed
146
    substr($serialized, 0, pos $serialized) = '';
147
148

    # Check if message is parsable.
149

150
151
    my $parser = MIME::Parser->new;
    $parser->output_to_core(1);
152
    $parser->tmp_dir($Conf::Conf{'tmpdir'});
sikeda's avatar
sikeda committed
153
    my $entity = $parser->parse_data(\$serialized);
154
    unless ($entity) {
155
        $log->syslog('err', 'Unable to parse message');
156
157
        return undef;
    }
158
    my $hdr = $entity->head;
sikeda's avatar
sikeda committed
159
    my ($dummy, $body_string) = split /(?:\A|\n)\r?\n/, $serialized, 2;
160

161
162
163
    $self->{_head}         = $hdr;
    $self->{_body}         = $body_string;
    $self->{_entity_cache} = $entity;
sikeda's avatar
sikeda committed
164
    $self->{'size'}        = length $serialized;
165

166
167
168
    unless (exists $self->{'sender'} and defined $self->{'sender'}) {
        ($self->{'sender'}, $self->{'gecos'}) = $self->_get_sender_email;
    }
169
170

    ## Store decoded subject and its original charset
171
    my $subject = $hdr->get('Subject');
172
    if (defined $subject and $subject =~ /\S/) {
173
        my @decoded_subject = MIME::EncWords::decode_mimewords($subject);
174
        $self->{'subject_charset'} = 'US-ASCII';
175
176
177
178
        foreach my $token (@decoded_subject) {
            unless ($token->[1]) {
                # don't decode header including raw 8-bit bytes.
                if ($token->[0] =~ /[^\x00-\x7F]/) {
179
                    $self->{'subject_charset'} = undef;
180
181
182
183
184
185
186
                    last;
                }
                next;
            }
            my $cset = MIME::Charset->new($token->[1]);
            # don't decode header encoded with unknown charset.
            unless ($cset->decoder) {
187
                $self->{'subject_charset'} = undef;
188
189
190
                last;
            }
            unless ($cset->output_charset eq 'US-ASCII') {
191
                $self->{'subject_charset'} = $token->[1];
192
193
            }
        }
194
    } else {
195
        $self->{'subject_charset'} = undef;
196
    }
197
    if ($self->{'subject_charset'}) {
sikeda's avatar
sikeda committed
198
199
200
        chomp $subject;
        $self->{'decoded_subject'} =
            MIME::EncWords::decode_mimewords($subject, Charset => 'UTF-8');
201
    } else {
sikeda's avatar
sikeda committed
202
        if (defined $subject) {
203
204
205
206
            chomp $subject;
            $subject =~ s/(\r\n|\r|\n)(?=[ \t])//g;
            $subject =~ s/\r\n|\r|\n/ /g;
        }
207
        $self->{'decoded_subject'} = $subject;
208
    }
209

210
211
    ## TOPICS
    my $topics;
212
    if ($topics = $hdr->get('X-Sympa-Topic')) {
213
        $self->{'topic'} = $topics;
214
215
    }

216
    # Message ID
217
218
219
    unless (exists $self->{'message_id'}) {
        $self->{'message_id'} = _get_message_id($self);
    }
220

221
    return $self;
222
223
}

224
225
226
227
# Tentative: removed when refactoring finished.
sub new_from_file {
    my $class = shift;
    my $file  = shift;
228

229
    open my $fh, '<', $file or return undef;
230
    my $serialized = do { local $RS; <$fh> };
231
232
    close $fh;

sikeda's avatar
sikeda committed
233
    my $self = $class->new($serialized, @_)
234
235
236
237
238
        or return undef;

    $self->{'filename'} = $file;
    # Get file date
    unless (exists $self->{'date'}) {
239
        $self->{'date'} = Sympa::Tools::File::get_mtime($file);
240
241
    }

242
    return $self;
243
244
245
246
247
248
}

## Get sender of the message according to header fields specified by
## 'sender_headers' parameter.
## FIXME: S/MIME signer may not be same as the sender given by this function.
sub _get_sender_email {
sikeda's avatar
sikeda committed
249
    my $self = shift;
250

sikeda's avatar
sikeda committed
251
    my $hdr = $self->{_head};
252
253

    my $sender = undef;
254
    my $gecos  = undef;
255
    foreach my $field (split /[\s,]+/, $Conf::Conf{'sender_headers'}) {
256
257
        if (lc $field eq 'return-path') {
            ## Try to get envelope sender
sikeda's avatar
sikeda committed
258
259
260
            if (    $self->{'envelope_sender'}
                and $self->{'envelope_sender'} ne '<>') {
                $sender = lc($self->{'envelope_sender'});
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
            }
        } elsif ($hdr->get($field)) {
            ## Try to get message header.
            ## On "Resent-*:" headers, the first occurrence must be used (see
            ## RFC 5322 3.6.6).
            ## FIXME: Though "From:" can occur multiple times, only the first
            ## one is detected.
            my $addr = $hdr->get($field, 0);               # get the first one
            my @sender_hdr = Mail::Address->parse($addr);
            if (@sender_hdr and $sender_hdr[0]->address) {
                $sender = lc($sender_hdr[0]->address);
                my $phrase = $sender_hdr[0]->phrase;
                if (defined $phrase and length $phrase) {
                    $gecos = MIME::EncWords::decode_mimewords($phrase,
                        Charset => 'UTF-8');
276
277
278
                    # Eliminate hostile characters.
                    $gecos =~ s/(\r\n|\r|\n)(?=[ \t])//g;
                    $gecos =~ s/[\0\r\n]+//g;
279
280
281
282
283
284
                }
                last;
            }
        }

        last if defined $sender;
285
286
    }
    unless (defined $sender) {
287
        #$log->syslog('debug3', 'No valid sender address');
sikeda's avatar
sikeda committed
288
        return;
289
    }
290
    unless (Sympa::Tools::Text::valid_email($sender)) {
291
        $log->syslog('err', 'Invalid sender address "%s"', $sender);
sikeda's avatar
sikeda committed
292
        return;
293
294
    }

295
    return ($sender, $gecos);
296
297
}

298
299
300
301
302
# Note that this must be called after decrypting message
# FIXME: Also check Resent-Message-ID:.
sub _get_message_id {
    my $self = shift;

303
304
    return Sympa::Tools::Text::canonic_message_id(
        $self->{_head}->get('Message-Id', 0));
305
306
}

307
308
# Old names: (part of) mail::mail_file(), mail::parse_tt2_messageasstring(),
# List::send_file(), List::send_global_file().
309
310
# Moved to: Sympa::Message::Template::new().
#sub new_from_template;
311

312
313
314
315
316
317
318
319
320
sub dup {
    my $self = shift;

    my $clone = {};
    foreach my $key (sort keys %$self) {
        my $val = $self->{$key};
        next unless defined $val;

        unless (Scalar::Util::blessed($val)) {
321
            $clone->{$key} = Sympa::Tools::Data::dup_var($val);
322
        } elsif ($val->can('dup') and !$val->isa('Sympa::List')) {
323
324
325
326
327
328
329
330
331
            $clone->{$key} = $val->dup;
        } else {
            $clone->{$key} = $val;
        }
    }

    return bless $clone => ref($self);
}

332
sub to_string {
333
334
    my $self    = shift;
    my %options = @_;
335

sikeda's avatar
sikeda committed
336
    my $serialized = '';
337
    if (ref $self->{'rcpt'} eq 'ARRAY' and @{$self->{'rcpt'}}) {
sikeda's avatar
sikeda committed
338
339
        $serialized .= sprintf "X-Sympa-To: %s\n",
            join(',', @{$self->{'rcpt'}});
340
    } elsif (defined $self->{'rcpt'} and length $self->{'rcpt'}) {
sikeda's avatar
sikeda committed
341
        $serialized .= sprintf "X-Sympa-To: %s\n",
342
343
344
            join(',', split(/\s*,\s*/, $self->{'rcpt'}));
    }
    if (defined $self->{'checksum'}) {
sikeda's avatar
sikeda committed
345
        $serialized .= sprintf "X-Sympa-Checksum: %s\n", $self->{'checksum'};
346
347
    }
    if (defined $self->{'family'}) {
sikeda's avatar
sikeda committed
348
        $serialized .= sprintf "X-Sympa-Family: %s\n", $self->{'family'};
349
    }
350
    if (defined $self->{'md5_check'}
351
        and length $self->{'md5_check'}) {    # New in 6.2a.41
352
353
        $serialized .= sprintf "X-Sympa-Auth-Level: %s\n", 'md5';
    }
354
    if (defined $self->{'message_id'}) {      # New in 6.2a.41
355
356
        $serialized .= sprintf "X-Sympa-Message-ID: %s\n",
            $self->{'message_id'};
357
    }
358
    if (defined $self->{'sender'}) {          # New in 6.2a.41
359
360
        $serialized .= sprintf "X-Sympa-Sender: %s\n", $self->{'sender'};
    }
361
362
363
364
    if (defined $self->{'gecos'}
        and length $self->{'gecos'}) {        # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Display-Name: %s\n", $self->{'gecos'};
    }
365
    if (%{$self->{'shelved'} || {}}) {        # New in 6.2a.41
366
367
        $serialized .= sprintf "X-Sympa-Shelved: %s\n", join(
            '; ',
368
369
            map {
                my $v = $self->{shelved}{$_};
370
                ("$v" eq '1') ? $_ : sprintf('%s=%s', $_, $v);
371
                }
372
373
374
375
376
                grep {
                $self->{shelved}{$_}
                } sort keys %{$self->{shelved}}
        );
    }
377
    if (defined $self->{'spam_status'}) {     # New in 6.2a.41.
378
379
        $serialized .= sprintf "X-Sympa-Spam-Status: %s\n",
            $self->{'spam_status'};
380
    }
381
382
    # This terminates pseudo-header part for attributes.
    unless (defined $self->{'envelope_sender'}) {
sikeda's avatar
sikeda committed
383
        $serialized .= "Return-Path: \n";
384
385
    }

sikeda's avatar
sikeda committed
386
    $serialized .= $self->as_string(%options);
387

sikeda's avatar
sikeda committed
388
    return $serialized;
389
390
}

391
392
393
sub add_header {
    my $self = shift;
    $self->{_head}->add(@_);
sikeda's avatar
sikeda committed
394
    delete $self->{_entity_cache};    # Clear entity cache.
395
396
397
398
399
}

sub delete_header {
    my $self = shift;
    $self->{_head}->delete(@_);
sikeda's avatar
sikeda committed
400
    delete $self->{_entity_cache};    # Clear entity cache.
401
402
403
404
405
}

sub replace_header {
    my $self = shift;
    $self->{_head}->replace(@_);
sikeda's avatar
sikeda committed
406
    delete $self->{_entity_cache};    # Clear entity cache.
407
408
409
410
411
412
}

sub head {
    shift->{_head};
}

413
414
415
416
417
# NOTE: As this processes is needed for incoming messages only, it would be
# moved to incoming pipeline class..
sub check_spam_status {
    my $self = shift;

sikeda's avatar
sikeda committed
418
    my $robot_id =
419
420
421
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
422

423
    my $spam_status =
IKEDA Soji's avatar
IKEDA Soji committed
424
425
        Sympa::Scenario->new($robot_id, 'spam_status')
        ->authz('smtp', {'message' => $self});
426
427
428
429
430
431
432
433
434
435
436
    if (defined $spam_status) {
        if (ref($spam_status) eq 'HASH') {
            $self->{'spam_status'} = $spam_status->{'action'};
        } else {
            $self->{'spam_status'} = $spam_status;
        }
    } else {
        $self->{'spam_status'} = 'unknown';
    }
}

437
my $has_mail_dkim_textwrap;
438

439
440
441
442
443
444
445
BEGIN {
    eval 'use Mail::DKIM::Signer';
    # This doesn't export $VERSION.
    eval 'use Mail::DKIM::TextWrap';
    $has_mail_dkim_textwrap = !$EVAL_ERROR;
    # Mail::DKIM::Signer prior to 0.38 doesn't import this.
    eval 'use Mail::DKIM::PrivateKey';
John Levine's avatar
John Levine committed
446
    eval 'use Mail::DKIM::ARC::Signer';
447
448
}

sikeda's avatar
sikeda committed
449
450
# Old name: tools::dkim_sign() which took string and returned string.
sub dkim_sign {
451
    $log->syslog('debug', '(%s)', @_);
sikeda's avatar
sikeda committed
452
    my $self    = shift;
sikeda's avatar
sikeda committed
453
454
455
456
457
458
459
460
    my %options = @_;

    my $dkim_d          = $options{'dkim_d'};
    my $dkim_i          = $options{'dkim_i'};
    my $dkim_selector   = $options{'dkim_selector'};
    my $dkim_privatekey = $options{'dkim_privatekey'};

    unless ($dkim_selector) {
461
        $log->syslog('err',
sikeda's avatar
sikeda committed
462
463
464
465
            "DKIM selector is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_privatekey) {
466
        $log->syslog('err',
sikeda's avatar
sikeda committed
467
468
469
470
            "DKIM key file is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_d) {
471
        $log->syslog('err',
sikeda's avatar
sikeda committed
472
473
474
475
            "DKIM d= tag is undefined, could not sign message");
        return undef;
    }

476
    unless ($Mail::DKIM::Signer::VERSION) {
477
        $log->syslog('err',
sikeda's avatar
sikeda committed
478
479
480
481
            "Failed to load Mail::DKIM::Signer Perl module, ignoring DKIM signature"
        );
        return undef;
    }
482
    unless ($has_mail_dkim_textwrap) {
483
        $log->syslog('err',
sikeda's avatar
sikeda committed
484
485
486
            "Failed to load Mail::DKIM::TextWrap Perl module, signature will not be pretty"
        );
    }
487
488

    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
sikeda's avatar
sikeda committed
489
490
    my $privatekey_string = join '',
        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $dkim_privatekey;
491
492
    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
    unless ($privatekey) {
493
        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
494
        return undef;
sikeda's avatar
sikeda committed
495
    }
496
497
    # create a signer object
    my $dkim = Mail::DKIM::Signer->new(
498
        Algorithm => "rsa-sha256",
499
500
501
502
503
504
        Method    => "relaxed",
        Domain    => $dkim_d,
        Selector  => $dkim_selector,
        Key       => $privatekey,
        ($dkim_i ? (Identity => $dkim_i) : ()),
    );
sikeda's avatar
sikeda committed
505
    unless ($dkim) {
506
        $log->syslog('err', 'Can\'t create Mail::DKIM::Signer');
sikeda's avatar
sikeda committed
507
508
509
        return undef;
    }
    # $new_body will store the body as fed to Mail::DKIM to reuse it
510
    # when returning the message as string.  Line terminators must be
511
    # normalized with CRLF.
512
    my $msg_as_string = $self->as_string;
sikeda's avatar
sikeda committed
513
    $msg_as_string =~ s/\r?\n/\r\n/g;
sikeda's avatar
sikeda committed
514
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
sikeda's avatar
sikeda committed
515
516
    $dkim->PRINT($msg_as_string);
    unless ($dkim->CLOSE) {
517
        $log->syslog('err', 'Cannot sign (DKIM) message');
sikeda's avatar
sikeda committed
518
519
520
521
522
523
524
        return undef;
    }

    my ($dummy, $new_body) = split /\r\n\r\n/, $msg_as_string, 2;
    $new_body =~ s/\r\n/\n/g;

    # Signing is done. Rebuilding message as string with original body
525
526
    # and new headers.
    # Note that DKIM-Signature: field should be prepended to the header.
527
528
    $self->add_header('DKIM-Signature', $dkim->signature->as_string, 0);
    $self->{_body} = $new_body;
529
    delete $self->{_entity_cache};    # Clear entity cache.
sikeda's avatar
sikeda committed
530

531
    return $self;
sikeda's avatar
sikeda committed
532
533
}

John Levine's avatar
John Levine committed
534
sub arc_seal {
John Levine's avatar
John Levine committed
535
    $log->syslog('debug2', '(%s)', @_);
John Levine's avatar
John Levine committed
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
    my $self    = shift;
    my %options = @_;

    my $arc_d          = $options{'arc_d'};
    my $arc_selector   = $options{'arc_selector'};
    my $arc_privatekey = $options{'arc_privatekey'};
    my $arc_srvid      = $options{'arc_srvid'};
    my $arc_cv         = $options{'arc_cv'};

    unless ($arc_selector) {
        $log->syslog('err',
            "ARC selector is undefined, could not seal message");
        return undef;
    }
    unless ($arc_privatekey) {
        $log->syslog('err',
            "ARC key file is undefined, could not seal message");
        return undef;
    }
    unless ($arc_d) {
        $log->syslog('err',
            "ARC d= tag is undefined, could not seal message");
        return undef;
    }

    unless ($arc_cv =~ m{^(none|pass|fail)$}) {
        $log->syslog('err',
Luc Didry's avatar
Luc Didry committed
563
            "ARC chain value %s is invalid, could not seal message", $arc_cv);
John Levine's avatar
John Levine committed
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
        return undef;
    }

    unless ($Mail::DKIM::ARC::Signer::VERSION) {
        $log->syslog('err',
            "Failed to load Mail::DKIM::ARC::Signer Perl module, no seal added"
        );
        return undef;
    }

    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
    my $privatekey_string = join '',
        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $arc_privatekey;
    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
    unless ($privatekey) {
        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
        return undef;

    }

    # create a signer object
    my $arc = Mail::DKIM::ARC::Signer->new(
        Algorithm => "rsa-sha256",
        Chain     => $arc_cv,
        SrvId     => $arc_srvid,
        Domain    => $arc_d,
        Selector  => $arc_selector,
        Key       => $privatekey,
    );
    unless ($arc) {
        $log->syslog('err', 'Can\'t create Mail::DKIM::ARC::Signer');
        return undef;
    }
    # $new_body will store the body as fed to Mail::DKIM to reuse it
    # when returning the message as string.  Line terminators must be
    # normalized with CRLF.
    my $msg_as_string = $self->as_string;
    $msg_as_string =~ s/\r?\n/\r\n/g;
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
    $arc->PRINT($msg_as_string);
    unless ($arc->CLOSE) {
        $log->syslog('err', 'Cannot ARC seal message');
        return undef;
    }
IKEDA Soji's avatar
IKEDA Soji committed
608
609
    $log->syslog('debug2', 'ARC %s: %s', $arc->{result},
        $arc->{result_reason});
John Levine's avatar
John Levine committed
610

John Levine's avatar
John Levine committed
611
612
613
    # don't need this since DKIM just did it
    #    my ($dummy, $new_body) = split /\r\n\r\n/, $msg_as_string, 2;
    #$new_body =~ s/\r\n/\n/g;
John Levine's avatar
John Levine committed
614

John Levine's avatar
John Levine committed
615
    # Seal is done. Add new headers for the seal
John Levine's avatar
John Levine committed
616
    my @seal = $arc->as_strings();
617
618
619
620
621
    if (grep { $_ and /\AARC-Seal:/i } @seal) {
        foreach my $ahdr (reverse @seal) {
            my ($ah, $av) = split /:\s*/, $ahdr, 2;
            $self->add_header($ah, $av, 0);
        }
John Levine's avatar
John Levine committed
622
    }
John Levine's avatar
John Levine committed
623
    #$self->{_body} = $new_body;
John Levine's avatar
John Levine committed
624
625
626
627
628
    delete $self->{_entity_cache};    # Clear entity cache.

    return $self;
}

Luc Didry's avatar
Luc Didry committed
629
630
631
BEGIN {
    eval 'use Mail::DKIM::Verifier';
    eval 'use Mail::DKIM::ARC::Verifier';
John Levine's avatar
John Levine committed
632
}
633

sikeda's avatar
sikeda committed
634
635
sub check_dkim_signature {
    my $self = shift;
636

sikeda's avatar
sikeda committed
637
    return unless $Mail::DKIM::Verifier::VERSION;
638

sikeda's avatar
sikeda committed
639
    my $robot_id =
640
641
642
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
John Levine's avatar
John Levine committed
643

644
    return
645
        unless Sympa::Tools::Data::smart_eq(
646
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
647

648
649
    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
650
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
651
652
653
654
655
656
657
658
659
        return;
    }

    # Line terminators must be normalized with CRLF.
    my $msg_as_string = $self->as_string;
    $msg_as_string =~ s/\r?\n/\r\n/g;
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
    $dkim->PRINT($msg_as_string);
    unless ($dkim->CLOSE) {
660
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
661
        return;
662
    }
663
664
665
666
667
668
669
670
671

    #FIXME: Identity of signatures would be checked.
    foreach my $signature ($dkim->signatures) {
        if ($signature->result_detail eq 'pass') {
            $self->{'dkim_pass'} = 1;
            return;
        }
    }
    delete $self->{'dkim_pass'};
672
673
}

John Levine's avatar
John Levine committed
674
675
676
677
678
679
680
681
682
683
sub check_arc_chain {
    my $self = shift;

    return unless $Mail::DKIM::ARC::Verifier::VERSION;

    my $robot_id =
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
    my $srvid;
Luc Didry's avatar
Luc Didry committed
684
    unless ($srvid = Conf::get_robot_conf($robot_id || '*', 'arc_srvid')) {
John Levine's avatar
John Levine committed
685
        $log->syslog('debug2', 'ARC library installed, but no arc_srvid set');
John Levine's avatar
John Levine committed
686
687
688
689
690
691
        return;
    }

    # if there is no authentication-results, not much point in checking ARC
    # since we can't add a new seal

Luc Didry's avatar
Luc Didry committed
692
    my @ars =
693
694
695
        grep { my $d = $_->param('_'); $d and lc $d eq lc $srvid }
        map { MIME::Field::ParamVal->parse($_) }
        $self->get_header('Authentication-Results');
John Levine's avatar
John Levine committed
696

Luc Didry's avatar
Luc Didry committed
697
698
699
    unless (@ars) {
        $log->syslog('debug2',
            'ARC enabled but no Authentication-Results: %s;', $srvid);
John Levine's avatar
John Levine committed
700
701
702
        return;
    }
    # already checked?
703
    foreach my $ar (@ars) {
704
705
        my $param_arc = $ar->param('arc');
        if ($param_arc and $param_arc =~ m{\A(pass|fail|none)\b}i) {
706
            $self->{shelved}->{arc_cv} = $1;
707
            $log->syslog('debug2', 'ARC already checked: %s', $param_arc);
708
709
            return;
        }
John Levine's avatar
John Levine committed
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
    }

    my $arc;
    unless ($arc = Mail::DKIM::ARC::Verifier->new(Strict => 1)) {
        $log->syslog('err', 'Could not create Mail::DKIM::ARC::Verifier');
        return;
    }

    # Line terminators must be normalized with CRLF.
    my $msg_as_string = $self->as_string;
    $msg_as_string =~ s/\r?\n/\r\n/g;
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
    $arc->PRINT($msg_as_string);
    unless ($arc->CLOSE) {
        $log->syslog('err', 'Cannot verify chain of (ARC) message');
        return;
    }

    $log->syslog('debug2', 'result %s', $arc->result);
    $self->{shelved}->{arc_cv} = $arc->result;
}

sikeda's avatar
sikeda committed
732
733
734
# Old name: tools::remove_invalid_dkim_signature() which takes a message as
# string and outputs idem without signature if invalid.
sub remove_invalid_dkim_signature {
735
    $log->syslog('debug2', '(%s)', @_);
736
    my $self = shift;
sikeda's avatar
sikeda committed
737

738
    return unless $self->get_header('DKIM-Signature');
739
740
741

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
742
        $log->syslog('info',
743
744
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
sikeda's avatar
sikeda committed
745
746
747
    }
}

748
749
750
sub as_entity {
    my $self = shift;

751
    unless (defined $self->{_entity_cache}) {
752
753
754
755
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');
756
757
758

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
759
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
760
        $self->{_entity_cache} = $parser->parse_data(\$string);
761
    }
762
    return $self->{_entity_cache};
763
764
765
766
767
768
769
}

sub set_entity {
    my $self   = shift;
    my $entity = shift;
    return undef unless $entity;

770
771
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
772
773

    if ($orig ne $new) {
sikeda's avatar
sikeda committed
774
775
776
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
777
778
779
780
781
    }

    return $entity;
}

782
sub as_string {
783
784
    my $self    = shift;
    my %options = @_;
785

786
    die 'Bug in logic.  Ask developer' unless $self->{_head};
787

788
789
790
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

791
792
793
794
795
796
    my $return_path = '';
    if (defined $self->{'envelope_sender'}) {
        my $val = $self->{'envelope_sender'};
        $val = "<$val>" unless $val eq '<>';
        $return_path = sprintf "Return-Path: %s\n", $val;
    }
sikeda's avatar
sikeda committed
797
798
799
    return
          $return_path
        . $self->{_head}->as_string . "\n"
800
        . (defined $self->{_body} ? $self->{_body} : '');
801
}
802

803
804
805
806
807
808
809
810
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
811
812
}

813
814
815
816
sub get_header {
    my $self  = shift;
    my $field = shift;
    my $sep   = shift;
817
818
    die sprintf 'Second argument is not index but separator: "%s"', $sep
        if defined $sep and Scalar::Util::looks_like_number($sep);
819

820
    my $hdr = $self->{_head};
821
822

    if (defined $sep or wantarray) {
823
        my @values = grep {s/\A$field\s*:\s*//i}
824
825
826
827
828
829
830
831
832
833
834
835
836
            split /\n(?![ \t])/, $hdr->as_string();
        if (defined $sep) {
            return undef unless @values;
            return join $sep, @values;
        }
        return @values;
    } else {
        my $value = $hdr->get($field, 0);
        chomp $value if defined $value;
        return $value;
    }
}

sikeda's avatar
sikeda committed
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
# Old name: tools::decode_header() which can take Message, MIME::Entity,
# MIME::Head or Mail::Header object as argument.
sub get_decoded_header {
    my $self = shift;
    my $tag  = shift;
    my $sep  = shift;

    my $head = $self->head;

    if (defined $sep) {
        my @values = $head->get($tag);
        return undef unless scalar @values;
        foreach my $val (@values) {
            $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
            chomp $val;
        }
        return join $sep, @values;
    } else {
        my $val = $head->get($tag);
        return undef unless defined $val;
        $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
        chomp $val;
        return $val;
    }
}

sikeda's avatar
sikeda committed
863
864
# Dump the Message object
# Currently not used.
865
866
sub dump {
    my ($self, $output) = @_;
sikeda's avatar
sikeda committed
867
    # my $output ||= \*STDERR;
868
869
870
871
872

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
873
874
875
876
877
878
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
879
    }
880

881
882
883
884
885
    select $old_output;

    return 1;
}

886
## Add topic and put header X-Sympa-Topic
887
# OBSOLETED.  No longer used.
888
sub add_topic {
889
    my ($self, $topic) = @_;
890
891

    $self->{'topic'} = $topic;
892
    $self->add_header('X-Sympa-Topic', $topic);
893
894
895
}

## Get topic
896
# OBSOLETED.  No longer used.
897
898
899
900
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
901
        return $self->{'topic'};
902
903

    } else {
904
        return '';
905
906
907
    }
}

908
sub clean_html {
sikeda's avatar
sikeda committed
909
    my $self = shift;
910

sikeda's avatar
sikeda committed
911
    my $robot =
912
913
914
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
915
916
917
918

    my $entity = $self->as_entity->dup;
    if ($entity = _fix_html_part($entity, $robot)) {
        $self->set_entity($entity);
919
        return 1;
920
921
922
923
    }
    return 0;
}

924
sub _fix_html_part {
sikeda's avatar
sikeda committed
925
926
    my $entity = shift;
    my $robot  = shift;
927
    return $entity unless $entity;
928

929
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
930
    if ($entity->parts) {
931
        my @newparts = ();
932
933
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
934
        }
935
        $entity->parts(\@newparts);
936
    } elsif ($eff_type eq 'text/html') {
937
        my $bodyh = $entity->bodyhandle;
938
        # Encoded body or null body won't be modified.
939
        return $entity if !$bodyh or $bodyh->is_encoded;
940
941
942
943

        my $body = $bodyh->as_string;
        # Re-encode parts to UTF-8, since StripScripts cannot handle texts
        # with some charsets (ISO-2022-*, UTF-16*, ...) correctly.
sikeda's avatar
sikeda committed
944
945
        my $cset = MIME::Charset->new(
            $entity->head->mime_attr('Content-Type.Charset') || '');
946
947
948
949
950
951
952
953
954
955
956
957
        unless ($cset->decoder) {
            # Charset is unknown.  Detect 7-bit charset.
            my ($dummy, $charset) =
                MIME::Charset::body_enco