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

# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11
12
# Copyright 2017, 2018, 2019, 2020 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
        and not exists $self->{'envelope_sender'}) {
        my $addr = $1;
        if ($addr =~ /<>/) {    # special: null envelope sender
            $self->{'envelope_sender'} = '<>';
137
138
139
        } elsif ($addr =~ /<MAILER-DAEMON>/) {
            # Same as above, but a workaround for pipe(8) of Postfix 2.3+.
            $self->{'envelope_sender'} = '<>';
sikeda's avatar
sikeda committed
140
141
        } else {
            my @addrs = Mail::Address->parse($addr);
142
143
            if (@addrs
                and Sympa::Tools::Text::valid_email($addrs[0]->address)) {
sikeda's avatar
sikeda committed
144
                $self->{'envelope_sender'} = $addrs[0]->address;
145
146
            }
        }
sikeda's avatar
sikeda committed
147
148
    }
    # Strip attributes.
sikeda's avatar
sikeda committed
149
    substr($serialized, 0, pos $serialized) = '';
150
151

    # Check if message is parsable.
152

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

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

169
170
171
    unless (exists $self->{'sender'} and defined $self->{'sender'}) {
        ($self->{'sender'}, $self->{'gecos'}) = $self->_get_sender_email;
    }
172
173

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

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

219
    # Message ID
220
221
222
    unless (exists $self->{'message_id'}) {
        $self->{'message_id'} = _get_message_id($self);
    }
223

224
    return $self;
225
226
}

227
228
229
230
# Tentative: removed when refactoring finished.
sub new_from_file {
    my $class = shift;
    my $file  = shift;
231

232
    open my $fh, '<', $file or return undef;
233
    my $serialized = do { local $RS; <$fh> };
234
235
    close $fh;

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

    $self->{'filename'} = $file;
    # Get file date
    unless (exists $self->{'date'}) {
242
        $self->{'date'} = Sympa::Tools::File::get_mtime($file);
243
244
    }

245
    return $self;
246
247
248
249
250
251
}

## 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
252
    my $self = shift;
253

sikeda's avatar
sikeda committed
254
    my $hdr = $self->{_head};
255
256

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

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

298
    return ($sender, $gecos);
299
300
}

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

306
307
    return Sympa::Tools::Text::canonic_message_id(
        $self->{_head}->get('Message-Id', 0));
308
309
}

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

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

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

335
sub to_string {
336
337
    my $self    = shift;
    my %options = @_;
338

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

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

sikeda's avatar
sikeda committed
391
    return $serialized;
392
393
}

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

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

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

sub head {
    shift->{_head};
}

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

426
    my $spam_status =
IKEDA Soji's avatar
IKEDA Soji committed
427
428
        Sympa::Scenario->new($robot_id, 'spam_status')
        ->authz('smtp', {'message' => $self});
429
430
431
432
433
434
435
436
437
438
439
    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';
    }
}

440
my $has_mail_dkim_textwrap;
441

442
443
444
445
446
447
448
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
449
    eval 'use Mail::DKIM::ARC::Signer';
450
451
}

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

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

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

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

527
528
529
530
531
532
533
534
535
536
    # 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
537
    # Signing is done. Rebuilding message as string with original body
538
539
    # and new headers.
    # Note that DKIM-Signature: field should be prepended to the header.
540
    $self->add_header('DKIM-Signature', $dkim_signature, 0);
541
    $self->{_body} = $new_body;
542
    delete $self->{_entity_cache};    # Clear entity cache.
sikeda's avatar
sikeda committed
543

544
    return $self;
sikeda's avatar
sikeda committed
545
546
}

John Levine's avatar
John Levine committed
547
sub arc_seal {
John Levine's avatar
John Levine committed
548
    $log->syslog('debug2', '(%s)', @_);
John Levine's avatar
John Levine committed
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
    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
576
            "ARC chain value %s is invalid, could not seal message", $arc_cv);
John Levine's avatar
John Levine committed
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
        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/;
616
617
    unless (eval { $arc->PRINT($msg_as_string) and $arc->CLOSE }) {
        $log->syslog('err', 'Cannot ARC seal message: %s', $EVAL_ERROR);
John Levine's avatar
John Levine committed
618
619
        return undef;
    }
IKEDA Soji's avatar
IKEDA Soji committed
620
621
    $log->syslog('debug2', 'ARC %s: %s', $arc->{result},
        $arc->{result_reason});
John Levine's avatar
John Levine committed
622

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

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

    return $self;
}

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

sikeda's avatar
sikeda committed
646
647
sub check_dkim_signature {
    my $self = shift;
648

sikeda's avatar
sikeda committed
649
    return unless $Mail::DKIM::Verifier::VERSION;
650

IKEDA Soji's avatar
IKEDA Soji committed
651
652
653
654
655
656
657
658
659
    my $robot_id =
        (ref $self->{context} eq 'Sympa::List') ? $self->{context}->{'domain'}
        : (ref $self->{context} eq 'Sympa::Family')
        ? $self->{context}->{'domain'}
        : $self->{context};

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

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

    #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'};
685
686
}

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

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

    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/;
735
736
737
    unless (eval { $arc->PRINT($msg_as_string) and $arc->CLOSE }) {
        $log->syslog('err', 'Cannot verify chain of (ARC) message: %s',
            $EVAL_ERROR);
John Levine's avatar
John Levine committed
738
739
740
741
742
743
744
        return;
    }

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

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

751
    return unless $self->get_header('DKIM-Signature');
752
753
754

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

761
762
763
sub as_entity {
    my $self = shift;

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

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

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

783
784
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
785
786

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

    return $entity;
}

795
sub as_string {
796
797
    my $self    = shift;
    my %options = @_;
798

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

801
802
803
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

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

816
817
818
819
820
821
822
823
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
824
825
}

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

833
    my $hdr = $self->{_head};
834
835

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

    my $old_output = select;
    select $output;

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

894
895
896
897
898
    select $old_output;

    return 1;
}

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

    $self->{'topic'} = $topic;
905
    $self->add_header('X-Sympa-Topic', $topic);
906
907
908
}

## Get topic
909
# OBSOLETED.  No longer used.
910
911
912
913
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
914
        return $self->{'topic'};
915
916

    } else {
917
        return '';
918
919
920
    }
}

921
sub clean_html {
sikeda's avatar
sikeda committed
922
    my $self = shift;
923

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

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

937
sub _fix_html_part {
sikeda's avatar
sikeda committed
938
939
    my $entity = shift;
    my $robot  = shift;
940
    return $entity unless $entity;
941

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