Message.pm 122 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
13
# Copyright 2017 The Sympa Community. See the AUTHORS.md file at the top-level
# directory of this distribution and at
# <https://github.com/sympa-community/sympa.git>.
14
15
16
17
18
19
20
21
22
23
24
25
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
26
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
27

28
package Sympa::Message;
29
30

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

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

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

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

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

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

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

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

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

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

    # Check if message is parsable.
148

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

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

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

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

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

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

220
    return $self;
221
222
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

sub head {
    shift->{_head};
}

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

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

422
    my $spam_status =
423
        Sympa::Scenario::request_action($robot_id || $Conf::Conf{'domain'},
424
        'spam_status', 'smtp', {'message' => $self});
425
426
427
428
429
430
431
432
433
434
435
    if (defined $spam_status) {
        if (ref($spam_status) eq 'HASH') {
            $self->{'spam_status'} = $spam_status->{'action'};
        } else {
            $self->{'spam_status'} = $spam_status;
        }
    } else {
        $self->{'spam_status'} = 'unknown';
    }
}

436
my $has_mail_dkim_textwrap;
437

438
439
440
441
442
443
444
445
446
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';
}

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

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

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

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

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

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

sikeda's avatar
sikeda committed
532
BEGIN { eval 'use Mail::DKIM::Verifier'; }
533

sikeda's avatar
sikeda committed
534
535
sub check_dkim_signature {
    my $self = shift;
536

sikeda's avatar
sikeda committed
537
    return unless $Mail::DKIM::Verifier::VERSION;
538

sikeda's avatar
sikeda committed
539
    my $robot_id =
540
541
542
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
543
    return
544
        unless Sympa::Tools::Data::smart_eq(
545
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
546

547
548
    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
549
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
550
551
552
553
554
555
556
557
558
        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) {
559
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
560
        return;
561
    }
562
563
564
565
566
567
568
569
570

    #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'};
571
572
}

sikeda's avatar
sikeda committed
573
574
575
# 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 {
576
    $log->syslog('debug2', '(%s)', @_);
577
    my $self = shift;
sikeda's avatar
sikeda committed
578

579
    return unless $self->get_header('DKIM-Signature');
580
581
582

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
583
        $log->syslog('info',
584
585
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
sikeda's avatar
sikeda committed
586
587
588
    }
}

589
590
591
sub as_entity {
    my $self = shift;

592
    unless (defined $self->{_entity_cache}) {
593
594
595
596
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');
597
598
599

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
600
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
601
        $self->{_entity_cache} = $parser->parse_data(\$string);
602
    }
603
    return $self->{_entity_cache};
604
605
606
607
608
609
610
}

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

611
612
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
613
614

    if ($orig ne $new) {
sikeda's avatar
sikeda committed
615
616
617
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
618
619
620
621
622
    }

    return $entity;
}

623
sub as_string {
624
625
    my $self    = shift;
    my %options = @_;
626

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

629
630
631
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

632
633
634
635
636
637
    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
638
639
640
    return
          $return_path
        . $self->{_head}->as_string . "\n"
641
        . (defined $self->{_body} ? $self->{_body} : '');
642
}
643

644
645
646
647
648
649
650
651
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
652
653
}

654
655
656
657
sub get_header {
    my $self  = shift;
    my $field = shift;
    my $sep   = shift;
658
659
    die sprintf 'Second argument is not index but separator: "%s"', $sep
        if defined $sep and Scalar::Util::looks_like_number($sep);
660

661
    my $hdr = $self->{_head};
662
663

    if (defined $sep or wantarray) {
664
        my @values = grep {s/\A$field\s*:\s*//i}
665
666
667
668
669
670
671
672
673
674
675
676
677
            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
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
# 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
704
705
# Dump the Message object
# Currently not used.
706
707
sub dump {
    my ($self, $output) = @_;
sikeda's avatar
sikeda committed
708
    # my $output ||= \*STDERR;
709
710
711
712
713

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
714
715
716
717
718
719
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
720
    }
721

722
723
724
725
726
    select $old_output;

    return 1;
}

727
## Add topic and put header X-Sympa-Topic
728
# OBSOLETED.  No longer used.
729
sub add_topic {
730
    my ($self, $topic) = @_;
731
732

    $self->{'topic'} = $topic;
733
    $self->add_header('X-Sympa-Topic', $topic);
734
735
736
}

## Get topic
737
# OBSOLETED.  No longer used.
738
739
740
741
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
742
        return $self->{'topic'};
743
744

    } else {
745
        return '';
746
747
748
    }
}

749
sub clean_html {
sikeda's avatar
sikeda committed
750
    my $self = shift;
751

sikeda's avatar
sikeda committed
752
    my $robot =
753
754
755
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
756
757
758
759

    my $entity = $self->as_entity->dup;
    if ($entity = _fix_html_part($entity, $robot)) {
        $self->set_entity($entity);
760
        return 1;
761
762
763
764
    }
    return 0;
}

765
sub _fix_html_part {
sikeda's avatar
sikeda committed
766
767
    my $entity = shift;
    my $robot  = shift;
768
    return $entity unless $entity;
769

770
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
771
    if ($entity->parts) {
772
        my @newparts = ();
773
774
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
775
        }
776
        $entity->parts(\@newparts);
777
    } elsif ($eff_type eq 'text/html') {
778
        my $bodyh = $entity->bodyhandle;
779
        # Encoded body or null body won't be modified.
780
        return $entity if !$bodyh or $bodyh->is_encoded;
781
782
783
784

        my $body = $bodyh->as_string;
        # Re-encode parts to UTF-8, since StripScripts cannot handle texts
        # with some charsets (ISO-2022-*, UTF-16*, ...) correctly.
sikeda's avatar
sikeda committed
785
786
        my $cset = MIME::Charset->new(
            $entity->head->mime_attr('Content-Type.Charset') || '');
787
788
789
790
791
792
793
794
795
796
797
798
        unless ($cset->decoder) {
            # Charset is unknown.  Detect 7-bit charset.
            my ($dummy, $charset) =
                MIME::Charset::body_encode($body, '', Detect7Bit => 'YES');
            $cset = MIME::Charset->new($charset)
                if $charset;
        }
        if (    $cset->decoder
            and $cset->as_string ne 'UTF-8'
            and $cset->as_string ne 'US-ASCII') {
            $cset->encoder('UTF-8');
            $body = $cset->encode($body);
799
            $entity->head->mime_attr('Content-Type.Charset', 'UTF-8');
800
801
802
        }

        my $filtered_body =
803
            Sympa::HTMLSanitizer->new($robot)->sanitize_html($body);
804
805
806

        my $io = $bodyh->open("w");
        unless (defined $io) {
807
            $log->syslog('err', 'Failed to save message: %m');
808
809
810
811
            return undef;
        }
        $io->print($filtered_body);
        $io->close;
812
813
        $entity->sync_headers(Length => 'COMPUTE')
            if $entity->head->get('Content-Length');
814
    }
815
    return $entity;
816
817
}

sikeda's avatar
sikeda committed
818
819
# Old name: tools::smime_decrypt() which took MIME::Entity object and list,
# and won't modify Message object.
820
sub smime_decrypt {
821
    $log->syslog('debug2', '(%s)', @_);
sikeda's avatar
sikeda committed
822
823
    my $self = shift;

824
825
    return 0 unless $Crypt::SMIME::VERSION;

826
827
828
    my $key_passwd = $Conf::Conf{'key_passwd'};
    $key_passwd = '' unless defined $key_passwd;

sikeda's avatar
sikeda committed
829
    my $content_type = lc($self->{_head}->mime_attr('Content-Type') || '');
sikeda's avatar
sikeda committed
830
    unless (
sikeda's avatar
sikeda committed
831
832
833
        (      $content_type eq 'application/pkcs7-mime'
            or $content_type eq 'application/x-pkcs7-mime'
        )
834
        and !Sympa::Tools::Data::smart_eq(
sikeda's avatar
sikeda committed
835
836
837
            $self->{_head}->mime_attr('Content-Type.smime-type'),
            qr/signed-data/i
        )
sikeda's avatar
sikeda committed
838
        ) {
sikeda's avatar
sikeda committed
839
840
        return 0;
    }
841

842
    #FIXME: an empty "context" parameter means mail to sympa@, listmaster@...
843
    my ($certs, $keys) =
844
        Sympa::Tools::SMIME::find_keys($self->{context} || '*', 'decrypt');
845
    unless (defined $certs and @$certs) {
846
        $log->syslog('err',
847
            'Unable to decrypt message: missing certificate file');
sikeda's avatar
sikeda committed
848
        return undef;
849
850
    }

851
    my ($msg_string, $entity);
852

853
    # Try all keys/certs until one decrypts.
854
855
    while (my $certfile = shift @$certs) {
        my $keyfile = shift @$keys;
856
        $log->syslog('debug', 'Trying decrypt with certificate %s, key %s',
857
858
            $certfile, $keyfile);

859
860
        my ($cert, $key);
        if (open my $fh, '<', $certfile) {
861
            $cert = do { local $RS; <$fh> };
862
            close $fh;
863
        }
864
        if (open my $fh, '<', $keyfile) {
865
            $key = do { local $RS; <$fh> };
866
            close $fh;
867
868
        }

869
870
871
872
873
874
875
        my $smime = Crypt::SMIME->new();
        if (length $key_passwd) {
            eval { $smime->setPrivateKey($key, $cert, $key_passwd) }
                or next;
        } else {
            eval { $smime->setPrivateKey($key, $cert) }
                or next;
876
        }
877
878
        $msg_string = eval { $smime->decrypt($self->as_string); };
        last if defined $msg_string;
879
880
    }

881
    unless (defined $msg_string) {
sikeda's avatar