rt/lib/RT/EmailParser.pm

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