Message.pm 129 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::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::Parser;
41
use MIME::Tools;
42
use Scalar::Util qw();
43
use Text::LineFold;
44
use URI::Escape qw();
45

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

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

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

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

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

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

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

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

        if ($k eq 'X-Sympa-To') {
            $self->{'rcpt'} = join ',', split(/\s*,\s*/, $v);
91
        } elsif ($k eq 'X-Sympa-Checksum') {    # To migrate format <= 6.2a.40
sikeda's avatar
sikeda committed
92
93
94
95
96
            $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;
97
        } elsif ($k eq 'X-Sympa-Auth-Level') {    # New in 6.2a.41
98
99
100
            if ($v eq 'md5') {
                $self->{'md5_check'} = 1;
            } else {
101
                $log->syslog('err',
102
103
                    'Unknown authentication level "%s", ignored', $v);
            }
104
105
        } elsif ($k eq 'X-Sympa-Message-ID') {    # New in 6.2a.41
            $self->{'message_id'} = $v;
106
107
        } elsif ($k eq 'X-Sympa-Sender') {        # New in 6.2a.41
            $self->{'sender'} = $v;
108
109
110
        } 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
111
112
113
114
            $self->{'shelved'} = {
                map {
                    my ($ak, $av) = split /=/, $_, 2;
                    ($ak => ($av || 1))
115
                } split(/\s*;\s*/, $v)
116
            };
117
        } elsif ($k eq 'X-Sympa-Spam-Status') {     # New in 6.2a.41
118
            $self->{'spam_status'} = $v;
sikeda's avatar
sikeda committed
119
        } else {
120
            $log->syslog('err', 'Unknown attribute information: "%s: %s"',
121
                $k, $v);
122
        }
sikeda's avatar
sikeda committed
123
124
    }
    # Ignore Unix From_
sikeda's avatar
sikeda committed
125
    $serialized =~ /\GFrom (.*?)\n(?![ \t])/cgs;
sikeda's avatar
sikeda committed
126
127
128
129
    # 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
130
    # to prevent forgery.  See CAVEAT.
sikeda's avatar
sikeda committed
131
    if ($serialized =~ /\GReturn-Path: (.*?)\n(?![ \t])/cgs
sikeda's avatar
sikeda committed
132
133
134
135
136
137
        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);
138
139
            if (@addrs
                and Sympa::Tools::Text::valid_email($addrs[0]->address)) {
sikeda's avatar
sikeda committed
140
                $self->{'envelope_sender'} = $addrs[0]->address;
141
142
            }
        }
sikeda's avatar
sikeda committed
143
144
    }
    # Strip attributes.
sikeda's avatar
sikeda committed
145
    substr($serialized, 0, pos $serialized) = '';
146
147

    # Check if message is parsable.
148

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

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

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

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

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

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

220
    return $self;
221
222
}

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

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

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

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

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

## 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
248
    my $self = shift;
249

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

    my $sender = undef;
253
    my $gecos  = undef;
254
    foreach my $field (split /[\s,]+/, $Conf::Conf{'sender_headers'}) {
255
256
        if (lc $field eq 'return-path') {
            ## Try to get envelope sender
sikeda's avatar
sikeda committed
257
258
259
            if (    $self->{'envelope_sender'}
                and $self->{'envelope_sender'} ne '<>') {
                $sender = lc($self->{'envelope_sender'});
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
            }
        } 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');
275
276
277
                    # Eliminate hostile characters.
                    $gecos =~ s/(\r\n|\r|\n)(?=[ \t])//g;
                    $gecos =~ s/[\0\r\n]+//g;
278
279
280
281
282
283
                }
                last;
            }
        }

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

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

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

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

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

311
312
313
314
315
316
317
318
319
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)) {
320
            $clone->{$key} = Sympa::Tools::Data::dup_var($val);
321
        } elsif ($val->can('dup') and !$val->isa('Sympa::List')) {
322
323
324
325
326
327
328
329
330
            $clone->{$key} = $val->dup;
        } else {
            $clone->{$key} = $val;
        }
    }

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

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

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

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

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

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

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

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

sub head {
    shift->{_head};
}

412
413
414
415
416
# 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
417
    my $robot_id =
418
419
420
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
421

422
    my $spam_status =
423
        Sympa::Scenario::request_action($robot_id || $Conf::Conf{'domain'},
424
        'spam_status', 'smtp', {'message' => $self});
425
426
427
428
429
430
431
432
433
434
435
    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';
    }
}

436
my $has_mail_dkim_textwrap;
437

438
439
440
441
442
443
444
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
445
    eval 'use Mail::DKIM::ARC::Signer';
446
447
}

sikeda's avatar
sikeda committed
448
449
# Old name: tools::dkim_sign() which took string and returned string.
sub dkim_sign {
450
    $log->syslog('debug', '(%s)', @_);
sikeda's avatar
sikeda committed
451
    my $self    = shift;
sikeda's avatar
sikeda committed
452
453
454
455
456
457
458
459
    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) {
460
        $log->syslog('err',
sikeda's avatar
sikeda committed
461
462
463
464
            "DKIM selector is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_privatekey) {
465
        $log->syslog('err',
sikeda's avatar
sikeda committed
466
467
468
469
            "DKIM key file is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_d) {
470
        $log->syslog('err',
sikeda's avatar
sikeda committed
471
472
473
474
            "DKIM d= tag is undefined, could not sign message");
        return undef;
    }

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

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

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

John Levine's avatar
John Levine committed
533
sub arc_seal {
John Levine's avatar
John Levine committed
534
    $log->syslog('debug2', '(%s)', @_);
John Levine's avatar
John Levine committed
535
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
    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
562
            "ARC chain value %s is invalid, could not seal message", $arc_cv);
John Levine's avatar
John Levine committed
563
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;
    }

John Levine's avatar
John Levine committed
608
609
610
    # 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
611

John Levine's avatar
John Levine committed
612
    # Seal is done. Add new headers for the seal
John Levine's avatar
John Levine committed
613
614
    my @seal = $arc->as_strings();
    foreach my $ahdr (@seal) {
Luc Didry's avatar
Luc Didry committed
615
        my ($ah, $av) = split /:\s*/, $ahdr, 2;
John Levine's avatar
John Levine committed
616
617
        $self->add_header($ah, $av, 0);
    }
John Levine's avatar
John Levine committed
618
    #$self->{_body} = $new_body;
John Levine's avatar
John Levine committed
619
620
621
622
623
    delete $self->{_entity_cache};    # Clear entity cache.

    return $self;
}

Luc Didry's avatar
Luc Didry committed
624
625
626
BEGIN {
    eval 'use Mail::DKIM::Verifier';
    eval 'use Mail::DKIM::ARC::Verifier';
John Levine's avatar
John Levine committed
627
}
628

sikeda's avatar
sikeda committed
629
630
sub check_dkim_signature {
    my $self = shift;
631

sikeda's avatar
sikeda committed
632
    return unless $Mail::DKIM::Verifier::VERSION;
633

sikeda's avatar
sikeda committed
634
    my $robot_id =
635
636
637
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
John Levine's avatar
John Levine committed
638

639
    return
640
        unless Sympa::Tools::Data::smart_eq(
641
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
642

643
644
    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
645
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
646
647
648
649
650
651
652
653
654
        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) {
655
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
656
        return;
657
    }
658
659
660
661
662
663
664
665
666

    #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'};
667
668
}

John Levine's avatar
John Levine committed
669
670
671
672
673
674
675
676
677
678
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
679
    unless ($srvid = Conf::get_robot_conf($robot_id || '*', 'arc_srvid')) {
John Levine's avatar
John Levine committed
680
        $log->syslog('debug2', 'ARC library installed, but no arc_srvid set');
John Levine's avatar
John Levine committed
681
682
683
684
685
686
        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
687
688
    my @ars =
        grep {m{^\s*\Q$srvid\E;}} $self->get_header('Authentication-Results');
John Levine's avatar
John Levine committed
689

Luc Didry's avatar
Luc Didry committed
690
691
692
    unless (@ars) {
        $log->syslog('debug2',
            'ARC enabled but no Authentication-Results: %s;', $srvid);
John Levine's avatar
John Levine committed
693
694
695
        return;
    }
    # already checked?
696
    foreach my $ar (@ars) {
Luc Didry's avatar
Luc Didry committed
697
        if ($ar =~ m{\barc=(pass|fail|none)\b}i) {
698
699
700
701
            $log->syslog('debug2', "ARC already $1");
            $self->{shelved}->{arc_cv} = $1;
            return;
        }
John Levine's avatar
John Levine committed
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
    }

    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
724
725
726
# 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 {
727
    $log->syslog('debug2', '(%s)', @_);
728
    my $self = shift;
sikeda's avatar
sikeda committed
729

730
    return unless $self->get_header('DKIM-Signature');
731
732
733

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
734
        $log->syslog('info',
735
736
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
sikeda's avatar
sikeda committed
737
738
739
    }
}

740
741
742
sub as_entity {
    my $self = shift;

743
    unless (defined $self->{_entity_cache}) {
744
745
746
747
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');
748
749
750

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
751
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
752
        $self->{_entity_cache} = $parser->parse_data(\$string);
753
    }
754
    return $self->{_entity_cache};
755
756
757
758
759
760
761
}

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

762
763
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
764
765

    if ($orig ne $new) {
sikeda's avatar
sikeda committed
766
767
768
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
769
770
771
772
773
    }

    return $entity;
}

774
sub as_string {
775
776
    my $self    = shift;
    my %options = @_;
777

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

780
781
782
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

783
784
785
786
787
788
    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
789
790
791
    return
          $return_path
        . $self->{_head}->as_string . "\n"
792
        . (defined $self->{_body} ? $self->{_body} : '');
793
}
794

795
796
797
798
799
800
801
802
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
803
804
}

805
806
807
808
sub get_header {
    my $self  = shift;
    my $field = shift;
    my $sep   = shift;
809
810
    die sprintf 'Second argument is not index but separator: "%s"', $sep
        if defined $sep and Scalar::Util::looks_like_number($sep);
811

812
    my $hdr = $self->{_head};
813
814

    if (defined $sep or wantarray) {
815
        my @values = grep {s/\A$field\s*:\s*//i}
816
817
818
819
820
821
822
823
824
825
826
827
828
            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
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
# 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
855
856
# Dump the Message object
# Currently not used.
857
858
sub dump {
    my ($self, $output) = @_;
sikeda's avatar
sikeda committed
859
    # my $output ||= \*STDERR;
860
861
862
863
864

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
865
866
867
868
869
870
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
871
    }
872

873
874
875
876
877
    select $old_output;

    return 1;
}

878
## Add topic and put header X-Sympa-Topic
879
# OBSOLETED.  No longer used.
880
sub add_topic {
881
    my ($self, $topic) = @_;
882
883

    $self->{'topic'} = $topic;
884
    $self->add_header('X-Sympa-Topic', $topic);
885
886
887
}

## Get topic
888
# OBSOLETED.  No longer used.
889
890
891
892
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
893
        return $self->{'topic'};
894
895

    } else {
896
        return '';
897
898
899
    }
}

900
sub clean_html {
sikeda's avatar
sikeda committed
901
    my $self = shift;
902

sikeda's avatar
sikeda committed
903
    my $robot =
904
905
906
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
907
908
909
910

    my $entity = $self->as_entity->dup;
    if ($entity = _fix_html_part($entity, $robot)) {
        $self->set_entity($entity);
911
        return 1;
912
913
914
915
    }
    return 0;
}

916
sub _fix_html_part {
sikeda's avatar
sikeda committed
917
918
    my $entity = shift;
    my $robot  = shift;
919
    return $entity unless $entity;
920

921
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
922
    if ($entity->parts) {
923
        my @newparts = ();
924
925
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
926
        }
927
        $entity->parts(\@newparts);
928
    } elsif ($eff_type eq 'text/html') {
929
        my $bodyh = $entity->bodyhandle;
930
        # Encoded body or null body won't be modified.
931
        return $entity if !$bodyh or $bodyh->is_encoded;
932
933
934
935

        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
936
937
        my $cset = MIME::Charset->new(
            $entity->head->mime_attr('Content-Type.Charset') || '');
938
939
940
941
942
943
944
945
946
947
948
949
        unless ($cset->decoder) {
            # Charset is unknown.  Detect 7-bit charset.
            my ($dummy, $charset) =
                MIME::Charset::body_encode($body, '', Detect7Bit => 'YES');
            $cset = MIME::Charset->new($charset)
                if $charset;
        }
        if (    $cset->decoder
            and $cset->as_string ne 'UTF-8'
            and $cset->as_string ne 'US-ASCII') {
            $cset->encoder('UTF-8');
            $body = $cset->encode($body);
950
            $entity->head->mime_attr('Content-Type.Charset', 'UTF-8');
951
952
953
        }

        my $filtered_body =
954
            Sympa::HTMLSanitizer->new($robot)->sanitize_html($body);
955
956
957

        my $io = $bodyh->open("w");
        unless (defined $io