rt/lib/RT/EmailParser.pm

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