Filename | /usr/local/libexec/sympa/Sympa/Message.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@2161 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@30 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@31 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@32 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@33 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@34 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@35 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@36 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@37 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@38 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@39 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@40 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@41 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@42 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@43 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@44 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@442 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@45 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@47 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@48 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@50 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@51 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@52 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@53 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@54 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@55 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@56 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@57 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@58 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@59 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@60 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@61 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@62 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@63 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@64 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@641 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | BEGIN@65 | Sympa::Message::
0 | 0 | 0 | 0s | 0s | __ANON__ (xsub) | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _add_footer_part | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _append_footer_header_to_part | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _append_parts | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _as_singlepart | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _check_dmarc_rr | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_dsn | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_message | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_multipart | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_other | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_text_html | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_text_plain | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _do_toplevel | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _fix_html_part | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _fix_utf8_parts | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _footer_text | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _getCharset | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _get_message_id | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _get_sender_email | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _hasTextPlain | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _merge_msg | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _parse_dmarc_rr | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _personalize_attrs | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _split_mail | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _urlize_one_part | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _urlize_parts | Sympa::Message::
0 | 0 | 0 | 0s | 0s | _urlize_sub_parts | Sympa::Message::
0 | 0 | 0 | 0s | 0s | add_header | Sympa::Message::
0 | 0 | 0 | 0s | 0s | add_topic | Sympa::Message::
0 | 0 | 0 | 0s | 0s | arc_seal | Sympa::Message::
0 | 0 | 0 | 0s | 0s | as_entity | Sympa::Message::
0 | 0 | 0 | 0s | 0s | as_string | Sympa::Message::
0 | 0 | 0 | 0s | 0s | body_as_string | Sympa::Message::
0 | 0 | 0 | 0s | 0s | check_arc_chain | Sympa::Message::
0 | 0 | 0 | 0s | 0s | check_dkim_signature | Sympa::Message::
0 | 0 | 0 | 0s | 0s | check_smime_signature | Sympa::Message::
0 | 0 | 0 | 0s | 0s | check_spam_status | Sympa::Message::
0 | 0 | 0 | 0s | 0s | check_virus_infection | Sympa::Message::
0 | 0 | 0 | 0s | 0s | clean_html | Sympa::Message::
0 | 0 | 0 | 0s | 0s | compute_topic | Sympa::Message::
0 | 0 | 0 | 0s | 0s | decorate | Sympa::Message::
0 | 0 | 0 | 0s | 0s | delete_header | Sympa::Message::
0 | 0 | 0 | 0s | 0s | dkim_sign | Sympa::Message::
0 | 0 | 0 | 0s | 0s | dmarc_protect | Sympa::Message::
0 | 0 | 0 | 0s | 0s | dump | Sympa::Message::
0 | 0 | 0 | 0s | 0s | dup | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_decoded_header | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_header | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_id | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_plain_body | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_plaindigest_body | Sympa::Message::
0 | 0 | 0 | 0s | 0s | get_topic | Sympa::Message::
0 | 0 | 0 | 0s | 0s | head | Sympa::Message::
0 | 0 | 0 | 0s | 0s | header_as_string | Sympa::Message::
0 | 0 | 0 | 0s | 0s | is_signed | Sympa::Message::
0 | 0 | 0 | 0s | 0s | new | Sympa::Message::
0 | 0 | 0 | 0s | 0s | new_from_file | Sympa::Message::
0 | 0 | 0 | 0s | 0s | personalize | Sympa::Message::
0 | 0 | 0 | 0s | 0s | personalize_text | Sympa::Message::
0 | 0 | 0 | 0s | 0s | prepare_message_according_to_mode | Sympa::Message::
0 | 0 | 0 | 0s | 0s | reformat_utf8_message | Sympa::Message::
0 | 0 | 0 | 0s | 0s | remove_invalid_dkim_signature | Sympa::Message::
0 | 0 | 0 | 0s | 0s | replace_header | Sympa::Message::
0 | 0 | 0 | 0s | 0s | set_entity | Sympa::Message::
0 | 0 | 0 | 0s | 0s | shelve_personalization | Sympa::Message::
0 | 0 | 0 | 0s | 0s | smime_decrypt | Sympa::Message::
0 | 0 | 0 | 0s | 0s | smime_encrypt | Sympa::Message::
0 | 0 | 0 | 0s | 0s | smime_sign | Sympa::Message::
0 | 0 | 0 | 0s | 0s | to_string | Sympa::Message::
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 | |||||
28 | package Sympa::Message; | ||||
29 | |||||
30 | use strict; | ||||
31 | use warnings; | ||||
32 | use DateTime; | ||||
33 | use Encode qw(); | ||||
34 | use English; # FIXME: drop $PREMATCH usage | ||||
35 | use HTML::TreeBuilder; | ||||
36 | use Mail::Address; | ||||
37 | use MIME::Charset; | ||||
38 | use MIME::EncWords; | ||||
39 | use MIME::Entity; | ||||
40 | use MIME::Field::ParamVal; | ||||
41 | use MIME::Parser; | ||||
42 | use MIME::Tools; | ||||
43 | use Scalar::Util qw(); | ||||
44 | use Text::LineFold; | ||||
45 | use URI::Escape qw(); | ||||
46 | |||||
47 | BEGIN { eval 'use Crypt::SMIME'; } # spent 0s executing statements in string eval | ||||
48 | BEGIN { eval 'use Net::DNS'; } # spent 0s executing statements in string eval | ||||
49 | |||||
50 | use Sympa; | ||||
51 | use Conf; | ||||
52 | use Sympa::Constants; | ||||
53 | use Sympa::HTML::FormatText; | ||||
54 | use Sympa::HTMLSanitizer; | ||||
55 | use Sympa::Language; | ||||
56 | use Sympa::Log; | ||||
57 | use Sympa::Scenario; | ||||
58 | use Sympa::Spool; | ||||
59 | use Sympa::Template; | ||||
60 | use Sympa::Tools::Data; | ||||
61 | use Sympa::Tools::File; | ||||
62 | use Sympa::Tools::Password; | ||||
63 | use Sympa::Tools::SMIME; | ||||
64 | use Sympa::Tools::Text; | ||||
65 | use Sympa::User; | ||||
66 | |||||
67 | my $language = Sympa::Language->instance; | ||||
68 | my $log = Sympa::Log->instance; | ||||
69 | |||||
70 | sub 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. | ||||
228 | sub 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. | ||||
251 | sub _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:. | ||||
303 | sub _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 | |||||
315 | sub 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 | |||||
335 | sub 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 | |||||
394 | sub add_header { | ||||
395 | my $self = shift; | ||||
396 | $self->{_head}->add(@_); | ||||
397 | delete $self->{_entity_cache}; # Clear entity cache. | ||||
398 | } | ||||
399 | |||||
400 | sub delete_header { | ||||
401 | my $self = shift; | ||||
402 | $self->{_head}->delete(@_); | ||||
403 | delete $self->{_entity_cache}; # Clear entity cache. | ||||
404 | } | ||||
405 | |||||
406 | sub replace_header { | ||||
407 | my $self = shift; | ||||
408 | $self->{_head}->replace(@_); | ||||
409 | delete $self->{_entity_cache}; # Clear entity cache. | ||||
410 | } | ||||
411 | |||||
412 | sub 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.. | ||||
418 | sub 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 | |||||
440 | my $has_mail_dkim_textwrap; | ||||
441 | |||||
442 | BEGIN { | ||||
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. | ||||
453 | sub 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 | |||||
547 | sub 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 | |||||
641 | BEGIN { | ||||
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 | |||||
646 | sub 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 | |||||
687 | sub 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. | ||||
747 | sub 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 | |||||
761 | sub 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 | |||||
778 | sub 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 | |||||
795 | sub 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 | |||||
816 | sub body_as_string { | ||||
817 | my $self = shift; | ||||
818 | return $self->{_body}; | ||||
819 | } | ||||
820 | |||||
821 | sub header_as_string { | ||||
822 | my $self = shift; | ||||
823 | return $self->{_head}->as_string; | ||||
824 | } | ||||
825 | |||||
826 | sub 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. | ||||
852 | sub 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. | ||||
878 | sub 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. | ||||
901 | sub 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. | ||||
910 | sub get_topic { | ||||
911 | my ($self) = @_; | ||||
912 | |||||
913 | if (defined $self->{'topic'}) { | ||||
914 | return $self->{'topic'}; | ||||
915 | |||||
916 | } else { | ||||
917 | return ''; | ||||
918 | } | ||||
919 | } | ||||
920 | |||||
921 | sub 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 | |||||
937 | sub _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. | ||||
992 | sub 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. | ||||
1107 | sub 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(). | ||||
1202 | sub 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. | ||||
1295 | sub 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 | |||||
1381 | sub 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() | ||||
1400 | sub 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 | |||||
1426 | sub _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 | |||||
1447 | sub _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() | ||||
1583 | sub 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 | |||||
1635 | sub 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(). | ||||
1696 | sub 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 | |||||
1797 | sub _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. | ||||
1832 | sub _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 | |||||
1931 | sub _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. | ||||
1996 | my $div_style = | ||||
1997 | 'background: transparent; border: none; clear: both; display: block; float: none; position: static'; | ||||
1998 | |||||
1999 | sub _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 | |||||
2125 | sub _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 | |||||
2154 | sub _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 | |||||
2199 | sub _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 | |||||
2340 | sub 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 | |||||
2360 | sub _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 | |||||
2483 | sub 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 | |||||
2501 | sub 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(). | ||||
2541 | sub _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(). | ||||
2599 | sub 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. | ||||
2871 | sub _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 | # | ||||
2929 | sub 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 | |||||
2948 | sub _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 | |||||
2966 | sub _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 | |||||
3010 | sub _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 | |||||
3077 | sub _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 | |||||
3118 | sub _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 | |||||
3127 | sub _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 | |||||
3140 | sub _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 | |||||
3199 | sub _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 | |||||
3211 | sub _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 | |||||
3225 | sub 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 | ||||
3415 | sub _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. | ||||
3483 | sub _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() | ||||
3504 | sub 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 | |||||
3587 | sub 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 | |||||
3618 | 1; | ||||
3619 | __END__ |