rt/lib/RT/EmailParser.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2015 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( 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     #If for some reason we weren't able to parse the message using a temp file
 135     # try it with a scalar
 136     if ( $@ || !$self->Entity ) {
 137         return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} );
 138     }
 139
 140 }
 141
 142
 143 =head2 ParseMIMEEntityFromSTDIN
 144
 145 Parse a message from standard input
 146
 147 =cut
 148
 149 sub ParseMIMEEntityFromSTDIN {
 150     my $self = shift;
 151     return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_);
 152 }
 153
 154 =head2 ParseMIMEEntityFromScalar  $message
 155
 156 Takes either a scalar or a reference to a scalar which contains a stringified MIME message.
 157 Parses it.
 158
 159 Returns true if it wins.
 160 Returns false if it loses.
 161
 162 =cut
 163
 164 sub ParseMIMEEntityFromScalar {
 165     my $self = shift;
 166     return $self->_ParseMIMEEntity( shift, 'parse_data', @_ );
 167 }
 168
 169 =head2 ParseMIMEEntityFromFilehandle *FH
 170
 171 Parses a mime entity from a filehandle passed in as an argument
 172
 173 =cut
 174
 175 sub ParseMIMEEntityFromFileHandle {
 176     my $self = shift;
 177     return $self->_ParseMIMEEntity( shift, 'parse', @_ );
 178 }
 179
 180 =head2 ParseMIMEEntityFromFile
 181
 182 Parses a mime entity from a filename passed in as an argument
 183
 184 =cut
 185
 186 sub ParseMIMEEntityFromFile {
 187     my $self = shift;
 188     return $self->_ParseMIMEEntity( shift, 'parse_open', @_ );
 189 }
 190
 191
 192 sub _ParseMIMEEntity {
 193     my $self = shift;
 194     my $message = shift;
 195     my $method = shift;
 196     my $postprocess = (@_ ? shift : 1);
 197     my $exact = shift;
 198
 199     # Create a new parser object:
 200     my $parser = MIME::Parser->new();
 201     $self->_SetupMIMEParser($parser);
 202     $parser->decode_bodies(0) if $exact;
 203
 204     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 205     unless ( $self->{'entity'} = $parser->$method($message) ) {
 206         $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
 207         # Try again, this time without extracting nested messages
 208         $parser->extract_nested_messages(0);
 209         unless ( $self->{'entity'} = $parser->$method($message) ) {
 210             $RT::Logger->crit("couldn't parse MIME stream");
 211             return ( undef);
 212         }
 213     }
 214
 215     $self->_PostProcessNewEntity if $postprocess;
 216
 217     return $self->{'entity'};
 218 }
 219
 220 sub _DecodeBodies {
 221     my $self = shift;
 222     return unless $self->{'entity'};
 223
 224     my @parts = $self->{'entity'}->parts_DFS;
 225     $self->_DecodeBody($_) foreach @parts;
 226 }
 227
 228 sub _DecodeBody {
 229     my $self = shift;
 230     my $entity = shift;
 231
 232     my $old = $entity->bodyhandle or return;
 233     return unless $old->is_encoded;
 234
 235     require MIME::Decoder;
 236     my $encoding = $entity->head->mime_encoding;
 237     my $decoder = MIME::Decoder->new($encoding);
 238     unless ( $decoder ) {
 239         $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary");
 240         $old->is_encoded(0);
 241         return;
 242     }
 243
 244     require MIME::Body;
 245     # XXX: use InCore for now, but later must switch to files
 246     my $new = MIME::Body::InCore->new();
 247     $new->binmode(1);
 248     $new->is_encoded(0);
 249
 250     my $source = $old->open('r') or die "couldn't open body: $!";
 251     my $destination = $new->open('w') or die "couldn't open body: $!";
 252     {
 253         local $@;
 254         eval { $decoder->decode($source, $destination) };
 255         $RT::Logger->error($@) if $@;
 256     }
 257     $source->close or die "can't close: $!";
 258     $destination->close or die "can't close: $!";
 259
 260     $entity->bodyhandle( $new );
 261 }
 262
 263 =head2 _PostProcessNewEntity
 264
 265 cleans up and postprocesses a newly parsed MIME Entity
 266
 267 =cut
 268
 269 sub _PostProcessNewEntity {
 270     my $self = shift;
 271
 272     #Now we've got a parsed mime object.
 273
 274     # Unfold headers that are have embedded newlines
 275     #  Better do this before conversion or it will break
 276     #  with multiline encoded Subject (RFC2047) (fsck.com #5594)
 277     $self->Head->unfold;
 278
 279     # try to convert text parts into utf-8 charset
 280     RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
 281 }
 282
 283 =head2 ParseCcAddressesFromHead HASHREF
 284
 285 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 286 Returns a list of all email addresses in the To and Cc
 287 headers b<except> the current Queue's email addresses, the CurrentUser's
 288 email address and anything that the RT->Config->Get('RTAddressRegexp') matches.
 289
 290 =cut
 291
 292 sub ParseCcAddressesFromHead {
 293     my $self = shift;
 294     my %args = (
 295         QueueObj    => undef,
 296         CurrentUser => undef,
 297         @_
 298     );
 299
 300     my (@Addresses);
 301
 302     my @ToObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('To') ) );
 303     my @CcObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('Cc') ) );
 304
 305     foreach my $AddrObj ( @ToObjs, @CcObjs ) {
 306         my $Address = $AddrObj->address;
 307         my $user = RT::User->new(RT->SystemUser);
 308         $Address = $user->CanonicalizeEmailAddress($Address);
 309         next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address;
 310         next if $self->IsRTAddress($Address);
 311
 312         push ( @Addresses, $Address );
 313     }
 314     return (@Addresses);
 315 }
 316
 317
 318 =head2 IsRTaddress ADDRESS
 319
 320 Takes a single parameter, an email address.
 321 Returns true if that address matches the C<RTAddressRegexp> config option.
 322 Returns false, otherwise.
 323
 324
 325 =cut
 326
 327 sub IsRTAddress {
 328     my $self = shift;
 329     my $address = shift;
 330
 331     return undef unless defined($address) and $address =~ /\S/;
 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     $self->CleanupAddresses(@addresses);
 552
 553     return @addresses;
 554
 555 }
 556
 557 =head2 CleanupAddresses ARRAY
 558
 559 Massages an array of L<Email::Address> objects to make their email addresses
 560 more palatable.
 561
 562 Currently this strips off surrounding single quotes around C<< ->address >> and
 563 B<< modifies the L<Email::Address> objects in-place >>.
 564
 565 Returns the list of objects for convienence in C<map>/C<grep> chains.
 566
 567 =cut
 568
 569 sub CleanupAddresses {
 570     my $self = shift;
 571
 572     for my $addr (@_) {
 573         next unless defined $addr;
 574         # Outlook sometimes sends addresses surrounded by single quotes;
 575         # clean them all up
 576         if ((my $email = $addr->address) =~ s/^'(.+)'$/$1/) {
 577             $addr->address($email);
 578         }
 579     }
 580     return @_;
 581 }
 582
 583 =head2 RescueOutlook
 584
 585 Outlook 2007/2010 have a bug when you write an email with the html format.
 586 it will send a 'multipart/alternative' with both 'text/plain' and 'text/html'
 587 in it.  it's cool to have a 'text/plain' part, but the problem is the part is
 588 not so right: all the "\n" in your main message will become "\n\n" :/
 589
 590 this method will fix this bug, i.e. replaces "\n\n" to "\n".
 591 return 1 if it does find the problem in the entity and get it fixed.
 592
 593 =cut
 594
 595
 596 sub RescueOutlook {
 597     my $self = shift;
 598     my $mime = $self->Entity();
 599     return unless $mime && $self->LooksLikeMSEmail($mime);
 600
 601     my $text_part;
 602     if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) {
 603         my $first = $mime->parts(0);
 604         if ( $first && $first->head->get('Content-Type') =~ m{multipart/alternative} )
 605         {
 606             my $inner_first = $first->parts(0);
 607             if ( $inner_first && $inner_first->head->get('Content-Type') =~ m{text/plain} )
 608             {
 609                 $text_part = $inner_first;
 610             }
 611         }
 612     }
 613     elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) {
 614         my $first = $mime->parts(0);
 615         if ( $first && $first->head->get('Content-Type') =~ m{text/plain} ) {
 616             $text_part = $first;
 617         }
 618     }
 619
 620     # Add base64 since we've seen examples of double newlines with
 621     # this type too. Need an example of a multi-part base64 to
 622     # handle that permutation if it exists.
 623     elsif ( ($mime->head->get('Content-Transfer-Encoding')||'') =~ m{base64} ) {
 624         $text_part = $mime;    # Assuming single part, already decoded.
 625     }
 626
 627     if ($text_part) {
 628
 629         # use the unencoded string
 630         my $content = $text_part->bodyhandle->as_string;
 631         if ( $content =~ s/\n\n/\n/g ) {
 632
 633             # Outlook puts a space on extra newlines, remove it
 634             $content =~ s/\ +$//mg;
 635
 636             # only write only if we did change the content
 637             if ( my $io = $text_part->open("w") ) {
 638                 $io->print($content);
 639                 $io->close;
 640                 $RT::Logger->debug(
 641                     "Removed extra newlines from MS Outlook message.");
 642                 return 1;
 643             }
 644             else {
 645                 $RT::Logger->error("Can't write to body to fix newlines");
 646             }
 647         }
 648     }
 649
 650     return;
 651 }
 652
 653 =head1 LooksLikeMSEmail
 654
 655 Try to determine if the current email may have
 656 come from MS Outlook or gone through Exchange, and therefore
 657 may have extra newlines added.
 658
 659 =cut
 660
 661 sub LooksLikeMSEmail {
 662     my $self = shift;
 663     my $mime = shift;
 664
 665     my $mailer = $mime->head->get('X-Mailer');
 666
 667     # 12.0 is outlook 2007, 14.0 is 2010
 668     return 1 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ );
 669
 670     if ( RT->Config->Get('CheckMoreMSMailHeaders') ) {
 671
 672         # Check for additional headers that might
 673         # indicate this came from Outlook or through Exchange.
 674         # A sample we received had the headers X-MS-Has-Attach: and
 675         # X-MS-Tnef-Correlator: and both had no value.
 676
 677         my @tags = $mime->head->tags();
 678         return 1 if grep { /^X-MS-/ } @tags;
 679     }
 680
 681     return 0;    # Doesn't look like MS email.
 682 }
 683
 684 sub DESTROY {
 685     my $self = shift;
 686     File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1)
 687         if $self->{'AttachmentDirs'};
 688 }
 689
 690
 691
 692 RT::Base->_ImportOverlays();
 693
 694 1;