← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:11 2021

Filename/usr/local/libexec/sympa/Sympa/Message.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSympa::Message::::BEGIN@2161Sympa::Message::BEGIN@2161
0000s0sSympa::Message::::BEGIN@30Sympa::Message::BEGIN@30
0000s0sSympa::Message::::BEGIN@31Sympa::Message::BEGIN@31
0000s0sSympa::Message::::BEGIN@32Sympa::Message::BEGIN@32
0000s0sSympa::Message::::BEGIN@33Sympa::Message::BEGIN@33
0000s0sSympa::Message::::BEGIN@34Sympa::Message::BEGIN@34
0000s0sSympa::Message::::BEGIN@35Sympa::Message::BEGIN@35
0000s0sSympa::Message::::BEGIN@36Sympa::Message::BEGIN@36
0000s0sSympa::Message::::BEGIN@37Sympa::Message::BEGIN@37
0000s0sSympa::Message::::BEGIN@38Sympa::Message::BEGIN@38
0000s0sSympa::Message::::BEGIN@39Sympa::Message::BEGIN@39
0000s0sSympa::Message::::BEGIN@40Sympa::Message::BEGIN@40
0000s0sSympa::Message::::BEGIN@41Sympa::Message::BEGIN@41
0000s0sSympa::Message::::BEGIN@42Sympa::Message::BEGIN@42
0000s0sSympa::Message::::BEGIN@43Sympa::Message::BEGIN@43
0000s0sSympa::Message::::BEGIN@44Sympa::Message::BEGIN@44
0000s0sSympa::Message::::BEGIN@442Sympa::Message::BEGIN@442
0000s0sSympa::Message::::BEGIN@45Sympa::Message::BEGIN@45
0000s0sSympa::Message::::BEGIN@47Sympa::Message::BEGIN@47
0000s0sSympa::Message::::BEGIN@48Sympa::Message::BEGIN@48
0000s0sSympa::Message::::BEGIN@50Sympa::Message::BEGIN@50
0000s0sSympa::Message::::BEGIN@51Sympa::Message::BEGIN@51
0000s0sSympa::Message::::BEGIN@52Sympa::Message::BEGIN@52
0000s0sSympa::Message::::BEGIN@53Sympa::Message::BEGIN@53
0000s0sSympa::Message::::BEGIN@54Sympa::Message::BEGIN@54
0000s0sSympa::Message::::BEGIN@55Sympa::Message::BEGIN@55
0000s0sSympa::Message::::BEGIN@56Sympa::Message::BEGIN@56
0000s0sSympa::Message::::BEGIN@57Sympa::Message::BEGIN@57
0000s0sSympa::Message::::BEGIN@58Sympa::Message::BEGIN@58
0000s0sSympa::Message::::BEGIN@59Sympa::Message::BEGIN@59
0000s0sSympa::Message::::BEGIN@60Sympa::Message::BEGIN@60
0000s0sSympa::Message::::BEGIN@61Sympa::Message::BEGIN@61
0000s0sSympa::Message::::BEGIN@62Sympa::Message::BEGIN@62
0000s0sSympa::Message::::BEGIN@63Sympa::Message::BEGIN@63
0000s0sSympa::Message::::BEGIN@64Sympa::Message::BEGIN@64
0000s0sSympa::Message::::BEGIN@641Sympa::Message::BEGIN@641
0000s0sSympa::Message::::BEGIN@65Sympa::Message::BEGIN@65
0000s0sSympa::Message::::__ANON__Sympa::Message::__ANON__ (xsub)
0000s0sSympa::Message::::_add_footer_partSympa::Message::_add_footer_part
0000s0sSympa::Message::::_append_footer_header_to_partSympa::Message::_append_footer_header_to_part
0000s0sSympa::Message::::_append_partsSympa::Message::_append_parts
0000s0sSympa::Message::::_as_singlepartSympa::Message::_as_singlepart
0000s0sSympa::Message::::_check_dmarc_rrSympa::Message::_check_dmarc_rr
0000s0sSympa::Message::::_do_dsnSympa::Message::_do_dsn
0000s0sSympa::Message::::_do_messageSympa::Message::_do_message
0000s0sSympa::Message::::_do_multipartSympa::Message::_do_multipart
0000s0sSympa::Message::::_do_otherSympa::Message::_do_other
0000s0sSympa::Message::::_do_text_htmlSympa::Message::_do_text_html
0000s0sSympa::Message::::_do_text_plainSympa::Message::_do_text_plain
0000s0sSympa::Message::::_do_toplevelSympa::Message::_do_toplevel
0000s0sSympa::Message::::_fix_html_partSympa::Message::_fix_html_part
0000s0sSympa::Message::::_fix_utf8_partsSympa::Message::_fix_utf8_parts
0000s0sSympa::Message::::_footer_textSympa::Message::_footer_text
0000s0sSympa::Message::::_getCharsetSympa::Message::_getCharset
0000s0sSympa::Message::::_get_message_idSympa::Message::_get_message_id
0000s0sSympa::Message::::_get_sender_emailSympa::Message::_get_sender_email
0000s0sSympa::Message::::_hasTextPlainSympa::Message::_hasTextPlain
0000s0sSympa::Message::::_merge_msgSympa::Message::_merge_msg
0000s0sSympa::Message::::_parse_dmarc_rrSympa::Message::_parse_dmarc_rr
0000s0sSympa::Message::::_personalize_attrsSympa::Message::_personalize_attrs
0000s0sSympa::Message::::_split_mailSympa::Message::_split_mail
0000s0sSympa::Message::::_urlize_one_partSympa::Message::_urlize_one_part
0000s0sSympa::Message::::_urlize_partsSympa::Message::_urlize_parts
0000s0sSympa::Message::::_urlize_sub_partsSympa::Message::_urlize_sub_parts
0000s0sSympa::Message::::add_headerSympa::Message::add_header
0000s0sSympa::Message::::add_topicSympa::Message::add_topic
0000s0sSympa::Message::::arc_sealSympa::Message::arc_seal
0000s0sSympa::Message::::as_entitySympa::Message::as_entity
0000s0sSympa::Message::::as_stringSympa::Message::as_string
0000s0sSympa::Message::::body_as_stringSympa::Message::body_as_string
0000s0sSympa::Message::::check_arc_chainSympa::Message::check_arc_chain
0000s0sSympa::Message::::check_dkim_signatureSympa::Message::check_dkim_signature
0000s0sSympa::Message::::check_smime_signatureSympa::Message::check_smime_signature
0000s0sSympa::Message::::check_spam_statusSympa::Message::check_spam_status
0000s0sSympa::Message::::check_virus_infectionSympa::Message::check_virus_infection
0000s0sSympa::Message::::clean_htmlSympa::Message::clean_html
0000s0sSympa::Message::::compute_topicSympa::Message::compute_topic
0000s0sSympa::Message::::decorateSympa::Message::decorate
0000s0sSympa::Message::::delete_headerSympa::Message::delete_header
0000s0sSympa::Message::::dkim_signSympa::Message::dkim_sign
0000s0sSympa::Message::::dmarc_protectSympa::Message::dmarc_protect
0000s0sSympa::Message::::dumpSympa::Message::dump
0000s0sSympa::Message::::dupSympa::Message::dup
0000s0sSympa::Message::::get_decoded_headerSympa::Message::get_decoded_header
0000s0sSympa::Message::::get_headerSympa::Message::get_header
0000s0sSympa::Message::::get_idSympa::Message::get_id
0000s0sSympa::Message::::get_plain_bodySympa::Message::get_plain_body
0000s0sSympa::Message::::get_plaindigest_bodySympa::Message::get_plaindigest_body
0000s0sSympa::Message::::get_topicSympa::Message::get_topic
0000s0sSympa::Message::::headSympa::Message::head
0000s0sSympa::Message::::header_as_stringSympa::Message::header_as_string
0000s0sSympa::Message::::is_signedSympa::Message::is_signed
0000s0sSympa::Message::::newSympa::Message::new
0000s0sSympa::Message::::new_from_fileSympa::Message::new_from_file
0000s0sSympa::Message::::personalizeSympa::Message::personalize
0000s0sSympa::Message::::personalize_textSympa::Message::personalize_text
0000s0sSympa::Message::::prepare_message_according_to_modeSympa::Message::prepare_message_according_to_mode
0000s0sSympa::Message::::reformat_utf8_messageSympa::Message::reformat_utf8_message
0000s0sSympa::Message::::remove_invalid_dkim_signatureSympa::Message::remove_invalid_dkim_signature
0000s0sSympa::Message::::replace_headerSympa::Message::replace_header
0000s0sSympa::Message::::set_entitySympa::Message::set_entity
0000s0sSympa::Message::::shelve_personalizationSympa::Message::shelve_personalization
0000s0sSympa::Message::::smime_decryptSympa::Message::smime_decrypt
0000s0sSympa::Message::::smime_encryptSympa::Message::smime_encrypt
0000s0sSympa::Message::::smime_signSympa::Message::smime_sign
0000s0sSympa::Message::::to_stringSympa::Message::to_string
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
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'; }
# spent 0s executing statements in string eval
48BEGIN { eval 'use Net::DNS'; }
# spent 0s executing statements in string eval
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';
# spent 0s executing statements in string eval
444 # This doesn't export $VERSION.
445 eval 'use Mail::DKIM::TextWrap';
# spent 0s executing statements in string eval
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';
# spent 0s executing statements in string eval
449 eval 'use Mail::DKIM::ARC::Signer';
# spent 0s executing statements in string eval
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';
# spent 0s executing statements in string eval
643 eval 'use Mail::DKIM::ARC::Verifier';
# spent 0s executing statements in string eval
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__