4cf4184a446dbb2060e53c4e9bb96cde4d115409
[usit-rt.git] / lib / RT / EmailParser.pm
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;