Message.pm

# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$

# Sympa - SYsteme de Multi-Postage Automatique
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
# Copyright 2017, 2018 The Sympa Community. See the AUTHORS.md file at the
# top-level directory of this distribution and at
# <https://github.com/sympa-community/sympa.git>.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package Sympa::Message;

use strict;
use warnings;
use DateTime;
use Encode qw();
use English;    # FIXME: drop $PREMATCH usage
use HTML::TreeBuilder;
use Mail::Address;
use MIME::Charset;
use MIME::EncWords;
use MIME::Entity;
use MIME::Parser;
use MIME::Tools;
use Scalar::Util qw();
use Text::LineFold;
use URI::Escape qw();

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

use Sympa;
use Conf;
use Sympa::Constants;
use Sympa::HTML::FormatText;
use Sympa::HTMLSanitizer;
use Sympa::Language;
use Sympa::Log;
use Sympa::Scenario;
use Sympa::Spool;
use Sympa::Template;
use Sympa::Tools::Data;
use Sympa::Tools::File;
use Sympa::Tools::Password;
use Sympa::Tools::SMIME;
use Sympa::Tools::Text;
use Sympa::User;

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

sub new {
    $log->syslog('debug2', '(%s, ...)', @_);
    my $class      = shift;
    my $serialized = shift;

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

    unless (defined $serialized and length $serialized) {
        $log->syslog('err', 'Empty message');
        return undef;
    }

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

    pos($serialized) = 0;
    while ($serialized =~ /\G(X-Sympa-[-\w]+): (.*?)\n(?![ \t])/cgs) {
        my ($k, $v) = ($1, $2);
        next unless length $v;

        if ($k eq 'X-Sympa-To') {
            $self->{'rcpt'} = join ',', split(/\s*,\s*/, $v);
        } elsif ($k eq 'X-Sympa-Checksum') {    # To migrate format <= 6.2a.40
            $self->{'checksum'} = $v;
        } elsif ($k eq 'X-Sympa-Family') {
            $self->{'family'} = $v;
        } elsif ($k eq 'X-Sympa-From') {    # Compatibility. Use Return-Path:
            $self->{'envelope_sender'} = $v;
        } elsif ($k eq 'X-Sympa-Auth-Level') {    # New in 6.2a.41
            if ($v eq 'md5') {
                $self->{'md5_check'} = 1;
            } else {
                $log->syslog('err',
                    'Unknown authentication level "%s", ignored', $v);
            }
        } elsif ($k eq 'X-Sympa-Message-ID') {    # New in 6.2a.41
            $self->{'message_id'} = $v;
        } elsif ($k eq 'X-Sympa-Sender') {        # New in 6.2a.41
            $self->{'sender'} = $v;
        } elsif ($k eq 'X-Sympa-Display-Name') {    # New in 6.2a.41
            $self->{'gecos'} = $v;
        } elsif ($k eq 'X-Sympa-Shelved') {         # New in 6.2a.41
            $self->{'shelved'} = {
                map {
                    my ($ak, $av) = split /=/, $_, 2;
                    ($ak => ($av || 1))
                } split(/\s*;\s*/, $v)
            };
        } elsif ($k eq 'X-Sympa-Spam-Status') {     # New in 6.2a.41
            $self->{'spam_status'} = $v;
        } else {
            $log->syslog('err', 'Unknown attribute information: "%s: %s"',
                $k, $v);
        }
    }
    # Ignore Unix From_
    $serialized =~ /\GFrom (.*?)\n(?![ \t])/cgs;
    # Get envelope sender from Return-Path:.
    # If old style X-Sympa-From: has been found, omit Return-Path:.
    #
    # We trust in "Return-Path:" header field only at the top of message
    # to prevent forgery.  See CAVEAT.
    if ($serialized =~ /\GReturn-Path: (.*?)\n(?![ \t])/cgs
        and not exists $self->{'envelope_sender'}) {
        my $addr = $1;
        if ($addr =~ /<>/) {    # special: null envelope sender
            $self->{'envelope_sender'} = '<>';
        } else {
            my @addrs = Mail::Address->parse($addr);
            if (@addrs
                and Sympa::Tools::Text::valid_email($addrs[0]->address)) {
                $self->{'envelope_sender'} = $addrs[0]->address;
            }
        }
    }
    # Strip attributes.
    substr($serialized, 0, pos $serialized) = '';

    # Check if message is parsable.

    my $parser = MIME::Parser->new;
    $parser->output_to_core(1);
    $parser->tmp_dir($Conf::Conf{'tmpdir'});
    my $entity = $parser->parse_data(\$serialized);
    unless ($entity) {
        $log->syslog('err', 'Unable to parse message');
        return undef;
    }
    my $hdr = $entity->head;
    my ($dummy, $body_string) = split /(?:\A|\n)\r?\n/, $serialized, 2;

    $self->{_head}         = $hdr;
    $self->{_body}         = $body_string;
    $self->{_entity_cache} = $entity;
    $self->{'size'}        = length $serialized;

    unless (exists $self->{'sender'} and defined $self->{'sender'}) {
        ($self->{'sender'}, $self->{'gecos'}) = $self->_get_sender_email;
    }

    ## Store decoded subject and its original charset
    my $subject = $hdr->get('Subject');
    if (defined $subject and $subject =~ /\S/) {
        my @decoded_subject = MIME::EncWords::decode_mimewords($subject);
        $self->{'subject_charset'} = 'US-ASCII';
        foreach my $token (@decoded_subject) {
            unless ($token->[1]) {
                # don't decode header including raw 8-bit bytes.
                if ($token->[0] =~ /[^\x00-\x7F]/) {
                    $self->{'subject_charset'} = undef;
                    last;
                }
                next;
            }
            my $cset = MIME::Charset->new($token->[1]);
            # don't decode header encoded with unknown charset.
            unless ($cset->decoder) {
                $self->{'subject_charset'} = undef;
                last;
            }
            unless ($cset->output_charset eq 'US-ASCII') {
                $self->{'subject_charset'} = $token->[1];
            }
        }
    } else {
        $self->{'subject_charset'} = undef;
    }
    if ($self->{'subject_charset'}) {
        chomp $subject;
        $self->{'decoded_subject'} =
            MIME::EncWords::decode_mimewords($subject, Charset => 'UTF-8');
    } else {
        if (defined $subject) {
            chomp $subject;
            $subject =~ s/(\r\n|\r|\n)(?=[ \t])//g;
            $subject =~ s/\r\n|\r|\n/ /g;
        }
        $self->{'decoded_subject'} = $subject;
    }

    ## TOPICS
    my $topics;
    if ($topics = $hdr->get('X-Sympa-Topic')) {
        $self->{'topic'} = $topics;
    }

    # Message ID
    unless (exists $self->{'message_id'}) {
        $self->{'message_id'} = _get_message_id($self);
    }

    return $self;
}

# Tentative: removed when refactoring finished.
sub new_from_file {
    my $class = shift;
    my $file  = shift;

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

    my $self = $class->new($serialized, @_)
        or return undef;

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

    return $self;
}

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

    my $hdr = $self->{_head};

    my $sender = undef;
    my $gecos  = undef;
    foreach my $field (split /[\s,]+/, $Conf::Conf{'sender_headers'}) {
        if (lc $field eq 'return-path') {
            ## Try to get envelope sender
            if (    $self->{'envelope_sender'}
                and $self->{'envelope_sender'} ne '<>') {
                $sender = lc($self->{'envelope_sender'});
            }
        } elsif ($hdr->get($field)) {
            ## Try to get message header.
            ## On "Resent-*:" headers, the first occurrence must be used (see
            ## RFC 5322 3.6.6).
            ## FIXME: Though "From:" can occur multiple times, only the first
            ## one is detected.
            my $addr = $hdr->get($field, 0);               # get the first one
            my @sender_hdr = Mail::Address->parse($addr);
            if (@sender_hdr and $sender_hdr[0]->address) {
                $sender = lc($sender_hdr[0]->address);
                my $phrase = $sender_hdr[0]->phrase;
                if (defined $phrase and length $phrase) {
                    $gecos = MIME::EncWords::decode_mimewords($phrase,
                        Charset => 'UTF-8');
                    # Eliminate hostile characters.
                    $gecos =~ s/(\r\n|\r|\n)(?=[ \t])//g;
                    $gecos =~ s/[\0\r\n]+//g;
                }
                last;
            }
        }

        last if defined $sender;
    }
    unless (defined $sender) {
        #$log->syslog('debug3', 'No valid sender address');
        return;
    }
    unless (Sympa::Tools::Text::valid_email($sender)) {
        $log->syslog('err', 'Invalid sender address "%s"', $sender);
        return;
    }

    return ($sender, $gecos);
}

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

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

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

sub dup {
    my $self = shift;

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

        unless (Scalar::Util::blessed($val)) {
            $clone->{$key} = Sympa::Tools::Data::dup_var($val);
        } elsif ($val->can('dup') and !$val->isa('Sympa::List')) {
            $clone->{$key} = $val->dup;
        } else {
            $clone->{$key} = $val;
        }
    }

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

sub to_string {
    my $self    = shift;
    my %options = @_;

    my $serialized = '';
    if (ref $self->{'rcpt'} eq 'ARRAY' and @{$self->{'rcpt'}}) {
        $serialized .= sprintf "X-Sympa-To: %s\n",
            join(',', @{$self->{'rcpt'}});
    } elsif (defined $self->{'rcpt'} and length $self->{'rcpt'}) {
        $serialized .= sprintf "X-Sympa-To: %s\n",
            join(',', split(/\s*,\s*/, $self->{'rcpt'}));
    }
    if (defined $self->{'checksum'}) {
        $serialized .= sprintf "X-Sympa-Checksum: %s\n", $self->{'checksum'};
    }
    if (defined $self->{'family'}) {
        $serialized .= sprintf "X-Sympa-Family: %s\n", $self->{'family'};
    }
    if (defined $self->{'md5_check'}
        and length $self->{'md5_check'}) {    # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Auth-Level: %s\n", 'md5';
    }
    if (defined $self->{'message_id'}) {      # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Message-ID: %s\n",
            $self->{'message_id'};
    }
    if (defined $self->{'sender'}) {          # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Sender: %s\n", $self->{'sender'};
    }
    if (defined $self->{'gecos'}
        and length $self->{'gecos'}) {        # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Display-Name: %s\n", $self->{'gecos'};
    }
    if (%{$self->{'shelved'} || {}}) {        # New in 6.2a.41
        $serialized .= sprintf "X-Sympa-Shelved: %s\n", join(
            '; ',
            map {
                my $v = $self->{shelved}{$_};
                ("$v" eq '1') ? $_ : sprintf('%s=%s', $_, $v);
                }
                grep {
                $self->{shelved}{$_}
                } sort keys %{$self->{shelved}}
        );
    }
    if (defined $self->{'spam_status'}) {     # New in 6.2a.41.
        $serialized .= sprintf "X-Sympa-Spam-Status: %s\n",
            $self->{'spam_status'};
    }
    # This terminates pseudo-header part for attributes.
    unless (defined $self->{'envelope_sender'}) {
        $serialized .= "Return-Path: \n";
    }

    $serialized .= $self->as_string(%options);

    return $serialized;
}

sub add_header {
    my $self = shift;
    $self->{_head}->add(@_);
    delete $self->{_entity_cache};    # Clear entity cache.
}

sub delete_header {
    my $self = shift;
    $self->{_head}->delete(@_);
    delete $self->{_entity_cache};    # Clear entity cache.
}

sub replace_header {
    my $self = shift;
    $self->{_head}->replace(@_);
    delete $self->{_entity_cache};    # Clear entity cache.
}

sub head {
    shift->{_head};
}

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

    my $robot_id =
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};

    my $spam_status =
        Sympa::Scenario::request_action($robot_id || $Conf::Conf{'domain'},
        'spam_status', 'smtp', {'message' => $self});
    if (defined $spam_status) {
        if (ref($spam_status) eq 'HASH') {
            $self->{'spam_status'} = $spam_status->{'action'};
        } else {
            $self->{'spam_status'} = $spam_status;
        }
    } else {
        $self->{'spam_status'} = 'unknown';
    }
}

my $has_mail_dkim_textwrap;

BEGIN {
    eval 'use Mail::DKIM::Signer';
    # This doesn't export $VERSION.
    eval 'use Mail::DKIM::TextWrap';
    $has_mail_dkim_textwrap = !$EVAL_ERROR;
    # Mail::DKIM::Signer prior to 0.38 doesn't import this.
    eval 'use Mail::DKIM::PrivateKey';
}

# Old name: tools::dkim_sign() which took string and returned string.
sub dkim_sign {
    $log->syslog('debug', '(%s)', @_);
    my $self    = shift;
    my %options = @_;

    my $dkim_d          = $options{'dkim_d'};
    my $dkim_i          = $options{'dkim_i'};
    my $dkim_selector   = $options{'dkim_selector'};
    my $dkim_privatekey = $options{'dkim_privatekey'};

    unless ($dkim_selector) {
        $log->syslog('err',
            "DKIM selector is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_privatekey) {
        $log->syslog('err',
            "DKIM key file is undefined, could not sign message");
        return undef;
    }
    unless ($dkim_d) {
        $log->syslog('err',
            "DKIM d= tag is undefined, could not sign message");
        return undef;
    }

    unless ($Mail::DKIM::Signer::VERSION) {
        $log->syslog('err',
            "Failed to load Mail::DKIM::Signer Perl module, ignoring DKIM signature"
        );
        return undef;
    }
    unless ($has_mail_dkim_textwrap) {
        $log->syslog('err',
            "Failed to load Mail::DKIM::TextWrap Perl module, signature will not be pretty"
        );
    }

    # DKIM::PrivateKey does never allow armour texts nor newlines.  Strip them.
    my $privatekey_string = join '',
        grep { !/^---/ and $_ } split /\r\n|\r|\n/, $dkim_privatekey;
    my $privatekey = Mail::DKIM::PrivateKey->load(Data => $privatekey_string);
    unless ($privatekey) {
        $log->syslog('err', 'Can\'t create Mail::DKIM::PrivateKey');
        return undef;
    }
    # create a signer object
    my $dkim = Mail::DKIM::Signer->new(
        Algorithm => "rsa-sha256",
        Method    => "relaxed",
        Domain    => $dkim_d,
        Selector  => $dkim_selector,
        Key       => $privatekey,
        ($dkim_i ? (Identity => $dkim_i) : ()),
    );
    unless ($dkim) {
        $log->syslog('err', 'Can\'t create Mail::DKIM::Signer');
        return undef;
    }
    # $new_body will store the body as fed to Mail::DKIM to reuse it
    # when returning the message as string.  Line terminators must be
    # normalized with CRLF.
    my $msg_as_string = $self->as_string;
    $msg_as_string =~ s/\r?\n/\r\n/g;
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
    $dkim->PRINT($msg_as_string);
    unless ($dkim->CLOSE) {
        $log->syslog('err', 'Cannot sign (DKIM) message');
        return undef;
    }

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

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

    return $self;
}

BEGIN { eval 'use Mail::DKIM::Verifier'; }

sub check_dkim_signature {
    my $self = shift;

    return unless $Mail::DKIM::Verifier::VERSION;

    my $robot_id =
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};
    return
        unless Sympa::Tools::Data::smart_eq(
        Conf::get_robot_conf($robot_id || '*', 'dkim_feature'), 'on');

    my $dkim;
    unless ($dkim = Mail::DKIM::Verifier->new()) {
        $log->syslog('err', 'Could not create Mail::DKIM::Verifier');
        return;
    }

    # Line terminators must be normalized with CRLF.
    my $msg_as_string = $self->as_string;
    $msg_as_string =~ s/\r?\n/\r\n/g;
    $msg_as_string =~ s/\r?\z/\r\n/ unless $msg_as_string =~ /\n\z/;
    $dkim->PRINT($msg_as_string);
    unless ($dkim->CLOSE) {
        $log->syslog('err', 'Cannot verify signature of (DKIM) message');
        return;
    }

    #FIXME: Identity of signatures would be checked.
    foreach my $signature ($dkim->signatures) {
        if ($signature->result_detail eq 'pass') {
            $self->{'dkim_pass'} = 1;
            return;
        }
    }
    delete $self->{'dkim_pass'};
}

# Old name: tools::remove_invalid_dkim_signature() which takes a message as
# string and outputs idem without signature if invalid.
sub remove_invalid_dkim_signature {
    $log->syslog('debug2', '(%s)', @_);
    my $self = shift;

    return unless $self->get_header('DKIM-Signature');

    $self->check_dkim_signature;
    unless ($self->{'dkim_pass'}) {
        $log->syslog('info',
            'DKIM signature of message %s is invalid, removing', $self);
        $self->delete_header('DKIM-Signature');
    }
}

sub as_entity {
    my $self = shift;

    unless (defined $self->{_entity_cache}) {
        die 'Bug in logic.  Ask developer' unless $self->{_head};
        my $string =
            $self->{_head}->as_string . "\n"
            . (defined $self->{_body} ? $self->{_body} : '');

        my $parser = MIME::Parser->new();
        $parser->output_to_core(1);
        $parser->tmp_dir($Conf::Conf{'tmpdir'});
        $self->{_entity_cache} = $parser->parse_data(\$string);
    }
    return $self->{_entity_cache};
}

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

    my $orig = $self->as_entity->as_string;
    my $new  = $entity->as_string;

    if ($orig ne $new) {
        $self->{_head} = $entity->head;
        $self->{_body} = $entity->body_as_string;
        $self->{_entity_cache} = $entity;    # Also update entity cache.
    }

    return $entity;
}

sub as_string {
    my $self    = shift;
    my %options = @_;

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

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

    my $return_path = '';
    if (defined $self->{'envelope_sender'}) {
        my $val = $self->{'envelope_sender'};
        $val = "<$val>" unless $val eq '<>';
        $return_path = sprintf "Return-Path: %s\n", $val;
    }
    return
          $return_path
        . $self->{_head}->as_string . "\n"
        . (defined $self->{_body} ? $self->{_body} : '');
}

sub body_as_string {
    my $self = shift;
    return $self->{_body};
}

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

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

    my $hdr = $self->{_head};

    if (defined $sep or wantarray) {
        my @values = grep {s/\A$field\s*:\s*//i}
            split /\n(?![ \t])/, $hdr->as_string();
        if (defined $sep) {
            return undef unless @values;
            return join $sep, @values;
        }
        return @values;
    } else {
        my $value = $hdr->get($field, 0);
        chomp $value if defined $value;
        return $value;
    }
}

# Old name: tools::decode_header() which can take Message, MIME::Entity,
# MIME::Head or Mail::Header object as argument.
sub get_decoded_header {
    my $self = shift;
    my $tag  = shift;
    my $sep  = shift;

    my $head = $self->head;

    if (defined $sep) {
        my @values = $head->get($tag);
        return undef unless scalar @values;
        foreach my $val (@values) {
            $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
            chomp $val;
        }
        return join $sep, @values;
    } else {
        my $val = $head->get($tag);
        return undef unless defined $val;
        $val = MIME::EncWords::decode_mimewords($val, Charset => 'UTF-8');
        chomp $val;
        return $val;
    }
}

# Dump the Message object
# Currently not used.
sub dump {
    my ($self, $output) = @_;
    # my $output ||= \*STDERR;

    my $old_output = select;
    select $output;

    foreach my $key (keys %{$self}) {
        if (ref($self->{$key}) eq 'MIME::Entity') {
            printf "%s =>\n", $key;
            $self->{$key}->print;
        } else {
            printf "%s => %s\n", $key, $self->{$key};
        }
    }

    select $old_output;

    return 1;
}

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

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

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

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

    } else {
        return '';
    }
}

sub clean_html {
    my $self = shift;

    my $robot =
        (ref $self->{context} eq 'Sympa::List')
        ? $self->{context}->{'domain'}
        : $self->{context};

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

sub _fix_html_part {
    my $entity = shift;
    my $robot  = shift;
    return $entity unless $entity;

    my $eff_type = $entity->head->mime_type || '';    # Use real content-type.
    if ($entity->parts) {
        my @newparts = ();
        foreach my $part ($entity->parts) {
            push @newparts, _fix_html_part($part, $robot);
        }
        $entity->parts(\@newparts);
    } elsif ($eff_type eq 'text/html') {
        my $bodyh = $entity->bodyhandle;
        # Encoded body or null body won't be modified.
        return $entity if !$bodyh or $bodyh->is_encoded;

        my $body = $bodyh->as_string;
        # Re-encode parts to UTF-8, since StripScripts cannot handle texts
        # with some charsets (ISO-2022-*, UTF-16*, ...) correctly.
        my $cset = MIME::Charset->new(
            $entity->head->mime_attr('Content-Type.Charset') || '');
        unless ($cset->decoder) {
            # Charset is unknown.  Detect 7-bit charset.
            my ($dummy, $charset) =
                MIME::Charset::body_encode($body, '', Detect7Bit => 'YES');
            $cset = MIME::Charset->new($charset)
                if $charset;
        }
        if (    $cset->decoder
            and $cset->as_string ne 'UTF-8'
            and $cset->as_string ne 'US-ASCII') {
            $cset->encoder('UTF-8');
            $body = $cset->encode($body);
            $entity->head->mime_attr('Content-Type.Charset', 'UTF-8');
        }

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

        my $io = $bodyh->open("w");
        unless (defined $io) {
            $log->syslog('err', 'Failed to save message: %m');
            return undef;
        }
        $io->print($filtered_body);
        $io->close;
        $entity->sync_headers(Length => 'COMPUTE')
            if $entity->head->get('Content-Length');
    }
    return $entity;
}

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

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

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

    my $content_type = lc($self->{_head}->mime_attr('Content-Type') || '');
    unless (
        (      $content_type eq 'application/pkcs7-mime'
            or $content_type eq 'application/x-pkcs7-mime'
        )
        and !Sympa::Tools::Data::smart_eq(
            $self->{_head}->mime_attr('Content-Type.smime-type'),
            qr/signed-data/i
        )
    ) {
        return 0;
    }

    #FIXME: an empty "context" parameter means mail to sympa@, listmaster@...
    my ($certs, $keys) =
        Sympa::Tools::SMIME::find_keys($self->{context} || '*', 'decrypt');
    unless (defined $certs and @$certs) {
        $log->syslog('err',
            'Unable to decrypt message: missing certificate file');
        return undef;
    }

    my ($msg_string, $entity);

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

        my ($cert, $key);
        if (open my $fh, '<', $certfile) {
            $cert = do { local $RS; <$fh> };
            close $fh;
        }
        if (open my $fh, '<', $keyfile) {
            $key = do { local $RS; <$fh> };
            close $fh;
        }

        my $smime = Crypt::SMIME->new();
        if (length $key_passwd) {
            eval { $smime->setPrivateKey($key, $cert, $key_passwd) }
                or next;
        } else {
            eval { $smime->setPrivateKey($key, $cert) }
                or next;
        }
        $msg_string = eval { $smime->decrypt($self->as_string); };
        last if defined $msg_string;
    }

    unless (defined $msg_string) {