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
        return undef;
    }

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

524
525
526
527
528
529
530
531
532
533
    # Mail::DKIM::Signer wraps DKIM-Signature with with \r\n\t; this
    # is the hardcoded Separator passed to Mail::DKIM::TextWrap via
    # Mail::DKIM::KeyValueList. MIME::Tools on the other hand
    # (MIME::Head::stringify() in particular) encode EOL as plain \n;
    # so it is necessary to normalize CRLF->LF for DKIM-Signature to
    # avoid confusing the mail agent.

    my $dkim_signature = $dkim->signature->as_string;
    $dkim_signature =~ s/\r\n/\n/g;

sikeda's avatar
sikeda committed
534
    # Signing is done. Rebuilding message as string with original body
535
536
    # and new headers.
    # Note that DKIM-Signature: field should be prepended to the header.
537
    $self->add_header('DKIM-Signature', $dkim_signature, 0);
538
    $self->{_body} = $new_body;
539
    delete $self->{_entity_cache};    # Clear entity cache.
sikeda's avatar
sikeda committed
540

541
    return $self;
sikeda's avatar
sikeda committed
542
543
}

John Levine's avatar
John Levine committed
544
sub arc_seal {
John Levine's avatar
John Levine committed
545
    $log->syslog('debug2', '(%s)', @_);
John Levine's avatar
John Levine committed
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
    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
573
            "ARC chain value %s is invalid, could not seal message", $arc_cv);
John Levine's avatar
John Levine committed
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
608
609
610
611
612
613
614
615
616
617
        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
618
619
    $log->syslog('debug2', 'ARC %s: %s', $arc->{result},
        $arc->{result_reason});
John Levine's avatar
John Levine committed
620

John Levine's avatar
John Levine committed
621
622
623
    # 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
624

John Levine's avatar
John Levine committed
625
    # Seal is done. Add new headers for the seal
John Levine's avatar
John Levine committed
626
    my @seal = $arc->as_strings();
627
628
629
630
631
    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
632
    }
John Levine's avatar
John Levine committed
633
    #$self->{_body} = $new_body;
John Levine's avatar
John Levine committed
634
635
636
637
638
    delete $self->{_entity_cache};    # Clear entity cache.

    return $self;
}

Luc Didry's avatar
Luc Didry committed
639
640
641
BEGIN {
    eval 'use Mail::DKIM::Verifier';
    eval 'use Mail::DKIM::ARC::Verifier';
John Levine's avatar
John Levine committed
642
}
643

sikeda's avatar
sikeda committed
644
645
sub check_dkim_signature {
    my $self = shift;
646

sikeda's avatar
sikeda committed
647
    return unless $Mail::DKIM::Verifier::VERSION;
648

sikeda's avatar
sikeda committed
649
    my $robot_id =
650
651
652
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
John Levine's avatar
John Levine committed
653

654
    return
655
        unless Sympa::Tools::Data::smart_eq(
656
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
657

658
659
    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
660
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
661
662
663
664
665
666
667
668
669
        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) {
670
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
671
        return;
672
    }
673
674
675
676
677
678
679
680
681

    #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'};
682
683
}

John Levine's avatar
John Levine committed
684
685
686
687
688
689
690
691
692
693
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
694
    unless ($srvid = Conf::get_robot_conf($robot_id || '*', 'arc_srvid')) {
John Levine's avatar
John Levine committed
695
        $log->syslog('debug2', 'ARC library installed, but no arc_srvid set');
John Levine's avatar
John Levine committed
696
697
698
699
700
701
        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
702
    my @ars =
703
704
705
        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
706

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

    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
742
743
744
# 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 {
745
    $log->syslog('debug2', '(%s)', @_);
746
    my $self = shift;
sikeda's avatar
sikeda committed
747

748
    return unless $self->get_header('DKIM-Signature');
749
750
751

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
752
        $log->syslog('info',
753
754
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
sikeda's avatar
sikeda committed
755
756
757
    }
}

758
759
760
sub as_entity {
    my $self = shift;

761
    unless (defined $self->{_entity_cache}) {
762
763
764
765
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');
766
767
768

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
769
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
770
        $self->{_entity_cache} = $parser->parse_data(\$string);
771
    }
772
    return $self->{_entity_cache};
773
774
775
776
777
778
779
}

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

780
781
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
782
783

    if ($orig ne $new) {
sikeda's avatar
sikeda committed
784
785
786
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
787
788
789
790
791
    }

    return $entity;
}

792
sub as_string {
793
794
    my $self    = shift;
    my %options = @_;
795

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

798
799
800
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

801
802
803
804
805
806
    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
807
808
809
    return
          $return_path
        . $self->{_head}->as_string . "\n"
810
        . (defined $self->{_body} ? $self->{_body} : '');
811
}
812

813
814
815
816
817
818
819
820
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
821
822
}

823
824
825
826
sub get_header {
    my $self  = shift;
    my $field = shift;
    my $sep   = shift;
827
828
    die sprintf 'Second argument is not index but separator: "%s"', $sep
        if defined $sep and Scalar::Util::looks_like_number($sep);
829

830
    my $hdr = $self->{_head};
831
832

    if (defined $sep or wantarray) {
833
        my @values = grep {s/\A$field\s*:\s*//i}
834
835
836
837
838
839
840
841
842
843
844
845
846
            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
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
# 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
873
874
# Dump the Message object
# Currently not used.
875
876
sub dump {
    my ($self, $output) = @_;
sikeda's avatar
sikeda committed
877
    # my $output ||= \*STDERR;
878
879
880
881
882

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
883
884
885
886
887
888
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
889
    }
890

891
892
893
894
895
    select $old_output;

    return 1;
}

896
## Add topic and put header X-Sympa-Topic
897
# OBSOLETED.  No longer used.
898
sub add_topic {
899
    my ($self, $topic) = @_;
900
901

    $self->{'topic'} = $topic;
902
    $self->add_header('X-Sympa-Topic', $topic);
903
904
905
}

## Get topic
906
# OBSOLETED.  No longer used.
907
908
909
910
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
911
        return $self->{'topic'};
912
913

    } else {
914
        return '';
915
916
917
    }
}

918
sub clean_html {
sikeda's avatar
sikeda committed
919
    my $self = shift;
920

sikeda's avatar
sikeda committed
921
    my $robot =
922
923
924
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
925
926
927
928

    my $entity = $self->as_entity->dup;
    if ($entity = _fix_html_part($entity, $robot)) {
        $self->set_entity($entity);
929
        return 1;
930
931
932
933
    }
    return 0;
}

934
sub _fix_html_part {
sikeda's avatar
sikeda committed
935
936
    my $entity = shift;
    my $robot  = shift;
937
    return $entity unless $entity;
938

939
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
940
    if ($entity->parts) {
941
        my @newparts = ();
942
943
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
944
        }
945
        $entity->parts(\@newparts);
946
    } elsif ($eff_type eq 'text/html') {
947
        my $bodyh = $entity->bodyhandle;
948
        # Encoded body or null body won't be modified.
949
        return $entity if !$bodyh or $bodyh->is_encoded;
950
951
952