rt/lib/RT/EmailParser.pm

   1 # BEGIN LICENSE BLOCK
   2 #
   3 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
   4 #
   5 # (Except where explictly superceded by other copyright notices)
   6 #
   7 # This work is made available to you under the terms of Version 2 of
   8 # the GNU General Public License. A copy of that license should have
   9 # been provided with this software, but in any event can be snarfed
  10 # from www.gnu.org.
  11 #
  12 # This work is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # Unless otherwise specified, all modifications, corrections or
  18 # extensions to this work which alter its source code become the
  19 # property of Best Practical Solutions, LLC when submitted for
  20 # inclusion in the work.
  21 #
  22 #
  23 # END LICENSE BLOCK
  24 package RT::EmailParser;
  25
  26
  27 use base qw/RT::Base/;
  28
  29 use strict;
  30 use Mail::Address;
  31 use MIME::Entity;
  32 use MIME::Head;
  33 use MIME::Parser;
  34 use File::Temp qw/tempdir/;
  35
  36 =head1 NAME
  37
  38   RT::Interface::CLI - helper functions for creating a commandline RT interface
  39
  40 =head1 SYNOPSIS
  41
  42
  43 =head1 DESCRIPTION
  44
  45
  46 =begin testing
  47
  48 ok(require RT::EmailParser);
  49
  50 =end testing
  51
  52
  53 =head1 METHODS
  54
  55 =head2 new
  56
  57
  58 =cut
  59
  60 sub new  {
  61   my $proto = shift;
  62   my $class = ref($proto) || $proto;
  63   my $self  = {};
  64   bless ($self, $class);
  65   return $self;
  66 }
  67
  68
  69
  70 # {{{ sub debug
  71
  72 sub debug {
  73     my $val = shift;
  74     my ($debug);
  75     if ($val) {
  76         $RT::Logger->debug( $val . "\n" );
  77         if ($debug) {
  78             print STDERR "$val\n";
  79         }
  80     }
  81     if ($debug) {
  82         return (1);
  83     }
  84 }
  85
  86 # }}}
  87
  88 # {{{ sub CheckForLoops
  89
  90 sub CheckForLoops {
  91     my $self = shift;
  92
  93     my $head = $self->Head;
  94
  95     #If this instance of RT sent it our, we don't want to take it in
  96     my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
  97     chomp($RTLoop);    #remove that newline
  98     if ( $RTLoop =~ /^\Q$RT::rtname\E/o ) {
  99         return (1);
 100     }
 101
 102     # TODO: We might not trap the case where RT instance A sends a mail
 103     # to RT instance B which sends a mail to ...
 104     return (undef);
 105 }
 106
 107 # }}}
 108
 109 # {{{ sub CheckForSuspiciousSender
 110
 111 sub CheckForSuspiciousSender {
 112     my $self = shift;
 113
 114     #if it's from a postmaster or mailer daemon, it's likely a bounce.
 115
 116     #TODO: better algorithms needed here - there is no standards for
 117     #bounces, so it's very difficult to separate them from anything
 118     #else.  At the other hand, the Return-To address is only ment to be
 119     #used as an error channel, we might want to put up a separate
 120     #Return-To address which is treated differently.
 121
 122     #TODO: search through the whole email and find the right Ticket ID.
 123
 124     my ( $From, $junk ) = $self->ParseSenderAddressFromHead();
 125
 126     if ( ( $From =~ /^mailer-daemon/i ) or ( $From =~ /^postmaster/i ) ) {
 127         return (1);
 128
 129     }
 130
 131     return (undef);
 132
 133 }
 134
 135 # }}}
 136
 137 # {{{ sub CheckForAutoGenerated
 138 sub CheckForAutoGenerated {
 139     my $self = shift;
 140     my $head = $self->Head;
 141
 142     my $Precedence = $head->get("Precedence") || "";
 143     if ( $Precedence =~ /^(bulk|junk)/i ) {
 144         return (1);
 145     }
 146     else {
 147         return (undef);
 148     }
 149 }
 150
 151 # }}}
 152
 153 # {{{ sub ParseMIMEEntityFromSTDIN
 154
 155 sub ParseMIMEEntityFromSTDIN {
 156     my $self = shift;
 157     return $self->ParseMIMEEntityFromFileHandle(\*STDIN);
 158 }
 159
 160 # }}}
 161
 162 =head2 ParseMIMEEntityFromScalar  $message
 163
 164 Takes either a scalar or a reference to a scalr which contains a stringified MIME message.
 165 Parses it.
 166
 167 Returns true if it wins.
 168 Returns false if it loses.
 169
 170
 171 =cut
 172
 173 sub ParseMIMEEntityFromScalar {
 174     my $self = shift;
 175     my $message = shift;
 176
 177     $self->_DoParse('parse_data', $message);
 178
 179 }
 180
 181 # {{{ ParseMIMEEntityFromFilehandle *FH
 182
 183 =head2 ParseMIMEEntityFromFilehandle *FH
 184
 185 Parses a mime entity from a filehandle passed in as an argument
 186
 187 =cut
 188
 189 sub ParseMIMEEntityFromFileHandle {
 190     my $self = shift;
 191     my $filehandle = shift;
 192
 193     $self->_DoParse('parse', $filehandle);
 194
 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
 210     my $file = shift;
 211     $self->_DoParse('parse_open', $file);
 212 }
 213
 214 # }}}
 215
 216 # {{{ _DoParse
 217
 218 =head2 _DoParse PARSEMETHOD CONTENT
 219
 220
 221 A helper for the various parsers to turn around and do the dispatch to the actual parser
 222
 223 =cut
 224
 225 sub _DoParse {
 226     my $self = shift;
 227     my $method = shift;
 228     my $file = shift;
 229
 230     # Create a new parser object:
 231
 232     my $parser = MIME::Parser->new();
 233     $self->_SetupMIMEParser($parser);
 234
 235
 236     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 237
 238     unless ( $self->{'entity'} = $parser->$method($file) ) {
 239
 240         # Try again, this time without extracting nested messages
 241         $parser->extract_nested_messages(0);
 242         unless ( $self->{'entity'} = $parser->$method($file) ) {
 243             $RT::Logger->crit("couldn't parse MIME stream");
 244             return ( undef);
 245         }
 246     }
 247     $self->_PostProcessNewEntity();
 248     return (1);
 249 }
 250
 251 # }}}
 252
 253
 254 # {{{ _PostProcessNewEntity
 255
 256 =head2 _PostProcessNewEntity
 257
 258 cleans up and postprocesses a newly parsed MIME Entity
 259
 260 =cut
 261
 262 sub _PostProcessNewEntity {
 263     my $self = shift;
 264
 265     #Now we've got a parsed mime object.
 266
 267     # try to convert text parts into utf-8 charset
 268     RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
 269
 270
 271     # Unfold headers that are have embedded newlines
 272     $self->Head->unfold;
 273
 274
 275 }
 276
 277 # }}}
 278
 279 # {{{ sub ParseTicketId
 280
 281 sub ParseTicketId {
 282     my $self = shift;
 283
 284     my $Subject = shift;
 285
 286     if ( $Subject =~ s/\[\Q$RT::rtname\E\s+\#(\d+)\s*\]//i ) {
 287         my $id = $1;
 288         $RT::Logger->debug("Found a ticket ID. It's $id");
 289         return ($id);
 290     }
 291     else {
 292         return (undef);
 293     }
 294 }
 295
 296 # }}}
 297
 298 # {{{ sub MailError
 299
 300 =head2 MailError { }
 301
 302
 303 # TODO this doesn't belong here.
 304 # TODO doc this
 305
 306
 307 =cut
 308
 309
 310 sub MailError {
 311     my $self = shift;
 312
 313     my %args = (
 314         To          => $RT::OwnerEmail,
 315         Bcc         => undef,
 316         From        => $RT::CorrespondAddress,
 317         Subject     => 'There has been an error',
 318         Explanation => 'Unexplained error',
 319         MIMEObj     => undef,
 320         LogLevel    => 'crit',
 321         @_
 322     );
 323
 324     $RT::Logger->log(
 325         level   => $args{'LogLevel'},
 326         message => $args{'Explanation'}
 327     );
 328     my $entity = MIME::Entity->build(
 329         Type                   => "multipart/mixed",
 330         From                   => $args{'From'},
 331         Bcc                    => $args{'Bcc'},
 332         To                     => $args{'To'},
 333         Subject                => $args{'Subject'},
 334         'X-RT-Loop-Prevention' => $RT::rtname,
 335     );
 336
 337     $entity->attach( Data => $args{'Explanation'} . "\n" );
 338
 339     my $mimeobj = $args{'MIMEObj'};
 340     $mimeobj->sync_headers();
 341     $entity->add_part($mimeobj);
 342
 343     if ( $RT::MailCommand eq 'sendmailpipe' ) {
 344         open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || return (0);
 345         print MAIL $entity->as_string;
 346         close(MAIL);
 347     }
 348     else {
 349         $entity->send( $RT::MailCommand, $RT::MailParams );
 350     }
 351 }
 352
 353 # }}}
 354
 355
 356
 357 # {{{ sub GetCurrentUser
 358
 359 sub GetCurrentUser {
 360     my $self     = shift;
 361     my $ErrorsTo = shift;
 362
 363     my %UserInfo = ();
 364
 365     #Suck the address of the sender out of the header
 366     my ( $Address, $Name ) = $self->ParseSenderAddressFromHead();
 367
 368     my $tempuser = RT::User->new($RT::SystemUser);
 369
 370     #This will apply local address canonicalization rules
 371     $Address = $tempuser->CanonicalizeEmailAddress($Address);
 372
 373     #If desired, synchronize with an external database
 374     my $UserFoundInExternalDatabase = 0;
 375
 376     # Username is the 'Name' attribute of the user that RT uses for things
 377     # like authentication
 378     my $Username = undef;
 379     ( $UserFoundInExternalDatabase, %UserInfo ) =
 380       $self->LookupExternalUserInfo( $Address, $Name );
 381
 382     $Address  = $UserInfo{'EmailAddress'};
 383     $Username = $UserInfo{'Name'};
 384
 385     #Get us a currentuser object to work with.
 386     my $CurrentUser = RT::CurrentUser->new();
 387
 388     # First try looking up by a username, if we got one from the external
 389     # db lookup. Next, try looking up by email address. Failing that,
 390     # try looking up by users who have this user's email address as their
 391     # username.
 392
 393     if ($Username) {
 394         $CurrentUser->LoadByName($Username);
 395     }
 396
 397     unless ( $CurrentUser->Id ) {
 398         $CurrentUser->LoadByEmail($Address);
 399     }
 400
 401     #If we can't get it by email address, try by name.
 402     unless ( $CurrentUser->Id ) {
 403         $CurrentUser->LoadByName($Address);
 404     }
 405
 406     unless ( $CurrentUser->Id ) {
 407
 408         #If we couldn't load a user, determine whether to create a user
 409
 410         # {{{ If we require an incoming address to be found in the external
 411         # user database, reject the incoming message appropriately
 412         if ( $RT::SenderMustExistInExternalDatabase
 413              && !$UserFoundInExternalDatabase ) {
 414
 415             my $Message =
 416               "Sender's email address was not found in the user database.";
 417
 418             # {{{  This code useful only if you've defined an AutoRejectRequest template
 419
 420             require RT::Template;
 421             my $template = new RT::Template($RT::Nobody);
 422             $template->Load('AutoRejectRequest');
 423             $Message = $template->Content || $Message;
 424
 425             # }}}
 426
 427             MailError(
 428                  To      => $ErrorsTo,
 429                  Subject => "Ticket Creation failed: user could not be created",
 430                  Explanation => $Message,
 431                  MIMEObj     => $self->Entity,
 432                  LogLevel    => 'notice' );
 433
 434             return ($CurrentUser);
 435
 436         }
 437
 438         # }}}
 439
 440         else {
 441             my $NewUser = RT::User->new($RT::SystemUser);
 442
 443             my ( $Val, $Message ) = $NewUser->Create(
 444                                   Name => ( $Username || $Address ),
 445                                   EmailAddress => $Address,
 446                                   RealName     => "$Name",
 447                                   Password     => undef,
 448                                   Privileged   => 0,
 449                                   Comments => 'Autocreated on ticket submission'
 450             );
 451
 452             unless ($Val) {
 453
 454                 # Deal with the race condition of two account creations at once
 455                 #
 456                 if ($Username) {
 457                     $NewUser->LoadByName($Username);
 458                 }
 459
 460                 unless ( $NewUser->Id ) {
 461                     $NewUser->LoadByEmail($Address);
 462                 }
 463
 464                 unless ( $NewUser->Id ) {
 465                     MailError(To          => $ErrorsTo,
 466                               Subject     => "User could not be created",
 467                               Explanation =>
 468                                 "User creation failed in mailgateway: $Message",
 469                               MIMEObj  => $self->Entity,
 470                               LogLevel => 'crit' );
 471                 }
 472             }
 473         }
 474
 475         #Load the new user object
 476         $CurrentUser->LoadByEmail($Address);
 477
 478         unless ( $CurrentUser->id ) {
 479             $RT::Logger->warning(
 480                                "Couldn't load user '$Address'." . "giving up" );
 481             MailError(
 482                    To          => $ErrorsTo,
 483                    Subject     => "User could not be loaded",
 484                    Explanation =>
 485                      "User  '$Address' could not be loaded in the mail gateway",
 486                    MIMEObj  => $self->Entity,
 487                    LogLevel => 'crit' );
 488
 489         }
 490     }
 491
 492     return ($CurrentUser);
 493
 494 }
 495
 496 # }}}
 497
 498
 499 # {{{ ParseCcAddressesFromHead
 500
 501 =head2 ParseCcAddressesFromHead HASHREF
 502
 503 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 504 Returns a list of all email addresses in the To and Cc
 505 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
 506 email address  and anything that the $RTAddressRegexp matches.
 507
 508 =cut
 509
 510 sub ParseCcAddressesFromHead {
 511
 512     my $self = shift;
 513
 514     my %args = (
 515         QueueObj    => undef,
 516         CurrentUser => undef,
 517         @_
 518     );
 519
 520     my (@Addresses);
 521
 522     my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
 523     my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
 524
 525     foreach my $AddrObj ( @ToObjs, @CcObjs ) {
 526         my $Address = $AddrObj->address;
 527         my $user = RT::User->new($RT::SystemUser);
 528         $Address = $user->CanonicalizeEmailAddress($Address);
 529         next if ( $args{'CurrentUser'}->EmailAddress   =~ /^$Address$/i );
 530         next if ( $args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i );
 531         next if ( $args{'QueueObj'}->CommentAddress    =~ /^$Address$/i );
 532         next if ( IsRTAddress($Address) );
 533
 534         push ( @Addresses, $Address );
 535     }
 536     return (@Addresses);
 537 }
 538
 539 # }}}
 540
 541 # {{{ ParseSenderAdddressFromHead
 542
 543 =head2 ParseSenderAddressFromHead
 544
 545 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
 546 of the From (evaluated in order of Reply-To:, From:, Sender)
 547
 548 =cut
 549
 550 sub ParseSenderAddressFromHead {
 551     my $self = shift;
 552
 553     #Figure out who's sending this message.
 554     my $From = $self->Head->get('Reply-To')
 555       || $self->Head->get('From')
 556       || $self->Head->get('Sender');
 557     return ( $self->ParseAddressFromHeader($From) );
 558 }
 559
 560 # }}}
 561
 562 # {{{ ParseErrorsToAdddressFromHead
 563
 564 =head2 ParseErrorsToAddressFromHead
 565
 566 Takes a MIME::Header object. Return a single value : user@host
 567 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
 568
 569 =cut
 570
 571 sub ParseErrorsToAddressFromHead {
 572     my $self = shift;
 573
 574     #Figure out who's sending this message.
 575
 576     foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
 577
 578         # If there's a header of that name
 579         my $headerobj = $self->Head->get($header);
 580         if ($headerobj) {
 581             my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
 582
 583             # If it's got actual useful content...
 584             return ($addr) if ($addr);
 585         }
 586     }
 587 }
 588
 589 # }}}
 590
 591 # {{{ ParseAddressFromHeader
 592
 593 =head2 ParseAddressFromHeader ADDRESS
 594
 595 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
 596
 597 =cut
 598
 599 sub ParseAddressFromHeader {
 600     my $self = shift;
 601     my $Addr = shift;
 602
 603     my @Addresses = Mail::Address->parse($Addr);
 604
 605     my $AddrObj = $Addresses[0];
 606
 607     unless ( ref($AddrObj) ) {
 608         return ( undef, undef );
 609     }
 610
 611     my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
 612
 613     #Lets take the from and load a user object.
 614     my $Address = $AddrObj->address;
 615
 616     return ( $Address, $Name );
 617 }
 618
 619 # }}}
 620
 621 # {{{ IsRTAddress
 622
 623 =item IsRTaddress ADDRESS
 624
 625 Takes a single parameter, an email address.
 626 Returns true if that address matches the $RTAddressRegexp.
 627 Returns false, otherwise.
 628
 629 =begin testing
 630
 631 is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" );
 632 is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" );
 633
 634 =end testing
 635
 636 =cut
 637
 638 sub IsRTAddress {
 639     my $self = shift;
 640     my $address = shift;
 641
 642     # Example: the following rule would tell RT not to Cc
 643     #   "tickets@noc.example.com"
 644     if ( defined($RT::RTAddressRegexp) &&
 645                        $address =~ /$RT::RTAddressRegexp/ ) {
 646         return(1);
 647     } else {
 648         return (undef);
 649     }
 650 }
 651
 652 # }}}
 653
 654
 655 # {{{ CullRTAddresses
 656
 657 =item CullRTAddresses ARRAY
 658
 659 Takes a single argument, an array of email addresses.
 660 Returns the same array with any IsRTAddress()es weeded out.
 661
 662 =begin testing
 663
 664 @before = ("rt\@example.com", "frt\@example.com");
 665 @after = ("frt\@example.com");
 666 ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses");
 667
 668 =end testing
 669
 670 =cut
 671
 672 sub CullRTAddresses {
 673     my $self = shift;
 674     my @addresses= (@_);
 675     my @addrlist;
 676
 677     foreach my $addr( @addresses ) {
 678       push (@addrlist, $addr)    unless IsRTAddress("", $addr);
 679     }
 680     return (@addrlist);
 681 }
 682
 683 # }}}
 684
 685
 686 # {{{ LookupExternalUserInfo
 687
 688
 689 # LookupExternalUserInfo is a site-definable method for synchronizing
 690 # incoming users with an external data source.
 691 #
 692 # This routine takes a tuple of EmailAddress and FriendlyName
 693 #   EmailAddress is the user's email address, ususally taken from
 694 #       an email message's From: header.
 695 #   FriendlyName is a freeform string, ususally taken from the "comment"
 696 #       portion of an email message's From: header.
 697 #
 698 # If you define an AutoRejectRequest template, RT will use this
 699 # template for the rejection message.
 700
 701
 702 =item LookupExternalUserInfo
 703
 704  LookupExternalUserInfo is a site-definable method for synchronizing
 705  incoming users with an external data source.
 706
 707  This routine takes a tuple of EmailAddress and FriendlyName
 708     EmailAddress is the user's email address, ususally taken from
 709         an email message's From: header.
 710     FriendlyName is a freeform string, ususally taken from the "comment"
 711         portion of an email message's From: header.
 712
 713  It returns (FoundInExternalDatabase, ParamHash);
 714
 715    FoundInExternalDatabase must  be set to 1 before return if the user was
 716    found in the external database.
 717
 718    ParamHash is a Perl parameter hash which can contain at least the following
 719    fields. These fields are used to populate RT's users database when the user
 720    is created
 721
 722     EmailAddress is the email address that RT should use for this user.
 723     Name is the 'Name' attribute RT should use for this user.
 724          'Name' is used for things like access control and user lookups.
 725     RealName is what RT should display as the user's name when displaying
 726          'friendly' names
 727
 728 =cut
 729
 730 sub LookupExternalUserInfo {
 731   my $self = shift;
 732   my $EmailAddress = shift;
 733   my $RealName = shift;
 734
 735   my $FoundInExternalDatabase = 1;
 736   my %params;
 737
 738   #Name is the RT username you want to use for this user.
 739   $params{'Name'} = $EmailAddress;
 740   $params{'EmailAddress'} = $EmailAddress;
 741   $params{'RealName'} = $RealName;
 742
 743   # See RT's contributed code for examples.
 744   # http://www.fsck.com/pub/rt/contrib/
 745   return ($FoundInExternalDatabase, %params);
 746 }
 747
 748 # }}}
 749
 750 # {{{ Accessor methods for parsed email messages
 751
 752 =head2 Head
 753
 754 Return the parsed head from this message
 755
 756 =cut
 757
 758 sub Head {
 759     my $self = shift;
 760     return $self->Entity->head;
 761 }
 762
 763 =head2 Entity
 764
 765 Return the parsed Entity from this message
 766
 767 =cut
 768
 769 sub Entity {
 770     my $self = shift;
 771     return $self->{'entity'};
 772 }
 773
 774 # }}}
 775 # {{{ _SetupMIMEParser
 776
 777 =head2 _SetupMIMEParser $parser
 778
 779 A private instance method which sets up a mime parser to do its job
 780
 781 =cut
 782
 783
 784     ## TODO: Does it make sense storing to disk at all?  After all, we
 785     ## need to put each msg as an in-core scalar before saving it to
 786     ## the database, don't we?
 787
 788     ## At the same time, we should make sure that we nuke attachments
 789     ## Over max size and return them
 790
 791 sub _SetupMIMEParser {
 792     my $self = shift;
 793     my $parser = shift;
 794     my $AttachmentDir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
 795
 796     # Set up output directory for files:
 797     $parser->output_dir("$AttachmentDir");
 798     $parser->filer->ignore_filename(1);
 799
 800
 801     #If someone includes a message, extract it
 802     $parser->extract_nested_messages(1);
 803
 804     $parser->extract_uuencode(1);           ### default is false
 805
 806     # Set up the prefix for files with auto-generated names:
 807     $parser->output_prefix("part");
 808
 809     # do _not_ store each msg as in-core scalar;
 810
 811     $parser->output_to_core(0);
 812 }
 813 # }}}
 814
 815 eval "require RT::EmailParser_Vendor";
 816 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm});
 817 eval "require RT::EmailParser_Local";
 818 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm});
 819
 820 1;