3 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
5 # (Except where explictly superceded by other copyright notices)
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
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.
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.
24 package RT::EmailParser;
27 use base qw/RT::Base/;
34 use File::Temp qw/tempdir/;
38 RT::Interface::CLI - helper functions for creating a commandline RT interface
48 ok(require RT::EmailParser);
62 my $class = ref($proto) || $proto;
64 bless ($self, $class);
76 $RT::Logger->debug( $val . "\n" );
78 print STDERR "$val\n";
88 # {{{ sub CheckForLoops
93 my $head = $self->Head;
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 ) {
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 ...
109 # {{{ sub CheckForSuspiciousSender
111 sub CheckForSuspiciousSender {
114 #if it's from a postmaster or mailer daemon, it's likely a bounce.
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.
122 #TODO: search through the whole email and find the right Ticket ID.
124 my ( $From, $junk ) = $self->ParseSenderAddressFromHead();
126 if ( ( $From =~ /^mailer-daemon/i ) or ( $From =~ /^postmaster/i ) ) {
137 # {{{ sub CheckForAutoGenerated
138 sub CheckForAutoGenerated {
140 my $head = $self->Head;
142 my $Precedence = $head->get("Precedence") || "";
143 if ( $Precedence =~ /^(bulk|junk)/i ) {
153 # {{{ sub ParseMIMEEntityFromSTDIN
155 sub ParseMIMEEntityFromSTDIN {
157 return $self->ParseMIMEEntityFromFileHandle(\*STDIN);
162 =head2 ParseMIMEEntityFromScalar $message
164 Takes either a scalar or a reference to a scalr which contains a stringified MIME message.
167 Returns true if it wins.
168 Returns false if it loses.
173 sub ParseMIMEEntityFromScalar {
177 $self->_DoParse('parse_data', $message);
181 # {{{ ParseMIMEEntityFromFilehandle *FH
183 =head2 ParseMIMEEntityFromFilehandle *FH
185 Parses a mime entity from a filehandle passed in as an argument
189 sub ParseMIMEEntityFromFileHandle {
191 my $filehandle = shift;
193 $self->_DoParse('parse', $filehandle);
199 # {{{ ParseMIMEEntityFromFile
201 =head2 ParseMIMEEntityFromFile
203 Parses a mime entity from a filename passed in as an argument
207 sub ParseMIMEEntityFromFile {
211 $self->_DoParse('parse_open', $file);
218 =head2 _DoParse PARSEMETHOD CONTENT
221 A helper for the various parsers to turn around and do the dispatch to the actual parser
230 # Create a new parser object:
232 my $parser = MIME::Parser->new();
233 $self->_SetupMIMEParser($parser);
236 # TODO: XXX 3.0 we really need to wrap this in an eval { }
238 unless ( $self->{'entity'} = $parser->$method($file) ) {
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");
247 $self->_PostProcessNewEntity();
254 # {{{ _PostProcessNewEntity
256 =head2 _PostProcessNewEntity
258 cleans up and postprocesses a newly parsed MIME Entity
262 sub _PostProcessNewEntity {
265 #Now we've got a parsed mime object.
267 # try to convert text parts into utf-8 charset
268 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
271 # Unfold headers that are have embedded newlines
279 # {{{ sub ParseTicketId
286 if ( $Subject =~ s/\[\Q$RT::rtname\E\s+\#(\d+)\s*\]//i ) {
288 $RT::Logger->debug("Found a ticket ID. It's $id");
303 # TODO this doesn't belong here.
314 To => $RT::OwnerEmail,
316 From => $RT::CorrespondAddress,
317 Subject => 'There has been an error',
318 Explanation => 'Unexplained error',
325 level => $args{'LogLevel'},
326 message => $args{'Explanation'}
328 my $entity = MIME::Entity->build(
329 Type => "multipart/mixed",
330 From => $args{'From'},
333 Subject => $args{'Subject'},
334 'X-RT-Loop-Prevention' => $RT::rtname,
337 $entity->attach( Data => $args{'Explanation'} . "\n" );
339 my $mimeobj = $args{'MIMEObj'};
340 $mimeobj->sync_headers();
341 $entity->add_part($mimeobj);
343 if ( $RT::MailCommand eq 'sendmailpipe' ) {
344 open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || return (0);
345 print MAIL $entity->as_string;
349 $entity->send( $RT::MailCommand, $RT::MailParams );
357 # {{{ sub GetCurrentUser
361 my $ErrorsTo = shift;
365 #Suck the address of the sender out of the header
366 my ( $Address, $Name ) = $self->ParseSenderAddressFromHead();
368 my $tempuser = RT::User->new($RT::SystemUser);
370 #This will apply local address canonicalization rules
371 $Address = $tempuser->CanonicalizeEmailAddress($Address);
373 #If desired, synchronize with an external database
374 my $UserFoundInExternalDatabase = 0;
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 );
382 $Address = $UserInfo{'EmailAddress'};
383 $Username = $UserInfo{'Name'};
385 #Get us a currentuser object to work with.
386 my $CurrentUser = RT::CurrentUser->new();
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
394 $CurrentUser->LoadByName($Username);
397 unless ( $CurrentUser->Id ) {
398 $CurrentUser->LoadByEmail($Address);
401 #If we can't get it by email address, try by name.
402 unless ( $CurrentUser->Id ) {
403 $CurrentUser->LoadByName($Address);
406 unless ( $CurrentUser->Id ) {
408 #If we couldn't load a user, determine whether to create a user
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 ) {
416 "Sender's email address was not found in the user database.";
418 # {{{ This code useful only if you've defined an AutoRejectRequest template
420 require RT::Template;
421 my $template = new RT::Template($RT::Nobody);
422 $template->Load('AutoRejectRequest');
423 $Message = $template->Content || $Message;
429 Subject => "Ticket Creation failed: user could not be created",
430 Explanation => $Message,
431 MIMEObj => $self->Entity,
432 LogLevel => 'notice' );
434 return ($CurrentUser);
441 my $NewUser = RT::User->new($RT::SystemUser);
443 my ( $Val, $Message ) = $NewUser->Create(
444 Name => ( $Username || $Address ),
445 EmailAddress => $Address,
449 Comments => 'Autocreated on ticket submission'
454 # Deal with the race condition of two account creations at once
457 $NewUser->LoadByName($Username);
460 unless ( $NewUser->Id ) {
461 $NewUser->LoadByEmail($Address);
464 unless ( $NewUser->Id ) {
465 MailError(To => $ErrorsTo,
466 Subject => "User could not be created",
468 "User creation failed in mailgateway: $Message",
469 MIMEObj => $self->Entity,
470 LogLevel => 'crit' );
475 #Load the new user object
476 $CurrentUser->LoadByEmail($Address);
478 unless ( $CurrentUser->id ) {
479 $RT::Logger->warning(
480 "Couldn't load user '$Address'." . "giving up" );
483 Subject => "User could not be loaded",
485 "User '$Address' could not be loaded in the mail gateway",
486 MIMEObj => $self->Entity,
487 LogLevel => 'crit' );
492 return ($CurrentUser);
499 # {{{ ParseCcAddressesFromHead
501 =head2 ParseCcAddressesFromHead HASHREF
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.
510 sub ParseCcAddressesFromHead {
516 CurrentUser => undef,
522 my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
523 my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
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) );
534 push ( @Addresses, $Address );
541 # {{{ ParseSenderAdddressFromHead
543 =head2 ParseSenderAddressFromHead
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)
550 sub ParseSenderAddressFromHead {
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) );
562 # {{{ ParseErrorsToAdddressFromHead
564 =head2 ParseErrorsToAddressFromHead
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)
571 sub ParseErrorsToAddressFromHead {
574 #Figure out who's sending this message.
576 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
578 # If there's a header of that name
579 my $headerobj = $self->Head->get($header);
581 my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
583 # If it's got actual useful content...
584 return ($addr) if ($addr);
591 # {{{ ParseAddressFromHeader
593 =head2 ParseAddressFromHeader ADDRESS
595 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
599 sub ParseAddressFromHeader {
603 my @Addresses = Mail::Address->parse($Addr);
605 my $AddrObj = $Addresses[0];
607 unless ( ref($AddrObj) ) {
608 return ( undef, undef );
611 my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
613 #Lets take the from and load a user object.
614 my $Address = $AddrObj->address;
616 return ( $Address, $Name );
623 =item IsRTaddress ADDRESS
625 Takes a single parameter, an email address.
626 Returns true if that address matches the $RTAddressRegexp.
627 Returns false, otherwise.
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" );
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/ ) {
655 # {{{ CullRTAddresses
657 =item CullRTAddresses ARRAY
659 Takes a single argument, an array of email addresses.
660 Returns the same array with any IsRTAddress()es weeded out.
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");
672 sub CullRTAddresses {
677 foreach my $addr( @addresses ) {
678 push (@addrlist, $addr) unless IsRTAddress("", $addr);
686 # {{{ LookupExternalUserInfo
689 # LookupExternalUserInfo is a site-definable method for synchronizing
690 # incoming users with an external data source.
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.
698 # If you define an AutoRejectRequest template, RT will use this
699 # template for the rejection message.
702 =item LookupExternalUserInfo
704 LookupExternalUserInfo is a site-definable method for synchronizing
705 incoming users with an external data source.
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.
713 It returns (FoundInExternalDatabase, ParamHash);
715 FoundInExternalDatabase must be set to 1 before return if the user was
716 found in the external database.
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
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
730 sub LookupExternalUserInfo {
732 my $EmailAddress = shift;
733 my $RealName = shift;
735 my $FoundInExternalDatabase = 1;
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;
743 # See RT's contributed code for examples.
744 # http://www.fsck.com/pub/rt/contrib/
745 return ($FoundInExternalDatabase, %params);
750 # {{{ Accessor methods for parsed email messages
754 Return the parsed head from this message
760 return $self->Entity->head;
765 Return the parsed Entity from this message
771 return $self->{'entity'};
775 # {{{ _SetupMIMEParser
777 =head2 _SetupMIMEParser $parser
779 A private instance method which sets up a mime parser to do its job
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?
788 ## At the same time, we should make sure that we nuke attachments
789 ## Over max size and return them
791 sub _SetupMIMEParser {
794 my $AttachmentDir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
796 # Set up output directory for files:
797 $parser->output_dir("$AttachmentDir");
798 $parser->filer->ignore_filename(1);
801 #If someone includes a message, extract it
802 $parser->extract_nested_messages(1);
804 $parser->extract_uuencode(1); ### default is false
806 # Set up the prefix for files with auto-generated names:
807 $parser->output_prefix("part");
809 # do _not_ store each msg as in-core scalar;
811 $parser->output_to_core(0);
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});