Message.pm 121 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 GIP RENATER
11
12
13
14
15
16
17
18
19
20
21
22
#
# 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
23
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
24

25
package Sympa::Message;
26
27

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

44
BEGIN { eval 'use Crypt::SMIME'; }
45
BEGIN { eval 'use Net::DNS'; }
46

47
use Sympa;
48
use Conf;
sikeda's avatar
sikeda committed
49
use Sympa::Constants;
50
use Sympa::HTML::FormatText;
51
use Sympa::HTMLSanitizer;
52
use Sympa::Language;
53
use Sympa::Log;
54
use Sympa::Scenario;
55
use Sympa::Spool;
56
use Sympa::Template;
57
use tools;
58
59
use Sympa::Tools::Data;
use Sympa::Tools::File;
60
use Sympa::Tools::Password;
61
use Sympa::Tools::SMIME;
62
use Sympa::Tools::Text;
63
use Sympa::Tools::WWW;
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
115
116
            $self->{'shelved'} = {
                map {
                    my ($ak, $av) = split /=/, $_, 2;
                    ($ak => ($av || 1))
                    } split(/\s*;\s*/, $v)
            };
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
138
139
        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);
            if (@addrs and tools::valid_email($addrs[0]->address)) {
                $self->{'envelope_sender'} = $addrs[0]->address;
140
141
            }
        }
sikeda's avatar
sikeda committed
142
143
    }
    # Strip attributes.
sikeda's avatar
sikeda committed
144
    substr($serialized, 0, pos $serialized) = '';
145
146

    # Check if message is parsable.
147

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

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

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

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

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

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

219
    return $self;
220
221
}

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

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

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

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

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

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

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

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

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

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

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

301
    return tools::clean_msg_id($self->{_head}->get('Message-Id', 0));
302
303
}

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

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

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

329
sub to_string {
330
331
    my $self    = shift;
    my %options = @_;
332

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

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

sikeda's avatar
sikeda committed
385
    return $serialized;
386
387
}

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

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

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

sub head {
    shift->{_head};
}

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

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

sikeda's avatar
sikeda committed
434
435
# Old name: tools::dkim_sign() which took string and returned string.
sub dkim_sign {
436
    $log->syslog('debug', '(%s)', @_);
sikeda's avatar
sikeda committed
437
    my $self    = shift;
sikeda's avatar
sikeda committed
438
439
440
441
442
443
444
445
    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) {
446
        $log->syslog('err',
sikeda's avatar
sikeda committed
447
448
449
450
            "DKIM selector is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_privatekey) {
451
        $log->syslog('err',
sikeda's avatar
sikeda committed
452
453
454
455
            "DKIM key file is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_d) {
456
        $log->syslog('err',
sikeda's avatar
sikeda committed
457
458
459
460
461
            "DKIM d= tag is undefined, could not sign message");
        return undef;
    }

    unless (eval "require Mail::DKIM::Signer") {
462
        $log->syslog('err',
sikeda's avatar
sikeda committed
463
464
465
466
467
            "Failed to load Mail::DKIM::Signer Perl module, ignoring DKIM signature"
        );
        return undef;
    }
    unless (eval "require Mail::DKIM::TextWrap") {
468
        $log->syslog('err',
sikeda's avatar
sikeda committed
469
470
471
            "Failed to load Mail::DKIM::TextWrap Perl module, signature will not be pretty"
        );
    }
472
473

    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
sikeda's avatar
sikeda committed
474
475
    my $privatekey_string = join '',
        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $dkim_privatekey;
476
477
    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
    unless ($privatekey) {
478
        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
479
        return undef;
sikeda's avatar
sikeda committed
480
    }
481
482
483
484
485
486
487
488
489
    # 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
490
    unless ($dkim) {
491
        $log->syslog('err', 'Can\'t create Mail::DKIM::Signer');
sikeda's avatar
sikeda committed
492
493
494
        return undef;
    }
    # $new_body will store the body as fed to Mail::DKIM to reuse it
495
    # when returning the message as string.  Line terminators must be
496
    # normalized with CRLF.
497
    my $msg_as_string = $self->as_string;
sikeda's avatar
sikeda committed
498
    $msg_as_string =~ s/\r?\n/\r\n/g;
sikeda's avatar
sikeda committed
499
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
sikeda's avatar
sikeda committed
500
501
    $dkim->PRINT($msg_as_string);
    unless ($dkim->CLOSE) {
502
        $log->syslog('err', 'Cannot sign (DKIM) message');
sikeda's avatar
sikeda committed
503
504
505
506
507
508
509
        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
510
511
    # and new headers.
    # Note that DKIM-Signature: field should be prepended to the header.
512
513
    $self->add_header('DKIM-Signature', $dkim->signature->as_string, 0);
    $self->{_body} = $new_body;
514
    delete $self->{_entity_cache};    # Clear entity cache.
sikeda's avatar
sikeda committed
515

516
    return $self;
sikeda's avatar
sikeda committed
517
518
}

sikeda's avatar
sikeda committed
519
BEGIN { eval 'use Mail::DKIM::Verifier'; }
520

sikeda's avatar
sikeda committed
521
522
sub check_dkim_signature {
    my $self = shift;
523

sikeda's avatar
sikeda committed
524
    return unless $Mail::DKIM::Verifier::VERSION;
525

sikeda's avatar
sikeda committed
526
    my $robot_id =
527
528
529
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
530
    return
531
        unless Sympa::Tools::Data::smart_eq(
532
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
533

534
535
    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
536
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
537
538
539
540
541
542
543
544
545
        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) {
546
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
547
        return;
548
    }
549
550
551
552
553
554
555
556
557

    #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'};
558
559
}

sikeda's avatar
sikeda committed
560
561
562
# 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 {
563
    $log->syslog('debug2', '(%s)', @_);
564
    my $self = shift;
sikeda's avatar
sikeda committed
565

566
    return unless $self->get_header('DKIM-Signature');
567
568
569

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
570
        $log->syslog('info',
571
572
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
sikeda's avatar
sikeda committed
573
574
575
    }
}

576
577
578
sub as_entity {
    my $self = shift;

579
    unless (defined $self->{_entity_cache}) {
580
581
582
583
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');
584
585
586

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
587
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
588
        $self->{_entity_cache} = $parser->parse_data(\$string);
589
    }
590
    return $self->{_entity_cache};
591
592
593
594
595
596
597
}

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

598
599
    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;
600
601

    if ($orig ne $new) {
sikeda's avatar
sikeda committed
602
603
604
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
605
606
607
608
609
    }

    return $entity;
}

610
sub as_string {
611
612
    my $self    = shift;
    my %options = @_;
613

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

616
617
618
    return $self->{'orig_msg_as_string'}
        if $options{'original'} and $self->{'smime_crypted'};

619
620
621
622
623
624
    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
625
626
627
    return
          $return_path
        . $self->{_head}->as_string . "\n"
628
        . (defined $self->{_body} ? $self->{_body} : '');
629
}
630

631
632
633
634
635
636
637
638
sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

sub header_as_string {
    my $self = shift;
    return $self->{_head}->as_string;
639
640
}

641
642
643
644
sub get_header {
    my $self  = shift;
    my $field = shift;
    my $sep   = shift;
645
646
    die sprintf 'Second argument is not index but separator: "%s"', $sep
        if defined $sep and Scalar::Util::looks_like_number($sep);
647

648
    my $hdr = $self->{_head};
649
650

    if (defined $sep or wantarray) {
651
        my @values = grep {s/\A$field\s*:\s*//i}
652
653
654
655
656
657
658
659
660
661
662
663
664
            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
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
# 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
691
692
# Dump the Message object
# Currently not used.
693
694
sub dump {
    my ($self, $output) = @_;
sikeda's avatar
sikeda committed
695
    # my $output ||= \*STDERR;
696
697
698
699
700

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
701
702
703
704
705
706
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
707
    }
708

709
710
711
712
713
    select $old_output;

    return 1;
}

714
## Add topic and put header X-Sympa-Topic
715
# OBSOLETED.  No longer used.
716
sub add_topic {
717
    my ($self, $topic) = @_;
718
719

    $self->{'topic'} = $topic;
720
    $self->add_header('X-Sympa-Topic', $topic);
721
722
723
}

## Get topic
724
# OBSOLETED.  No longer used.
725
726
727
728
sub get_topic {
    my ($self) = @_;

    if (defined $self->{'topic'}) {
729
        return $self->{'topic'};
730
731

    } else {
732
        return '';
733
734
735
    }
}

736
sub clean_html {
sikeda's avatar
sikeda committed
737
    my $self = shift;
738

sikeda's avatar
sikeda committed
739
    my $robot =
740
741
742
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
743
744
745
746

    my $entity = $self->as_entity->dup;
    if ($entity = _fix_html_part($entity, $robot)) {
        $self->set_entity($entity);
747
        return 1;
748
749
750
751
    }
    return 0;
}

752
sub _fix_html_part {
sikeda's avatar
sikeda committed
753
754
    my $entity = shift;
    my $robot  = shift;
755
    return $entity unless $entity;
756

757
    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
758
    if ($entity->parts) {
759
        my @newparts = ();
760
761
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
762
        }
763
        $entity->parts(\@newparts);
764
    } elsif ($eff_type eq 'text/html') {
765
        my $bodyh = $entity->bodyhandle;
766
        # Encoded body or null body won't be modified.
767
        return $entity if !$bodyh or $bodyh->is_encoded;
768
769
770
771

        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
772
773
        my $cset = MIME::Charset->new(
            $entity->head->mime_attr('Content-Type.Charset') || '');
774
775
776
777
778
779
780
781
782
783
784
785
        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);
786
            $entity->head->mime_attr('Content-Type.Charset', 'UTF-8');
787
788
789
        }

        my $filtered_body =
790
            Sympa::HTMLSanitizer->new($robot)->sanitize_html($body);
791
792
793

        my $io = $bodyh->open("w");
        unless (defined $io) {
794
            $log->syslog('err', 'Failed to save message: %m');
795
796
797
798
            return undef;
        }
        $io->print($filtered_body);
        $io->close;
799
800
        $entity->sync_headers(Length => 'COMPUTE')
            if $entity->head->get('Content-Length');
801
    }
802
    return $entity;
803
804
}

sikeda's avatar
sikeda committed
805
806
# Old name: tools::smime_decrypt() which took MIME::Entity object and list,
# and won't modify Message object.
807
sub smime_decrypt {
808
    $log->syslog('debug2', '(%s)', @_);
sikeda's avatar
sikeda committed
809
810
    my $self = shift;

811
812
    return 0 unless $Crypt::SMIME::VERSION;

813
814
815
    my $key_passwd = $Conf::Conf{'key_passwd'};
    $key_passwd = '' unless defined $key_passwd;

sikeda's avatar
sikeda committed
816
    my $content_type = lc($self->{_head}->mime_attr('Content-Type') || '');
sikeda's avatar
sikeda committed
817
    unless (
sikeda's avatar
sikeda committed
818
819
820
        (      $content_type eq 'application/pkcs7-mime'
            or $content_type eq 'application/x-pkcs7-mime'
        )
821
        and !Sympa::Tools::Data::smart_eq(
sikeda's avatar
sikeda committed
822
823
824
            $self->{_head}->mime_attr('Content-Type.smime-type'),
            qr/signed-data/i
        )
sikeda's avatar
sikeda committed
825
        ) {
sikeda's avatar
sikeda committed
826
827
        return 0;
    }
828

829
    #FIXME: an empty "context" parameter means mail to sympa@, listmaster@...
830
    my ($certs, $keys) =
831
        Sympa::Tools::SMIME::find_keys($self->{context} || '*', 'decrypt');
832
    unless (defined $certs and @$certs) {
833
        $log->syslog('err',
834
            'Unable to decrypt message: missing certificate file');
sikeda's avatar
sikeda committed
835
        return undef;
836
837
    }

838
    my ($msg_string, $entity);
839

840
    # Try all keys/certs until one decrypts.
841
842
    while (my $certfile = shift @$certs) {
        my $keyfile = shift @$keys;
843
        $log->syslog('debug', 'Trying decrypt with certificate %s, key %s',
844
845
            $certfile, $keyfile);

846
847
        my ($cert, $key);
        if (open my $fh, '<', $certfile) {
848
            $cert = do { local $RS; <$fh> };
849
            close $fh;
850
        }
851
        if (open my $fh, '<', $keyfile) {
852
            $key = do { local $RS; <$fh> };
853
            close $fh;
854
855
        }

856
857
858
859
860
861
862
        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;
863
        }
864
865
        $msg_string = eval { $smime->decrypt($self->as_string); };
        last if defined $msg_string;
866
867
    }

868
    unless (defined $msg_string) {
869
        $log->syslog('err', 'Message could not be decrypted');
870
871
872
873
        return undef;
    }
    my $parser = MIME::Parser->new;
    $parser->output_to_core(1);
874
    $parser->tmp_dir($Conf::Conf{'tmpdir'});
875
876
    $entity = $parser->parse_data($msg_string);
    unless (defined $entity) {
877
        $log->syslog('err', 'Message could not be decrypted');
sikeda's avatar
sikeda committed
878
        return undef;
879
880
    }