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 =~ /^$RT::rtname/ ) {
  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
 163 sub ParseMIMEEntityFromScalar {
 164     my $self = shift;
 165     my $message = shift;
 166
 167     # Create a new parser object:
 168
 169     my $parser = MIME::Parser->new();
 170     $self->_SetupMIMEParser($parser);
 171
 172
 173     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 174     unless ( $self->{'entity'} = $parser->parse_data($message) ) {
 175         # Try again, this time without extracting nested messages
 176         $parser->extract_nested_messages(0);
 177         unless ( $self->{'entity'} = $parser->parse_data($message) ) {
 178             $RT::Logger->crit("couldn't parse MIME stream");
 179             return ( undef);
 180         }
 181     }
 182     $self->_PostProcessNewEntity();
 183     return (1);
 184 }
 185
 186 # {{{ ParseMIMEEntityFromFilehandle *FH
 187
 188 =head2 ParseMIMEEntityFromFilehandle *FH
 189
 190 Parses a mime entity from a filehandle passed in as an argument
 191
 192 =cut
 193
 194 sub ParseMIMEEntityFromFileHandle {
 195     my $self = shift;
 196     my $filehandle = shift;
 197
 198     # Create a new parser object:
 199
 200     my $parser = MIME::Parser->new();
 201     $self->_SetupMIMEParser($parser);
 202
 203
 204     # TODO: XXX 3.0 we really need to wrap this in an eval { }
 205
 206     unless ( $self->{'entity'} = $parser->parse($filehandle) ) {
 207
 208         # Try again, this time without extracting nested messages
 209         $parser->extract_nested_messages(0);
 210         unless ( $self->{'entity'} = $parser->parse($filehandle) ) {
 211             $RT::Logger->crit("couldn't parse MIME stream");
 212             return ( undef);
 213         }
 214     }
 215     $self->_PostProcessNewEntity();
 216     return (1);
 217 }
 218
 219 # }}}
 220
 221 # {{{ _PostProcessNewEntity
 222
 223 =head2 _PostProcessNewEntity
 224
 225 cleans up and postprocesses a newly parsed MIME Entity
 226
 227 =cut
 228
 229 sub _PostProcessNewEntity {
 230     my $self = shift;
 231
 232     #Now we've got a parsed mime object.
 233
 234     # try to convert text parts into utf-8 charset
 235     RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
 236
 237
 238     # Unfold headers that are have embedded newlines
 239     $self->Head->unfold;
 240
 241
 242 }
 243
 244 # }}}
 245
 246 # {{{ sub ParseTicketId
 247
 248 sub ParseTicketId {
 249     my $self = shift;
 250
 251     my $Subject = shift;
 252
 253     if ( $Subject =~ s/\[$RT::rtname \#(\d+)\s*\]//i ) {
 254         my $id = $1;
 255         $RT::Logger->debug("Found a ticket ID. It's $id");
 256         return ($id);
 257     }
 258     else {
 259         return (undef);
 260     }
 261 }
 262
 263 # }}}
 264
 265 # {{{ sub MailError
 266
 267 =head2 MailError { }
 268
 269
 270 # TODO this doesn't belong here.
 271 # TODO doc this
 272
 273
 274 =cut
 275
 276
 277 sub MailError {
 278     my $self = shift;
 279
 280     my %args = (
 281         To          => $RT::OwnerEmail,
 282         Bcc         => undef,
 283         From        => $RT::CorrespondAddress,
 284         Subject     => 'There has been an error',
 285         Explanation => 'Unexplained error',
 286         MIMEObj     => undef,
 287         LogLevel    => 'crit',
 288         @_
 289     );
 290
 291     $RT::Logger->log(
 292         level   => $args{'LogLevel'},
 293         message => $args{'Explanation'}
 294     );
 295     my $entity = MIME::Entity->build(
 296         Type                   => "multipart/mixed",
 297         From                   => $args{'From'},
 298         Bcc                    => $args{'Bcc'},
 299         To                     => $args{'To'},
 300         Subject                => $args{'Subject'},
 301         'X-RT-Loop-Prevention' => $RT::rtname,
 302     );
 303
 304     $entity->attach( Data => $args{'Explanation'} . "\n" );
 305
 306     my $mimeobj = $args{'MIMEObj'};
 307     $mimeobj->sync_headers();
 308     $entity->add_part($mimeobj);
 309
 310     if ( $RT::MailCommand eq 'sendmailpipe' ) {
 311         open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || return (0);
 312         print MAIL $entity->as_string;
 313         close(MAIL);
 314     }
 315     else {
 316         $entity->send( $RT::MailCommand, $RT::MailParams );
 317     }
 318 }
 319
 320 # }}}
 321
 322
 323
 324 # {{{ sub GetCurrentUser
 325
 326 sub GetCurrentUser {
 327     my $self     = shift;
 328     my $ErrorsTo = shift;
 329
 330     my %UserInfo = ();
 331
 332     #Suck the address of the sender out of the header
 333     my ( $Address, $Name ) = $self->ParseSenderAddressFromHead();
 334
 335     my $tempuser = RT::User->new($RT::SystemUser);
 336
 337     #This will apply local address canonicalization rules
 338     $Address = $tempuser->CanonicalizeEmailAddress($Address);
 339
 340     #If desired, synchronize with an external database
 341     my $UserFoundInExternalDatabase = 0;
 342
 343     # Username is the 'Name' attribute of the user that RT uses for things
 344     # like authentication
 345     my $Username = undef;
 346     ( $UserFoundInExternalDatabase, %UserInfo ) =
 347       $self->LookupExternalUserInfo( $Address, $Name );
 348
 349     $Address  = $UserInfo{'EmailAddress'};
 350     $Username = $UserInfo{'Name'};
 351
 352     #Get us a currentuser object to work with.
 353     my $CurrentUser = RT::CurrentUser->new();
 354
 355     # First try looking up by a username, if we got one from the external
 356     # db lookup. Next, try looking up by email address. Failing that,
 357     # try looking up by users who have this user's email address as their
 358     # username.
 359
 360     if ($Username) {
 361         $CurrentUser->LoadByName($Username);
 362     }
 363
 364     unless ( $CurrentUser->Id ) {
 365         $CurrentUser->LoadByEmail($Address);
 366     }
 367
 368     #If we can't get it by email address, try by name.
 369     unless ( $CurrentUser->Id ) {
 370         $CurrentUser->LoadByName($Address);
 371     }
 372
 373     unless ( $CurrentUser->Id ) {
 374
 375         #If we couldn't load a user, determine whether to create a user
 376
 377         # {{{ If we require an incoming address to be found in the external
 378         # user database, reject the incoming message appropriately
 379         if ( $RT::SenderMustExistInExternalDatabase
 380              && !$UserFoundInExternalDatabase ) {
 381
 382             my $Message =
 383               "Sender's email address was not found in the user database.";
 384
 385             # {{{  This code useful only if you've defined an AutoRejectRequest template
 386
 387             require RT::Template;
 388             my $template = new RT::Template($RT::Nobody);
 389             $template->Load('AutoRejectRequest');
 390             $Message = $template->Content || $Message;
 391
 392             # }}}
 393
 394             MailError(
 395                  To      => $ErrorsTo,
 396                  Subject => "Ticket Creation failed: user could not be created",
 397                  Explanation => $Message,
 398                  MIMEObj     => $self->Entity,
 399                  LogLevel    => 'notice' );
 400
 401             return ($CurrentUser);
 402
 403         }
 404
 405         # }}}
 406
 407         else {
 408             my $NewUser = RT::User->new($RT::SystemUser);
 409
 410             my ( $Val, $Message ) = $NewUser->Create(
 411                                   Name => ( $Username || $Address ),
 412                                   EmailAddress => $Address,
 413                                   RealName     => "$Name",
 414                                   Password     => undef,
 415                                   Privileged   => 0,
 416                                   Comments => 'Autocreated on ticket submission'
 417             );
 418
 419             unless ($Val) {
 420
 421                 # Deal with the race condition of two account creations at once
 422                 #
 423                 if ($Username) {
 424                     $NewUser->LoadByName($Username);
 425                 }
 426
 427                 unless ( $NewUser->Id ) {
 428                     $NewUser->LoadByEmail($Address);
 429                 }
 430
 431                 unless ( $NewUser->Id ) {
 432                     MailError(To          => $ErrorsTo,
 433                               Subject     => "User could not be created",
 434                               Explanation =>
 435                                 "User creation failed in mailgateway: $Message",
 436                               MIMEObj  => $self->Entity,
 437                               LogLevel => 'crit' );
 438                 }
 439             }
 440         }
 441
 442         #Load the new user object
 443         $CurrentUser->LoadByEmail($Address);
 444
 445         unless ( $CurrentUser->id ) {
 446             $RT::Logger->warning(
 447                                "Couldn't load user '$Address'." . "giving up" );
 448             MailError(
 449                    To          => $ErrorsTo,
 450                    Subject     => "User could not be loaded",
 451                    Explanation =>
 452                      "User  '$Address' could not be loaded in the mail gateway",
 453                    MIMEObj  => $self->Entity,
 454                    LogLevel => 'crit' );
 455
 456         }
 457     }
 458
 459     return ($CurrentUser);
 460
 461 }
 462
 463 # }}}
 464
 465
 466 # {{{ ParseCcAddressesFromHead
 467
 468 =head2 ParseCcAddressesFromHead HASHREF
 469
 470 Takes a hashref object containing QueueObj, Head and CurrentUser objects.
 471 Returns a list of all email addresses in the To and Cc
 472 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
 473 email address  and anything that the $RTAddressRegexp matches.
 474
 475 =cut
 476
 477 sub ParseCcAddressesFromHead {
 478
 479     my $self = shift;
 480
 481     my %args = (
 482         QueueObj    => undef,
 483         CurrentUser => undef,
 484         @_
 485     );
 486
 487     my (@Addresses);
 488
 489     my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
 490     my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
 491
 492     foreach my $AddrObj ( @ToObjs, @CcObjs ) {
 493         my $Address = $AddrObj->address;
 494         my $user = RT::User->new($RT::SystemUser);
 495         $Address = $user->CanonicalizeEmailAddress($Address);
 496         next if ( $args{'CurrentUser'}->EmailAddress   =~ /^$Address$/i );
 497         next if ( $args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i );
 498         next if ( $args{'QueueObj'}->CommentAddress    =~ /^$Address$/i );
 499         next if ( IsRTAddress($Address) );
 500
 501         push ( @Addresses, $Address );
 502     }
 503     return (@Addresses);
 504 }
 505
 506 # }}}
 507
 508 # {{{ ParseSenderAdddressFromHead
 509
 510 =head2 ParseSenderAddressFromHead
 511
 512 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
 513 of the From (evaluated in order of Reply-To:, From:, Sender)
 514
 515 =cut
 516
 517 sub ParseSenderAddressFromHead {
 518     my $self = shift;
 519
 520     #Figure out who's sending this message.
 521     my $From = $self->Head->get('Reply-To')
 522       || $self->Head->get('From')
 523       || $self->Head->get('Sender');
 524     return ( $self->ParseAddressFromHeader($From) );
 525 }
 526
 527 # }}}
 528
 529 # {{{ ParseErrorsToAdddressFromHead
 530
 531 =head2 ParseErrorsToAddressFromHead
 532
 533 Takes a MIME::Header object. Return a single value : user@host
 534 of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
 535
 536 =cut
 537
 538 sub ParseErrorsToAddressFromHead {
 539     my $self = shift;
 540
 541     #Figure out who's sending this message.
 542
 543     foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
 544
 545         # If there's a header of that name
 546         my $headerobj = $self->Head->get($header);
 547         if ($headerobj) {
 548             my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
 549
 550             # If it's got actual useful content...
 551             return ($addr) if ($addr);
 552         }
 553     }
 554 }
 555
 556 # }}}
 557
 558 # {{{ ParseAddressFromHeader
 559
 560 =head2 ParseAddressFromHeader ADDRESS
 561
 562 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
 563
 564 =cut
 565
 566 sub ParseAddressFromHeader {
 567     my $self = shift;
 568     my $Addr = shift;
 569
 570     my @Addresses = Mail::Address->parse($Addr);
 571
 572     my $AddrObj = $Addresses[0];
 573
 574     unless ( ref($AddrObj) ) {
 575         return ( undef, undef );
 576     }
 577
 578     my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
 579
 580     #Lets take the from and load a user object.
 581     my $Address = $AddrObj->address;
 582
 583     return ( $Address, $Name );
 584 }
 585
 586 # }}}
 587
 588 # {{{ IsRTAddress
 589
 590 =item IsRTaddress ADDRESS
 591
 592 Takes a single parameter, an email address.
 593 Returns true if that address matches the $RTAddressRegexp.
 594 Returns false, otherwise.
 595
 596 =begin testing
 597
 598 is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" );
 599 is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" );
 600
 601 =end testing
 602
 603 =cut
 604
 605 sub IsRTAddress {
 606     my $self = shift;
 607     my $address = shift;
 608
 609     # Example: the following rule would tell RT not to Cc
 610     #   "tickets@noc.example.com"
 611     if ( defined($RT::RTAddressRegexp) &&
 612                        $address =~ /$RT::RTAddressRegexp/ ) {
 613         return(1);
 614     } else {
 615         return (undef);
 616     }
 617 }
 618
 619 # }}}
 620
 621
 622 # {{{ CullRTAddresses
 623
 624 =item CullRTAddresses ARRAY
 625
 626 Takes a single argument, an array of email addresses.
 627 Returns the same array with any IsRTAddress()es weeded out.
 628
 629 =begin testing
 630
 631 @before = ("rt\@example.com", "frt\@example.com");
 632 @after = ("frt\@example.com");
 633 ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses");
 634
 635 =end testing
 636
 637 =cut
 638
 639 sub CullRTAddresses {
 640     my $self = shift;
 641     my @addresses= (@_);
 642     my @addrlist;
 643
 644     foreach my $addr( @addresses ) {
 645       push (@addrlist, $addr)    unless IsRTAddress("", $addr);
 646     }
 647     return (@addrlist);
 648 }
 649
 650 # }}}
 651
 652
 653 # {{{ LookupExternalUserInfo
 654
 655
 656 # LookupExternalUserInfo is a site-definable method for synchronizing
 657 # incoming users with an external data source.
 658 #
 659 # This routine takes a tuple of EmailAddress and FriendlyName
 660 #   EmailAddress is the user's email address, ususally taken from
 661 #       an email message's From: header.
 662 #   FriendlyName is a freeform string, ususally taken from the "comment"
 663 #       portion of an email message's From: header.
 664 #
 665 # If you define an AutoRejectRequest template, RT will use this
 666 # template for the rejection message.
 667
 668
 669 =item LookupExternalUserInfo
 670
 671  LookupExternalUserInfo is a site-definable method for synchronizing
 672  incoming users with an external data source.
 673
 674  This routine takes a tuple of EmailAddress and FriendlyName
 675     EmailAddress is the user's email address, ususally taken from
 676         an email message's From: header.
 677     FriendlyName is a freeform string, ususally taken from the "comment"
 678         portion of an email message's From: header.
 679
 680  It returns (FoundInExternalDatabase, ParamHash);
 681
 682    FoundInExternalDatabase must  be set to 1 before return if the user was
 683    found in the external database.
 684
 685    ParamHash is a Perl parameter hash which can contain at least the following
 686    fields. These fields are used to populate RT's users database when the user
 687    is created
 688
 689     EmailAddress is the email address that RT should use for this user.
 690     Name is the 'Name' attribute RT should use for this user.
 691          'Name' is used for things like access control and user lookups.
 692     RealName is what RT should display as the user's name when displaying
 693          'friendly' names
 694
 695 =cut
 696
 697 sub LookupExternalUserInfo {
 698   my $self = shift;
 699   my $EmailAddress = shift;
 700   my $RealName = shift;
 701
 702   my $FoundInExternalDatabase = 1;
 703   my %params;
 704
 705   #Name is the RT username you want to use for this user.
 706   $params{'Name'} = $EmailAddress;
 707   $params{'EmailAddress'} = $EmailAddress;
 708   $params{'RealName'} = $RealName;
 709
 710   # See RT's contributed code for examples.
 711   # http://www.fsck.com/pub/rt/contrib/
 712   return ($FoundInExternalDatabase, %params);
 713 }
 714
 715 # }}}
 716
 717 # {{{ Accessor methods for parsed email messages
 718
 719 =head2 Head
 720
 721 Return the parsed head from this message
 722
 723 =cut
 724
 725 sub Head {
 726     my $self = shift;
 727     return $self->Entity->head;
 728 }
 729
 730 =head2 Entity
 731
 732 Return the parsed Entity from this message
 733
 734 =cut
 735
 736 sub Entity {
 737     my $self = shift;
 738     return $self->{'entity'};
 739 }
 740
 741 # }}}
 742 # {{{ _SetupMIMEParser
 743
 744 =head2 _SetupMIMEParser $parser
 745
 746 A private instance method which sets up a mime parser to do its job
 747
 748 =cut
 749
 750
 751     ## TODO: Does it make sense storing to disk at all?  After all, we
 752     ## need to put each msg as an in-core scalar before saving it to
 753     ## the database, don't we?
 754
 755     ## At the same time, we should make sure that we nuke attachments
 756     ## Over max size and return them
 757
 758 sub _SetupMIMEParser {
 759     my $self = shift;
 760     my $parser = shift;
 761     my $AttachmentDir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
 762
 763     # Set up output directory for files:
 764     $parser->output_dir("$AttachmentDir");
 765
 766     #If someone includes a message, don't extract it
 767     $parser->extract_nested_messages(1);
 768
 769     # Set up the prefix for files with auto-generated names:
 770     $parser->output_prefix("part");
 771
 772     # If content length is <= 50000 bytes, store each msg as in-core scalar;
 773     # Else, write to a disk file (the default action):
 774
 775     $parser->output_to_core(50000);
 776 }
 777 # }}}
 778
 779 eval "require RT::EmailParser_Vendor";
 780 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm});
 781 eval "require RT::EmailParser_Local";
 782 die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm});
 783
 784 1;