]>
Commit | Line | Data |
---|---|---|
84fb5b46 MKG |
1 | # BEGIN BPS TAGGED BLOCK {{{ |
2 | # | |
3 | # COPYRIGHT: | |
4 | # | |
5 | # This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC | |
6 | # <sales@bestpractical.com> | |
7 | # | |
8 | # (Except where explicitly superseded by other copyright notices) | |
9 | # | |
10 | # | |
11 | # LICENSE: | |
12 | # | |
13 | # This work is made available to you under the terms of Version 2 of | |
14 | # the GNU General Public License. A copy of that license should have | |
15 | # been provided with this software, but in any event can be snarfed | |
16 | # from www.gnu.org. | |
17 | # | |
18 | # This work is distributed in the hope that it will be useful, but | |
19 | # WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
21 | # General Public License for more details. | |
22 | # | |
23 | # You should have received a copy of the GNU General Public License | |
24 | # along with this program; if not, write to the Free Software | |
25 | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
26 | # 02110-1301 or visit their web page on the internet at | |
27 | # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. | |
28 | # | |
29 | # | |
30 | # CONTRIBUTION SUBMISSION POLICY: | |
31 | # | |
32 | # (The following paragraph is not intended to limit the rights granted | |
33 | # to you to modify and distribute this software under the terms of | |
34 | # the GNU General Public License and is only of importance to you if | |
35 | # you choose to contribute your changes and enhancements to the | |
36 | # community by submitting them to Best Practical Solutions, LLC.) | |
37 | # | |
38 | # By intentionally submitting any modifications, corrections or | |
39 | # derivatives to this work, or any other work intended for use with | |
40 | # Request Tracker, to Best Practical Solutions, LLC, you confirm that | |
41 | # you are the copyright holder for those contributions and you grant | |
42 | # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, | |
43 | # royalty-free, perpetual, license to use, copy, create derivative | |
44 | # works based on those contributions, and sublicense and distribute | |
45 | # those contributions and any derivatives thereof. | |
46 | # | |
47 | # END BPS TAGGED BLOCK }}} | |
48 | ||
49 | package RT::EmailParser; | |
50 | ||
51 | ||
52 | use base qw/RT::Base/; | |
53 | ||
54 | use strict; | |
55 | use warnings; | |
56 | ||
57 | ||
58 | use Email::Address; | |
59 | use MIME::Entity; | |
60 | use MIME::Head; | |
61 | use MIME::Parser; | |
62 | use File::Temp qw/tempdir/; | |
63 | ||
64 | =head1 NAME | |
65 | ||
66 | RT::EmailParser - helper functions for parsing parts from incoming | |
67 | email messages | |
68 | ||
69 | =head1 SYNOPSIS | |
70 | ||
71 | ||
72 | =head1 DESCRIPTION | |
73 | ||
74 | ||
75 | ||
76 | ||
77 | =head1 METHODS | |
78 | ||
79 | =head2 new | |
80 | ||
81 | Returns a new RT::EmailParser object | |
82 | ||
83 | =cut | |
84 | ||
85 | sub new { | |
86 | my $proto = shift; | |
87 | my $class = ref($proto) || $proto; | |
88 | my $self = {}; | |
89 | bless ($self, $class); | |
90 | return $self; | |
91 | } | |
92 | ||
93 | ||
94 | =head2 SmartParseMIMEEntityFromScalar Message => SCALAR_REF [, Decode => BOOL, Exact => BOOL ] } | |
95 | ||
96 | Parse a message stored in a scalar from scalar_ref. | |
97 | ||
98 | =cut | |
99 | ||
100 | sub SmartParseMIMEEntityFromScalar { | |
101 | my $self = shift; | |
102 | my %args = ( Message => undef, Decode => 1, Exact => 0, @_ ); | |
103 | ||
104 | eval { | |
105 | my ( $fh, $temp_file ); | |
106 | for ( 1 .. 10 ) { | |
107 | ||
108 | # on NFS and NTFS, it is possible that tempfile() conflicts | |
109 | # with other processes, causing a race condition. we try to | |
110 | # accommodate this by pausing and retrying. | |
111 | last | |
112 | if ( $fh, $temp_file ) = | |
113 | eval { File::Temp::tempfile( undef, UNLINK => 0 ) }; | |
114 | sleep 1; | |
115 | } | |
116 | if ($fh) { | |
117 | ||
118 | #thank you, windows | |
119 | binmode $fh; | |
120 | $fh->autoflush(1); | |
121 | print $fh $args{'Message'}; | |
122 | close($fh); | |
123 | if ( -f $temp_file ) { | |
124 | ||
125 | # We have to trust the temp file's name -- untaint it | |
126 | $temp_file =~ /(.*)/; | |
127 | my $entity = $self->ParseMIMEEntityFromFile( $1, $args{'Decode'}, $args{'Exact'} ); | |
128 | unlink($1); | |
129 | return $entity; | |
130 | } | |
131 | } | |
132 | }; | |
133 | ||
134 | $self->RescueOutlook; | |
135 | ||
136 | #If for some reason we weren't able to parse the message using a temp file | |
137 | # try it with a scalar | |
138 | if ( $@ || !$self->Entity ) { | |
139 | return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} ); | |
140 | } | |
141 | ||
142 | } | |
143 | ||
144 | ||
145 | =head2 ParseMIMEEntityFromSTDIN | |
146 | ||
147 | Parse a message from standard input | |
148 | ||
149 | =cut | |
150 | ||
151 | sub ParseMIMEEntityFromSTDIN { | |
152 | my $self = shift; | |
153 | return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_); | |
154 | } | |
155 | ||
156 | =head2 ParseMIMEEntityFromScalar $message | |
157 | ||
158 | Takes either a scalar or a reference to a scalar which contains a stringified MIME message. | |
159 | Parses it. | |
160 | ||
161 | Returns true if it wins. | |
162 | Returns false if it loses. | |
163 | ||
164 | =cut | |
165 | ||
166 | sub ParseMIMEEntityFromScalar { | |
167 | my $self = shift; | |
168 | return $self->_ParseMIMEEntity( shift, 'parse_data', @_ ); | |
169 | } | |
170 | ||
171 | =head2 ParseMIMEEntityFromFilehandle *FH | |
172 | ||
173 | Parses a mime entity from a filehandle passed in as an argument | |
174 | ||
175 | =cut | |
176 | ||
177 | sub ParseMIMEEntityFromFileHandle { | |
178 | my $self = shift; | |
179 | return $self->_ParseMIMEEntity( shift, 'parse', @_ ); | |
180 | } | |
181 | ||
182 | =head2 ParseMIMEEntityFromFile | |
183 | ||
184 | Parses a mime entity from a filename passed in as an argument | |
185 | ||
186 | =cut | |
187 | ||
188 | sub ParseMIMEEntityFromFile { | |
189 | my $self = shift; | |
190 | return $self->_ParseMIMEEntity( shift, 'parse_open', @_ ); | |
191 | } | |
192 | ||
193 | ||
194 | sub _ParseMIMEEntity { | |
195 | my $self = shift; | |
196 | my $message = shift; | |
197 | my $method = shift; | |
198 | my $postprocess = (@_ ? shift : 1); | |
199 | my $exact = shift; | |
200 | ||
201 | # Create a new parser object: | |
202 | my $parser = MIME::Parser->new(); | |
203 | $self->_SetupMIMEParser($parser); | |
204 | $parser->decode_bodies(0) if $exact; | |
205 | ||
206 | # TODO: XXX 3.0 we really need to wrap this in an eval { } | |
207 | unless ( $self->{'entity'} = $parser->$method($message) ) { | |
208 | $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages"); | |
209 | # Try again, this time without extracting nested messages | |
210 | $parser->extract_nested_messages(0); | |
211 | unless ( $self->{'entity'} = $parser->$method($message) ) { | |
212 | $RT::Logger->crit("couldn't parse MIME stream"); | |
213 | return ( undef); | |
214 | } | |
215 | } | |
216 | ||
217 | $self->_PostProcessNewEntity if $postprocess; | |
218 | ||
219 | return $self->{'entity'}; | |
220 | } | |
221 | ||
222 | sub _DecodeBodies { | |
223 | my $self = shift; | |
224 | return unless $self->{'entity'}; | |
225 | ||
226 | my @parts = $self->{'entity'}->parts_DFS; | |
227 | $self->_DecodeBody($_) foreach @parts; | |
228 | } | |
229 | ||
230 | sub _DecodeBody { | |
231 | my $self = shift; | |
232 | my $entity = shift; | |
233 | ||
234 | my $old = $entity->bodyhandle or return; | |
235 | return unless $old->is_encoded; | |
236 | ||
237 | require MIME::Decoder; | |
238 | my $encoding = $entity->head->mime_encoding; | |
239 | my $decoder = MIME::Decoder->new($encoding); | |
240 | unless ( $decoder ) { | |
241 | $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary"); | |
242 | $old->is_encoded(0); | |
243 | return; | |
244 | } | |
245 | ||
246 | require MIME::Body; | |
247 | # XXX: use InCore for now, but later must switch to files | |
248 | my $new = MIME::Body::InCore->new(); | |
249 | $new->binmode(1); | |
250 | $new->is_encoded(0); | |
251 | ||
252 | my $source = $old->open('r') or die "couldn't open body: $!"; | |
253 | my $destination = $new->open('w') or die "couldn't open body: $!"; | |
254 | { | |
255 | local $@; | |
256 | eval { $decoder->decode($source, $destination) }; | |
257 | $RT::Logger->error($@) if $@; | |
258 | } | |
259 | $source->close or die "can't close: $!"; | |
260 | $destination->close or die "can't close: $!"; | |
261 | ||
262 | $entity->bodyhandle( $new ); | |
263 | } | |
264 | ||
265 | =head2 _PostProcessNewEntity | |
266 | ||
267 | cleans up and postprocesses a newly parsed MIME Entity | |
268 | ||
269 | =cut | |
270 | ||
271 | sub _PostProcessNewEntity { | |
272 | my $self = shift; | |
273 | ||
274 | #Now we've got a parsed mime object. | |
275 | ||
276 | # Unfold headers that are have embedded newlines | |
277 | # Better do this before conversion or it will break | |
278 | # with multiline encoded Subject (RFC2047) (fsck.com #5594) | |
279 | $self->Head->unfold; | |
280 | ||
281 | # try to convert text parts into utf-8 charset | |
282 | RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8'); | |
283 | } | |
284 | ||
285 | =head2 ParseCcAddressesFromHead HASHREF | |
286 | ||
287 | Takes a hashref object containing QueueObj, Head and CurrentUser objects. | |
288 | Returns a list of all email addresses in the To and Cc | |
289 | headers b<except> the current Queue\'s email addresses, the CurrentUser\'s | |
290 | email address and anything that the RT->Config->Get('RTAddressRegexp') matches. | |
291 | ||
292 | =cut | |
293 | ||
294 | sub ParseCcAddressesFromHead { | |
295 | my $self = shift; | |
296 | my %args = ( | |
297 | QueueObj => undef, | |
298 | CurrentUser => undef, | |
299 | @_ | |
300 | ); | |
301 | ||
302 | my (@Addresses); | |
303 | ||
304 | my @ToObjs = Email::Address->parse( $self->Head->get('To') ); | |
305 | my @CcObjs = Email::Address->parse( $self->Head->get('Cc') ); | |
306 | ||
307 | foreach my $AddrObj ( @ToObjs, @CcObjs ) { | |
308 | my $Address = $AddrObj->address; | |
309 | my $user = RT::User->new(RT->SystemUser); | |
310 | $Address = $user->CanonicalizeEmailAddress($Address); | |
311 | next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address; | |
312 | next if $self->IsRTAddress($Address); | |
313 | ||
314 | push ( @Addresses, $Address ); | |
315 | } | |
316 | return (@Addresses); | |
317 | } | |
318 | ||
319 | ||
320 | =head2 IsRTaddress ADDRESS | |
321 | ||
322 | Takes a single parameter, an email address. | |
323 | Returns true if that address matches the C<RTAddressRegexp> config option. | |
324 | Returns false, otherwise. | |
325 | ||
326 | ||
327 | =cut | |
328 | ||
329 | sub IsRTAddress { | |
330 | my $self = shift; | |
331 | my $address = shift; | |
332 | ||
333 | if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) { | |
334 | return $address =~ /$address_re/i ? 1 : undef; | |
335 | } | |
336 | ||
337 | # we don't warn here, but do in config check | |
338 | if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) { | |
339 | return 1 if lc $correspond_address eq lc $address; | |
340 | } | |
341 | if ( my $comment_address = RT->Config->Get('CommentAddress') ) { | |
342 | return 1 if lc $comment_address eq lc $address; | |
343 | } | |
344 | ||
345 | my $queue = RT::Queue->new( RT->SystemUser ); | |
346 | $queue->LoadByCols( CorrespondAddress => $address ); | |
347 | return 1 if $queue->id; | |
348 | ||
349 | $queue->LoadByCols( CommentAddress => $address ); | |
350 | return 1 if $queue->id; | |
351 | ||
352 | return undef; | |
353 | } | |
354 | ||
355 | ||
356 | =head2 CullRTAddresses ARRAY | |
357 | ||
358 | Takes a single argument, an array of email addresses. | |
359 | Returns the same array with any IsRTAddress()es weeded out. | |
360 | ||
361 | ||
362 | =cut | |
363 | ||
364 | sub CullRTAddresses { | |
365 | my $self = shift; | |
366 | my @addresses = (@_); | |
367 | ||
368 | return grep { !$self->IsRTAddress($_) } @addresses; | |
369 | } | |
370 | ||
371 | ||
372 | ||
373 | ||
374 | ||
375 | # LookupExternalUserInfo is a site-definable method for synchronizing | |
376 | # incoming users with an external data source. | |
377 | # | |
378 | # This routine takes a tuple of EmailAddress and FriendlyName | |
379 | # EmailAddress is the user's email address, ususally taken from | |
380 | # an email message's From: header. | |
381 | # FriendlyName is a freeform string, ususally taken from the "comment" | |
382 | # portion of an email message's From: header. | |
383 | # | |
384 | # If you define an AutoRejectRequest template, RT will use this | |
385 | # template for the rejection message. | |
386 | ||
387 | ||
388 | =head2 LookupExternalUserInfo | |
389 | ||
390 | LookupExternalUserInfo is a site-definable method for synchronizing | |
391 | incoming users with an external data source. | |
392 | ||
393 | This routine takes a tuple of EmailAddress and FriendlyName | |
394 | EmailAddress is the user's email address, ususally taken from | |
395 | an email message's From: header. | |
396 | FriendlyName is a freeform string, ususally taken from the "comment" | |
397 | portion of an email message's From: header. | |
398 | ||
399 | It returns (FoundInExternalDatabase, ParamHash); | |
400 | ||
401 | FoundInExternalDatabase must be set to 1 before return if the user | |
402 | was found in the external database. | |
403 | ||
404 | ParamHash is a Perl parameter hash which can contain at least the | |
405 | following fields. These fields are used to populate RT's users | |
406 | database when the user is created. | |
407 | ||
408 | EmailAddress is the email address that RT should use for this user. | |
409 | Name is the 'Name' attribute RT should use for this user. | |
410 | 'Name' is used for things like access control and user lookups. | |
411 | RealName is what RT should display as the user's name when displaying | |
412 | 'friendly' names | |
413 | ||
414 | =cut | |
415 | ||
416 | sub LookupExternalUserInfo { | |
417 | my $self = shift; | |
418 | my $EmailAddress = shift; | |
419 | my $RealName = shift; | |
420 | ||
421 | my $FoundInExternalDatabase = 1; | |
422 | my %params; | |
423 | ||
424 | #Name is the RT username you want to use for this user. | |
425 | $params{'Name'} = $EmailAddress; | |
426 | $params{'EmailAddress'} = $EmailAddress; | |
427 | $params{'RealName'} = $RealName; | |
428 | ||
429 | return ($FoundInExternalDatabase, %params); | |
430 | } | |
431 | ||
432 | =head2 Head | |
433 | ||
434 | Return the parsed head from this message | |
435 | ||
436 | =cut | |
437 | ||
438 | sub Head { | |
439 | my $self = shift; | |
440 | return $self->Entity->head; | |
441 | } | |
442 | ||
443 | =head2 Entity | |
444 | ||
445 | Return the parsed Entity from this message | |
446 | ||
447 | =cut | |
448 | ||
449 | sub Entity { | |
450 | my $self = shift; | |
451 | return $self->{'entity'}; | |
452 | } | |
453 | ||
454 | ||
455 | ||
456 | =head2 _SetupMIMEParser $parser | |
457 | ||
458 | A private instance method which sets up a mime parser to do its job | |
459 | ||
460 | =cut | |
461 | ||
462 | ||
463 | ## TODO: Does it make sense storing to disk at all? After all, we | |
464 | ## need to put each msg as an in-core scalar before saving it to | |
465 | ## the database, don't we? | |
466 | ||
467 | ## At the same time, we should make sure that we nuke attachments | |
468 | ## Over max size and return them | |
469 | ||
470 | sub _SetupMIMEParser { | |
471 | my $self = shift; | |
472 | my $parser = shift; | |
473 | ||
474 | # Set up output directory for files; we use $RT::VarPath instead | |
475 | # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always | |
476 | # writable. | |
477 | my $tmpdir; | |
478 | if ( -w $RT::VarPath ) { | |
479 | $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 ); | |
480 | } elsif (-w File::Spec->tmpdir) { | |
481 | $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 ); | |
482 | } else { | |
483 | $RT::Logger->crit("Neither the RT var directory ($RT::VarPath) nor the system tmpdir (@{[File::Spec->tmpdir]}) are writable; falling back to in-memory parsing!"); | |
484 | } | |
485 | ||
486 | #If someone includes a message, extract it | |
487 | $parser->extract_nested_messages(1); | |
488 | $parser->extract_uuencode(1); ### default is false | |
489 | ||
490 | if ($tmpdir) { | |
491 | # If we got a writable tmpdir, write to disk | |
492 | push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir ); | |
493 | $parser->output_dir($tmpdir); | |
494 | $parser->filer->ignore_filename(1); | |
495 | ||
496 | # Set up the prefix for files with auto-generated names: | |
497 | $parser->output_prefix("part"); | |
498 | ||
499 | # From the MIME::Parser docs: | |
500 | # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope" | |
501 | # Turns out that the default is to recycle tempfiles | |
502 | # Temp files should never be recycled, especially when running under perl taint checking | |
503 | ||
504 | $parser->tmp_recycling(0) if $parser->can('tmp_recycling'); | |
505 | } else { | |
506 | # Otherwise, fall back to storing it in memory | |
507 | $parser->output_to_core(1); | |
508 | $parser->tmp_to_core(1); | |
509 | $parser->use_inner_files(1); | |
510 | } | |
511 | ||
512 | } | |
513 | ||
514 | =head2 ParseEmailAddress string | |
515 | ||
516 | Returns a list of Email::Address objects | |
517 | Works around the bug that Email::Address 1.889 and earlier | |
518 | doesn't handle local-only email addresses (when users pass | |
519 | in just usernames on the RT system in fields that expect | |
520 | Email Addresses) | |
521 | ||
522 | We don't handle the case of | |
523 | bob, fred@bestpractical.com | |
524 | because we don't want to fail parsing | |
525 | bob, "Falcone, Fred" <fred@bestpractical.com> | |
526 | The next release of Email::Address will have a new method | |
527 | we can use that removes the bandaid | |
528 | ||
529 | =cut | |
530 | ||
531 | sub ParseEmailAddress { | |
532 | my $self = shift; | |
533 | my $address_string = shift; | |
534 | ||
535 | $address_string =~ s/^\s+|\s+$//g; | |
536 | ||
537 | my @addresses; | |
538 | # if it looks like a username / local only email | |
539 | if ($address_string !~ /@/ && $address_string =~ /^\w+$/) { | |
540 | my $user = RT::User->new( RT->SystemUser ); | |
541 | my ($id, $msg) = $user->Load($address_string); | |
542 | if ($id) { | |
543 | push @addresses, Email::Address->new($user->Name,$user->EmailAddress); | |
544 | } else { | |
545 | $RT::Logger->error("Unable to parse an email address from $address_string: $msg"); | |
546 | } | |
547 | } else { | |
548 | @addresses = Email::Address->parse($address_string); | |
549 | } | |
550 | ||
551 | return @addresses; | |
552 | ||
553 | } | |
554 | ||
555 | =head2 RescueOutlook | |
556 | ||
557 | Outlook 2007/2010 have a bug when you write an email with the html format. | |
558 | it will send a 'multipart/alternative' with both 'text/plain' and 'text/html' | |
559 | in it. it's cool to have a 'text/plain' part, but the problem is the part is | |
560 | not so right: all the "\n" in your main message will become "\n\n" :/ | |
561 | ||
562 | this method will fix this bug, i.e. replaces "\n\n" to "\n". | |
563 | return 1 if it does find the problem in the entity and get it fixed. | |
564 | ||
565 | =cut | |
566 | ||
567 | ||
568 | sub RescueOutlook { | |
569 | my $self = shift; | |
570 | my $mime = $self->Entity(); | |
571 | return unless $mime; | |
572 | ||
573 | my $mailer = $mime->head->get('X-Mailer'); | |
574 | # 12.0 is outlook 2007, 14.0 is 2010 | |
575 | if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ ) { | |
576 | my $text_part; | |
577 | if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) { | |
578 | my $first = $mime->parts(0); | |
579 | if ( $first->head->get('Content-Type') =~ m{multipart/alternative} ) | |
580 | { | |
581 | my $inner_first = $first->parts(0); | |
582 | if ( $inner_first->head->get('Content-Type') =~ m{text/plain} ) | |
583 | { | |
584 | $text_part = $inner_first; | |
585 | } | |
586 | } | |
587 | } | |
588 | elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) { | |
589 | my $first = $mime->parts(0); | |
590 | if ( $first->head->get('Content-Type') =~ m{text/plain} ) { | |
591 | $text_part = $first; | |
592 | } | |
593 | } | |
594 | ||
595 | if ($text_part) { | |
596 | ||
597 | # use the unencoded string | |
598 | my $content = $text_part->bodyhandle->as_string; | |
599 | if ( $content =~ s/\n\n/\n/g ) { | |
600 | # only write only if we did change the content | |
601 | if ( my $io = $text_part->open("w") ) { | |
602 | $io->print($content); | |
603 | $io->close; | |
604 | return 1; | |
605 | } | |
606 | else { | |
607 | $RT::Logger->error("can't write to body"); | |
608 | } | |
609 | } | |
610 | } | |
611 | } | |
612 | return; | |
613 | } | |
614 | ||
615 | ||
616 | sub DESTROY { | |
617 | my $self = shift; | |
618 | File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1) | |
619 | if $self->{'AttachmentDirs'}; | |
620 | } | |
621 | ||
622 | ||
623 | ||
624 | RT::Base->_ImportOverlays(); | |
625 | ||
626 | 1; |