rt/lib/RT/EmailParser.pm

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