1# -*- indent-tabs-mode: nil; -*-
2# vim:ft=perl:et:sw=4
3# $Id$
4
5# Sympa - SYsteme de Multi-Postage Automatique
6#
7# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11# Copyright 2017, 2018, 2019, 2020, 2021 The Sympa Community. See the
12# AUTHORS.md file at the top-level directory of this distribution and at
13# <https://github.com/sympa-community/sympa.git>.
14#
15# This program is free software; you can redistribute it and/or modify
16# it under the terms of the GNU General Public License as published by
17# the Free Software Foundation; either version 2 of the License, or
18# (at your option) any later version.
19#
20# This program is distributed in the hope that it will be useful,
21# but WITHOUT ANY WARRANTY; without even the implied warranty of
22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23# GNU General Public License for more details.
24#
25# 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
28package Sympa::Message;
29
30use strict;
31use warnings;
32use DateTime;
33use Encode qw();
34use English;    # FIXME: drop $PREMATCH usage
35use HTML::TreeBuilder;
36use Mail::Address;
37use MIME::Charset;
38use MIME::EncWords;
39use MIME::Entity;
40use MIME::Field::ParamVal;
41use MIME::Parser;
42use MIME::Tools;
43use Scalar::Util qw();
44use Text::LineFold;
45use URI::Escape qw();
46
47BEGIN { eval 'use Crypt::SMIME'; }
48BEGIN { eval 'use Net::DNS'; }
49
50use Sympa;
51use Conf;
52use Sympa::Constants;
53use Sympa::HTML::FormatText;
54use Sympa::HTMLSanitizer;
55use Sympa::Language;
56use Sympa::Log;
57use Sympa::Scenario;
58use Sympa::Spool;
59use Sympa::Template;
60use Sympa::Tools::Data;
61use Sympa::Tools::File;
62use Sympa::Tools::Password;
63use Sympa::Tools::SMIME;
64use Sympa::Tools::Text;
65use Sympa::User;
66
67my $language = Sympa::Language->instance;
68my $log      = Sympa::Log->instance;
69
70sub new {
71    $log->syslog('debug2', '(%s, ...)', @_);
72    my $class      = shift;
73    my $serialized = shift;
74
75    my $self = bless {@_} => $class;
76
77    unless (defined $serialized and length $serialized) {
78        $log->syslog('err', 'Empty message');
79        return undef;
80    }
81
82    # Get attributes from pseudo-header fields at the top of serialized
83    # message.  Note that field names are case-sensitive.
84
85    pos($serialized) = 0;
86    while ($serialized =~ /\G(X-Sympa-[-\w]+): (.*?)\n(?![ \t])/cgs) {
87        my ($k, $v) = ($1, $2);
88        next unless length $v;
89
90        if ($k eq 'X-Sympa-To') {
91            $self->{'rcpt'} = join ',', split(/\s*,\s*/, $v);
92        } elsif ($k eq 'X-Sympa-Checksum') {    # To migrate format <= 6.2a.40
93            $self->{'checksum'} = $v;
94        } elsif ($k eq 'X-Sympa-Family') {
95            $self->{'family'} = $v;
96        } elsif ($k eq 'X-Sympa-From') {    # Compatibility. Use Return-Path:
97            $self->{'envelope_sender'} = $v;
98        } elsif ($k eq 'X-Sympa-Auth-Level') {    # New in 6.2a.41
99            if ($v eq 'md5') {
100                $self->{'md5_check'} = 1;
101            } else {
102                $log->syslog('err',
103                    'Unknown authentication level "%s", ignored', $v);
104            }
105        } elsif ($k eq 'X-Sympa-Message-ID') {    # New in 6.2a.41
106            $self->{'message_id'} = $v;
107        } elsif ($k eq 'X-Sympa-Sender') {        # New in 6.2a.41
108            $self->{'sender'} = $v;
109        } elsif ($k eq 'X-Sympa-Display-Name') {    # New in 6.2a.41
110            $self->{'gecos'} = $v;
111        } elsif ($k eq 'X-Sympa-Shelved') {         # New in 6.2a.41
112            $self->{'shelved'} = {
113                map {
114                    my ($ak, $av) = split /=/, $_, 2;
115                    ($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;
120        } else {
121            $log->syslog('err', 'Unknown attribute information: "%s: %s"',
122                $k, $v);
123        }
124    }
125    # Ignore Unix From_
126    $serialized =~ /\GFrom (.*?)\n(?![ \t])/cgs;
127    # Get envelope sender from Return-Path:.
128    # If old style X-Sympa-From: has been found, omit Return-Path:.
129    #
130    # We trust in "Return-Path:" header field only at the top of message
131    # to prevent forgery.  See CAVEAT.
132    if ($serialized =~ /\GReturn-Path: (.*?)\n(?![ \t])/cgs
133        and not exists $self->{'envelope_sender'}) {
134        my $addr = $1;
135        if ($addr =~ /<>/) {    # special: null envelope sender
136            $self->{'envelope_sender'} = '<>';
137        } elsif ($addr =~ /<MAILER-DAEMON>/) {
138            # Same as above, but a workaround for pipe(8) of Postfix 2.3+.
139            $self->{'envelope_sender'} = '<>';
140        } else {
141            my @addrs = Mail::Address->parse($addr);
142            if (@addrs
143                and Sympa::Tools::Text::valid_email($addrs[0]->address)) {
144                $self->{'envelope_sender'} = $addrs[0]->address;
145            }
146        }
147    }
148    # Strip attributes.
149    substr($serialized, 0, pos $serialized) = '';
150
151    # Check if message is parsable.
152
153    my $parser = MIME::Parser->new;
154    $parser->output_to_core(1);
155    $parser->tmp_dir($Conf::Conf{'tmpdir'});
156    my $entity = $parser->parse_data(\$serialized);
157    unless ($entity) {
158        $log->syslog('err', 'Unable to parse message');
159        return undef;
160    }
161    my $hdr = $entity->head;
162    my ($dummy, $body_string) = split /(?:\A|\n)\r?\n/, $serialized, 2;
163
164    $self->{_head}         = $hdr;
165    $self->{_body}         = $body_string;
166    $self->{_entity_cache} = $entity;
167    $self->{'size'}        = length $serialized;
168
169    unless (exists $self->{'sender'} and defined $self->{'sender'}) {
170        ($self->{'sender'}, $self->{'gecos'}) = $self->_get_sender_email;
171    }
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        foreach my $token (@decoded_subject) {
179            unless ($token->[1]) {
180                # don't decode header including raw 8-bit bytes.
181                if ($token->[0] =~ /[^\x00-\x7F]/) {
182                    $self->{'subject_charset'} = undef;
183                    last;
184                }
185                next;
186            }
187            my $cset = MIME::Charset->new($token->[1]);
188            # don't decode header encoded with unknown charset.
189            unless ($cset->decoder) {
190                $self->{'subject_charset'} = undef;
191                last;
192            }
193            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'}) {
201        chomp $subject;
202        $self->{'decoded_subject'} =
203            MIME::EncWords::decode_mimewords($subject, Charset => 'UTF-8');
204    } else {
205        if (defined $subject) {
206            chomp $subject;
207            $subject =~ s/(\r\n|\r|\n)(?=[ \t])//g;
208            $subject =~ s/\r\n|\r|\n/ /g;
209        }
210        $self->{'decoded_subject'} = $subject;
211    }
212
213    ## TOPICS
214    my $topics;
215    if ($topics = $hdr->get('X-Sympa-Topic')) {
216        $self->{'topic'} = $topics;
217    }
218
219    # Message ID
220    unless (exists $self->{'message_id'}) {
221        $self->{'message_id'} = _get_message_id($self);
222    }
223
224    return $self;
225}
226
227# Tentative: removed when refactoring finished.
228sub new_from_file {
229    my $class = shift;
230    my $file  = shift;
231
232    open my $fh, '<', $file or return undef;
233    my $serialized = do { local $RS; <$fh> };
234    close $fh;
235
236    my $self = $class->new($serialized, @_)
237        or return undef;
238
239    $self->{'filename'} = $file;
240    # Get file date
241    unless (exists $self->{'date'}) {
242        $self->{'date'} = Sympa::Tools::File::get_mtime($file);
243    }
244
245    return $self;
246}
247
248## Get sender of the message according to header fields specified by
249## 'sender_headers' parameter.
250## FIXME: S/MIME signer may not be same as the sender given by this function.
251sub _get_sender_email {
252    my $self = shift;
253
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        if (lc $field eq 'return-path') {
260            ## Try to get envelope sender
261            if (    $self->{'envelope_sender'}
262                and $self->{'envelope_sender'} ne '<>') {
263                $sender = lc($self->{'envelope_sender'});
264            }
265        } elsif ($hdr->get($field)) {
266            ## Try to get message header.
267            ## On "Resent-*:" headers, the first occurrence must be used (see
268            ## RFC 5322 3.6.6).
269            ## FIXME: Though "From:" can occur multiple times, only the first
270            ## one is detected.
271            my $addr = $hdr->get($field, 0);               # get the first one
272            my @sender_hdr = Mail::Address->parse($addr);
273            if (@sender_hdr and $sender_hdr[0]->address) {
274                $sender = lc($sender_hdr[0]->address);
275                my $phrase = $sender_hdr[0]->phrase;
276                if (defined $phrase and length $phrase) {
277                    $gecos = MIME::EncWords::decode_mimewords($phrase,
278                        Charset => 'UTF-8');
279                    # Eliminate hostile characters.
280                    $gecos =~ s/(\r\n|\r|\n)(?=[ \t])//g;
281                    $gecos =~ s/[\0\r\n]+//g;
282                }
283                last;
284            }
285        }
286
287        last if defined $sender;
288    }
289    unless (defined $sender) {
290        #$log->syslog('debug3', 'No valid sender address');
291        return;
292    }
293    unless (Sympa::Tools::Text::valid_email($sender)) {
294        $log->syslog('err', 'Invalid sender address "%s"', $sender);
295        return;
296    }
297
298    return ($sender, $gecos);
299}
300
301# Note that this must be called after decrypting message
302# FIXME: Also check Resent-Message-ID:.
303sub _get_message_id {
304    my $self = shift;
305
306    return Sympa::Tools::Text::canonic_message_id(
307        $self->{_head}->get('Message-Id', 0));
308}
309
310# Old names: (part of) mail::mail_file(), mail::parse_tt2_messageasstring(),
311# List::send_file(), List::send_global_file().
312# Moved to: Sympa::Message::Template::new().
313#sub new_from_template;
314
315sub dup {
316    my $self = shift;
317
318    my $clone = {};
319    foreach my $key (sort keys %$self) {
320        my $val = $self->{$key};
321        next unless defined $val;
322
323        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            $clone->{$key} = $val->dup;
327        } else {
328            $clone->{$key} = $val;
329        }
330    }
331
332    return bless $clone => ref($self);
333}
334
335sub to_string {
336    my $self    = shift;
337    my %options = @_;
338
339    my $serialized = '';
340    if (ref $self->{'rcpt'} eq 'ARRAY' and @{$self->{'rcpt'}}) {
341        $serialized .= sprintf "X-Sympa-To: %s\n",
342            join(',', @{$self->{'rcpt'}});
343    } elsif (defined $self->{'rcpt'} and length $self->{'rcpt'}) {
344        $serialized .= sprintf "X-Sympa-To: %s\n",
345            join(',', split(/\s*,\s*/, $self->{'rcpt'}));
346    }
347    if (defined $self->{'checksum'}) {
348        $serialized .= sprintf "X-Sympa-Checksum: %s\n", $self->{'checksum'};
349    }
350    if (defined $self->{'family'}) {
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        $serialized .= sprintf "X-Sympa-Auth-Level: %s\n", 'md5';
356    }
357    if (defined $self->{'message_id'}) {      # New in 6.2a.41
358        $serialized .= sprintf "X-Sympa-Message-ID: %s\n",
359            $self->{'message_id'};
360    }
361    if (defined $self->{'sender'}) {          # New in 6.2a.41
362        $serialized .= sprintf "X-Sympa-Sender: %s\n", $self->{'sender'};
363    }
364    if (defined $self->{'gecos'}
365        and length $self->{'gecos'}) {        # New in 6.2a.41
366        $serialized .= sprintf "X-Sympa-Display-Name: %s\n", $self->{'gecos'};
367    }
368    if (%{$self->{'shelved'} || {}}) {        # New in 6.2a.41
369        $serialized .= sprintf "X-Sympa-Shelved: %s\n", join(
370            '; ',
371            map {
372                my $v = $self->{shelved}{$_};
373                ("$v" eq '1') ? $_ : sprintf('%s=%s', $_, $v);
374                }
375                grep {
376                $self->{shelved}{$_}
377                } sort keys %{$self->{shelved}}
378        );
379    }
380    if (defined $self->{'spam_status'}) {     # New in 6.2a.41.
381        $serialized .= sprintf "X-Sympa-Spam-Status: %s\n",
382            $self->{'spam_status'};
383    }
384    # This terminates pseudo-header part for attributes.
385    unless (defined $self->{'envelope_sender'}) {
386        $serialized .= "Return-Path: \n";
387    }
388
389    $serialized .= $self->as_string(%options);
390
391    return $serialized;
392}
393
394sub add_header {
395    my $self = shift;
396    $self->{_head}->add(@_);
397    delete $self->{_entity_cache};    # Clear entity cache.
398}
399
400sub delete_header {
401    my $self = shift;
402    $self->{_head}->delete(@_);
403    delete $self->{_entity_cache};    # Clear entity cache.
404}
405
406sub replace_header {
407    my $self = shift;
408    $self->{_head}->replace(@_);
409    delete $self->{_entity_cache};    # Clear entity cache.
410}
411
412sub head {
413    shift->{_head};
414}
415
416# NOTE: As this processes is needed for incoming messages only, it would be
417# moved to incoming pipeline class..
418sub check_spam_status {
419    my $self = shift;
420
421    my $robot_id =
422        (ref $self->{context} eq 'Sympa::List')
423        ? $self->{context}->{'domain'}
424        : $self->{context};
425
426    my $spam_status =
427        Sympa::Scenario->new($robot_id, 'spam_status')
428        ->authz('smtp', {'message' => $self});
429    if (defined $spam_status) {
430        if (ref($spam_status) eq 'HASH') {
431            $self->{'spam_status'} = $spam_status->{'action'};
432        } else {
433            $self->{'spam_status'} = $spam_status;
434        }
435    } else {
436        $self->{'spam_status'} = 'unknown';
437    }
438}
439
440my $has_mail_dkim_textwrap;
441
442BEGIN {
443    eval 'use Mail::DKIM::Signer';
444    # This doesn't export $VERSION.
445    eval 'use Mail::DKIM::TextWrap';
446    $has_mail_dkim_textwrap = !$EVAL_ERROR;
447    # Mail::DKIM::Signer prior to 0.38 doesn't import this.
448    eval 'use Mail::DKIM::PrivateKey';
449    eval 'use Mail::DKIM::ARC::Signer';
450}
451
452# Old name: tools::dkim_sign() which took string and returned string.
453sub dkim_sign {
454    $log->syslog('debug', '(%s)', @_);
455    my $self    = shift;
456    my %options = @_;
457
458    my $dkim_d          = $options{'dkim_d'};
459    my $dkim_i          = $options{'dkim_i'};
460    my $dkim_selector   = $options{'dkim_selector'};
461    my $dkim_privatekey = $options{'dkim_privatekey'};
462
463    unless ($dkim_selector) {
464        $log->syslog('err',
465            "DKIM selector is undefined, could not sign message");
466        return undef;
467    }
468    unless ($dkim_privatekey) {
469        $log->syslog('err',
470            "DKIM key file is undefined, could not sign message");
471        return undef;
472    }
473    unless ($dkim_d) {
474        $log->syslog('err',
475            "DKIM d= tag is undefined, could not sign message");
476        return undef;
477    }
478
479    unless ($Mail::DKIM::Signer::VERSION) {
480        $log->syslog('err',
481            "Failed to load Mail::DKIM::Signer Perl module, ignoring DKIM signature"
482        );
483        return undef;
484    }
485    unless ($has_mail_dkim_textwrap) {
486        $log->syslog('err',
487            "Failed to load Mail::DKIM::TextWrap Perl module, signature will not be pretty"
488        );
489    }
490
491    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
492    my $privatekey_string = join '',
493        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $dkim_privatekey;
494    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
495    unless ($privatekey) {
496        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
497        return undef;
498    }
499    # create a signer object
500    my $dkim = Mail::DKIM::Signer->new(
501        Algorithm => "rsa-sha256",
502        Method    => "relaxed",
503        Domain    => $dkim_d,
504        Selector  => $dkim_selector,
505        Key       => $privatekey,
506        ($dkim_i ? (Identity => $dkim_i) : ()),
507    );
508    unless ($dkim) {
509        $log->syslog('err', 'Can\'t create Mail::DKIM::Signer');
510        return undef;
511    }
512    # $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;
516    $msg_as_string =~ s/\r?\n/\r\n/g;
517    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
518    $dkim->PRINT($msg_as_string);
519    unless ($dkim->CLOSE) {
520        $log->syslog('err', 'Cannot sign (DKIM) message');
521        return undef;
522    }
523
524    my ($dummy, $new_body) = split /\r\n\r\n/, $msg_as_string, 2;
525    $new_body =~ s/\r\n/\n/g;
526
527    # Mail::DKIM::Signer wraps DKIM-Signature with with \r\n\t; this
528    # is the hardcoded Separator passed to Mail::DKIM::TextWrap via
529    # Mail::DKIM::KeyValueList. MIME::Tools on the other hand
530    # (MIME::Head::stringify() in particular) encode EOL as plain \n;
531    # so it is necessary to normalize CRLF->LF for DKIM-Signature to
532    # avoid confusing the mail agent.
533
534    my $dkim_signature = $dkim->signature->as_string;
535    $dkim_signature =~ s/\r\n/\n/g;
536
537    # Signing is done. Rebuilding message as string with original body
538    # and new headers.
539    # 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.
543
544    return $self;
545}
546
547sub arc_seal {
548    $log->syslog('debug2', '(%s)', @_);
549    my $self    = shift;
550    my %options = @_;
551
552    my $arc_d          = $options{'arc_d'};
553    my $arc_selector   = $options{'arc_selector'};
554    my $arc_privatekey = $options{'arc_privatekey'};
555    my $arc_srvid      = $options{'arc_srvid'};
556    my $arc_cv         = $options{'arc_cv'};
557
558    unless ($arc_selector) {
559        $log->syslog('err',
560            "ARC selector is undefined, could not seal message");
561        return undef;
562    }
563    unless ($arc_privatekey) {
564        $log->syslog('err',
565            "ARC key file is undefined, could not seal message");
566        return undef;
567    }
568    unless ($arc_d) {
569        $log->syslog('err',
570            "ARC d= tag is undefined, could not seal message");
571        return undef;
572    }
573
574    unless ($arc_cv =~ m{^(none|pass|fail)$}) {
575        $log->syslog('err',
576            "ARC chain value %s is invalid, could not seal message", $arc_cv);
577        return undef;
578    }
579
580    unless ($Mail::DKIM::ARC::Signer::VERSION) {
581        $log->syslog('err',
582            "Failed to load Mail::DKIM::ARC::Signer Perl module, no seal added"
583        );
584        return undef;
585    }
586
587    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
588    my $privatekey_string = join '',
589        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $arc_privatekey;
590    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
591    unless ($privatekey) {
592        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
593        return undef;
594
595    }
596
597    # create a signer object
598    my $arc = Mail::DKIM::ARC::Signer->new(
599        Algorithm => "rsa-sha256",
600        Chain     => $arc_cv,
601        SrvId     => $arc_srvid,
602        Domain    => $arc_d,
603        Selector  => $arc_selector,
604        Key       => $privatekey,
605    );
606    unless ($arc) {
607        $log->syslog('err', 'Can\'t create Mail::DKIM::ARC::Signer');
608        return undef;
609    }
610    # $new_body will store the body as fed to Mail::DKIM to reuse it
611    # when returning the message as string.  Line terminators must be
612    # normalized with CRLF.
613    my $msg_as_string = $self->as_string;
614    $msg_as_string =~ s/\r?\n/\r\n/g;
615    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
616    unless (eval { $arc->PRINT($msg_as_string) and $arc->CLOSE }) {
617        $log->syslog('err', 'Cannot ARC seal message: %s', $EVAL_ERROR);
618        return undef;
619    }
620    $log->syslog('debug2', 'ARC %s: %s', $arc->{result},
621        $arc->{result_reason});
622
623    # don't need this since DKIM just did it
624    #    my ($dummy, $new_body) = split /\r\n\r\n/, $msg_as_string, 2;
625    #$new_body =~ s/\r\n/\n/g;
626
627    # Seal is done. Add new headers for the seal
628    my @seal = $arc->as_strings();
629    if (grep { $_ and /\AARC-Seal:/i } @seal) {
630        foreach my $ahdr (reverse @seal) {
631            my ($ah, $av) = split /:\s*/, $ahdr, 2;
632            $self->add_header($ah, $av, 0);
633        }
634    }
635    #$self->{_body} = $new_body;
636    delete $self->{_entity_cache};    # Clear entity cache.
637
638    return $self;
639}
640
641BEGIN {
642    eval 'use Mail::DKIM::Verifier';
643    eval 'use Mail::DKIM::ARC::Verifier';
644}
645
646sub check_dkim_signature {
647    my $self = shift;
648
649    return unless $Mail::DKIM::Verifier::VERSION;
650
651    my $robot_id =
652        (ref $self->{context} eq 'Sympa::List') ? $self->{context}->{'domain'}
653        : (ref $self->{context} eq 'Sympa::Family')
654        ? $self->{context}->{'domain'}
655        : $self->{context};
656
657    return
658        unless Sympa::Tools::Data::smart_eq(
659        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');
660
661    my $dkim;
662    unless ($dkim = Mail::DKIM::Verifier->new()) {
663        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
664        return;
665    }
666
667    # Line terminators must be normalized with CRLF.
668    my $msg_as_string = $self->as_string;
669    $msg_as_string =~ s/\r?\n/\r\n/g;
670    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
671    $dkim->PRINT($msg_as_string);
672    unless ($dkim->CLOSE) {
673        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
674        return;
675    }
676
677    #FIXME: Identity of signatures would be checked.
678    foreach my $signature ($dkim->signatures) {
679        if ($signature->result_detail eq 'pass') {
680            $self->{'dkim_pass'} = 1;
681            return;
682        }
683    }
684    delete $self->{'dkim_pass'};
685}
686
687sub check_arc_chain {
688    my $self = shift;
689
690    return unless $Mail::DKIM::ARC::Verifier::VERSION;
691
692    my $robot_id =
693        (ref $self->{context} eq 'Sympa::List')
694        ? $self->{context}->{'domain'}
695        : $self->{context};
696    my $srvid;
697    unless ($srvid = Conf::get_robot_conf($robot_id || '*', 'arc_srvid')) {
698        $log->syslog('debug2', 'ARC library installed, but no arc_srvid set');
699        return;
700    }
701
702    # if there is no authentication-results, not much point in checking ARC
703    # since we can't add a new seal
704
705    my @ars =
706        grep { my $d = $_->param('_'); $d and lc $d eq lc $srvid }
707        map { MIME::Field::ParamVal->parse($_) }
708        $self->get_header('Authentication-Results');
709
710    unless (@ars) {
711        $log->syslog('debug2',
712            'ARC enabled but no Authentication-Results: %s;', $srvid);
713        return;
714    }
715    # already checked?
716    foreach my $ar (@ars) {
717        my $param_arc = $ar->param('arc');
718        if ($param_arc and $param_arc =~ m{\A(pass|fail|none)\b}i) {
719            $self->{shelved}->{arc_cv} = $1;
720            $log->syslog('debug2', 'ARC already checked: %s', $param_arc);
721            return;
722        }
723    }
724
725    my $arc;
726    unless ($arc = Mail::DKIM::ARC::Verifier->new(Strict => 1)) {
727        $log->syslog('err', 'Could not create Mail::DKIM::ARC::Verifier');
728        return;
729    }
730
731    # Line terminators must be normalized with CRLF.
732    my $msg_as_string = $self->as_string;
733    $msg_as_string =~ s/\r?\n/\r\n/g;
734    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
735    unless (eval { $arc->PRINT($msg_as_string) and $arc->CLOSE }) {
736        $log->syslog('err', 'Cannot verify chain of (ARC) message: %s',
737            $EVAL_ERROR);
738        return;
739    }
740
741    $log->syslog('debug2', 'result %s', $arc->result);
742    $self->{shelved}->{arc_cv} = $arc->result;
743}
744
745# Old name: tools::remove_invalid_dkim_signature() which takes a message as
746# string and outputs idem without signature if invalid.
747sub remove_invalid_dkim_signature {
748    $log->syslog('debug2', '(%s)', @_);
749    my $self = shift;
750
751    return unless $self->get_header('DKIM-Signature');
752
753    $self->check_dkim_signature;
754    unless ($self->{'dkim_pass'}) {
755        $log->syslog('info',
756            'DKIM signature of message %s is invalid, removing', $self);
757        $self->delete_header('DKIM-Signature');
758    }
759}
760
761sub as_entity {
762    my $self = shift;
763
764    unless (defined $self->{_entity_cache}) {
765        die 'Bug in logic.  Ask developer' unless $self->{_head};
766        my $string =
767            $self->{_head}->as_string . "\n"
768            . (defined $self->{_body} ? $self->{_body} : '');
769
770        my $parser = MIME::Parser->new();
771        $parser->output_to_core(1);
772        $parser->tmp_dir($Conf::Conf{'tmpdir'});
773        $self->{_entity_cache} = $parser->parse_data(\$string);
774    }
775    return $self->{_entity_cache};
776}
777
778sub set_entity {
779    my $self   = shift;
780    my $entity = shift;
781    return undef unless $entity;
782
783    my $orig = $self->as_entity->as_string;
784    my $new  = $entity->as_string;
785
786    if ($orig ne $new) {
787        $self->{_head} = $entity->head;
788        $self->{_body} = $entity->body_as_string;
789        $self->{_entity_cache} = $entity;    # Also update entity cache.
790    }
791
792    return $entity;
793}
794
795sub as_string {
796    my $self    = shift;
797    my %options = @_;
798
799    die 'Bug in logic.  Ask developer' unless $self->{_head};
800
801    return $self->{'orig_msg_as_string'}
802        if $options{'original'} and $self->{'smime_crypted'};
803
804    my $return_path = '';
805    if (defined $self->{'envelope_sender'}) {
806        my $val = $self->{'envelope_sender'};
807        $val = "<$val>" unless $val eq '<>';
808        $return_path = sprintf "Return-Path: %s\n", $val;
809    }
810    return
811          $return_path
812        . $self->{_head}->as_string . "\n"
813        . (defined $self->{_body} ? $self->{_body} : '');
814}
815
816sub body_as_string {
817    my $self = shift;
818    return $self->{_body};
819}
820
821sub header_as_string {
822    my $self = shift;
823    return $self->{_head}->as_string;
824}
825
826sub get_header {
827    my $self  = shift;
828    my $field = shift;
829    my $sep   = shift;
830    die sprintf 'Second argument is not index but separator: "%s"', $sep
831        if defined $sep and Scalar::Util::looks_like_number($sep);
832
833    my $hdr = $self->{_head};
834
835    if (defined $sep or wantarray) {
836        my @values = grep {s/\A$field\s*:\s*//i}
837            split /\n(?![ \t])/, $hdr->as_string();
838        if (defined $sep) {
839            return undef unless @values;
840            return join $sep, @values;
841        }
842        return @values;
843    } else {
844        my $value = $hdr->get($field, 0);
845        chomp $value if defined $value;
846        return $value;
847    }
848}
849
850# Old name: tools::decode_header() which can take Message, MIME::Entity,
851# MIME::Head or Mail::Header object as argument.
852sub get_decoded_header {
853    my $self = shift;
854    my $tag  = shift;
855    my $sep  = shift;
856
857    my $head = $self->head;
858
859    if (defined $sep) {
860        my @values = $head->get($tag);
861        return undef unless scalar @values;
862        foreach my $val (@values) {
863            $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
864            chomp $val;
865        }
866        return join $sep, @values;
867    } else {
868        my $val = $head->get($tag);
869        return undef unless defined $val;
870        $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
871        chomp $val;
872        return $val;
873    }
874}
875
876# Dump the Message object
877# Currently not used.
878sub dump {
879    my ($self, $output) = @_;
880    # my $output ||= \*STDERR;
881
882    my $old_output = select;
883    select $output;
884
885    foreach my $key (keys %{$self}) {
886        if (ref($self->{$key}) eq 'MIME::Entity') {
887            printf "%s =>\n", $key;
888            $self->{$key}->print;
889        } else {
890            printf "%s => %s\n", $key, $self->{$key};
891        }
892    }
893
894    select $old_output;
895
896    return 1;
897}
898
899## Add topic and put header X-Sympa-Topic
900# OBSOLETED.  No longer used.
901sub add_topic {
902    my ($self, $topic) = @_;
903
904    $self->{'topic'} = $topic;
905    $self->add_header('X-Sympa-Topic', $topic);
906}
907
908## Get topic
909# OBSOLETED.  No longer used.
910sub get_topic {
911    my ($self) = @_;
912
913    if (defined $self->{'topic'}) {
914        return $self->{'topic'};
915
916    } else {
917        return '';
918    }
919}
920
921sub clean_html {
922    my $self = shift;
923
924    my $robot =
925        (ref $self->{context} eq 'Sympa::List')
926        ? $self->{context}->{'domain'}
927        : $self->{context};
928
929    my $entity = $self->as_entity->dup;
930    if ($entity = _fix_html_part($entity, $robot)) {
931        $self->set_entity($entity);
932        return 1;
933    }
934    return 0;
935}
936
937sub _fix_html_part {
938    my $entity = shift;
939    my $robot  = shift;
940    return $entity unless $entity;
941
942    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
943    if ($entity->parts) {
944        my @newparts = ();
945        foreach my $part ($entity->parts) {
946            push @newparts, _fix_html_part($part, $robot);
947        }
948        $entity->parts(\@newparts);
949    } elsif ($eff_type eq 'text/html') {
950        my $bodyh = $entity->bodyhandle;
951        # Encoded body or null body won't be modified.
952        return $entity if !$bodyh or $bodyh->is_encoded;
953
954        my $body = $bodyh->as_string;
955        # Re-encode parts to UTF-8, since StripScripts cannot handle texts
956        # with some charsets (ISO-2022-*, UTF-16*, ...) correctly.
957        my $cset = MIME::Charset->new(
958            $entity->head->mime_attr('Content-Type.Charset') || '');
959        unless ($cset->decoder) {
960            # Charset is unknown.  Detect 7-bit charset.
961            my ($dummy, $charset) =
962                MIME::Charset::body_encode($body, '', Detect7Bit => 'YES');
963            $cset = MIME::Charset->new($charset)
964                if $charset;
965        }
966        if (    $cset->decoder
967            and $cset->as_string ne 'UTF-8'
968            and $cset->as_string ne 'US-ASCII') {
969            $cset->encoder('UTF-8');
970            $body = $cset->encode($body);
971            $entity->head->mime_attr('Content-Type.Charset', 'UTF-8');
972        }
973
974        my $filtered_body =
975            Sympa::HTMLSanitizer->new($robot)->sanitize_html($body);
976
977        my $io = $bodyh->open("w");
978        unless (defined $io) {
979            $log->syslog('err', 'Failed to save message: %m');
980            return undef;
981        }
982        $io->print($filtered_body);
983        $io->close;
984        $entity->sync_headers(Length => 'COMPUTE')
985            if $entity->head->get('Content-Length');
986    }
987    return $entity;
988}
989
990# Old name: tools::smime_decrypt() which took MIME::Entity object and list,
991# and won't modify Message object.
992sub smime_decrypt {
993    $log->syslog('debug2', '(%s)', @_);
994    my $self = shift;
995
996    return 0 unless $Crypt::SMIME::VERSION;
997
998    my $key_passwd = $Conf::Conf{'key_passwd'};
999    $key_passwd = '' unless defined $key_passwd;
1000
1001    my $content_type = lc($self->{_head}->mime_attr('Content-Type') || '');
1002    unless (
1003        (      $content_type eq 'application/pkcs7-mime'
1004            or $content_type eq 'application/x-pkcs7-mime'
1005        )
1006        and !Sympa::Tools::Data::smart_eq(
1007            $self->{_head}->mime_attr('Content-Type.smime-type'),
1008            qr/signed-data/i
1009        )
1010    ) {
1011        return 0;
1012    }
1013
1014    #FIXME: an empty "context" parameter means mail to sympa@, listmaster@...
1015    my ($certs, $keys) =
1016        Sympa::Tools::SMIME::find_keys($self->{context} || '*', 'decrypt');
1017    unless (defined $certs and @$certs) {
1018        $log->syslog('err',
1019            'Unable to decrypt message: missing certificate file');
1020        return undef;
1021    }
1022
1023    my ($msg_string, $entity);
1024
1025    # Try all keys/certs until one decrypts.
1026    while (my $certfile = shift @$certs) {
1027        my $keyfile = shift @$keys;
1028        $log->syslog('debug', 'Trying decrypt with certificate %s, key %s',
1029            $certfile, $keyfile);
1030
1031        my ($cert, $key);
1032        if (open my $fh, '<', $certfile) {
1033            $cert = do { local $RS; <$fh> };
1034            close $fh;
1035        }
1036        if (open my $fh, '<', $keyfile) {
1037            $key = do { local $RS; <$fh> };
1038            close $fh;
1039        }
1040
1041        my $smime = Crypt::SMIME->new();
1042        if (length $key_passwd) {
1043            eval { $smime->setPrivateKey($key, $cert, $key_passwd) }
1044                or next;
1045        } else {
1046            eval { $smime->setPrivateKey($key, $cert) }
1047                or next;
1048        }
1049        $msg_string = eval { $smime->decrypt($self->as_string); };
1050        last if defined $msg_string;
1051    }
1052
1053    unless (defined $msg_string) {
1054        $log->syslog('err', 'Message could not be decrypted');
1055        return undef;
1056    }
1057    my $parser = MIME::Parser->new;
1058    $parser->output_to_core(1);
1059    $parser->tmp_dir($Conf::Conf{'tmpdir'});
1060    $entity = $parser->parse_data($msg_string);
1061    unless (defined $entity) {
1062        $log->syslog('err', 'Message could not be decrypted');
1063        return undef;
1064    }
1065
1066    my ($dummy, $body_string) = split /(?:\A|\n)\r?\n/, $msg_string, 2;
1067    my $head = $entity->head;
1068    # Now remove headers from $msg_string.
1069    # Keep for each header defined in the incoming message but undefined in
1070    # the decrypted message, add this header in the decrypted form.
1071    my $predefined_headers;
1072    foreach my $header ($head->tags) {
1073        $predefined_headers->{lc $header} = 1 if $head->get($header);
1074    }
1075    foreach my $header (split /\n(?![ \t])/, $self->header_as_string) {
1076        next unless $header =~ /^([^\s:]+)\s*:\s*(.*)$/s;
1077        my ($tag, $val) = ($1, $2);
1078        $head->add($tag, $val) unless $predefined_headers->{lc $tag};
1079    }
1080    # Some headers from the initial message should not be restored
1081    # Content-Disposition and Content-Transfer-Encoding if the result is
1082    # multipart
1083    $head->delete('Content-Disposition')
1084        if $self->get_header('Content-Disposition');
1085    if (Sympa::Tools::Data::smart_eq(
1086            $head->mime_attr('Content-Type'),
1087            qr/multipart/i
1088        )
1089    ) {
1090        $head->delete('Content-Transfer-Encoding')
1091            if $self->get_header('Content-Transfer-Encoding');
1092    }
1093
1094    # We should be the sender and/or the listmaster
1095
1096    $self->{'smime_crypted'}      = 'smime_crypted';
1097    $self->{'orig_msg_as_string'} = $self->as_string;
1098    $self->{_head}                = $head;
1099    $self->{_body}                = $body_string;
1100    delete $self->{_entity_cache};    # Clear entity cache.
1101    $log->syslog('debug', 'Message has been decrypted');
1102
1103    return $self;
1104}
1105
1106# Old name: tools::smime_encrypt() which returns stringified message.
1107sub smime_encrypt {
1108    $log->syslog('debug2', '(%s, %s)', @_);
1109    my $self  = shift;
1110    my $email = shift;
1111
1112    my $msg_header = $self->{_head};
1113
1114    my $certfile;
1115    my $entity;
1116
1117    my $base =
1118        $Conf::Conf{'ssl_cert_dir'} . '/'
1119        . Sympa::Tools::Text::escape_chars($email);
1120    if (-f $base . '@enc') {
1121        $certfile = $base . '@enc';
1122    } else {
1123        $certfile = $base;
1124    }
1125    unless (-r $certfile) {
1126        $log->syslog('notice',
1127            'Unable to encrypt message to %s (missing certificate %s)',
1128            $email, $certfile);
1129        return undef;
1130    }
1131
1132    my $cert;
1133    if (open my $fh, '<', $certfile) {
1134        $cert = do { local $RS; <$fh> };
1135        close $fh;
1136    }
1137
1138    # encrypt the incoming message parse it.
1139    my $smime = Crypt::SMIME->new();
1140    #FIXME: Add intermediate CA certificates if any.
1141    eval { $smime->setPublicKey($cert); };
1142    if ($EVAL_ERROR) {
1143        $log->syslog('err', 'Unable to encrypt message to %s: %s',
1144            $email, $EVAL_ERROR);
1145        return undef;
1146    }
1147
1148    # don't; cf RFC2633 3.1. netscape 4.7 at least can't parse encrypted
1149    # stuff that contains a whole header again... since MIME::Tools has
1150    # got no function for this, we need to manually extract only the MIME
1151    # headers...
1152    #XXX$msg_header->print(\*MSGDUMP);
1153    #XXXprintf MSGDUMP "\n%s", $msg_body;
1154    my $dup_head = $msg_header->dup();
1155    foreach my $t ($dup_head->tags()) {
1156        $dup_head->delete($t) unless $t =~ /^(mime|content)-/i;
1157    }
1158
1159    #FIXME: is $self->body_as_string respect base64 number of char per line ??
1160    my $msg_string = eval {
1161        $smime->encrypt($dup_head->as_string . "\n" . $self->body_as_string);
1162    };
1163    unless (defined $msg_string) {
1164        $log->syslog('err', 'Unable to S/MIME encrypt message: %s',
1165            $EVAL_ERROR);
1166        return undef;
1167    }
1168
1169    ## Get as MIME object
1170    my $parser = MIME::Parser->new;
1171    $parser->output_to_core(1);
1172    $parser->tmp_dir($Conf::Conf{'tmpdir'});
1173    unless ($entity = $parser->parse_data($msg_string)) {
1174        $log->syslog('notice', 'Unable to parse message');
1175        return undef;
1176    }
1177
1178    my ($dummy, $body_string) = split /\n\r?\n/, $msg_string, 2;
1179
1180    # foreach header defined in  the incomming message but undefined in
1181    # the crypted message, add this header in the crypted form.
1182    my $predefined_headers;
1183    foreach my $header ($entity->head->tags) {
1184        $predefined_headers->{lc $header} = 1
1185            if $entity->head->get($header);
1186    }
1187    foreach my $header (split /\n(?![ \t])/, $msg_header->as_string) {
1188        next unless $header =~ /^([^\s:]+)\s*:\s*(.*)$/s;
1189        my ($tag, $val) = ($1, $2);
1190        $entity->head->add($tag, $val)
1191            unless $predefined_headers->{lc $tag};
1192    }
1193
1194    $self->{_head} = $entity->head;
1195    $self->{_body} = $body_string;
1196    delete $self->{_entity_cache};    # Clear entity cache.
1197
1198    return $self;
1199}
1200
1201# Old name: tools::smime_sign().
1202sub smime_sign {
1203    $log->syslog('debug2', '(%s)', @_);
1204    my $self = shift;
1205
1206    my $list       = $self->{context};
1207    my $key_passwd = $Conf::Conf{'key_passwd'};
1208    $key_passwd = '' unless defined $key_passwd;
1209
1210    #FIXME
1211    return 1 unless $list;
1212
1213    my ($certfile, $keyfile) = Sympa::Tools::SMIME::find_keys($list, 'sign');
1214
1215    my $signed_msg;
1216
1217    ## Keep a set of header fields ONLY
1218    ## OpenSSL only needs content type & encoding to generate a
1219    ## multipart/signed msg
1220    my $dup_head = $self->head->dup;
1221    foreach my $field ($dup_head->tags) {
1222        next if $field =~ /^(content-type|content-transfer-encoding)$/i;
1223        $dup_head->delete($field);
1224    }
1225
1226    my ($cert, $key);
1227    if (open my $fh, '<', $certfile) {
1228        $cert = do { local $RS; <$fh> };
1229        close $fh;
1230    }
1231    if (open my $fh, '<', $keyfile) {
1232        $key = do { local $RS; <$fh> };
1233        close $fh;
1234    }
1235
1236    my $smime = Crypt::SMIME->new();
1237    #FIXME: Add intermediate CA certificates if any.
1238    if (length $key_passwd) {
1239        unless (eval { $smime->setPrivateKey($key, $cert, $key_passwd) }) {
1240            $log->syslog('err', 'Unable to S/MIME sign message: %s',
1241                $EVAL_ERROR);
1242            return undef;
1243        }
1244    } else {
1245        unless (eval { $smime->setPrivateKey($key, $cert) }) {
1246            $log->syslog('err', 'Unable to S/MIME sign message: %s',
1247                $EVAL_ERROR);
1248            return undef;
1249        }
1250    }
1251    my $msg_string = eval {
1252        $smime->sign($dup_head->as_string . "\n" . $self->body_as_string);
1253    };
1254    unless (defined $msg_string) {
1255        $log->syslog('err', 'Unable to S/MIME sign message: %s', $EVAL_ERROR);
1256        return undef;
1257    }
1258
1259    my $parser = MIME::Parser->new;
1260    $parser->output_to_core(1);
1261    $parser->tmp_dir($Conf::Conf{'tmpdir'});
1262    unless ($signed_msg = $parser->parse_data($msg_string)) {
1263        $log->syslog('notice', 'Unable to parse message');
1264        return undef;
1265    }
1266
1267    ## foreach header defined in  the incoming message but undefined in the
1268    ## crypted message, add this header in the crypted form.
1269    my $head = $signed_msg->head;
1270    my $predefined_headers;
1271    foreach my $header ($head->tags) {
1272        $predefined_headers->{lc $header} = 1
1273            if $head->get($header);
1274    }
1275    foreach my $header (split /\n(?![ \t])/, $self->header_as_string) {
1276        next unless $header =~ /^([^\s:]+)\s*:\s*(.*)$/s;
1277        my ($tag, $val) = ($1, $2);
1278        $head->add($tag, $val)
1279            unless $predefined_headers->{lc $tag};
1280    }
1281
1282    ## Keeping original message string in addition to updated headers.
1283    my ($dummy, $body_string) = split /(?:\A|\n)\r?\n/, $msg_string, 2;
1284
1285    $self->{_head} = $head;
1286    $self->{_body} = $body_string;
1287    delete $self->{_entity_cache};    # Clear entity cache.
1288    $self->check_smime_signature;
1289
1290    return $self;
1291}
1292
1293# Old name: tools::smime_sign_check() or Message::smime_sign_check()
1294# which won't alter Message object.
1295sub check_smime_signature {
1296    $log->syslog('debug2', '(%s)', @_);
1297    my $self = shift;
1298
1299    return 0 unless $Crypt::SMIME::VERSION;
1300    return 0 unless $self->is_signed;
1301
1302    ## Messages that should not be altered (no footer)
1303    $self->{'protected'} = 1;
1304
1305    my $sender = $self->{'sender'};
1306
1307    # First step is to check if message signing is OK.
1308    my $smime = Crypt::SMIME->new;
1309    eval {    # Crypt::SMIME >= 0.15 is required.
1310        $smime->setPublicKeyStore(grep { defined $_ and length $_ }
1311                ($Conf::Conf{'cafile'}, $Conf::Conf{'capath'}));
1312    };
1313    unless (eval { $smime->check($self->as_string) }) {
1314        $log->syslog('info', '%s: Unable to verify S/MIME signature: %s',
1315            $self, $EVAL_ERROR);
1316        return undef;
1317    }
1318
1319    # Second step is to check the signer of message matches the sender.
1320    # We need to check which certificate is for our user (CA and intermediate
1321    # certs are also included), and look at the purpose:
1322    # S/MIME signing and/or S/MIME encryption.
1323    #FIXME: A better analyse should be performed to extract the signer email.
1324    my %certs;
1325    my $signers = Crypt::SMIME::getSigners($self->as_string);
1326    foreach my $cert (@{$signers || []}) {
1327        my $parsed = Sympa::Tools::SMIME::parse_cert(text => $cert);
1328        next unless $parsed;
1329        next unless $parsed->{'email'}{lc $sender};
1330
1331        if ($parsed->{'purpose'}{'sign'} and $parsed->{'purpose'}{'enc'}) {
1332            $certs{'both'} = $cert;
1333            $log->syslog('debug', 'Found a signing + encryption cert');
1334        } elsif ($parsed->{'purpose'}{'sign'}) {
1335            $certs{'sign'} = $cert;
1336            $log->syslog('debug', 'Found a signing cert');
1337        } elsif ($parsed->{'purpose'}{'enc'}) {
1338            $certs{'enc'} = $cert;
1339            $log->syslog('debug', 'Found an encryption cert');
1340        }
1341        last if $certs{'both'} or ($certs{'sign'} and $certs{'enc'});
1342    }
1343    unless ($certs{both} or $certs{sign} or $certs{enc}) {
1344        $log->syslog('info', '%s: Could not extract certificate for %s',
1345            $self, $sender);
1346        return undef;
1347    }
1348
1349    # OK, now we have the certs, either a combined sign+encryption one
1350    # or a pair of single-purpose. save them, as email@addr if combined,
1351    # or as email@addr@sign / email@addr@enc for split certs.
1352    foreach my $c (keys %certs) {
1353        my $filename = "$Conf::Conf{ssl_cert_dir}/"
1354            . Sympa::Tools::Text::escape_chars(lc($sender));
1355        if ($c ne 'both') {
1356            unlink $filename;    # just in case there's an old cert left...
1357            $filename .= "\@$c";
1358        } else {
1359            unlink("$filename\@enc");
1360            unlink("$filename\@sign");
1361        }
1362        $log->syslog('debug', 'Saving %s cert in %s', $c, $filename);
1363        my $fh;
1364        unless (open $fh, '>', $filename) {
1365            $log->syslog('err', 'Unable to create certificate file %s: %m',
1366                $filename);
1367            return undef;
1368        }
1369        print $fh $certs{$c};
1370        close $fh;
1371    }
1372
1373    # TODO: Future version should check if the subject of certificate was part
1374    # of the SMIME signature.
1375    $self->{'smime_signed'} = 1;
1376    $log->syslog('debug3', '%s is signed, signature is checked', $self);
1377    ## Il faudrait traiter les cas d'erreur (0 différent de undef)
1378    return 1;
1379}
1380
1381sub is_signed {
1382    my $self = shift;
1383
1384    my $content_type = lc($self->head->mime_attr('Content-Type') // '');
1385    my $protocol = lc($self->head->mime_attr('Content-Type.protocol') // '');
1386    my $smime_type =
1387        lc($self->head->mime_attr('Content-Type.smime-type') // '');
1388    return 1
1389        if $content_type eq 'multipart/signed'
1390        and ($protocol eq 'application/pkcs7-signature'
1391        or $protocol eq 'application/x-pkcs7-signature');
1392    return 1
1393        if ($content_type eq 'application/pkcs7-mime'
1394        or $content_type eq 'application/x-pkcs7-mime')
1395        and $smime_type eq 'signed-data';
1396    return 0;
1397}
1398
1399# Old name: Bulk::merge_msg()
1400sub personalize {
1401    my $self = shift;
1402    my $list = shift;
1403    my $rcpt = shift || undef;
1404
1405    my $content_type = lc($self->{_head}->mime_attr('Content-Type') || '');
1406    if (   $content_type eq 'multipart/encrypted'
1407        or $content_type eq 'multipart/signed'
1408        or $content_type eq 'application/pkcs7-mime'
1409        or $content_type eq 'application/x-pkcs7-mime') {
1410        return 1;
1411    }
1412
1413    my $entity = $self->as_entity->dup;
1414
1415    # Initialize parameters at first only once.
1416    my $data = $self->_personalize_attrs;
1417
1418    unless (defined _merge_msg($entity, $list, $rcpt, $data)) {
1419        return undef;
1420    }
1421
1422    $self->set_entity($entity);
1423    return $self;
1424}
1425
1426sub _personalize_attrs {
1427    my $self = shift;
1428
1429    my $entity  = $self->as_entity;
1430    my $headers = $entity->head;
1431
1432    my $data = {headers => {}};
1433    foreach my $key (
1434        qw/subject x-originating-ip message-id date x-original-to from to thread-topic content-type/
1435    ) {
1436        next unless $headers->count($key);
1437        my $value = $headers->get($key, 0);
1438        chomp $value;
1439        $value =~ s/(?:\r\n|\r|\n)(?=[ \t])//g;    # unfold
1440        $data->{headers}{$key} = $value;
1441    }
1442    $data->{subject} = $self->{decoded_subject};
1443
1444    return $data;
1445}
1446
1447sub _merge_msg {
1448    my $entity = shift;
1449    my $list   = shift;
1450    my $rcpt   = shift;
1451    my $data   = shift;
1452
1453    my $enc = $entity->head->mime_encoding;
1454    # Parts with nonstandard encodings aren't modified.
1455    if ($enc and $enc !~ /^(?:base64|quoted-printable|[78]bit|binary)$/i) {
1456        return $entity;
1457    }
1458    my $eff_type = $entity->effective_type || 'text/plain';
1459    # Signed or encrypted parts aren't modified.
1460    if ($eff_type =~ m{^multipart/(signed|encrypted)$}) {
1461        return $entity;
1462    }
1463
1464    # Check for attchment-part, which should not be changed
1465    if ('attachment' eq
1466        lc($entity->head->mime_attr('Content-Disposition') // '')) {
1467        return $entity;
1468    }
1469
1470    if ($entity->parts) {
1471        foreach my $part ($entity->parts) {
1472            unless (_merge_msg($part, $list, $rcpt, $data)) {
1473                $log->syslog('err', 'Failed to personalize message part');
1474                return undef;
1475            }
1476        }
1477    } elsif ($eff_type =~ m{^(?:multipart|message)(?:/|\Z)}i) {
1478        # multipart or message types without subparts.
1479        return $entity;
1480    } elsif (MIME::Tools::textual_type($eff_type)) {
1481        my ($charset, $in_cset, $bodyh, $body, $utf8_body);
1482
1483        my ($descr) = ($entity->head->get('Content-Description', 0));
1484        chomp $descr if $descr;
1485        $descr = MIME::EncWords::decode_mimewords($descr, Charset => 'UTF-8');
1486
1487        $data->{'part'} = {
1488            description => $descr,
1489            disposition =>
1490                lc($entity->head->mime_attr('Content-Disposition') || ''),
1491            encoding => $enc,
1492            type     => $eff_type,
1493        };
1494
1495        $bodyh = $entity->bodyhandle;
1496        # Encoded body or null body won't be modified.
1497        if (!$bodyh or $bodyh->is_encoded) {
1498            return $entity;
1499        }
1500
1501        $body = $bodyh->as_string;
1502        unless (defined $body and length $body) {
1503            return $entity;
1504        }
1505
1506        ## Detect charset.  If charset is unknown, detect 7-bit charset.
1507        $charset = $entity->head->mime_attr('Content-Type.Charset');
1508        $in_cset = MIME::Charset->new($charset || 'NONE');
1509        unless ($in_cset->decoder) {
1510            $in_cset =
1511                MIME::Charset->new(MIME::Charset::detect_7bit_charset($body)
1512                    || 'NONE');
1513        }
1514        unless ($in_cset->decoder) {
1515            $log->syslog('err', 'Unknown charset "%s"', $charset);
1516            return undef;
1517        }
1518        $in_cset->encoder($in_cset);    # no charset conversion
1519
1520        ## Only decodable bodies are allowed.
1521        eval { $utf8_body = Encode::encode_utf8($in_cset->decode($body, 1)); };
1522        if ($EVAL_ERROR) {
1523            $log->syslog('err', 'Cannot decode by charset "%s"', $charset);
1524            return undef;
1525        }
1526
1527        ## PARSAGE ##
1528
1529        my $message_output;
1530        unless (
1531            defined(
1532                $message_output =
1533                    personalize_text($utf8_body, $list, $rcpt, $data)
1534            )
1535        ) {
1536            $log->syslog('err', 'Error merging message');
1537            return undef;
1538        }
1539        $utf8_body = $message_output;
1540
1541        ## Data not encodable by original charset will fallback to UTF-8.
1542        my ($newcharset, $newenc);
1543        ($body, $newcharset, $newenc) =
1544            $in_cset->body_encode(Encode::decode_utf8($utf8_body),
1545            Replacement => 'FALLBACK');
1546        unless ($newcharset) {    # bug in MIME::Charset?
1547            $log->syslog('err', 'Can\'t determine output charset');
1548            return undef;
1549        } elsif ($newcharset ne $in_cset->as_string) {
1550            $entity->head->mime_attr('Content-Transfer-Encoding' => $newenc);
1551            $entity->head->mime_attr('Content-Type.Charset' => $newcharset);
1552
1553            ## normalize newline to CRLF if transfer-encoding is BASE64.
1554            $body =~ s/\r\n|\r|\n/\r\n/g
1555                if $newenc and $newenc eq 'BASE64';
1556        } else {
1557            ## normalize newline to CRLF if transfer-encoding is BASE64.
1558            $body =~ s/\r\n|\r|\n/\r\n/g
1559                if $enc and uc $enc eq 'BASE64';
1560        }
1561
1562        ## Save new body.
1563        my $io = $bodyh->open('w');
1564        unless ($io
1565            and $io->print($body)
1566            and $io->close) {
1567            $log->syslog('err', 'Can\'t write in Entity: %m');
1568            return undef;
1569        }
1570        $entity->sync_headers(Length => 'COMPUTE')
1571            if $entity->head->get('Content-Length');
1572
1573        return $entity;
1574    }
1575
1576    return $entity;
1577}
1578
1579# Moved to Sympa::Spindle::AuthorizeMessage::_test_personalize().
1580#sub test_personalize;
1581
1582# Old name: Bulk::merge_data()
1583sub personalize_text {
1584    my $body = shift;
1585    my $list = shift;
1586    my $rcpt = shift;
1587    my $data = shift || {};
1588
1589    die 'Unexpected type of $list' unless ref $list eq 'Sympa::List';
1590
1591    my $listname = $list->{'name'};
1592    my $robot_id = $list->{'domain'};
1593
1594    $data->{'listname'} = $listname;
1595    $data->{'domain'}   = $robot_id;
1596    $data->{'robot'}    = $data->{'domain'};    # Compat.<=6.2.52.
1597    $data->{'wwsympa_url'} = Conf::get_robot_conf($robot_id, 'wwsympa_url');
1598
1599    my $message_output;
1600
1601    my $user = $list->get_list_member($rcpt) if $rcpt;
1602
1603    if ($user) {
1604        $user->{'escaped_email'} = URI::Escape::uri_escape($rcpt);
1605        $user->{'friendly_date'} =
1606            $language->gettext_strftime("%d %b %Y  %H:%M",
1607            localtime($user->{'date'}));
1608
1609        # this method has been removed because some users may forward
1610        # authentication link
1611        # $user->{'fingerprint'} = tools::get_fingerprint($rcpt);
1612    }
1613
1614    $data->{'user'} = $user if $user;
1615
1616    # Parse the template in the message : replace the tags and the parameters
1617    # by the corresponding values
1618    my $template = Sympa::Template->new(undef);
1619    unless (
1620        $template->parse(
1621            $data, \$body, \$message_output, is_not_template => 1
1622        )
1623    ) {
1624        $log->syslog(
1625            'err',
1626            'Failed parsing template: %s',
1627            $template->{last_error}
1628        );
1629        return undef;
1630    }
1631
1632    return $message_output;
1633}
1634
1635sub prepare_message_according_to_mode {
1636    my $self = shift;
1637    my $mode = shift;
1638    my $list = shift;
1639
1640    my $robot_id = $list->{'domain'};
1641
1642    if (   $mode eq 'nomail'
1643        or $mode eq 'summary'
1644        or $mode eq 'digest'
1645        or $mode eq 'digestplain') {
1646        ;
1647    } elsif ($mode eq 'notice') {
1648        ##Prepare message for notice reception mode
1649        my $entity = $self->as_entity->dup;
1650
1651        $entity->bodyhandle(undef);
1652        $entity->parts([]);
1653        $self->set_entity($entity);
1654    } elsif ($mode eq 'txt') {
1655        ##Prepare message for txt reception mode
1656        my $entity = $self->as_entity->dup;
1657
1658        if (_as_singlepart($entity, 'text/plain')) {
1659            $log->syslog('notice', 'Multipart message changed to singlepart');
1660        }
1661        $self->set_entity($entity);
1662
1663        # Add a footer
1664        $self->{shelved}{decorate} = 1;
1665    } elsif ($mode eq 'urlize') {
1666        # Prepare message for urlize reception mode.
1667        # Not extract message/rfc822 parts.
1668        my $parser = MIME::Parser->new;
1669        $parser->extract_nested_messages(0);
1670        $parser->extract_uuencode(1);
1671        $parser->output_to_core(1);
1672        $parser->tmp_dir($Conf::Conf{'tmpdir'});
1673
1674        my $msg_string = $self->as_string;
1675        $msg_string =~ s/\AReturn-Path: (.*?)\n(?![ \t])//s;
1676        my $entity = $parser->parse_data($msg_string);
1677
1678        _urlize_parts($entity, $list, $self->{'message_id'});
1679        $self->set_entity($entity);
1680
1681        # Add a footer
1682        $self->{shelved}{decorate} = 1;
1683    } else {    # 'mail'
1684        # Prepare message for normal reception mode,
1685        # and add a footer.
1686        $self->{shelved}{decorate} = 1
1687            unless $self->{'protected'};
1688    }
1689
1690    return $self;
1691}
1692
1693# Old name:
1694# Sympa::List::add_parts() or Message::add_parts(), n.b. not add_part().
1695# Sympa::Message::_decorate_parts().
1696sub decorate {
1697    $log->syslog('debug3', '(%s, %s, %s => %s)', @_);
1698    my $self    = shift;
1699    my $list    = shift;
1700    my $rcpt    = shift;
1701    my %options = @_;
1702
1703    return unless ref $list eq 'Sympa::List';
1704
1705    my $entity = $self->as_entity->dup;
1706    my $mode = $options{mode} || '';
1707
1708    my $type = $list->{'admin'}{'footer_type'};
1709    my $eff_type = $entity->effective_type || 'text/plain';
1710
1711    ## Signed or encrypted messages won't be modified.
1712    return 1 if $eff_type =~ /^multipart\/(signed|encrypted)$/i;
1713
1714    my $header =
1715        ($type eq 'mime')
1716        && Sympa::search_fullpath($list, 'message_header.mime')
1717        || Sympa::search_fullpath($list, 'message_header');
1718    my $footer =
1719        ($type eq 'mime')
1720        && Sympa::search_fullpath($list, 'message_footer.mime')
1721        || Sympa::search_fullpath($list, 'message_footer');
1722    my $global_footer =
1723        ($type eq 'mime')
1724        && Sympa::search_fullpath($list->{'domain'},
1725        'message_global_footer.mime')
1726        || Sympa::search_fullpath($list->{'domain'}, 'message_global_footer');
1727    # No footer/header.
1728    return
1729           unless $header and -s $header
1730        or $footer        and -s $footer
1731        or $global_footer and -s $global_footer;
1732
1733    my $data;
1734    if ($mode) {
1735        $data = $self->_personalize_attrs;
1736    }
1737
1738    if ($type eq 'append') {
1739        # append footer/header
1740        my $header_text = _footer_text(
1741            $header, $list, $rcpt, $data,
1742            mode => $mode,
1743            type => 'header'
1744        ) // '';
1745        my $footer_text = _footer_text(
1746            $footer, $list, $rcpt, $data,
1747            mode => $mode,
1748            type => 'footer'
1749        ) // '';
1750        my $global_footer_text = _footer_text(
1751            $global_footer, $list, $rcpt, $data,
1752            mode => $mode,
1753            type => 'global footer'
1754        ) // '';
1755        if (   length $header_text
1756            or length $footer_text
1757            or length $global_footer_text) {
1758            if (_append_parts(
1759                    $entity,      $header_text,
1760                    $footer_text, $global_footer_text
1761                )
1762            ) {
1763                $entity->sync_headers(Length => 'COMPUTE')
1764                    if $entity->head->get('Content-Length');
1765            }
1766        }
1767    } else {
1768        ## MIME footer/header
1769        if ($header and -s $header) {
1770            _add_footer_part(
1771                $entity, $header, $list, $rcpt, $data,
1772                mode    => $mode,
1773                type    => 'header',
1774                prepend => 1
1775            );
1776        }
1777        if ($footer and -s $footer) {
1778            _add_footer_part(
1779                $entity, $footer, $list, $rcpt, $data,
1780                mode => $mode,
1781                type => 'footer'
1782            );
1783        }
1784        if ($global_footer and -s $global_footer) {
1785            _add_footer_part(
1786                $entity, $global_footer, $list, $rcpt, $data,
1787                mode => $mode,
1788                type => 'global footer'
1789            );
1790        }
1791    }
1792
1793    $self->set_entity($entity);
1794    return 1;
1795}
1796
1797sub _footer_text {
1798    my $footer  = shift;
1799    my $list    = shift;
1800    my $rcpt    = shift;
1801    my $data    = shift;
1802    my %options = @_;
1803
1804    my $mode = $options{mode};
1805    my $type = $options{type};
1806
1807    my $footer_text = '';
1808    if ($footer and -s $footer) {
1809        if (open my $fh, '<', $footer) {
1810            $footer_text = do { local $RS; <$fh> };
1811            close $fh;
1812        }
1813        if ($mode) {
1814            $footer_text =
1815                personalize_text($footer_text, $list, $rcpt, $data);
1816            unless (defined $footer_text) {
1817                $log->syslog('info', 'Error personalizing %s', $type);
1818                $footer_text = '';
1819            }
1820        }
1821        $footer_text = '' unless $footer_text =~ /\S/;
1822    }
1823    return $footer_text;
1824}
1825
1826## Append header/footer/global_footer to text/plain body.
1827## Note: As some charsets (e.g. UTF-16) are not compatible to US-ASCII,
1828##   we must concatenate decoded header/body/footer/global_footer and at last
1829##   encode it.
1830## Note: With BASE64 transfer-encoding, newline must be normalized to CRLF,
1831##   however, original body would be intact.
1832sub _append_parts {
1833    my $entity            = shift;
1834    my $header_msg        = shift || '';
1835    my $footer_msg        = shift || '';
1836    my $global_footer_msg = shift || '';
1837
1838    my $enc = $entity->head->mime_encoding;
1839    # Parts with nonstandard encodings aren't modified.
1840    if ($enc and $enc !~ /^(?:base64|quoted-printable|[78]bit|binary)$/i) {
1841        return undef;
1842    }
1843    my $eff_type = $entity->effective_type || 'text/plain';
1844    my $body;
1845    my $io;
1846
1847    ## Signed or encrypted parts aren't modified.
1848    if ($eff_type =~ m{^multipart/(signed|encrypted)$}i) {
1849        return undef;
1850    }
1851
1852    ## Skip attached parts.
1853    my $disposition = $entity->head->mime_attr('Content-Disposition');
1854    return undef
1855        if $disposition and uc $disposition ne 'INLINE';
1856
1857    ## Preparing header, footer and global_footer for inclusion.
1858    if ($eff_type eq 'text/plain' or $eff_type eq 'text/html') {
1859        if (   length $header_msg
1860            or length $footer_msg
1861            or length $global_footer_msg) {
1862            # Only decodable bodies are allowed.
1863            my $bodyh = $entity->bodyhandle;
1864            if ($bodyh) {
1865                return undef if $bodyh->is_encoded;
1866                $body = $bodyh->as_string();
1867            } else {
1868                $body = '';
1869            }
1870
1871            # Alter body.
1872            $body = _append_footer_header_to_part(
1873                {   'part'          => $entity,
1874                    'header'        => $header_msg,
1875                    'footer'        => $footer_msg,
1876                    'global_footer' => $global_footer_msg,
1877                    'eff_type'      => $eff_type,
1878                    'body'          => $body
1879                }
1880            );
1881            return undef unless defined $body;
1882
1883            # Save new body.
1884            $io = $bodyh->open('w');
1885            unless (defined $io) {
1886                $log->syslog('err', 'Failed to save message: %m');
1887                return undef;
1888            }
1889            $io->print($body);
1890            $io->close;
1891            $entity->sync_headers(Length => 'COMPUTE')
1892                if $entity->head->get('Content-Length');
1893
1894            return 1;
1895        }
1896    } elsif ($eff_type eq 'multipart/mixed') {
1897        ## Append to the first part, since other parts will be "attachments".
1898        if ($entity->parts
1899            and _append_parts(
1900                $entity->parts(0), $header_msg,
1901                $footer_msg,       $global_footer_msg
1902            )
1903        ) {
1904            return 1;
1905        }
1906    } elsif ($eff_type eq 'multipart/alternative') {
1907        ## We try all the alternatives
1908        my $r = undef;
1909        foreach my $p ($entity->parts) {
1910            $r = 1
1911                if _append_parts($p, $header_msg, $footer_msg,
1912                $global_footer_msg);
1913        }
1914        return $r if $r;
1915    } elsif ($eff_type eq 'multipart/related') {
1916        ## Append to the first part, since other parts will be "attachments".
1917        if ($entity->parts
1918            and _append_parts(
1919                $entity->parts(0), $header_msg,
1920                $footer_msg,       $global_footer_msg
1921            )
1922        ) {
1923            return 1;
1924        }
1925    }
1926
1927    ## We couldn't find any parts to modify.
1928    return undef;
1929}
1930
1931sub _add_footer_part {
1932    my $entity  = shift;
1933    my $footer  = shift;
1934    my $list    = shift;
1935    my $rcpt    = shift;
1936    my $data    = shift;
1937    my %options = @_;
1938
1939    my $mode    = $options{mode};
1940    my $type    = $options{type};
1941    my $prepend = $options{prepend};
1942
1943    my $parser = MIME::Parser->new;
1944    $parser->output_to_core(1);
1945    $parser->tmp_dir($Conf::Conf{'tmpdir'});
1946
1947    my $fh;
1948    my $footer_part;
1949    my $error;
1950    unless (open $fh, '<', $footer) {
1951        return 0;
1952    } elsif ($footer =~ /\.mime$/) {
1953        eval { $footer_part = $parser->parse($fh); };
1954        close $fh;
1955        $error = $parser->last_error;
1956    } else {
1957        # text/plain footer
1958        my $footer_text = do { local $RS; <$fh> };
1959        close $fh;
1960        eval {
1961            $footer_part = MIME::Entity->build(
1962                Data       => $footer_text,
1963                Type       => "text/plain",
1964                Filename   => undef,
1965                'X-Mailer' => undef,
1966                Encoding   => "8bit",
1967                Charset    => "UTF-8"
1968            );
1969        };
1970        $error = $EVAL_ERROR;
1971    }
1972
1973    my $eff_type = $entity->effective_type || 'text/plain';
1974
1975    unless ($footer_part) {
1976        $log->syslog('err', 'Failed to parse MIME data %s: %s',
1977            $footer, $error);
1978    } elsif ($mode
1979        and not defined _merge_msg($footer_part, $list, $rcpt, $data)) {
1980        $log->syslog('info', 'Error personalizing %s', $type);
1981    } else {
1982        unless ($entity->is_multipart) {
1983            $entity->make_multipart;
1984        } elsif ($eff_type =~ /^multipart\/alternative/i
1985            or $eff_type =~ /^multipart\/related/i) {
1986            $log->syslog('debug3', 'Making message %s into multipart/mixed',
1987                $entity);
1988            $entity->make_multipart("mixed", Force => 1);
1989        }
1990
1991        $entity->add_part($footer_part, $prepend ? 0 : -1);
1992    }
1993}
1994
1995# Styles to cancel local CSS.
1996my $div_style =
1997    'background: transparent; border: none; clear: both; display: block; float: none; position: static';
1998
1999sub _append_footer_header_to_part {
2000    my $data = shift;
2001
2002    my $entity            = $data->{'part'};
2003    my $header_msg        = $data->{'header'};
2004    my $footer_msg        = $data->{'footer'};
2005    my $global_footer_msg = $data->{'global_footer'};
2006    my $eff_type          = $data->{'eff_type'};
2007    my $body              = $data->{'body'};
2008
2009    my $in_cset;
2010
2011    ## Detect charset.  If charset is unknown, detect 7-bit charset.
2012    my $charset = $entity->head->mime_attr('Content-Type.Charset');
2013    $in_cset = MIME::Charset->new($charset || 'NONE');
2014    unless ($in_cset->decoder) {
2015        # MIME::Charset 1.009.2 or later required.
2016        $in_cset =
2017            MIME::Charset->new(MIME::Charset::detect_7bit_charset($body)
2018                || 'NONE');
2019    }
2020    unless ($in_cset->decoder) {
2021        return undef;
2022    }
2023    $in_cset->encoder($in_cset);    # no charset conversion
2024
2025    # Decode body to Unicode, since Sympa::Tools::Text::encode_html() and
2026    # newline normalization will break texts with several character sets
2027    # (UTF-16/32, ISO-2022-JP, ...).
2028    # Only decodable bodies are allowed.
2029    eval {
2030        $body = $in_cset->decode($body, 1);
2031        $header_msg        = Encode::decode_utf8($header_msg,        1);
2032        $footer_msg        = Encode::decode_utf8($footer_msg,        1);
2033        $global_footer_msg = Encode::decode_utf8($global_footer_msg, 1);
2034    };
2035    return undef if $EVAL_ERROR;
2036
2037    my $new_body;
2038    if ($eff_type eq 'text/plain') {
2039        $log->syslog('debug3', "Treating text/plain part");
2040
2041        ## Add newlines.  For BASE64 encoding they also must be normalized.
2042        if (length $header_msg) {
2043            $header_msg .= "\n" unless $header_msg =~ /\n\z/;
2044        }
2045        if (length $footer_msg and length $body) {
2046            $body .= "\n" unless $body =~ /\n\z/;
2047        }
2048        if (length $global_footer_msg and length $body) {
2049            $body .= "\n" unless $body =~ /\n\z/;
2050        }
2051        if (length $footer_msg) {
2052            $footer_msg .= "\n" unless $footer_msg =~ /\n\z/;
2053        }
2054        if (length $global_footer_msg) {
2055            $global_footer_msg .= "\n" unless $global_footer_msg =~ /\n\z/;
2056        }
2057        if (uc($entity->head->mime_attr('Content-Transfer-Encoding') || '')
2058            eq 'BASE64') {
2059            $header_msg =~ s/\r\n|\r|\n/\r\n/g;
2060            $body =~ s/(\r\n|\r|\n)\z/\r\n/;    # only at end
2061            $footer_msg =~ s/\r\n|\r|\n/\r\n/g;
2062            $global_footer_msg =~ s/\r\n|\r|\n/\r\n/g;
2063        }
2064
2065        $new_body = $header_msg . $body . $footer_msg . $global_footer_msg;
2066
2067        ## Data not encodable by original charset will fallback to UTF-8.
2068        my ($newcharset, $newenc);
2069        ($body, $newcharset, $newenc) =
2070            $in_cset->body_encode($new_body, Replacement => 'FALLBACK');
2071        unless ($newcharset) {                  # bug in MIME::Charset?
2072            $log->syslog('err', 'Can\'t determine output charset');
2073            return undef;
2074        } elsif ($newcharset ne $in_cset->as_string) {
2075            $entity->head->mime_attr('Content-Transfer-Encoding' => $newenc);
2076            $entity->head->mime_attr('Content-Type.Charset' => $newcharset);
2077        }
2078    } elsif ($eff_type eq 'text/html') {
2079        $log->syslog('debug3', "Treating text/html part");
2080
2081        # Escape special characters.
2082        $header_msg = Sympa::Tools::Text::encode_html($header_msg);
2083        $header_msg =~ s/(\r\n|\r|\n)$//;       # strip the last newline.
2084        $header_msg =~ s,(\r\n|\r|\n),<br/>,g;
2085        $footer_msg = Sympa::Tools::Text::encode_html($footer_msg);
2086        $footer_msg =~ s/(\r\n|\r|\n)$//;       # strip the last newline.
2087        $footer_msg =~ s,(\r\n|\r|\n),<br/>,g;
2088        $global_footer_msg =
2089            Sympa::Tools::Text::encode_html($global_footer_msg);
2090        $global_footer_msg =~ s/(\r\n|\r|\n)$//;    # strip the last newline.
2091        $global_footer_msg =~ s,(\r\n|\r|\n),<br/>,g;
2092
2093        $new_body = $body;
2094        if (length $header_msg) {
2095            my $div = sprintf '<div style="%s">%s</div>',
2096                $div_style, $header_msg;
2097            $new_body =~ s,(<body\b[^>]*>),$1$div,i
2098                or $new_body = $div . $new_body;
2099        }
2100        if (length $footer_msg) {
2101            my $div = sprintf '<div style="%s">%s</div>',
2102                $div_style, $footer_msg;
2103            $new_body =~ s,(</\s*body\b[^>]*>),$div$1,i
2104                or $new_body = $new_body . $div;
2105        }
2106        if (length $global_footer_msg) {
2107            my $div = sprintf '<div style="%s">%s</div>',
2108                $div_style, $global_footer_msg;
2109            $new_body =~ s,(</\s*body\b[^>]*>),$div$1,i
2110                or $new_body = $new_body . $div;
2111        }
2112        # Append newline if it is not there: A few MUAs need it.
2113        $new_body .= "\n" unless $new_body =~ /\n\z/;
2114
2115        # Unencodable characters are encoded to entity, because charset
2116        # metadata in HTML won't be altered.
2117        # Problem: FB_HTMLCREF of several codecs are broken.
2118        eval { $body = $in_cset->encode($new_body, Encode::FB_HTMLCREF); };
2119        return undef if $EVAL_ERROR;
2120    }
2121
2122    return $body;
2123}
2124
2125sub _urlize_parts {
2126    my $entity     = shift;
2127    my $list       = shift;
2128    my $message_id = shift;
2129
2130    ## Only multipart/mixed messages are modified.
2131    my $eff_type = $entity->effective_type || 'text/plain';
2132    unless ($eff_type eq 'multipart/mixed'
2133        or $eff_type eq 'multipart/alternative'
2134        or $eff_type eq 'multipart/related') {
2135        return undef;
2136    }
2137
2138    my $expl = $list->{'dir'} . '/urlized';
2139    unless (-d $expl or mkdir $expl, 0775) {
2140        $log->syslog('err', 'Unable to create urlized directory %s', $expl);
2141        return undef;
2142    }
2143
2144    ## Clean up Message-ID and preventing double percent encoding.
2145    my $dir1 = Sympa::Tools::Text::encode_filesystem_safe($message_id);
2146    unless (-d "$expl/$dir1" or mkdir "$expl/$dir1", 0775) {
2147        $log->syslog('err', 'Unable to create urlized directory %s/%s: %m',
2148            $expl, $dir1);
2149        return 0;
2150    }
2151    return _urlize_sub_parts($entity, $list, $message_id, $dir1, 0);
2152}
2153
2154sub _urlize_sub_parts {
2155    my $entity     = shift;
2156    my $list       = shift;
2157    my $message_id = shift;
2158    my $directory  = shift;
2159    my $i          = shift;
2160    my @parts      = ();
2161    use Data::Dumper;
2162    my $parent_eff_type = $entity->effective_type();
2163
2164    foreach my $part ($entity->parts) {
2165        my $eff_type = $part->effective_type || 'text/plain';
2166        if ($eff_type eq 'multipart/mixed') {
2167            $i++;
2168            my $p =
2169                _urlize_sub_parts($part->dup, $list, $message_id, $directory,
2170                $i);
2171            push @parts, $p;
2172        } elsif (
2173            (      $eff_type eq 'multipart/alternative'
2174                or $eff_type eq 'multipart/related'
2175            )
2176            and $i < 2
2177        ) {
2178            $i++;
2179            my $p =
2180                _urlize_sub_parts($part->dup, $list, $message_id, $directory,
2181                $i);
2182            push @parts, $p;
2183        } else {
2184            my $p = _urlize_one_part($part->dup, $list, $directory, $i,
2185                $parent_eff_type);
2186            if (defined $p) {
2187                push @parts, $p;
2188                $i++;
2189            } else {
2190                push @parts, $part;
2191            }
2192        }
2193    }
2194
2195    $entity->parts(\@parts);
2196    return $entity;
2197}
2198
2199sub _urlize_one_part {
2200    my $entity          = shift;
2201    my $list            = shift;
2202    my $dir             = shift;
2203    my $i               = shift;
2204    my $parent_eff_type = shift;
2205
2206    return undef unless ($parent_eff_type eq 'multipart/mixed');
2207
2208    my $expl     = $list->{'dir'} . '/urlized';
2209    my $listname = $list->{'name'};
2210    my $head     = $entity->head;
2211    my $encoding = $head->mime_encoding;
2212
2213    # name of the linked file
2214    my $filename;
2215    if ($head->recommended_filename) {
2216        $filename = $head->recommended_filename;
2217        if (Encode::is_utf8($filename)) {
2218            # MIME-tools >= 5.501 returns Unicode value ("utf8 flag" on).
2219            $filename = Encode::encode_utf8($filename);
2220        } elsif ($filename !~ /[^\s\x20-\x7E]/
2221            and $filename =~ /=[?][-.+\w]+[?][BQ][?].*[?]=/i) {
2222            # Earlier versions of MIME-tools won't decode (nonstandard)
2223            # RFC-2047-encoded parameters.
2224            $filename = MIME::EncWords::decode_mimewords($filename,
2225                Charset => 'UTF-8') // $filename;
2226        }
2227    } else {
2228        my $content_disposition =
2229            lc($entity->head->mime_attr('Content-Disposition') // '');
2230        if ($entity->effective_type =~ m{\Atext}
2231            && (  !$content_disposition
2232                || $content_disposition eq 'attachment')
2233            && $entity->head->mime_attr('content-type.charset')
2234        ) {
2235            return undef;
2236        }
2237        my $fileExt = Conf::get_mime_type($entity->effective_type || '')
2238            || 'bin';
2239        $filename = sprintf 'msg.%d.%s', $i, $fileExt;
2240    }
2241    my $safe_filename = Sympa::Tools::Text::encode_filesystem_safe($filename);
2242    my $file = sprintf '%s/%s/%s', $expl, $dir, $safe_filename;
2243
2244    # Create the linked file
2245    # Store body in file
2246    my $fh;
2247    unless (open $fh, '>', $file) {
2248        $log->syslog('err', 'Unable to open %s: %m', $file);
2249        return undef;
2250    }
2251    if ($entity->bodyhandle) {
2252        my $ct = $entity->effective_type || 'text/plain';
2253        printf $fh "Content-Type: %s", $ct;
2254        printf $fh "; Charset=%s",
2255            $head->mime_attr('Content-Type.Charset')
2256            if Sympa::Tools::Data::smart_eq(
2257            $head->mime_attr('Content-Type.Charset'), qr/\S/);
2258        print $fh "\n\n";
2259        print $fh $entity->bodyhandle->as_string;
2260    } else {
2261        my $ct = $entity->effective_type || 'application/octet-stream';
2262        printf $fh "Content-Type: %s", $ct;
2263        print $fh "\n\n";
2264        print $fh $entity->body_as_string;
2265    }
2266    close $fh;
2267
2268    my $size = -s $file;
2269
2270    ## Only URLize files with a moderate size
2271    if ($size < $Conf::Conf{'urlize_min_size'}) {
2272        unlink $file;
2273        return undef;
2274    }
2275
2276    # Do NOT escape '/' chars separating path components.
2277    my $file_url =
2278        Sympa::get_url($list, 'attach', paths => [$dir, $safe_filename]);
2279
2280    my $parser = MIME::Parser->new;
2281    $parser->output_to_core(1);
2282    $parser->tmp_dir($Conf::Conf{'tmpdir'});
2283    my $new_part;
2284
2285    my $charset = Conf::lang2charset($language->get_lang);
2286    my $data    = {
2287        file_name => $filename,
2288        file_url  => $file_url,
2289        file_size => $size,
2290        charset   => $charset,    # compat. <= 6.1.
2291    };
2292
2293    my $template = Sympa::Template->new(
2294        $list,
2295        subdir => 'mail_tt2',
2296        lang   => $language->get_lang
2297    );
2298    unless ($template->parse($data, 'urlized_part.tt2', \$new_part)) {
2299        $log->syslog(
2300            'err',
2301            'Can\'t parse template urlized_part.tt2: %s',
2302            $template->{last_error}
2303        );
2304        return undef;
2305    }
2306    $entity = $parser->parse_data(\$new_part);
2307    _fix_utf8_parts($entity, $parser, [], $charset);
2308
2309    return $entity;
2310}
2311
2312# Some paths of message processing in Sympa can't recognize Unicode strings.
2313# At least MIME::Parser::parse_data() and Template::proccess(): these
2314# methods occationalily break strings containing Unicode characters.
2315#
2316# My mail_utf8 patch expects the behavior as following ---
2317#
2318# Sub-messages to be attached (into digests, moderation notices etc.) will
2319# passed to Sympa::Mail::reformat_message() separately then attached to reformatted
2320# parent message again.  As a result, sub-messages won't be broken.  Since
2321# they won't cause mixture of Unicode string (parent message generated by
2322# Sympa::Template::parse()) and byte string (sub-messages).
2323#
2324# Note: For compatibility with old style, data passed to
2325# Sympa::Mail::reformat_message() already includes sub-message(s).  Then:
2326# - When a part has an `X-Sympa-Attach:' header field for internal use, new
2327#   style, Sympa::Mail::reformat_message() attaches raw sub-message to reformatted
2328#   parent message again;
2329# - When a part doesn't have any `X-Sympa-Attach:' header fields, sub-
2330#   messages generated by [% INSERT %] directive(s) in the template will be
2331#   used.
2332#
2333# More Note: Latter behavior above will give expected result only if
2334# contents of sub-messages are US-ASCII or ISO-8859-1. In other cases
2335# customized templates (if any) should be modified so that they have
2336# appropriate `X-Sympa-Attach:' header fields.
2337#
2338# Sub-messages are gathered from template context paramenters.
2339
2340sub reformat_utf8_message {
2341    my $self        = shift;
2342    my $attachments = shift || [];
2343    my $defcharset  = shift;
2344
2345    my $entity = $self->as_entity->dup;
2346
2347    my $parser = MIME::Parser->new();
2348    $parser->output_to_core(1);
2349    $parser->tmp_dir($Conf::Conf{'tmpdir'});
2350
2351    $entity->head->delete('X-Mailer');
2352    _fix_utf8_parts($entity, $parser, $attachments, $defcharset);
2353    $entity->head->add('X-Mailer', sprintf 'Sympa %s',
2354        Sympa::Constants::VERSION);
2355
2356    $self->set_entity($entity);
2357    return $self;
2358}
2359
2360sub _fix_utf8_parts {
2361    my $entity      = shift;
2362    my $parser      = shift;
2363    my $attachments = shift || [];
2364    my $defcharset  = shift;
2365    return $entity unless $entity;
2366
2367    my $enc = $entity->head->mime_encoding;
2368    # Parts with nonstandard encodings aren't modified.
2369    return $entity
2370        if $enc and $enc !~ /^(?:base64|quoted-printable|[78]bit|binary)$/i;
2371    my $eff_type = $entity->effective_type;
2372    # Signed or encrypted parts aren't modified.
2373    if ($eff_type =~ m{^multipart/(signed|encrypted)$}) {
2374        return $entity;
2375    }
2376
2377    if ($entity->head->get('X-Sympa-Attach')) {    # Need re-attaching data.
2378        my $data = shift @{$attachments};
2379        if (ref $data eq 'MIME::Entity') {
2380            $entity->parts([$data]);
2381        } elsif (ref $data eq 'SCALAR' or ref $data eq 'ARRAY') {
2382            eval { $data = $parser->parse_data($data); };
2383            if ($EVAL_ERROR) {
2384                $log->syslog('notice', 'Failed to parse MIME data');
2385                $data = $parser->parse_data('');
2386            }
2387            $entity->parts([$data]);
2388        } else {
2389            if (Scalar::Util::blessed($data)
2390                and $data->isa('Sympa::Message')) {
2391                $data = $data->as_string;
2392            } elsif (ref $data) {
2393                die sprintf 'Unsupported type for attachment: %s', ref $data;
2394            } else {    # already stringified.
2395                eval { $parser->parse_data($data); };    # check only.
2396                if ($EVAL_ERROR) {
2397                    $log->syslog('notice', 'Failed to parse MIME data');
2398                    $data = '';
2399                }
2400            }
2401            $parser->extract_nested_messages(0);    # Keep attachments intact.
2402            $data =
2403                $parser->parse_data($entity->head->as_string . "\n" . $data);
2404            $parser->extract_nested_messages(1);
2405            %$entity = %$data;
2406        }
2407        $entity->head->delete('X-Sympa-Attach');
2408    } elsif ($entity->parts) {
2409        my @newparts = ();
2410        foreach my $part ($entity->parts) {
2411            push @newparts,
2412                _fix_utf8_parts($part, $parser, $attachments, $defcharset);
2413        }
2414        $entity->parts(\@newparts);
2415    } elsif ($eff_type =~ m{^(?:multipart|message)(?:/|\Z)}i) {
2416        # multipart or message types without subparts.
2417        return $entity;
2418    } elsif (MIME::Tools::textual_type($eff_type)) {
2419        my $bodyh = $entity->bodyhandle;
2420        # Encoded body or null body won't be modified.
2421        return $entity if !$bodyh or $bodyh->is_encoded;
2422
2423        my $head = $entity->head;
2424        my $body = $bodyh->as_string;
2425        my $wrap = $body;
2426        if ($head->get('X-Sympa-NoWrap')) {    # Need not wrapping
2427            $head->delete('X-Sympa-NoWrap');
2428        } elsif ($eff_type eq 'text/plain'
2429            and lc($head->mime_attr('Content-type.Format') || '') ne 'flowed')
2430        {
2431            $wrap = Sympa::Tools::Text::wrap_text($body);
2432        }
2433
2434        my $charset = $head->mime_attr("Content-Type.Charset") || $defcharset;
2435        my ($newbody, $newcharset, $newenc) =
2436            MIME::Charset::body_encode(Encode::decode_utf8($wrap),
2437            $charset, Replacement => 'FALLBACK');
2438        # Append newline if it is not there.  A few MUAs need it.
2439        $newbody .= "\n" unless $newbody =~ /\n\z/;
2440
2441        if (    $newenc eq $enc
2442            and $newcharset eq $charset
2443            and $newbody eq $body) {
2444            # Normalize field, especially because charset may be absent.
2445            $head->mime_attr('Content-Type',              uc $eff_type);
2446            $head->mime_attr('Content-Type.Charset',      $newcharset);
2447            $head->mime_attr('Content-Transfer-Encoding', $newenc);
2448
2449            $head->add("MIME-Version", "1.0")
2450                unless $head->get("MIME-Version");
2451            return $entity;
2452        }
2453
2454        ## normalize newline to CRLF if transfer-encoding is BASE64.
2455        $newbody =~ s/\r\n|\r|\n/\r\n/g
2456            if $newenc and $newenc eq 'BASE64';
2457
2458        # Fix headers and body.
2459        $head->mime_attr("Content-Type", "TEXT/PLAIN")
2460            unless $head->mime_attr("Content-Type");
2461        $head->mime_attr("Content-Type.Charset",      $newcharset);
2462        $head->mime_attr("Content-Transfer-Encoding", $newenc);
2463        $head->add("MIME-Version", "1.0") unless $head->get("MIME-Version");
2464        my $io = $bodyh->open("w");
2465
2466        unless (defined $io) {
2467            $log->syslog('err', 'Failed to save message: %m');
2468            return undef;
2469        }
2470
2471        $io->print($newbody);
2472        $io->close;
2473        $entity->sync_headers(Length => 'COMPUTE');
2474    } else {
2475        # Binary or text with long lines will be suggested to be BASE64.
2476        $entity->head->mime_attr("Content-Transfer-Encoding",
2477            $entity->suggest_encoding);
2478        $entity->sync_headers(Length => 'COMPUTE');
2479    }
2480    return $entity;
2481}
2482
2483sub shelve_personalization {
2484    my $self    = shift;
2485    my %options = @_;
2486
2487    my $list = $self->{context};
2488    die 'bug in logic. Ask developer' unless ref $list eq 'Sympa::List';
2489
2490    my $apply_on =
2491        ('web' eq ($options{type} // ''))
2492        ? $list->{'admin'}{'personalization'}{'web_apply_on'}
2493        : $list->{'admin'}{'personalization'}{'mail_apply_on'};
2494
2495    if (    'on' eq ($list->{'admin'}{'personalization_feature'} || 'off')
2496        and 'none' ne ($apply_on || 'none')) {
2497        $self->{shelved}{merge} = $apply_on;
2498    }
2499}
2500
2501sub get_plain_body {
2502    $log->syslog('debug2', '(%s)', @_);
2503    my $self = shift;
2504
2505    my $entity = $self->as_entity->dup;
2506    return undef unless _as_singlepart($entity, 'text/plain');
2507    return undef unless $entity->bodyhandle;
2508    my $body = $entity->bodyhandle->as_string;
2509
2510    # Get charset
2511    my $cset =
2512        MIME::Charset->new($entity->head->mime_attr('Content-Type.Charset')
2513            || 'NONE');
2514    unless ($cset->decoder) {
2515        # Charset is unknown.  Detect 7-bit charset.
2516        $cset = MIME::Charset->new(MIME::Charset::detect_7bit_charset($body));
2517    }
2518    unless ($cset->decoder) {
2519        $cset = MIME::Charset->new('US-ASCII');
2520    }
2521
2522    # Unfold flowed text if required.
2523    my $format = lc($entity->head->mime_attr('Content-Type.Format') || '');
2524    my $delsp  = lc($entity->head->mime_attr('Content-Type.DelSp')  || '');
2525    if ($format eq 'flowed') {
2526        my $linefold =
2527            Text::LineFold->new(Charset => $cset, OutputCharset => 'UTF-8');
2528        if ($delsp eq 'yes') {
2529            return $linefold->unfold($body, 'FLOWED');
2530        } else {
2531            return $linefold->unfold($body, 'FLOWEDSP');
2532        }
2533    } else {
2534        $cset->encoder('UTF-8');
2535        return $cset->encode($body);
2536    }
2537}
2538
2539# Make multipart/alternative message to singlepart.
2540# Old name: tools::as_singlepart(), Sympa::Tools::Message::as_singlepart().
2541sub _as_singlepart {
2542    my $entity         = shift;
2543    my $preferred_type = shift;
2544    my $loops          = shift || 0;
2545
2546    my $done = 0;
2547
2548    $loops++;
2549    return undef unless $entity;
2550    return undef if 4 < $loops;
2551
2552    my $eff_type = lc($entity->effective_type || 'text/plain');
2553    if ($eff_type eq lc $preferred_type) {
2554        $done = 1;
2555    } elsif ($eff_type eq 'multipart/alternative') {
2556        foreach my $part ($entity->parts) {
2557            my $eff_type = lc($part->effective_type || 'text/plain');
2558            if ($eff_type eq lc $preferred_type
2559                or (    $eff_type eq 'multipart/related'
2560                    and $part->parts
2561                    and lc($part->parts(0)->effective_type || 'text/plain')
2562                    eq $preferred_type)
2563            ) {
2564                ## Only keep the first matching part
2565                $entity->parts([$part]);
2566                $entity->make_singlepart();
2567                $done = 1;
2568                last;
2569            }
2570        }
2571    } elsif ($eff_type eq 'multipart/signed') {
2572        my @parts = $entity->parts();
2573        ## Only keep the first part
2574        $entity->parts([$parts[0]]);
2575        $entity->make_singlepart();
2576
2577        $done ||= _as_singlepart($entity, $preferred_type, $loops);
2578
2579    } elsif ($eff_type =~ /^multipart/) {
2580        foreach my $part ($entity->parts) {
2581            next unless $part;    ## Skip empty parts
2582
2583            my $eff_type = lc($part->effective_type || 'text/plain');
2584            if ($eff_type eq 'multipart/alternative') {
2585                if (_as_singlepart($part, $preferred_type, $loops)) {
2586                    $entity->parts([$part]);
2587                    $entity->make_singlepart();
2588                    $done = 1;
2589                }
2590            }
2591        }
2592    }
2593
2594    return $done;
2595}
2596
2597# Note: this would be moved to incoming pipeline package.
2598# Old names: tools::virus_infected(), Sympa::Tools::Message::virus_infected().
2599sub check_virus_infection {
2600    $log->syslog('debug2', '(%s, ...)', @_);
2601    my $self    = shift;
2602    my %options = @_;
2603
2604    my $robot_id;
2605    if (ref $self->{context} eq 'Sympa::List') {
2606        $robot_id = $self->{context}->{'domain'};
2607    } elsif ($self->{context} and $self->{context} ne '*') {
2608        $robot_id = $self->{context};
2609    } else {
2610        $robot_id = '*';
2611    }
2612
2613    my $antivirus_path = Conf::get_robot_conf($robot_id, 'antivirus_path');
2614    my @antivirus_args = split /\s+/,
2615        (Conf::get_robot_conf($robot_id, 'antivirus_args') || '');
2616
2617    unless ($antivirus_path) {
2618        $log->syslog('debug',
2619            'Sympa not configured to scan virus in message');
2620        return 0;
2621    }
2622
2623    my $subdir = [split /\//, $self->get_id]->[0];
2624    my $work_dir = join '/', $Conf::Conf{'tmpdir'}, 'antivirus', $subdir;
2625    unless (-d $work_dir or Sympa::Tools::File::mkdir_all($work_dir, 0755)) {
2626        $log->syslog('err', 'Unable to create tmp antivirus directory %s: %m',
2627            $work_dir);
2628        return undef;
2629    }
2630
2631    ## Call the procedure of splitting mail
2632    unless ($self->_split_mail($work_dir)) {
2633        $log->syslog('err', 'Could not split mail %s', $self);
2634        return undef;
2635    }
2636
2637    my $virusfound = 0;
2638    my $error_msg;
2639    my $result;
2640
2641    if ($antivirus_path =~ /\/uvscan$/) {
2642        # McAfee
2643
2644        # impossible to look for viruses with no option set
2645        unless (@antivirus_args) {
2646            $log->syslog('err', 'Missing "antivirus_args" in sympa.conf');
2647            return undef;
2648        }
2649
2650        my $pipein;
2651        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2652            $work_dir) {
2653            $log->syslog('err', 'Cannot open pipe: %m');
2654            return undef;
2655        }
2656        while (<$pipein>) {
2657            $result .= $_;
2658            chomp $result;
2659            if (   (/^\s*Found the\s+(.*)\s*virus.*$/i)
2660                || (/^\s*Found application\s+(.*)\.\s*$/i)) {
2661                $virusfound = $1;
2662            }
2663        }
2664        close $pipein;
2665        my $status = $CHILD_ERROR >> 8;
2666
2667        ## uvscan status = 12 or 13 (*256) => virus
2668        if ($status == 13 or $status == 12) {
2669            $virusfound ||= "unknown";
2670        }
2671
2672        ## Meaning of the codes
2673        ##  12 : The program tried to clean a file, and that clean failed for
2674        ##  some reason and the file is still infected.
2675        ##  13 : One or more viruses or hostile objects (such as a Trojan
2676        ##  horse, joke program,  or  a  test file) were found.
2677        ##  15 : The programs self-check failed; the program might be infected
2678        ##  or damaged.
2679        ##  19 : The program succeeded in cleaning all infected files.
2680
2681        $error_msg = $result
2682            if $status != 0
2683            and $status != 12
2684            and $status != 13
2685            and $status != 19;
2686    } elsif ($antivirus_path =~ /\/vscan$/) {
2687        # Trend Micro
2688
2689        my $pipein;
2690        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2691            $work_dir) {
2692            $log->syslog('err', 'Cannot open pipe: %m');
2693            return undef;
2694        }
2695        while (<$pipein>) {
2696            if (/Found virus (\S+) /i) {
2697                $virusfound = $1;
2698            }
2699        }
2700        close $pipein;
2701        my $status = $CHILD_ERROR >> 8;
2702
2703        ## uvscan status = 1 | 2 (*256) => virus
2704        if ($status == 1 or $status == 2) {
2705            $virusfound ||= "unknown";
2706        }
2707    } elsif ($antivirus_path =~ /\/fsav$/) {
2708        # F-Secure
2709        my $dbdir = $PREMATCH;
2710
2711        # impossible to look for viruses with no option set
2712        unless (@antivirus_args) {
2713            $log->syslog('err', 'Missing "antivirus_args" in sympa.conf');
2714            return undef;
2715        }
2716
2717        my $pipein;
2718        unless (
2719            open $pipein, '-|', $antivirus_path,
2720            '--databasedirectory' => $dbdir,
2721            @antivirus_args, $work_dir
2722        ) {
2723            $log->syslog('err', 'Cannot open pipe: %m');
2724            return undef;
2725        }
2726        while (<$pipein>) {
2727            if (/infection:\s+(.*)/) {
2728                $virusfound = $1;
2729            }
2730        }
2731        close $pipein;
2732        my $status = $CHILD_ERROR >> 8;
2733
2734        ## fsecure status = 3 (*256) => virus
2735        if ($status == 3) {
2736            $virusfound ||= "unknown";
2737        }
2738    } elsif ($antivirus_path =~ /f-prot\.sh$/) {
2739        my $pipein;
2740        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2741            $work_dir) {
2742            $log->syslog('err', 'Cannot open pipe: %m');
2743            return undef;
2744        }
2745        while (<$pipein>) {
2746            if (/Infection:\s+(.*)/) {
2747                $virusfound = $1;
2748            }
2749        }
2750        close $pipein;
2751        my $status = $CHILD_ERROR >> 8;
2752
2753        ## f-prot status = 3 (*256) => virus
2754        if ($status == 3) {
2755            $virusfound ||= "unknown";
2756        }
2757    } elsif ($antivirus_path =~ /kavscanner/) {
2758        # Kaspersky
2759
2760        # impossible to look for viruses with no option set
2761        unless (@antivirus_args) {
2762            $log->syslog('err', 'Missing "antivirus_args" in sympa.conf');
2763            return undef;
2764        }
2765
2766        my $pipein;
2767        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2768            $work_dir) {
2769            $log->syslog('err', 'Cannot open pipe: %m');
2770            return undef;
2771        }
2772        while (<$pipein>) {
2773            if (/infected:\s+(.*)/) {
2774                $virusfound = $1;
2775            } elsif (/suspicion:\s+(.*)/i) {
2776                $virusfound = $1;
2777            }
2778        }
2779        close $pipein;
2780        my $status = $CHILD_ERROR >> 8;
2781
2782        ## uvscan status = 3 (*256) => virus
2783        if ($status >= 3) {
2784            $virusfound ||= "unknown";
2785        }
2786
2787    } elsif ($antivirus_path =~ /\/sweep$/) {
2788        # Sophos Antivirus... by liuk@publinet.it
2789
2790        # impossible to look for viruses with no option set
2791        unless (@antivirus_args) {
2792            $log->syslog('err', 'Missing "antivirus_args" in sympa.conf');
2793            return undef;
2794        }
2795
2796        my $pipein;
2797        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2798            $work_dir) {
2799            $log->syslog('err', 'Cannot open pipe: %m');
2800            return undef;
2801        }
2802        while (<$pipein>) {
2803            if (/Virus\s+(.*)/) {
2804                $virusfound = $1;
2805            }
2806        }
2807        close $pipein;
2808        my $status = $CHILD_ERROR >> 8;
2809
2810        ## sweep status = 3 (*256) => virus
2811        if ($status == 3) {
2812            $virusfound ||= "unknown";
2813        }
2814
2815        ## Clam antivirus
2816    } elsif ($antivirus_path =~ /\/clamd?scan$/) {
2817        # Clam antivirus
2818        my $result;
2819
2820        my $pipein;
2821        unless (open $pipein, '-|', $antivirus_path, @antivirus_args,
2822            $work_dir) {
2823            $log->syslog('err', 'Cannot open pipe: %m');
2824            return undef;
2825        }
2826        while (<$pipein>) {
2827            $result .= $_;
2828            chomp $result;
2829            if (/^\S+:\s(.*)\sFOUND$/) {
2830                $virusfound = $1;
2831            }
2832        }
2833        close $pipein;
2834        my $status = $CHILD_ERROR >> 8;
2835
2836        ## Clamscan status = 1 (*256) => virus
2837        if ($status == 1) {
2838            $virusfound ||= "unknown";
2839        }
2840        $error_msg = $result
2841            if $status != 0 and $status != 1;
2842    }
2843
2844    ## Error while running antivir, notify listmaster
2845    if ($error_msg) {
2846        Sympa::send_notify_to_listmaster(
2847            '*',
2848            'virus_scan_failed',
2849            {   'filename'  => $work_dir,
2850                'error_msg' => $error_msg
2851            }
2852        );
2853    }
2854
2855    # if debug mode is active, the working directory is kept
2856    unless ($options{debug}) {    #FIXME: Is this condition required?
2857        opendir DIR, $work_dir;
2858        my @list = readdir DIR;
2859        closedir DIR;
2860        foreach my $file (@list) {
2861            unlink "$work_dir/$file";
2862        }
2863        rmdir $work_dir;
2864    }
2865
2866    return $virusfound;
2867}
2868
2869# Old name: tools::split_mail(), Sympa::Tools::Message::split_mail().
2870# Currently this is used by check_virus_infection() only.
2871sub _split_mail {
2872    my $self = shift;
2873    my $dir  = shift;
2874
2875    my $i = 0;
2876    foreach
2877        my $part (grep { $_ and $_->bodyhandle } $self->as_entity->parts_DFS)
2878    {
2879        my $head = $part->head;
2880        my $fileExt;
2881
2882        if (    $head->mime_attr('Content-Type.Name')
2883            and $head->mime_attr('Content-Type.Name') =~
2884            /\.([.\w]*\w)\s*\"*$/) {
2885            $fileExt = $1;
2886        } elsif ($head->recommended_filename
2887            and $head->recommended_filename =~ /\.([.\w]*\w)\s*\"*$/) {
2888            $fileExt = $1;
2889            # MIME-tools >= 5.501 returns Unicode value ("utf8 flag" on).
2890            $fileExt = Encode::encode_utf8($fileExt)
2891                if Encode::is_utf8($fileExt);
2892        } else {
2893            $fileExt = Conf::get_mime_type($head->mime_type) || 'bin';
2894        }
2895
2896        ## Store body in file
2897        my $fh;
2898        unless (open $fh, '>', sprintf('%s/msg%03d.%s', $dir, $i, $fileExt)) {
2899            $log->syslog('err', 'Unable to create %s/msg%03d.%s: %m',
2900                $dir, $i, $fileExt);
2901            return undef;
2902        }
2903        print $fh $part->bodyhandle->as_string;
2904        close $fh;
2905
2906        $i++;
2907    }
2908
2909    return 1;
2910}
2911
2912# Old name: PlainDigest::plain_body_as_string(),
2913#   Sympa::Tools::Message::plain_body_as_string().
2914#
2915# Changes
2916# 20080910
2917# - don't bother trying to find path to lynx unless use_lynx is true
2918# - anchor content-type test strings to end of string to avoid
2919#    picking up malformed headers as per bug 3702
2920# - local Text::Wrap variables
2921# - moved repeated code to get charset into sub _getCharset
2922# - added use of MIME::Charset to check charset aliases
2923# 20100810 - S. Ikeda
2924# - Remove dependency on Text::Wrap: use common utility tools::wrap_text().
2925# - Use MIME::Charset OO to handle vendor-defined encodings.
2926# - Use MIME::EncWords instead of MIME::WordDecoder.
2927# - Now HTML::FormatText is mandatory.  Remove Lynx support.
2928#
2929sub get_plaindigest_body {
2930    my $self = shift;
2931
2932    # Reparse message to extract UUEncode.
2933    my $parser = MIME::Parser->new;
2934    $parser->output_to_core(1);
2935    $parser->tmp_dir($Conf::Conf{'tmpdir'});
2936    $parser->extract_uuencode(1);
2937    $parser->extract_nested_messages(1);
2938    my $topent = $parser->parse_data($self->as_string);
2939
2940    my $string = _do_toplevel($topent);
2941
2942    ## clean up after ourselves
2943    #$topent->purge;
2944
2945    return Sympa::Tools::Text::wrap_text($string, '', '');
2946}
2947
2948sub _do_toplevel {
2949    my $topent = shift;
2950    if (   $topent->effective_type =~ /^text\/plain$/i
2951        || $topent->effective_type =~ /^text\/enriched/i) {
2952        return _do_text_plain($topent);
2953    } elsif ($topent->effective_type =~ /^text\/html$/i) {
2954        return _do_text_html($topent);
2955    } elsif ($topent->effective_type =~ /^multipart\/.*/i) {
2956        return _do_multipart($topent);
2957    } elsif ($topent->effective_type =~ /^message\/rfc822$/i) {
2958        return _do_message($topent);
2959    } elsif ($topent->effective_type =~ /^message\/delivery\-status$/i) {
2960        return _do_dsn($topent);
2961    } else {
2962        return _do_other($topent);
2963    }
2964}
2965
2966sub _do_multipart {
2967    my $topent = shift;
2968
2969    my $string = '';
2970
2971    # cycle through each part and process accordingly
2972    foreach my $subent ($topent->parts) {
2973        if (   $subent->effective_type =~ /^text\/plain$/i
2974            || $subent->effective_type =~ /^text\/enriched/i) {
2975            $string .= _do_text_plain($subent);
2976        } elsif ($subent->effective_type =~ /^multipart\/related$/i) {
2977            if ($topent->effective_type =~ /^multipart\/alternative$/i
2978                && _hasTextPlain($topent)) {
2979                # this is a rare case - /related nested inside /alternative.
2980                # If there's also a text/plain alternative just ignore it
2981                next;
2982            } else {
2983                # just treat like any other multipart
2984                $string .= _do_multipart($subent);
2985            }
2986        } elsif ($subent->effective_type =~ /^multipart\/.*/i) {
2987            $string .= _do_multipart($subent);
2988        } elsif ($subent->effective_type =~ /^text\/html$/i) {
2989            if ($topent->effective_type =~ /^multipart\/alternative$/i
2990                && _hasTextPlain($topent)) {
2991                # there's a text/plain alternive, so don't warn
2992                # that the text/html part has been scrubbed
2993                next;
2994            }
2995            $string .= _do_text_html($subent);
2996        } elsif ($subent->effective_type =~ /^message\/rfc822$/i) {
2997            $string .= _do_message($subent);
2998        } elsif ($subent->effective_type =~ /^message\/delivery\-status$/i) {
2999            $string .= _do_dsn($subent);
3000        } else {
3001            # something else - just scrub it and add a message to say what was
3002            # there
3003            $string .= _do_other($subent);
3004        }
3005    }
3006
3007    return $string;
3008}
3009
3010sub _do_message {
3011    my $topent = shift;
3012    my $msgent = $topent->parts(0);
3013
3014    my $string = '';
3015
3016    unless ($msgent) {
3017        return $language->gettext(
3018            "----- Malformed message ignored -----\n\n");
3019    }
3020
3021    # Get decoded headers.
3022    # Note that MIME::Head::get() returns empty array if requested fields are
3023    # not found.
3024    my ($from) = map {
3025        chomp $_;
3026        MIME::EncWords::decode_mimewords($_, Charset => 'UTF-8')
3027    } ($msgent->head->get('From', 0));
3028    $from = $language->gettext("[Unknown]")
3029        unless defined $from and length $from;
3030    my ($subject) = map {
3031        chomp $_;
3032        MIME::EncWords::decode_mimewords($_, Charset => 'UTF-8')
3033    } ($msgent->head->get('Subject', 0));
3034    my ($date) = map {
3035        chomp $_;
3036        MIME::EncWords::decode_mimewords($_, Charset => 'UTF-8')
3037    } ($msgent->head->get('Date', 0));
3038    my $to = join ', ', map {
3039        chomp $_;
3040        MIME::EncWords::decode_mimewords($_, Charset => 'UTF-8')
3041    } ($msgent->head->get('To'));
3042    my $cc = join ', ', map {
3043        chomp $_;
3044        MIME::EncWords::decode_mimewords($_, Charset => 'UTF-8')
3045    } ($msgent->head->get('Cc'));
3046
3047    my @fromline = Mail::Address->parse($msgent->head->get('From'));
3048    my $name;
3049    if ($fromline[0]) {
3050        $name = MIME::EncWords::decode_mimewords($fromline[0]->name(),
3051            Charset => 'utf8');
3052        $name = $fromline[0]->address()
3053            unless defined $name and $name =~ /\S/;
3054        chomp $name;
3055    }
3056    $name = $from unless defined $name and length $name;
3057
3058    $string .= $language->gettext(
3059        "\n[Attached message follows]\n-----Original message-----\n");
3060    my $headers = '';
3061    $headers .= $language->gettext_sprintf("Date: %s\n", $date) if $date;
3062    $headers .= $language->gettext_sprintf("From: %s\n", $from) if $from;
3063    $headers .= $language->gettext_sprintf("To: %s\n",   $to)   if $to;
3064    $headers .= $language->gettext_sprintf("Cc: %s\n",   $cc)   if $cc;
3065    $headers .= $language->gettext_sprintf("Subject: %s\n", $subject)
3066        if $subject;
3067    $headers .= "\n";
3068    $string .= Sympa::Tools::Text::wrap_text($headers, '', '    ');
3069
3070    $string .= _do_toplevel($msgent);
3071
3072    $string .= $language->gettext_sprintf(
3073        "-----End of original message from %s-----\n\n", $name);
3074    return $string;
3075}
3076
3077sub _do_text_plain {
3078    my $entity = shift;
3079
3080    my $string = '';
3081
3082    if (($entity->head->get('Content-Disposition') || '') =~ /attachment/) {
3083        return _do_other($entity);
3084    }
3085
3086    my $thispart = $entity->bodyhandle->as_string;
3087
3088    # deal with CR/LF left over - a problem from Outlook which
3089    # qp encodes them
3090    $thispart =~ s/\r\n/\n/g;
3091
3092    ## normalise body to UTF-8
3093    # get charset
3094    my $charset = _getCharset($entity);
3095    eval {
3096        $charset->encoder('utf8');
3097        $thispart = $charset->encode($thispart);
3098    };
3099    if ($EVAL_ERROR) {
3100        # mmm, what to do if it fails?
3101        $string .= $language->gettext_sprintf(
3102            "** Warning: A message part is using unrecognised character set %s\n    Some characters may be lost or incorrect **\n\n",
3103            $charset->as_string
3104        );
3105        $thispart =~ s/[^\x00-\x7F]/?/g;
3106    }
3107
3108    # deal with 30 hyphens (RFC 1153)
3109    $thispart =~ s/\n-{30}(\n|$)/\n -----------------------------\n/g;
3110    # leading and trailing lines (RFC 1153)
3111    $thispart =~ s/^\n*//;
3112    $thispart =~ s/\n+$/\n/;
3113
3114    $string .= $thispart;
3115    return $string;
3116}
3117
3118sub _do_other {
3119    # just add a note that attachment was stripped.
3120    my $entity = shift;
3121
3122    return $language->gettext_sprintf(
3123        "\n[An attachment of type %s was included here]\n",
3124        $entity->mime_type);
3125}
3126
3127sub _do_dsn {
3128    my $entity = shift;
3129
3130    my $string = '';
3131
3132    $string .= $language->gettext("\n-----Delivery Status Report-----\n");
3133    $string .= _do_text_plain($entity);
3134    $string .=
3135        $language->gettext("\n-----End of Delivery Status Report-----\n");
3136
3137    return $string;
3138}
3139
3140sub _do_text_html {
3141    # get a plain text representation of an HTML part
3142    my $entity = shift;
3143
3144    my $string = '';
3145    my $text;
3146
3147    unless (defined $entity->bodyhandle) {
3148        return $language->gettext(
3149            "\n[** Unable to process HTML message part **]\n");
3150    }
3151
3152    my $body = $entity->bodyhandle->as_string;
3153
3154    # deal with CR/LF left over - a problem from Outlook which
3155    # qp encodes them
3156    $body =~ s/\r\n/\n/g;
3157
3158    my $charset = _getCharset($entity);
3159
3160    eval {
3161        # normalise body to internal unicode
3162        if ($charset->decoder) {
3163            $body = $charset->decode($body);
3164        } else {
3165            # mmm, what to do if it fails?
3166            $string .= $language->gettext_sprintf(
3167                "** Warning: A message part is using unrecognised character set %s\n    Some characters may be lost or incorrect **\n\n",
3168                $charset->as_string
3169            );
3170            $body =~ s/[^\x00-\x7F]/?/g;
3171        }
3172        my $tree = HTML::TreeBuilder->new->parse($body);
3173        $tree->eof();
3174        my $formatter =
3175            Sympa::HTML::FormatText->new(leftmargin => 0, rightmargin => 72);
3176        $text = $formatter->format($tree);
3177        $tree->delete();
3178        $text = Encode::encode_utf8($text);
3179    };
3180    if ($EVAL_ERROR) {
3181        $string .= $language->gettext(
3182            "\n[** Unable to process HTML message part **]\n");
3183        return $string;
3184    }
3185
3186    $string .= $language->gettext("[ Text converted from HTML ]\n");
3187
3188    # deal with 30 hyphens (RFC 1153)
3189    $text =~ s/\n-{30}(\n|$)/\n -----------------------------\n/g;
3190    # leading and trailing lines (RFC 1153)
3191    $text =~ s/^\n*//;
3192    $text =~ s/\n+$/\n/;
3193
3194    $string .= $text;
3195
3196    return $string;
3197}
3198
3199sub _hasTextPlain {
3200    # tell if an entity has text/plain children
3201    my $topent  = shift;
3202    my @subents = $topent->parts;
3203    foreach my $subent (@subents) {
3204        if ($subent->effective_type =~ /^text\/plain$/i) {
3205            return 1;
3206        }
3207    }
3208    return undef;
3209}
3210
3211sub _getCharset {
3212    my $entity = shift;
3213
3214    my $charset =
3215          $entity->head->mime_attr('content-type.charset')
3216        ? $entity->head->mime_attr('content-type.charset')
3217        : 'us-ascii';
3218    # malformed mail with single quotes around charset?
3219    if ($charset =~ /'([^']*)'/i) { $charset = $1; }
3220
3221    # get charset object.
3222    return MIME::Charset->new($charset);
3223}
3224
3225sub dmarc_protect {
3226    my $self = shift;
3227
3228    my $list = $self->{context};
3229    return unless ref $list eq 'Sympa::List';
3230
3231    return unless $list->{'admin'}{'dmarc_protection'};
3232    my @modes = @{$list->{'admin'}{'dmarc_protection'}{'mode'} || []};
3233    return unless grep { $_ and $_ ne 'none' } @modes;
3234    $log->syslog('debug', 'DMARC protection on');
3235
3236    my $dkim_signature = $self->get_header('DKIM-Signature');
3237    my $domain_regex   = $list->{'admin'}{'dmarc_protection'}{'domain_regex'};
3238
3239    my $original_from = $self->get_header('From');
3240    my ($from)        = Mail::Address->parse($original_from);
3241    my $from_address  = $from->address if $from;
3242    $log->syslog('debug', 'From address: <%s>', $from_address);
3243
3244    # Will this message be processed?
3245    if (grep { $_ eq 'all' } @modes) {
3246        $log->syslog('debug', 'Munging From for ALL messages');
3247    } elsif (
3248        $dkim_signature and grep {
3249            $_ eq 'dkim_signature'
3250        } @modes
3251    ) {
3252        $log->syslog('debug', 'Munging From for DKIM-signed messages');
3253    } elsif (
3254        $from_address
3255        and $domain_regex
3256        and grep {
3257            $_ eq 'domain_regex'
3258        } @modes
3259        and eval {
3260            $from_address =~ /$domain_regex$/;
3261        }
3262    ) {
3263        $log->syslog('debug',
3264            'Munging From for messages based on domain regexp');
3265    } elsif ($from_address and $self->_check_dmarc_rr($from_address)) {
3266        $log->syslog('debug', 'Munging From for messages with strict policy');
3267    } else {
3268        return;
3269    }
3270
3271    my $listtype = $self->{listtype} || '';
3272
3273    # Remove any DKIM signatures we find
3274    if ($dkim_signature) {
3275        $self->add_header('X-Original-DKIM-Signature', $dkim_signature);
3276        $self->delete_header('DKIM-Signature');
3277        $self->delete_header('DomainKey-Signature');
3278        $log->syslog('debug',
3279            'Removing previous DKIM and DomainKey signatures');
3280    }
3281
3282    # Identify default new From address
3283    my $phraseMode = $list->{'admin'}{'dmarc_protection'}{'phrase'}
3284        || 'name_via_list';
3285    my $newName;
3286    my $newComment;
3287    my $anonaddr;
3288    my $anonphrase;
3289    if ($listtype eq 'owner' or $listtype eq 'editor') {
3290        # -request or -editor address
3291        $anonaddr = Sympa::get_address($list, $listtype);
3292    } else {
3293        $anonaddr = $list->{'admin'}{'dmarc_protection'}{'other_email'};
3294        $anonaddr = Sympa::get_address($list)
3295            unless $anonaddr and $anonaddr =~ /\@/;
3296        my @anonFrom = Mail::Address->parse($anonaddr);
3297        if (@anonFrom) {
3298            $anonaddr   = $anonFrom[0]->address;
3299            $anonphrase = $anonFrom[0]->phrase;
3300        }
3301    }
3302    $log->syslog('debug', 'Anonymous From: %s', $anonaddr);
3303
3304    if ($from) {
3305        # We should always have a From address in reality, unless the
3306        # message is from a badly-behaved automate.
3307        my $origName =
3308            MIME::EncWords::decode_mimewords($from->phrase,
3309            Charset => 'UTF-8')
3310            if defined $from->phrase;
3311        unless (defined $origName and $origName =~ /\S/) {
3312            # If we dont have a Phrase, should we search the Sympa
3313            # database for the sender to obtain their name that way?
3314            # Might be difficult.
3315            ($origName) = split /\@/, $from_address;
3316        }
3317
3318        if ($phraseMode eq 'name_and_email') {
3319            $newName    = $origName;
3320            $newComment = $from_address;
3321        } elsif ($phraseMode eq 'name_email_via_list') {
3322            $newName = $origName;
3323
3324            if ($listtype eq 'owner') {
3325                $newComment = $language->gettext_sprintf(
3326                    '%s via Owner Address of %s Mailing List',
3327                    $from_address, $list->{'name'});
3328            } elsif ($listtype eq 'editor') {
3329                $newComment = $language->gettext_sprintf(
3330                    '%s via Moderator Address of %s Mailing List',
3331                    $from_address, $list->{'name'});
3332            } else {
3333                $newComment =
3334                    $language->gettext_sprintf('%s via %s Mailing List',
3335                    $from_address, $list->{'name'});
3336            }
3337        } elsif ($phraseMode eq 'name_via_list') {
3338            $newName = $origName;
3339
3340            if ($listtype eq 'owner') {
3341                $newComment = $language->gettext_sprintf(
3342                    'via Owner Address of %s Mailing List',
3343                    $list->{'name'});
3344            } elsif ($listtype eq 'editor') {
3345                $newComment = $language->gettext_sprintf(
3346                    'via Moderator Address of %s Mailing List',
3347                    $list->{'name'});
3348            } else {
3349                $newComment =
3350                    $language->gettext_sprintf('via %s Mailing List',
3351                    $list->{'name'});
3352            }
3353        } elsif ($phraseMode eq 'list_for_email') {
3354            if ($listtype eq 'owner') {
3355                $newName = $language->gettext_sprintf(
3356                    'Owner Address of %s Mailing List',
3357                    $list->{'name'});
3358            } elsif ($listtype eq 'editor') {
3359                $newName = $language->gettext_sprintf(
3360                    'Moderator Address of %s Mailing List',
3361                    $list->{'name'});
3362            } else {
3363                $newName = $language->gettext_sprintf('%s Mailing List',
3364                    $list->{'name'});
3365            }
3366
3367            $newComment =
3368                $language->gettext_sprintf('on behalf of %s', $origName);
3369        } elsif ($phraseMode eq 'list_for_name') {
3370            if ($listtype eq 'owner') {
3371                $newName = $language->gettext_sprintf(
3372                    'Owner Address of %s Mailing List',
3373                    $list->{'name'});
3374            } elsif ($listtype eq 'editor') {
3375                $newName = $language->gettext_sprintf(
3376                    'Moderator Address of %s Mailing List',
3377                    $list->{'name'});
3378            } else {
3379                $newName = $language->gettext_sprintf('%s Mailing List',
3380                    $list->{'name'});
3381            }
3382
3383            $newComment =
3384                $language->gettext_sprintf('on behalf of %s', $from_address);
3385        } else {
3386            $newName = $origName;
3387        }
3388
3389        $self->add_header('Reply-To', $from_address)
3390            unless $self->get_header('Reply-To');
3391    }
3392    # If the new From email address has a Phrase component, then
3393    # append it
3394    if (defined $anonphrase and length $anonphrase) {
3395        if (defined $newName and $newName =~ /\S/) {
3396            $newName .= ' ' . $anonphrase;
3397        } else {
3398            $newName = $anonphrase;
3399        }
3400    }
3401    $newName = $language->gettext('Anonymous')
3402        unless defined $newName and $newName =~ /\S/;
3403
3404    $self->add_header('X-Original-From', $original_from);
3405    $self->replace_header(
3406        'From',
3407        Sympa::Tools::Text::addrencode(
3408            $anonaddr,                               $newName,
3409            Conf::lang2charset($language->get_lang), $newComment
3410        )
3411    );
3412}
3413
3414# Strict auto policy - is the sender domain policy to reject
3415sub _check_dmarc_rr {
3416    my $self  = shift;
3417    my $email = shift;
3418
3419    # Net::DNS is optional.
3420    unless ($Net::DNS::VERSION) {
3421        $log->syslog('err',
3422            'Unable to get DNS RR. Net::DNS required. Install it first');
3423        return 0;
3424    }
3425
3426    my $domain = $email;
3427    $domain =~ s/\A.*\@//;    # strip local part.
3428
3429    my $list = $self->{context};
3430    my $dns  = Net::DNS::Resolver->new;
3431
3432    my $rrstr;
3433    my $sp = 0;
3434    while (0 <= index $domain, '.') {
3435        my $packet = $dns->query("_dmarc.$domain", 'TXT');
3436        next unless $packet;
3437
3438        ($rrstr) = grep { $_ and $_ =~ /\Av=DMARC/i } map {
3439            # Note: txtdata() of Net::DNS::RR::TXT >=0.69 returns array of
3440            # text fragments in array context. Take care to get values in
3441            # scalar context.
3442            # Additionally, it returns Unicode value ("utf8 flag" on).
3443            my $rrstr;
3444            if ($_->type eq 'TXT') {
3445                $rrstr = $_->txtdata;
3446                $rrstr = Encode::encode_utf8($rrstr)
3447                    if Encode::is_utf8($rrstr);
3448            }
3449            $rrstr;
3450        } $packet->answer;
3451        last if $rrstr;
3452    } continue {
3453        $domain =~ s/\A[^.]*[.]//;
3454        $sp = 1;
3455    }
3456    return 0 unless $rrstr;    # no valid record found.
3457
3458    my %rr = _parse_dmarc_rr($rrstr);
3459    my $policy = ($sp and $rr{sp}) || $rr{p};
3460    return 0 unless $policy;    # no policy found.
3461
3462    $log->syslog('debug', 'DMARC DNS record found: %s', $rrstr);
3463    $self->add_header('X-Original-DMARC-Record', sprintf 'domain=%s; %s',
3464        $domain, $rrstr);
3465
3466    my @modes = @{$list->{'admin'}{'dmarc_protection'}{'mode'} || []};
3467    unless (
3468        (lc $policy eq 'reject' and grep { $_ eq 'dmarc_reject' } @modes)
3469        or (lc $policy eq 'quarantine'
3470            and grep { $_ eq 'dmarc_quarantine' } @modes)
3471        or grep { $_ eq 'dmarc_any' } @modes
3472    ) {
3473        $log->syslog('debug', 'No DMARC policy matched');
3474        return 0;
3475    } else {
3476        $log->syslog('debug', 'DMARC policy "%s" matched', $policy);
3477        return 1;
3478    }
3479}
3480
3481# Parse DMARC TXT RR.
3482# Partially borrowed from parse() in Mail::DMARC::Policy by MBRADSHAW@cpan.
3483sub _parse_dmarc_rr {
3484    my $str = shift;
3485
3486    my $cleaned = $str;
3487    $cleaned =~ s/\s//g;      # remove whitespace
3488    $cleaned =~ s/\\;/;/g;    # replace \;  with ;
3489    $cleaned =~ s/;;/;/g;     # replace ;;  with ;
3490    $cleaned =~ s/;0;/;/g;    # replace ;0; with ;
3491    chop $cleaned if ';' eq substr $cleaned, -1, 1;    # remove a trailing ;
3492    my @tag_vals = split /;/, $cleaned;
3493
3494    my %rr;
3495    foreach my $tv (@tag_vals) {
3496        my ($tag, $value) = split /=|:|-/, $tv, 2;
3497        next unless defined $tag and defined $value and length $value;
3498        $rr{lc $tag} = $value;
3499    }
3500    return %rr;
3501}
3502
3503# Old name: Sympa::List::compute_topic()
3504sub compute_topic {
3505    $log->syslog('debug2', '(%s)', @_);
3506    my $self = shift;
3507
3508    my $list = $self->{context};
3509    return undef unless ref $list eq 'Sympa::List';
3510
3511    my @topic_array;
3512    my %topic_hash;
3513    my %keywords;
3514
3515    # Getting keywords.
3516    foreach my $topic (@{$list->{'admin'}{'msg_topic'} || []}) {
3517        my $list_keyw = Sympa::Tools::Data::get_array_from_splitted_string(
3518            $topic->{'keywords'});
3519
3520        foreach my $keyw (@{$list_keyw}) {
3521            $keywords{$keyw} = $topic->{'name'};
3522        }
3523    }
3524
3525    # getting string to parse
3526    # We convert it to UTF-8 for case-ignore match with non-ASCII keywords.
3527    my $mail_string = '';
3528    if (index($list->{'admin'}{'msg_topic_keywords_apply_on'}, 'subject') >=
3529        0) {
3530        $mail_string = $self->{'decoded_subject'} . "\n";
3531    }
3532    unless ($list->{'admin'}{'msg_topic_keywords_apply_on'} eq 'subject') {
3533        my $entity = $self->as_entity;
3534        my $eff_type = $entity->effective_type || '';
3535        if ($eff_type eq 'multipart/signed' and $entity->parts) {
3536            $entity = $entity->parts(0);
3537        }
3538        #FIXME: Should also handle application/pkcs7-mime format.
3539
3540        # get bodies of any text/* parts, not digging nested subparts.
3541        my @parts;
3542        if ($entity->parts) {
3543            @parts = $entity->parts;
3544        } else {
3545            @parts = ($entity);
3546        }
3547        foreach my $part (@parts) {
3548            next unless $part->effective_type =~ /^text\//i;
3549            my $charset = $part->head->mime_attr("Content-Type.Charset");
3550            $charset = MIME::Charset->new($charset);
3551            $charset->encoder('UTF-8');
3552
3553            if (defined $part->bodyhandle) {
3554                my $body = $part->bodyhandle->as_string();
3555                my $converted;
3556                eval { $converted = $charset->encode($body); };
3557                if ($EVAL_ERROR) {
3558                    $converted = $body;
3559                    $converted =~ s/[^\x01-\x7F]/?/g;
3560                }
3561                $mail_string .= $converted . "\n";
3562            }
3563        }
3564    }
3565    # foldcase string
3566    $mail_string = Sympa::Tools::Text::foldcase($mail_string);
3567
3568    # parsing
3569    foreach my $keyw (keys %keywords) {
3570        if (index($mail_string, Sympa::Tools::Text::foldcase($keyw)) >= 0) {
3571            $topic_hash{$keywords{$keyw}} = 1;
3572        }
3573    }
3574
3575    # for no double
3576    foreach my $k (sort keys %topic_hash) {
3577        push @topic_array, $k if $topic_hash{$k};
3578    }
3579
3580    unless (@topic_array) {
3581        return '';
3582    } else {
3583        return join(',', @topic_array);
3584    }
3585}
3586
3587sub get_id {
3588    my $self = shift;
3589
3590    my $id;
3591    # Tentative.  Alternatives for more general ID in the future.
3592    if ($self->{'messagekey'}) {
3593        $id = $self->{'messagekey'};
3594    } elsif ($self->{'filename'}) {
3595        my @parts = split /\//, $self->{'filename'};
3596        $id = pop @parts;
3597    } elsif (exists $self->{'message_id'}) {
3598        $id = $self->{'message_id'};
3599    }
3600
3601    my $shelved;
3602    if (%{$self->{shelved} || {}}) {
3603        $shelved = sprintf 'shelved:%s', join(
3604            ';',
3605            map {
3606                my $v = $self->{shelved}{$_};
3607                ("$v" eq '1') ? $_ : sprintf('%s=%s', $_, $v);
3608                }
3609                grep {
3610                $self->{shelved}{$_}
3611                } sort keys %{$self->{shelved}}
3612        );
3613    }
3614
3615    return join '/', grep {$_} ($id, $shelved);
3616}
3617
36181;
3619__END__
3620
3621=encoding utf-8
3622
3623=head1 NAME
3624
3625Sympa::Message - Mail message embedding for internal use in Sympa
3626
3627=head1 SYNOPSIS
3628
3629  use Sympa::Message;
3630  my $message = Sympa::Message->new($serialized, context => $list);
3631
3632=head1 DESCRIPTION
3633
3634While processing a message in Sympa, we need to link information to the
3635message, modify headers and such.  This was quite a problem when a message was
3636signed, as modifying anything in the message body would alter its MD5
3637footprint. And probably make the message to be rejected by clients verifying
3638its identity (which is somehow a good thing as it is the reason why people use
3639MD5 after all). With such messages, the process was complex. We then decided
3640to embed any message treated in a "Message" object, thus making the process
3641easier.
3642
3643=head2 Methods and functions
3644
3645=over
3646
3647=item new ( $serialized, context =E<gt> $that, KEY =E<gt> value, ... )
3648
3649I<Constructor>.
3650Creates a new L<Sympa::Message> object.
3651
3652Parameters:
3653
3654=over
3655
3656=item $serialized
3657
3658Serialized message.
3659
3660=item context =E<gt> object
3661
3662Context.  L<Sympa::List> object, Robot or C<'*'>.
3663
3664=item key =E<gt> value, ...
3665
3666Metadata.
3667
3668=back
3669
3670Returns:
3671
3672A new L<Sympa::Message> object, or I<undef>, if something went wrong.
3673
3674=item dup ( )
3675
3676I<Copy constructor>.
3677Gets deep copy of instance.
3678
3679=item to_string ( [ original =E<gt> 0|1 ] )
3680
3681I<Serializer>.
3682Returns serialized data of Message object.
3683
3684Parameter:
3685
3686=over
3687
3688=item original =E<gt> 0|1
3689
3690If set to 1 and content has been decrypted, returns original content.
3691Default is 0.
3692
3693=back
3694
3695Returns:
3696
3697Serialized representation of Message object.
3698
3699=item add_header ( $field, $value, [ $index ] )
3700
3701I<Instance method>.
3702Adds a header field named $field with body $value.
3703If $index is given, the field will be inserted at the place it indicates:
3704If it is C<0>, the field will be prepended.
3705
3706=item delete_header ( $field, [ $index ] )
3707
3708I<Instance method>.
3709Deletes all occurrences of the header field named $field.
3710
3711=item replace_header ( $field, $value, [ $index ] )
3712
3713I<Instance method>.
3714Replaces header fields named $field with $value.
3715
3716=item head
3717
3718I<Instance method>.
3719Gets header of the message as L<MIME::Head> instance.
3720
3721Note that returned value is real reference to internal data structure.
3722Even if it was changed, string representation of message may not be updated.
3723Alternatively, use L</add_header>(), L</delete_header>() or
3724L</replace_header>() to modify header.
3725
3726=item check_spam_status ( )
3727
3728I<Instance method>.
3729Gets spam status according to spam_status scenario
3730and sets it as {spam_status} attribute.
3731
3732=item dkim_sign ( dkim_d =E<gt> $d, [ dkim_i =E<gt> $i ],
3733dkim_selector =E<gt> $selector, dkim_privatekey =E<gt> $privatekey )
3734
3735I<Instance method>.
3736Adds DKIM signature to the message.
3737
3738=item check_dkim_signature ( )
3739
3740I<Instance method>.
3741Checks DKIM signature of the message
3742and sets or clears {dkim_pass} item of the message object.
3743
3744=item remove_invalid_dkim_signature ( )
3745
3746I<Instance method>.
3747Verifies DKIM signatures included in the message,
3748and if any of them are invalid, removes them.
3749
3750=item check_arc_chain ( )
3751
3752I<Instance method>.
3753Checks ARC chain of the message
3754and sets {shelved}{arc_cv} item of the message object.
3755
3756=item arc_seal ( )
3757
3758I<Instance method>.
3759Adds a new ARC seal if there's an arc_cv from check_arc_chain and
3760the cv is none or valid.
3761
3762=item as_entity ( )
3763
3764I<Instance method>.
3765Gets message content as MIME entity (L<MIME::Entity> instance).
3766
3767Note that returned value is real reference to internal data structure.
3768Even if it was changed, string representation of message may not be updated.
3769Below is better way to modify message.
3770
3771    my $entity = $message->as_entity->dup;
3772    # ... Modify $entity...
3773    $message->set_entity($entity);
3774
3775=item set_entity ( $entity )
3776
3777I<Instance method>.
3778Updates message with MIME entity (L<MIME::Entity> instance).
3779String representation will be automatically updated.
3780
3781=item as_string ( )
3782
3783I<Instance method>.
3784Gets a string representation of message.
3785
3786Parameter:
3787
3788=over
3789
3790=item original =E<gt> 0|1
3791
3792If set to 1 and content has been decrypted, returns original content.
3793Default is 0.
3794
3795=back
3796
3797Note that method like "set_string()" does not exist:
3798You would be better to create new instance rather than replacing entire
3799content.
3800
3801=item body_as_string ( )
3802
3803I<Instance method>.
3804Gets body of the message as string.
3805
3806Note that the result won't be decoded.
3807
3808=item header_as_string ( )
3809
3810I<Instance method>.
3811Gets header part of the message as string.
3812
3813Note that the result won't be decoded nor unfolded.
3814
3815=item get_header ( $field, [ $sep ] )
3816
3817I<Instance method>.
3818Gets value(s) of header field $field, stripping trailing newline.
3819
3820B<In scalar context> without $sep, returns first occurrence or C<undef>.
3821If $sep is defined, returns all occurrences joined by it, or C<undef>.
3822Otherwise B<in array context>, returns an array of all occurrences or C<()>.
3823
3824Note:
3825Folding newlines will not be removed.
3826
3827=item get_decoded_header ( $tag, [ $sep ] )
3828
3829I<Instance method>.
3830Returns header value decoded to UTF-8 or undef.
3831Trailing newline will be removed.
3832If $sep is given, returns all occurrences joined by it.
3833
3834=item dump ( $output )
3835
3836I<Instance method>.
3837Dumps a Message object to a stream.
3838
3839Parameters:
3840
3841=over
3842
3843=item $output
3844
3845the stream to which dump the object
3846
3847=back
3848
3849Returns:
3850
3851=over
3852
3853=item 1
3854
3855if everything's alright
3856
3857=back
3858
3859=item add_topic ( $output )
3860
3861Note:
3862No longer used.
3863
3864I<Instance method>.
3865Adds topic and puts header X-Sympa-Topic.
3866
3867Parameters:
3868
3869=over
3870
3871=item $output
3872
3873the string containing the topic to add
3874
3875=back
3876
3877Returns:
3878
3879=over
3880
3881=item 1
3882
3883if everything's alright
3884
3885=back
3886
3887=item get_topic ( )
3888
3889Note:
3890No longer used.
3891
3892I<Instance method>.
3893Gets topic of message.
3894
3895Parameters:
3896
3897None.
3898
3899Returns:
3900
3901=over
3902
3903=item the topic
3904
3905if it exists
3906
3907=item empty string
3908
3909otherwise
3910
3911=back
3912
3913=item clean_html ( )
3914
3915I<Instance method>.
3916Encodes HTML parts of the message by UTF-8 and strips scripts included in
3917them.
3918
3919=item smime_decrypt ( )
3920
3921I<Instance method>.
3922Decrypts message using private key of user.
3923
3924Note that this method modifies Message object.
3925
3926Parameters:
3927
3928None.
3929
3930Returns:
3931
3932True value if message was decrypted.  Otherwise false value.
3933
3934If decrypting succeeded, {smime_crypted} item is set.
3935
3936=item smime_encrypt ( $email )
3937
3938I<Instance method>.
3939Encrypts message using certificate of user.
3940
3941Note that this method modifies Message object.
3942
3943Parameters:
3944
3945=over
3946
3947=item $email
3948
3949E-mail address of user.
3950
3951=back
3952
3953Returns:
3954
3955True value if encryption succeeded, or C<undef>.
3956
3957=item smime_sign ( )
3958
3959I<Instance method>.
3960Adds S/MIME signature to the message.
3961
3962Signing key is taken from what stored in list directory.
3963
3964Parameters:
3965
3966None.
3967
3968Returns:
3969
3970True value if message was successfully signed.
3971Otherwise false value.
3972
3973=item check_smime_signature ( )
3974
3975I<Instance method>.
3976Verifies S/MIME signature of the message,
3977and if verification succeeded, sets {smime_signed} item true.
3978
3979Parameters:
3980
3981None
3982
3983Returns:
3984
39851 if signature is successfully verified.
39860 otherwise.
3987C<undef> if something went wrong.
3988
3989=item is_signed ( )
3990
3991I<Instance method>.
3992Checks if the message is signed.
3993
3994B<Note>:
3995This checks if the message has appropriate content type and
3996header parameters.  Use check_smime_signature() to check if the message has
3997properly signed content.
3998
3999Currently, S/MIME-signed messages with content type
4000"multipart/signed" or "application/pkcs7-mime" (with smime-type="signed-data"
4001parameter) are recognized.
4002Enveloped-only messages are not supported.
4003The other signature mechanisms such as PGP/MIME have not been supported yet.
4004
4005Parameters:
4006
4007None.
4008
4009Returns:
4010
4011C<1> if the message is considered signed.
4012C<0> otherwise.
4013
4014=item personalize ( $list, [ $rcpt ] )
4015
4016I<Instance method>.
4017Personalizes a message with custom attributes of a user.
4018
4019Parameters:
4020
4021=over
4022
4023=item $list
4024
4025L<List> object.
4026
4027=item $rcpt
4028
4029Recipient.
4030
4031=item $data
4032
4033Hashref.  Additional data to be interpolated into personalized message.
4034
4035=back
4036
4037Returns:
4038
4039Modified message itself, or C<undef> if error occurred.
4040
4041=item test_personalize ( $list )
4042
4043DEPRECATED by Sympa 6.2.13.
4044No longer available.
4045
4046I<Instance method>.
4047Tests if personalization can be performed successfully over all subscribers
4048of list.
4049
4050Parameters:
4051
4052Returns:
4053
4054C<1> if succeed, or C<undef>.
4055
4056=item personalize_text ( $body, $list, [ $rcpt ], [ $data ] )
4057
4058I<Function>.
4059Retrieves the customized data of the
4060users then parses the text. It returns the
4061personalized text.
4062
4063Parameters:
4064
4065=over
4066
4067=item $body
4068
4069Message body with the TT2.
4070
4071=item $list
4072
4073L<List> object.
4074
4075=item $rcpt
4076
4077The recipient email.
4078
4079=item $data
4080
4081Hashref.  Additional data to be interpolated into personalized message.
4082
4083=back
4084
4085Returns:
4086
4087Customized text, or C<undef> if error occurred.
4088
4089=item prepare_message_according_to_mode ( $mode, $list )
4090
4091I<Instance method>.
4092Transforms the message according to reception mode:
4093C<'mail'>, C<'notice'> or C<'txt'>.
4094Note: 'html' mode was deprecated as of 6.2.23b.2.
4095
4096By C<'nomail'>, C<'digest'>, C<'digestplain'> or C<'summary'> mode,
4097the message is not modified.
4098
4099Returns modified message object itself, or C<undef> if transformation failed.
4100
4101=item decorate ($list, [ mode =E<gt> I<personalization mode> ] )
4102
4103I<Instance method>.
4104Adds footer/header to a message.
4105
4106=item reformat_utf8_message ( )
4107
4108I<Instance method>.
4109Reformats bodies of text parts contained in the message using
4110recommended encoding schema and/or charsets defined by MIME::Charset.
4111
4112MIME-compliant headers are appended / modified.  And custom X-Mailer:
4113header is appended :).
4114
4115Parameters:
4116
4117=over
4118
4119=item $attachments
4120
4121ref(ARRAY) - messages to be attached as subparts.
4122
4123=back
4124
4125Returns:
4126
4127string
4128
4129=item shelve_personalization ( type =E<gt> $type )
4130
4131I<Instance method>.
4132Shelve personalization ("merge feature") if necessary.
4133$type is either C<'web'> or C<'mail'>.
4134
4135Dies if the context of the message was not List.
4136
4137=item get_plain_body ( )
4138
4139I<Instance method>.
4140Gets decoded content of text/plain part.
4141
4142The text will be converted to UTF-8.
4143Flowed text (see RFC 3676) will be conjuncted.
4144
4145=item check_virus_infection ( [ debug =E<gt> 1 ] )
4146
4147I<Instance method>.
4148Checks the message using anti-virus plugin, if configuration requests it.
4149
4150Parameter:
4151
4152TBD.
4153
4154Returns:
4155
4156The name of malware the message contains, if any;
4157C<"unknown"> for unidentified malware;
4158C<undef> if checking failed;
4159otherwise C<0>.
4160
4161=item get_plaindigest_body ( )
4162
4163I<Instance method>.
4164Returns a plain text version of message, suitable for use in plain text
4165digests.
4166
4167=over
4168
4169=item *
4170
4171Most attachments are stripped out and replaced with a
4172note that they've been stripped. text/plain parts are
4173retained.
4174
4175=item *
4176
4177An attempt to convert text/html parts to plain text is made
4178if there is no text/plain alternative.
4179
4180=item *
4181
4182All messages are converted from their original character
4183set to UTF-8.
4184
4185=item *
4186
4187Parts of type message/rfc822 are recursed
4188through in the same way, with brief headers included.
4189
4190=item *
4191
4192Any line consisting only of 30 hyphens has the first
4193character changed to space (see RFC 1153). Lines are
4194wrapped at 76 columns.
4195
4196=back
4197
4198Parameters:
4199
4200None.
4201
4202Returns:
4203
4204String.
4205
4206=item dmarc_protect ( )
4207
4208I<Instance method>.
4209Munges the C<From:> header field if we are using DMARC Protection mode.
4210
4211Parameters:
4212
4213None.
4214
4215Returns:
4216
4217None.
4218C<From:> field of the message may be modified.
4219
4220=item compute_topic ( )
4221
4222I<Instance method>.
4223Compute the topic of the message. The topic is got
4224from keywords defined in list parameter
4225msg_topic.keywords. The keyword is applied on the
4226subject and/or the body of the message according
4227to list parameter msg_topic_keywords_apply_on
4228
4229Parameters:
4230
4231None.
4232
4233Returns:
4234
4235String of tag(s), can be separated by ',', can be empty.
4236
4237=item get_id ( )
4238
4239I<Instance method>.
4240Gets unique identifier of instance.
4241
4242=back
4243
4244=head2 Context and Metadata
4245
4246Context and metadata given to constructor are accessible as hash elements of
4247object.  These are typically used.
4248
4249=over
4250
4251=item {context}
4252
4253Context of the message, L<Sympa::List> object, robot or C<'*'>.
4254
4255=item {date}
4256
4257The UNIX time messages was initially accepted, or the time message should be
4258delivered.
4259
4260=item {domainpart}
4261
4262=item {listname}
4263
4264=item {listtype}
4265
4266=item {localpart}
4267
4268Domain, name, type and local part of context.
4269
4270=item {priority}
4271
4272Priority of the message.
4273
4274=item {tag}
4275
4276Tag of packet used by bulk spool to control logging.
4277C<'0'> is the first message of multiple packet.
4278C<'z'> is the last.
4279C<'s'> is the single message with single packet.
4280
4281=item {time}
4282
4283The Unix time in floating point number when the message was stored into the
4284spool.  This is used by bulk spool.
4285
4286=back
4287
4288=head2 Attributes
4289
4290These are accessible as hash elements of objects.
4291
4292=over
4293
4294=item {checksum}
4295
4296No longer used.  It is kept for compatibility with Sympa 6.1.x or earlier.
4297See also upgrade_send_spool(1).
4298
4299=item {envelope_sender}
4300
4301Envelope sender, a.k.a. "Unix From".
4302This is not always same as {sender} attribute
4303nor the content of C<From:> field.
4304
4305C<'E<lt>E<gt>'> will be used for "null envelope sender".
4306
4307=item {family}
4308
4309Name of family (see L<Sympa::Family>) the message corresponds to.
4310This is given by familyqueue(8) program.
4311
4312=item {gecos}
4313
4314Display name of actual sender (see {sender} below), if any.
4315
4316=item {md5_check}
4317
4318True value indicates that the message has been authenticated by C<md5> level
4319(password authentication).
4320This is set by web mailer of WWSympa and used by incoming spool.
4321
4322=item {message_id}
4323
4324Original message ID of the message.
4325
4326=item {rcpt}
4327
4328Recipients for delivery.
4329This is kept for compatibility with earlier releases.
4330
4331=item {sender}
4332
4333Actual sender of the message.
4334This is determined according to C<sender_headers> configuration parameter.
4335See also {envelope_sender} above.
4336
4337=item {shelved}
4338
4339Shelved processing.
4340Hashref with multiple items.
4341Currently these items are available:
4342
4343=over
4344
4345=item decorate =E<gt> 1
4346
4347Adding footer/header if any.
4348
4349This item was added on Sympa 6.2.59b.2 to avoid processing decoration twice
4350with the messages stored into outgoing spool by earlier version of Sympa.
4351
4352=item dkim_sign =E<gt> 1
4353
4354Adding DKIM signature.
4355
4356=item dmarc_protect =E<gt> 1
4357
4358DMARC protection.  See also L</dmarc_protect>().
4359
4360=item merge =E<gt> C<footer>|C<all>
4361
4362Personalizing.
4363
4364On Sympa 6.2.58 or earlier, there was no distiction between C<footer> and C<all>.
4365The C<merge> item in the messages stored into outgoing spool by earlier version
4366of Sympa will be treated as C<all>.
4367
4368=item smime_encrypt =E<gt> 1
4369
4370Adding S/MIME encryption.
4371
4372=item smime_sign =E<gt> 1
4373
4374Adding S/MIME signature.
4375
4376=item tracking =E<gt> C<dsn>|C<mdn>|C<r>|C<w>|C<verp>
4377
4378Requesting tracking feature including VERP.
4379
4380=back
4381
4382This is used by bulk spool.
4383
4384=item {spam_status}
4385
4386Result of spam check.
4387This is set by L</check_spam_status>() method.
4388
4389=back
4390
4391=head2 Serialization
4392
4393L<Sympa::Message> object includes number of slots as hash items:
4394B<metadata>, B<context>, B<attributes> and B<message content>.
4395Metadata including context are given by spool:
4396See L<Sympa::Spool/"Marshaling and unmarshaling metadata">.
4397
4398Logically, objects are stored into physical spool as B<serialized form>
4399and deserialized when they are fetched from spool.
4400B<Attributes> will be serialized and deserialized along with raw message
4401content.
4402Attributes are encoded in C<X-Sympa-*:> pseudo-header fields and
4403C<Return-Path:> header field.
4404Below is an example of serialized form.
4405
4406  X-Sympa-Message-ID: 123456789.12345@domain.name : {message_id} attribute
4407  X-Sympa-Sender: user01@user.sympa.test          : {sender} attribute
4408  X-Sympa-Display-Name: Infant                    : {gecos} attribute
4409  X-Sympa-Shelved: dkim_sign; tracking=mdn        : {shelved} attribute
4410  X-Sympa-Spam-Status: ham                        : {spam_status} attribute
4411  Return-Path: sympa-request@domain.name          : {envelope_sender} attribute
4412  Message-Id: <123456789.12345@domain.name>       :   ---
4413  From: Infant <user@other.host.dom>              :    |
4414  To: User <user@some.host.name>                  :    |
4415  Subject: Howdy world                            :    | Raw message content
4416  X-Sympa-Topic: sometopic                        :    |
4417                                                  :    |
4418  Bonjour, le monde.                              :    |
4419                                                  :   ---
4420
4421On msg, automatic and bounce spools,
4422C<Return-Path:> header fields are given by MDA
4423and C<X-Sympa-*:> header fields are given by queue programs.
4424On other spools, they are given by components of Sympa.
4425
4426Pseudo-header fields I<should> appear at beginning of serialized content.
4427Fields appear at other places (e.g. C<X-Sympa-Topic:> field above) are not
4428attributes but are the part of raw message content.
4429
4430Pseudo-header fields I<should not> be included in actually sent messages.
4431
4432=head1 CAVEAT
4433
4434=head2 Adding C<Return-Path:> field
4435
4436We trust in C<Return-Path:> header field only at the top of message
4437to prevent forgery.  To ensure it will be added to messages by MDA,
4438
4439=over
4440
4441=item Sendmail
4442
4443Add C<P> in the C<F=> flags of local mailer line (such as C<Mlocal>).
4444
4445=item Postfix
4446
4447=over
4448
4449=item local(8)
4450
4451Prepending C<Return-Path:> is available by default.
4452
4453=item pipe(8)
4454
4455Add C<R> to the C<flags=> attributes in master.cf.
4456
4457Additionally with Postfix 2.3 or later, add an empty C<null_sender=>
4458attribute.
4459Or "null envelope sender" would be replaced with C<E<lt>MAILER-DAEMONE<gt>>.
4460
4461=back
4462
4463=item Exim
4464
4465Set C<return_path_add> to be true with pipe_transport.
4466
4467=item qmail
4468
4469Use preline(1).
4470
4471=item sympa-milter
4472
4473As of version 0.7, prepending C<Return-Path:> is available.
4474
4475=back
4476
4477=head1 BUGS
4478
4479L<get_plaindigest_body>()
4480seems to ignore any text after a UUencoded attachment.
4481
4482=head1 HISTORY
4483
4484L<Message> module appeared on Sympa 3.3.6.
4485It was initially written by:
4486
4487=over
4488
4489=item * Serge Aumont <sa AT cru.fr>
4490
4491=item * Olivier SalaE<252>n <os AT cru.fr>
4492
4493=back
4494
4495L<get_plaindigest_body>, ex. L<PlainDigest/plain_body_as_string>,
4496was initially written by Chris Hastie.  It appeared on Sympa 4.2b.1.
4497
4498  (c) Chris Hastie 2004 - 2008.
4499
4500Renamed and merged L<Sympa::Message> appeared on Sympa 6.2.
4501
4502=cut
4503