rt/lib/RT/EmailParser.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2016 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                 my $entity = $self->ParseMIMEEntityFromFile( $temp_file, $args{'Decode'}, $args{'Exact'} );
 126                 unlink($temp_file);
 127                 return $entity;
 128             }
 129         }
 130     };
 131
 132     #If for some reason we weren't able to parse the message using a temp file
 133     # try it with a scalar
 134     if ( $@ || !$self->Entity ) {
 135         return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} );
 136     }
 137
 138 }
 139
 140
 141 =head2 ParseMIMEEntityFromSTDIN
 142
 143 Parse a message from standard input
 144
 145 =cut
 146
 147 sub ParseMIMEEntityFromSTDIN {
 148     my $self = shift;
 149     return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_);
 150 }
 151
 152 =head2 ParseMIMEEntityFromScalar  $message
 153
 154 Takes either a scalar or a reference to a scalar which contains a stringified MIME message.
 155 Parses it.
 156
 157 Returns true if it wins.
 158 Returns false if it loses.
 159
 160 =cut
 161
 162 sub ParseMIMEEntityFromScalar {
 163     my $self = shift;
 164     return $self->_ParseMIMEEntity( shift, 'parse_data', @_ );
 165 }
 166
 167 =head2 ParseMIMEEntityFromFilehandle *FH
 168
 169 Parses a mime entity from a filehandle passed in as an argument
 170
 171 =cut
 172
 173 sub ParseMIMEEntityFromFileHandle {
 174     my $self = shift;
 175     return $self->_ParseMIMEEntity( shift, 'parse', @_ );
 176 }
 177
 178 =head2 ParseMIMEEntityFromFile
 179
 180 Parses a mime entity from a filename passed in as an argument
 181
 182 =cut
 183
 184 sub ParseMIMEEntityFromFile {
 185     my $self = shift;
 186     return $self->_ParseMIMEEntity( shift, 'parse_open', @_ );
 187 }
 188
 189
 190 sub _ParseMIMEEntity {
 191     my $self = shift;
 192     my $message = shift;
 193     my $method = shift;
 194     my $postprocess = (@_ ? shift : 1);
 195     my $exact = shift;
 196
 197     # Create a new parser object:
 198     my $parser = MIME::Parser->new();
 199     $self->_SetupMIMEParser($parser);
 200     $parser->decode_bodies(0) if $exact;
 201
 202     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 203     unless ( $self->{'entity'} = $parser->$method($message) ) {
 204         $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
 205         # Try again, this time without extracting nested messages
 206         $parser->extract_nested_messages(0);
 207         unless ( $self->{'entity'} = $parser->$method($message) ) {
 208             $RT::Logger->crit("couldn't parse MIME stream");
 209             return ( undef);
 210         }
 211     }
 212
 213     $self->_PostProcessNewEntity if $postprocess;
 214
 215     return $self->{'entity'};
 216 }
 217
 218 sub _DecodeBodies {
 219     my $self = shift;
 220     return unless $self->{'entity'};
 221
 222     my @parts = $self->{'entity'}->parts_DFS;
 223     $self->_DecodeBody($_) foreach @parts;
 224 }
 225
 226 sub _DecodeBody {
 227     my $self = shift;
 228     my $entity = shift;
 229
 230     my $old = $entity->bodyhandle or return;
 231     return unless $old->is_encoded;
 232
 233     require MIME::Decoder;
 234     my $encoding = $entity->head->mime_encoding;
 235     my $decoder = MIME::Decoder->new($encoding);
 236     unless ( $decoder ) {
 237         $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary");
 238         $old->is_encoded(0);
 239         return;
 240     }
 241
 242     require MIME::Body;
 243     # XXX: use InCore for now, but later must switch to files
 244     my $new = MIME::Body::InCore->new();
 245     $new->binmode(1);
 246     $new->is_encoded(0);
 247
 248     my $source = $old->open('r') or die "couldn't open body: $!";
 249     my $destination = $new->open('w') or die "couldn't open body: $!";
 250     {
 251         local $@;
 252         eval { $decoder->decode($source, $destination) };
 253         $RT::Logger->error($@) if $@;
 254     }
 255     $source->close or die "can't close: $!";
 256     $destination->close or die "can't close: $!";
 257
 258     $entity->bodyhandle( $new );
 259 }
 260
 261 =head2 _PostProcessNewEntity
 262
 263 cleans up and postprocesses a newly parsed MIME Entity
 264
 265 =cut
 266
 267 sub _PostProcessNewEntity {
 268     my $self = shift;
 269
 270     #Now we've got a parsed mime object.
 271
 272     # Unfold headers that are have embedded newlines
 273     #  Better do this before conversion or it will break
 274     #  with multiline encoded Subject (RFC2047) (fsck.com #5594)
 275     $self->Head->unfold;
 276
 277     # try to convert text parts into utf-8 charset
 278     RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
 279 }
 280
 281 =head2 ParseCcAddressesFromHead HASHREF
 282
 283 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 284 Returns a list of all email addresses in the To and Cc
 285 headers b<except> the current Queue's email addresses, the CurrentUser's
 286 email address and anything that the RT->Config->Get('RTAddressRegexp') matches.
 287
 288 =cut
 289
 290 sub ParseCcAddressesFromHead {
 291     my $self = shift;
 292     my %args = (
 293         QueueObj    => undef,
 294         CurrentUser => undef,
 295         @_
 296     );
 297
 298     my (@Addresses);
 299
 300     my @ToObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('To') ) );
 301     my @CcObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('Cc') ) );
 302
 303     foreach my $AddrObj ( @ToObjs, @CcObjs ) {
 304         my $Address = $AddrObj->address;
 305         my $user = RT::User->new(RT->SystemUser);
 306         $Address = $user->CanonicalizeEmailAddress($Address);
 307         next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address;
 308         next if $self->IsRTAddress($Address);
 309
 310         push ( @Addresses, $Address );
 311     }
 312     return (@Addresses);
 313 }
 314
 315
 316 =head2 IsRTaddress ADDRESS
 317
 318 Takes a single parameter, an email address.
 319 Returns true if that address matches the C<RTAddressRegexp> config option.
 320 Returns false, otherwise.
 321
 322
 323 =cut
 324
 325 sub IsRTAddress {
 326     my $self = shift;
 327     my $address = shift;
 328
 329     return undef unless defined($address) and $address =~ /\S/;
 330
 331     if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) {
 332         return $address =~ /$address_re/i ? 1 : undef;
 333     }
 334
 335     # we don't warn here, but do in config check
 336     if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) {
 337         return 1 if lc $correspond_address eq lc $address;
 338     }
 339     if ( my $comment_address = RT->Config->Get('CommentAddress') ) {
 340         return 1 if lc $comment_address eq lc $address;
 341     }
 342
 343     my $queue = RT::Queue->new( RT->SystemUser );
 344     $queue->LoadByCols( CorrespondAddress => $address );
 345     return 1 if $queue->id;
 346
 347     $queue->LoadByCols( CommentAddress => $address );
 348     return 1 if $queue->id;
 349
 350     return undef;
 351 }
 352
 353
 354 =head2 CullRTAddresses ARRAY
 355
 356 Takes a single argument, an array of email addresses.
 357 Returns the same array with any IsRTAddress()es weeded out.
 358
 359
 360 =cut
 361
 362 sub CullRTAddresses {
 363     my $self = shift;
 364     my @addresses = (@_);
 365
 366     return grep { !$self->IsRTAddress($_) } @addresses;
 367 }
 368
 369
 370
 371
 372
 373 # LookupExternalUserInfo is a site-definable method for synchronizing
 374 # incoming users with an external data source.
 375 #
 376 # This routine takes a tuple of EmailAddress and FriendlyName
 377 #   EmailAddress is the user's email address, ususally taken from
 378 #       an email message's From: header.
 379 #   FriendlyName is a freeform string, ususally taken from the "comment"
 380 #       portion of an email message's From: header.
 381 #
 382 # If you define an AutoRejectRequest template, RT will use this
 383 # template for the rejection message.
 384
 385
 386 =head2 LookupExternalUserInfo
 387
 388  LookupExternalUserInfo is a site-definable method for synchronizing
 389  incoming users with an external data source.
 390
 391  This routine takes a tuple of EmailAddress and FriendlyName
 392     EmailAddress is the user's email address, ususally taken from
 393         an email message's From: header.
 394     FriendlyName is a freeform string, ususally taken from the "comment"
 395         portion of an email message's From: header.
 396
 397  It returns (FoundInExternalDatabase, ParamHash);
 398
 399    FoundInExternalDatabase must  be set to 1 before return if the user
 400    was found in the external database.
 401
 402    ParamHash is a Perl parameter hash which can contain at least the
 403    following fields. These fields are used to populate RT's users
 404    database when the user is created.
 405
 406     EmailAddress is the email address that RT should use for this user.
 407     Name is the 'Name' attribute RT should use for this user.
 408          'Name' is used for things like access control and user lookups.
 409     RealName is what RT should display as the user's name when displaying
 410          'friendly' names
 411
 412 =cut
 413
 414 sub LookupExternalUserInfo {
 415   my $self = shift;
 416   my $EmailAddress = shift;
 417   my $RealName = shift;
 418
 419   my $FoundInExternalDatabase = 1;
 420   my %params;
 421
 422   #Name is the RT username you want to use for this user.
 423   $params{'Name'} = $EmailAddress;
 424   $params{'EmailAddress'} = $EmailAddress;
 425   $params{'RealName'} = $RealName;
 426
 427   return ($FoundInExternalDatabase, %params);
 428 }
 429
 430 =head2 Head
 431
 432 Return the parsed head from this message
 433
 434 =cut
 435
 436 sub Head {
 437     my $self = shift;
 438     return $self->Entity->head;
 439 }
 440
 441 =head2 Entity
 442
 443 Return the parsed Entity from this message
 444
 445 =cut
 446
 447 sub Entity {
 448     my $self = shift;
 449     return $self->{'entity'};
 450 }
 451
 452
 453
 454 =head2 _SetupMIMEParser $parser
 455
 456 A private instance method which sets up a mime parser to do its job
 457
 458 =cut
 459
 460
 461     ## TODO: Does it make sense storing to disk at all?  After all, we
 462     ## need to put each msg as an in-core scalar before saving it to
 463     ## the database, don't we?
 464
 465     ## At the same time, we should make sure that we nuke attachments
 466     ## Over max size and return them
 467
 468 sub _SetupMIMEParser {
 469     my $self   = shift;
 470     my $parser = shift;
 471
 472     # Set up output directory for files; we use $RT::VarPath instead
 473     # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always
 474     # writable.
 475     my $tmpdir;
 476     if ( -w $RT::VarPath ) {
 477         $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 );
 478     } elsif (-w File::Spec->tmpdir) {
 479         $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
 480     } else {
 481         $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!");
 482     }
 483
 484     #If someone includes a message, extract it
 485     $parser->extract_nested_messages(1);
 486     $parser->extract_uuencode(1);    ### default is false
 487
 488     if ($tmpdir) {
 489         # If we got a writable tmpdir, write to disk
 490         push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir );
 491         $parser->output_dir($tmpdir);
 492         $parser->filer->ignore_filename(1);
 493
 494         # Set up the prefix for files with auto-generated names:
 495         $parser->output_prefix("part");
 496
 497         # From the MIME::Parser docs:
 498         # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
 499         # Turns out that the default is to recycle tempfiles
 500         # Temp files should never be recycled, especially when running under perl taint checking
 501
 502         $parser->tmp_recycling(0) if $parser->can('tmp_recycling');
 503     } else {
 504         # Otherwise, fall back to storing it in memory
 505         $parser->output_to_core(1);
 506         $parser->tmp_to_core(1);
 507         $parser->use_inner_files(1);
 508     }
 509
 510 }
 511
 512 =head2 ParseEmailAddress string
 513
 514 Returns a list of Email::Address objects
 515 Works around the bug that Email::Address 1.889 and earlier
 516 doesn't handle local-only email addresses (when users pass
 517 in just usernames on the RT system in fields that expect
 518 Email Addresses)
 519
 520 We don't handle the case of
 521 bob, fred@bestpractical.com
 522 because we don't want to fail parsing
 523 bob, "Falcone, Fred" <fred@bestpractical.com>
 524 The next release of Email::Address will have a new method
 525 we can use that removes the bandaid
 526
 527 =cut
 528
 529 use Email::Address::List;
 530
 531 sub ParseEmailAddress {
 532     my $self = shift;
 533     my $address_string = shift;
 534
 535     my @list = Email::Address::List->parse(
 536         $address_string,
 537         skip_comments => 1,
 538         skip_groups => 1,
 539     );
 540     my $logger = sub { RT->Logger->error(
 541         "Unable to parse an email address from $address_string: ". shift
 542     ) };
 543
 544     my @addresses;
 545     foreach my $e ( @list ) {
 546         if ($e->{'type'} eq 'mailbox') {
 547             if ($e->{'not_ascii'}) {
 548                 $logger->($e->{'value'} ." contains not ASCII values");
 549                 next;
 550             }
 551             push @addresses, $e->{'value'}
 552         } elsif ( $e->{'value'} =~ /^\s*(\w+)\s*$/ ) {
 553             my $user = RT::User->new( RT->SystemUser );
 554             $user->Load( $1 );
 555             if ($user->id) {
 556                 push @addresses, Email::Address->new($user->Name, $user->EmailAddress);
 557             } else {
 558                 $logger->($e->{'value'} ." is not a valid email address and is not user name");
 559             }
 560         } else {
 561             $logger->($e->{'value'} ." is not a valid email address");
 562         }
 563     }
 564
 565     $self->CleanupAddresses(@addresses);
 566
 567     return @addresses;
 568 }
 569
 570 =head2 CleanupAddresses ARRAY
 571
 572 Massages an array of L<Email::Address> objects to make their email addresses
 573 more palatable.
 574
 575 Currently this strips off surrounding single quotes around C<< ->address >> and
 576 B<< modifies the L<Email::Address> objects in-place >>.
 577
 578 Returns the list of objects for convienence in C<map>/C<grep> chains.
 579
 580 =cut
 581
 582 sub CleanupAddresses {
 583     my $self = shift;
 584
 585     for my $addr (@_) {
 586         next unless defined $addr;
 587         # Outlook sometimes sends addresses surrounded by single quotes;
 588         # clean them all up
 589         if ((my $email = $addr->address) =~ s/^'(.+)'$/$1/) {
 590             $addr->address($email);
 591         }
 592     }
 593     return @_;
 594 }
 595
 596 =head2 RescueOutlook
 597
 598 Outlook 2007/2010 have a bug when you write an email with the html format.
 599 it will send a 'multipart/alternative' with both 'text/plain' and 'text/html'
 600 in it.  it's cool to have a 'text/plain' part, but the problem is the part is
 601 not so right: all the "\n" in your main message will become "\n\n" :/
 602
 603 this method will fix this bug, i.e. replaces "\n\n" to "\n".
 604 return 1 if it does find the problem in the entity and get it fixed.
 605
 606 =cut
 607
 608
 609 sub RescueOutlook {
 610     my $self = shift;
 611     my $mime = $self->Entity();
 612     return unless $mime && $self->LooksLikeMSEmail($mime);
 613
 614     my $text_part;
 615     if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) {
 616         my $first = $mime->parts(0);
 617         if ( $first && $first->head->get('Content-Type') =~ m{multipart/alternative} )
 618         {
 619             my $inner_first = $first->parts(0);
 620             if ( $inner_first && $inner_first->head->get('Content-Type') =~ m{text/plain} )
 621             {
 622                 $text_part = $inner_first;
 623             }
 624         }
 625     }
 626     elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) {
 627         my $first = $mime->parts(0);
 628         if ( $first && $first->head->get('Content-Type') =~ m{text/plain} ) {
 629             $text_part = $first;
 630         }
 631     }
 632
 633     # Add base64 since we've seen examples of double newlines with
 634     # this type too. Need an example of a multi-part base64 to
 635     # handle that permutation if it exists.
 636     elsif ( ($mime->head->get('Content-Transfer-Encoding')||'') =~ m{base64} ) {
 637         $text_part = $mime;    # Assuming single part, already decoded.
 638     }
 639
 640     if ($text_part) {
 641
 642         # use the unencoded string
 643         my $content = $text_part->bodyhandle->as_string;
 644         if ( $content =~ s/\n\n/\n/g ) {
 645
 646             # Outlook puts a space on extra newlines, remove it
 647             $content =~ s/\ +$//mg;
 648
 649             # only write only if we did change the content
 650             if ( my $io = $text_part->open("w") ) {
 651                 $io->print($content);
 652                 $io->close;
 653                 $RT::Logger->debug(
 654                     "Removed extra newlines from MS Outlook message.");
 655                 return 1;
 656             }
 657             else {
 658                 $RT::Logger->error("Can't write to body to fix newlines");
 659             }
 660         }
 661     }
 662
 663     return;
 664 }
 665
 666 =head1 LooksLikeMSEmail
 667
 668 Try to determine if the current email may have
 669 come from MS Outlook or gone through Exchange, and therefore
 670 may have extra newlines added.
 671
 672 =cut
 673
 674 sub LooksLikeMSEmail {
 675     my $self = shift;
 676     my $mime = shift;
 677
 678     my $mailer = $mime->head->get('X-Mailer');
 679
 680     # 12.0 is outlook 2007, 14.0 is 2010
 681     return 1 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ );
 682
 683     if ( RT->Config->Get('CheckMoreMSMailHeaders') ) {
 684
 685         # Check for additional headers that might
 686         # indicate this came from Outlook or through Exchange.
 687         # A sample we received had the headers X-MS-Has-Attach: and
 688         # X-MS-Tnef-Correlator: and both had no value.
 689
 690         my @tags = $mime->head->tags();
 691         return 1 if grep { /^X-MS-/ } @tags;
 692     }
 693
 694     return 0;    # Doesn't look like MS email.
 695 }
 696
 697 sub DESTROY {
 698     my $self = shift;
 699     File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1)
 700         if $self->{'AttachmentDirs'};
 701 }
 702
 703
 704
 705 RT::Base->_ImportOverlays();
 706
 707 1;