Message.pm 133 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, 2021 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
    if (grep { $_ and /\AARC-Seal:/i } @seal) {
        foreach my $ahdr (reverse @seal) {
            my ($ah, $av) = split /:\s*/, $ahdr, 2;
632
633
634
            # Normalize CRLF->LF for ARC header fields to avoid confusing the
            # mail agent.  See also the comment in dkim_sign().
            $av =~ s/\r\n/\n/g;
635
636
            $self->add_header($ah, $av, 0);
        }
John Levine's avatar
John Levine committed
637
    }
John Levine's avatar
John Levine committed
638
    #$self->{_body} = $new_body;
John Levine's avatar
John Levine committed
639
640
641
642
643
    delete $self->{_entity_cache};    # Clear entity cache.

    return $self;
}

Luc Didry's avatar
Luc Didry committed
644
645
646
BEGIN {
    eval 'use Mail::DKIM::Verifier';
    eval 'use Mail::DKIM::ARC::Verifier';
John Levine's avatar
John Levine committed
647
}
648

sikeda's avatar
sikeda committed
649
650
sub check_dkim_signature {
    my $self = shift;
651

sikeda's avatar
sikeda committed
652
    return unless $Mail::DKIM::Verifier::VERSION;
653

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

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

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

    #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'};
688
689
}

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

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

    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/;
738
739
740
    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
741
742
743
744
745
746
747
        return;
    }

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

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

754
    return unless $self->get_header('DKIM-Signature');
755
756
757

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

764
765
766
sub as_entity {
    my $self = shift;

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

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

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

786
787
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
788
789

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

    return $entity;
}

798
sub as_string {
799
800
    my $self    = shift;
    my %options = @_;
801

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

804
805
806
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

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

819
820
821
822
823
824
825
826
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
827
828
}

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

836
    my $hdr = $self->{_head};
837
838

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

    my $old_output = select;
    select $output;

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

897
898
899
900
901
    select $old_output;

    return 1;
}

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

    $self->{'topic'} = $topic;
908
    $self->add_header('X-Sympa-Topic', $topic);
909
910
911
}

## Get topic
912
# OBSOLETED.  No longer used.
913
914
915
916
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
917
        return $self->{'topic'};
918
919

    } else {
920
        return '';
921
922
923
    }
}

924
sub clean_html {
sikeda's avatar
sikeda committed
925
    my $self = shift;
926

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

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

940
sub _fix_html_part {
sikeda's avatar
sikeda committed
941
942
    my $entity = shift;
    my $robot  = shift;
943
    return $entity unless $entity;
944

945
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
946
    if ($entity->parts) {
947
        my @newparts = ();
948
949
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);