rt/lib/RT/EmailParser.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
   6 #                                          <jesse@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., 675 Mass Ave, Cambridge, MA 02139, USA.
  26 #
  27 #
  28 # CONTRIBUTION SUBMISSION POLICY:
  29 #
  30 # (The following paragraph is not intended to limit the rights granted
  31 # to you to modify and distribute this software under the terms of
  32 # the GNU General Public License and is only of importance to you if
  33 # you choose to contribute your changes and enhancements to the
  34 # community by submitting them to Best Practical Solutions, LLC.)
  35 #
  36 # By intentionally submitting any modifications, corrections or
  37 # derivatives to this work, or any other work intended for use with
  38 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  39 # you are the copyright holder for those contributions and you grant
  40 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  41 # royalty-free, perpetual, license to use, copy, create derivative
  42 # works based on those contributions, and sublicense and distribute
  43 # those contributions and any derivatives thereof.
  44 #
  45 # END BPS TAGGED BLOCK }}}
  46 package RT::EmailParser;
  47
  48
  49 use base qw/RT::Base/;
  50
  51 use strict;
  52 use Mail::Address;
  53 use MIME::Entity;
  54 use MIME::Head;
  55 use MIME::Parser;
  56 use File::Temp qw/tempdir/;
  57
  58 =head1 NAME
  59
  60   RT::EmailParser - helper functions for parsing parts from incoming
  61   email messages
  62
  63 =head1 SYNOPSIS
  64
  65
  66 =head1 DESCRIPTION
  67
  68
  69 =begin testing
  70
  71 ok(require RT::EmailParser);
  72
  73 =end testing
  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 # {{{ sub SmartParseMIMEEntityFromScalar
  94
  95 =head2 SmartParseMIMEEntityFromScalar { Message => SCALAR_REF, Decode => BOOL }
  96
  97 Parse a message stored in a scalar from scalar_ref
  98
  99 =cut
 100
 101 sub SmartParseMIMEEntityFromScalar {
 102     my $self = shift;
 103     my %args = ( Message => undef, Decode => 1, @_ );
 104
 105     my ( $fh, $temp_file );
 106     eval {
 107
 108         for ( 1 .. 10 ) {
 109
 110             # on NFS and NTFS, it is possible that tempfile() conflicts
 111             # with other processes, causing a race condition. we try to
 112             # accommodate this by pausing and retrying.
 113             last
 114               if ( $fh, $temp_file ) =
 115               eval { File::Temp::tempfile( undef, UNLINK => 0 ) };
 116             sleep 1;
 117         }
 118         if ($fh) {
 119
 120             #thank you, windows
 121             binmode $fh;
 122             $fh->autoflush(1);
 123             print $fh $args{'Message'};
 124             close($fh);
 125             if ( -f $temp_file ) {
 126
 127                 # We have to trust the temp file's name -- untaint it
 128                 $temp_file =~ /(.*)/;
 129                 $self->ParseMIMEEntityFromFile( $1, $args{'Decode'} );
 130                 unlink($1);
 131             }
 132         }
 133     };
 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         $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'} );
 139     }
 140
 141 }
 142
 143 # }}}
 144
 145 # {{{ sub ParseMIMEEntityFromSTDIN
 146
 147 =head2 ParseMIMEEntityFromSTDIN
 148
 149 Parse a message from standard input
 150
 151 =cut
 152
 153 sub ParseMIMEEntityFromSTDIN {
 154     my $self = shift;
 155     my $postprocess = (@_ ? shift : 1);
 156     return $self->ParseMIMEEntityFromFileHandle(\*STDIN, $postprocess);
 157 }
 158
 159 # }}}
 160
 161 # {{{ ParseMIMEEntityFromScalar
 162
 163 =head2 ParseMIMEEntityFromScalar  $message
 164
 165 Takes either a scalar or a reference to a scalr which contains a stringified MIME message.
 166 Parses it.
 167
 168 Returns true if it wins.
 169 Returns false if it loses.
 170
 171 =cut
 172
 173 sub ParseMIMEEntityFromScalar {
 174     my $self = shift;
 175     my $message = shift;
 176     my $postprocess = (@_ ? shift : 1);
 177     $self->_ParseMIMEEntity($message,'parse_data', $postprocess);
 178 }
 179
 180 # }}}
 181
 182 # {{{ ParseMIMEEntityFromFilehandle *FH
 183
 184 =head2 ParseMIMEEntityFromFilehandle *FH
 185
 186 Parses a mime entity from a filehandle passed in as an argument
 187
 188 =cut
 189
 190 sub ParseMIMEEntityFromFileHandle {
 191     my $self = shift;
 192     my $filehandle = shift;
 193     my $postprocess = (@_ ? shift : 1);
 194     $self->_ParseMIMEEntity($filehandle,'parse', $postprocess);
 195 }
 196
 197 # }}}
 198
 199 # {{{ ParseMIMEEntityFromFile
 200
 201 =head2 ParseMIMEEntityFromFile
 202
 203 Parses a mime entity from a filename passed in as an argument
 204
 205 =cut
 206
 207 sub ParseMIMEEntityFromFile {
 208     my $self = shift;
 209     my $file = shift;
 210     my $postprocess = (@_ ? shift : 1);
 211     $self->_ParseMIMEEntity($file,'parse_open',$postprocess);
 212 }
 213
 214 # }}}
 215
 216 # {{{ _ParseMIMEEntity
 217 sub _ParseMIMEEntity {
 218     my $self = shift;
 219     my $message = shift;
 220     my $method = shift;
 221     my $postprocess = shift;
 222     # Create a new parser object:
 223
 224     my $parser = MIME::Parser->new();
 225     $self->_SetupMIMEParser($parser);
 226
 227
 228     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 229     unless ( $self->{'entity'} = $parser->$method($message) ) {
 230         $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages");
 231         # Try again, this time without extracting nested messages
 232         $parser->extract_nested_messages(0);
 233         unless ( $self->{'entity'} = $parser->$method($message) ) {
 234             $RT::Logger->crit("couldn't parse MIME stream");
 235             return ( undef);
 236         }
 237     }
 238     if ($postprocess) {
 239     $self->_PostProcessNewEntity() ;
 240     }
 241
 242 }
 243
 244 # }}}
 245
 246 # {{{ _PostProcessNewEntity
 247
 248 =head2 _PostProcessNewEntity
 249
 250 cleans up and postprocesses a newly parsed MIME Entity
 251
 252 =cut
 253
 254 sub _PostProcessNewEntity {
 255     my $self = shift;
 256
 257     #Now we've got a parsed mime object.
 258
 259     # Unfold headers that are have embedded newlines
 260     #  Better do this before conversion or it will break
 261     #  with multiline encoded Subject (RFC2047) (fsck.com #5594)
 262
 263     $self->Head->unfold;
 264
 265
 266     # try to convert text parts into utf-8 charset
 267     RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
 268
 269
 270
 271
 272 }
 273
 274 # }}}
 275
 276 # {{{ sub ParseTicketId
 277
 278 sub ParseTicketId {
 279     my $self = shift;
 280     $RT::Logger->warnings("RT::EmailParser->ParseTicketId deprecated. You should be using RT::Interface::Email at (". join(":",caller).")");
 281
 282     require RT::Interface::Email;
 283     RT::Interface::Email::ParseTicketId(@_);
 284 }
 285
 286 # }}}
 287
 288
 289
 290 # {{{ ParseCcAddressesFromHead
 291
 292 =head2 ParseCcAddressesFromHead HASHREF
 293
 294 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 295 Returns a list of all email addresses in the To and Cc
 296 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
 297 email address  and anything that the $RTAddressRegexp matches.
 298
 299 =cut
 300
 301 sub ParseCcAddressesFromHead {
 302
 303     my $self = shift;
 304
 305     my %args = (
 306         QueueObj    => undef,
 307         CurrentUser => undef,
 308         @_
 309     );
 310
 311     my (@Addresses);
 312
 313     my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
 314     my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
 315
 316     foreach my $AddrObj ( @ToObjs, @CcObjs ) {
 317         my $Address = $AddrObj->address;
 318         my $user = RT::User->new($RT::SystemUser);
 319         $Address = $user->CanonicalizeEmailAddress($Address);
 320         next if ( lc $args{'CurrentUser'}->EmailAddress   eq lc $Address );
 321         next if ( lc $args{'QueueObj'}->CorrespondAddress eq lc $Address );
 322         next if ( lc $args{'QueueObj'}->CommentAddress    eq lc $Address );
 323         next if ( $self->IsRTAddress($Address) );
 324
 325         push ( @Addresses, $Address );
 326     }
 327     return (@Addresses);
 328 }
 329
 330 # }}}
 331
 332 # {{{ ParseSenderAdddressFromHead
 333
 334 =head2 ParseSenderAddressFromHead
 335
 336 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
 337 of the From (evaluated in order of Reply-To:, From:, Sender)
 338
 339 =cut
 340
 341 sub ParseSenderAddressFromHead {
 342     my $self = shift;
 343
 344     #Figure out who's sending this message.
 345     my $From = $self->Head->get('Reply-To')
 346       || $self->Head->get('From')
 347       || $self->Head->get('Sender');
 348     return ( $self->ParseAddressFromHeader($From) );
 349 }
 350
 351 # }}}
 352
 353 # {{{ ParseErrorsToAdddressFromHead
 354
 355 =head2 ParseErrorsToAddressFromHead
 356
 357 Takes a MIME::Header object. Return a single value : user@host
 358 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
 359
 360 =cut
 361
 362 sub ParseErrorsToAddressFromHead {
 363     my $self = shift;
 364
 365     #Figure out who's sending this message.
 366
 367     foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
 368
 369         # If there's a header of that name
 370         my $headerobj = $self->Head->get($header);
 371         if ($headerobj) {
 372             my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
 373
 374             # If it's got actual useful content...
 375             return ($addr) if ($addr);
 376         }
 377     }
 378 }
 379
 380 # }}}
 381
 382 # {{{ ParseAddressFromHeader
 383
 384 =head2 ParseAddressFromHeader ADDRESS
 385
 386 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
 387
 388 =cut
 389
 390 sub ParseAddressFromHeader {
 391     my $self = shift;
 392     my $Addr = shift;
 393
 394     # Perl 5.8.0 breaks when doing regex matches on utf8
 395     Encode::_utf8_off($Addr) if $] == 5.008;
 396     my @Addresses = Mail::Address->parse($Addr);
 397
 398     my $AddrObj = $Addresses[0];
 399
 400     unless ( ref($AddrObj) ) {
 401         return ( undef, undef );
 402     }
 403
 404     my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
 405
 406     #Lets take the from and load a user object.
 407     my $Address = $AddrObj->address;
 408
 409     return ( $Address, $Name );
 410 }
 411
 412 # }}}
 413
 414 # {{{ IsRTAddress
 415
 416 =head2 IsRTaddress ADDRESS
 417
 418 Takes a single parameter, an email address.
 419 Returns true if that address matches the $RTAddressRegexp.
 420 Returns false, otherwise.
 421
 422 =begin testing
 423
 424 is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" );
 425 is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" );
 426
 427 =end testing
 428
 429 =cut
 430
 431 sub IsRTAddress {
 432     my $self = shift;
 433     my $address = shift;
 434
 435     # Example: the following rule would tell RT not to Cc
 436     #   "tickets@noc.example.com"
 437     if ( defined($RT::RTAddressRegexp) &&
 438                        $address =~ /$RT::RTAddressRegexp/i ) {
 439         return(1);
 440     } else {
 441         return (undef);
 442     }
 443 }
 444
 445 # }}}
 446
 447
 448 # {{{ CullRTAddresses
 449
 450 =head2 CullRTAddresses ARRAY
 451
 452 Takes a single argument, an array of email addresses.
 453 Returns the same array with any IsRTAddress()es weeded out.
 454
 455 =begin testing
 456
 457 @before = ("rt\@example.com", "frt\@example.com");
 458 @after = ("frt\@example.com");
 459 ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses");
 460
 461 =end testing
 462
 463 =cut
 464
 465 sub CullRTAddresses {
 466     my $self = shift;
 467     my @addresses= (@_);
 468     my @addrlist;
 469
 470     foreach my $addr( @addresses ) {
 471                                  # We use the class instead of the instance
 472                                  # because sloppy code calls this method
 473                                  # without a $self
 474       push (@addrlist, $addr)    unless RT::EmailParser->IsRTAddress($addr);
 475     }
 476     return (@addrlist);
 477 }
 478
 479 # }}}
 480
 481
 482 # {{{ LookupExternalUserInfo
 483
 484
 485 # LookupExternalUserInfo is a site-definable method for synchronizing
 486 # incoming users with an external data source.
 487 #
 488 # This routine takes a tuple of EmailAddress and FriendlyName
 489 #   EmailAddress is the user's email address, ususally taken from
 490 #       an email message's From: header.
 491 #   FriendlyName is a freeform string, ususally taken from the "comment"
 492 #       portion of an email message's From: header.
 493 #
 494 # If you define an AutoRejectRequest template, RT will use this
 495 # template for the rejection message.
 496
 497
 498 =head2 LookupExternalUserInfo
 499
 500  LookupExternalUserInfo is a site-definable method for synchronizing
 501  incoming users with an external data source.
 502
 503  This routine takes a tuple of EmailAddress and FriendlyName
 504     EmailAddress is the user's email address, ususally taken from
 505         an email message's From: header.
 506     FriendlyName is a freeform string, ususally taken from the "comment"
 507         portion of an email message's From: header.
 508
 509  It returns (FoundInExternalDatabase, ParamHash);
 510
 511    FoundInExternalDatabase must  be set to 1 before return if the user
 512    was found in the external database.
 513
 514    ParamHash is a Perl parameter hash which can contain at least the
 515    following fields. These fields are used to populate RT's users
 516    database when the user is created.
 517
 518     EmailAddress is the email address that RT should use for this user.
 519     Name is the 'Name' attribute RT should use for this user.
 520          'Name' is used for things like access control and user lookups.
 521     RealName is what RT should display as the user's name when displaying
 522          'friendly' names
 523
 524 =cut
 525
 526 sub LookupExternalUserInfo {
 527   my $self = shift;
 528   my $EmailAddress = shift;
 529   my $RealName = shift;
 530
 531   my $FoundInExternalDatabase = 1;
 532   my %params;
 533
 534   #Name is the RT username you want to use for this user.
 535   $params{'Name'} = $EmailAddress;
 536   $params{'EmailAddress'} = $EmailAddress;
 537   $params{'RealName'} = $RealName;
 538
 539   # See RT's contributed code for examples.
 540   # http://www.fsck.com/pub/rt/contrib/
 541   return ($FoundInExternalDatabase, %params);
 542 }
 543
 544 # }}}
 545
 546 # {{{ Accessor methods for parsed email messages
 547
 548 =head2 Head
 549
 550 Return the parsed head from this message
 551
 552 =cut
 553
 554 sub Head {
 555     my $self = shift;
 556     return $self->Entity->head;
 557 }
 558
 559 =head2 Entity
 560
 561 Return the parsed Entity from this message
 562
 563 =cut
 564
 565 sub Entity {
 566     my $self = shift;
 567     return $self->{'entity'};
 568 }
 569
 570 # }}}
 571
 572 # {{{ _SetupMIMEParser
 573
 574 =head2 _SetupMIMEParser $parser
 575
 576 A private instance method which sets up a mime parser to do its job
 577
 578 =cut
 579
 580
 581     ## TODO: Does it make sense storing to disk at all?  After all, we
 582     ## need to put each msg as an in-core scalar before saving it to
 583     ## the database, don't we?
 584
 585     ## At the same time, we should make sure that we nuke attachments
 586     ## Over max size and return them
 587
 588 sub _SetupMIMEParser {
 589     my $self   = shift;
 590     my $parser = shift;
 591
 592     # Set up output directory for files:
 593
 594     my $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
 595     push ( @{ $self->{'AttachmentDirs'} }, $tmpdir );
 596     $parser->output_dir($tmpdir);
 597     $parser->filer->ignore_filename(1);
 598
 599     #If someone includes a message, extract it
 600     $parser->extract_nested_messages(1);
 601
 602     $parser->extract_uuencode(1);    ### default is false
 603
 604     # Set up the prefix for files with auto-generated names:
 605     $parser->output_prefix("part");
 606
 607     # do _not_ store each msg as in-core scalar;
 608
 609     $parser->output_to_core(0);
 610
 611     # From the MIME::Parser docs:
 612     # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope"
 613     # Turns out that the default is to recycle tempfiles
 614     # Temp files should never be recycled, especially when running under perl taint checking
 615
 616     $parser->tmp_recycling(0);
 617
 618 }
 619
 620 # }}}
 621
 622 sub DESTROY {
 623     my $self = shift;
 624     File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1);
 625 }
 626
 627
 628
 629 eval "require RT::EmailParser_Vendor";
 630 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm});
 631 eval "require RT::EmailParser_Local";
 632 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm});
 633
 634 1;