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 =~ /^$RT::rtname/ ) {
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);
163 sub ParseMIMEEntityFromScalar {
167 # Create a new parser object:
169 my $parser = MIME::Parser->new();
170 $self->_SetupMIMEParser($parser);
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");
182 $self->_PostProcessNewEntity();
186 # {{{ ParseMIMEEntityFromFilehandle *FH
188 =head2 ParseMIMEEntityFromFilehandle *FH
190 Parses a mime entity from a filehandle passed in as an argument
194 sub ParseMIMEEntityFromFileHandle {
196 my $filehandle = shift;
198 # Create a new parser object:
200 my $parser = MIME::Parser->new();
201 $self->_SetupMIMEParser($parser);
204 # TODO: XXX 3.0 we really need to wrap this in an eval { }
206 unless ( $self->{'entity'} = $parser->parse($filehandle) ) {
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");
215 $self->_PostProcessNewEntity();
221 # {{{ _PostProcessNewEntity
223 =head2 _PostProcessNewEntity
225 cleans up and postprocesses a newly parsed MIME Entity
229 sub _PostProcessNewEntity {
232 #Now we've got a parsed mime object.
234 # try to convert text parts into utf-8 charset
235 RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8');
238 # Unfold headers that are have embedded newlines
246 # {{{ sub ParseTicketId
253 if ( $Subject =~ s/\[$RT::rtname \#(\d+)\s*\]//i ) {
255 $RT::Logger->debug("Found a ticket ID. It's $id");
270 # TODO this doesn't belong here.
281 To => $RT::OwnerEmail,
283 From => $RT::CorrespondAddress,
284 Subject => 'There has been an error',
285 Explanation => 'Unexplained error',
292 level => $args{'LogLevel'},
293 message => $args{'Explanation'}
295 my $entity = MIME::Entity->build(
296 Type => "multipart/mixed",
297 From => $args{'From'},
300 Subject => $args{'Subject'},
301 'X-RT-Loop-Prevention' => $RT::rtname,
304 $entity->attach( Data => $args{'Explanation'} . "\n" );
306 my $mimeobj = $args{'MIMEObj'};
307 $mimeobj->sync_headers();
308 $entity->add_part($mimeobj);
310 if ( $RT::MailCommand eq 'sendmailpipe' ) {
311 open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || return (0);
312 print MAIL $entity->as_string;
316 $entity->send( $RT::MailCommand, $RT::MailParams );
324 # {{{ sub GetCurrentUser
328 my $ErrorsTo = shift;
332 #Suck the address of the sender out of the header
333 my ( $Address, $Name ) = $self->ParseSenderAddressFromHead();
335 my $tempuser = RT::User->new($RT::SystemUser);
337 #This will apply local address canonicalization rules
338 $Address = $tempuser->CanonicalizeEmailAddress($Address);
340 #If desired, synchronize with an external database
341 my $UserFoundInExternalDatabase = 0;
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 );
349 $Address = $UserInfo{'EmailAddress'};
350 $Username = $UserInfo{'Name'};
352 #Get us a currentuser object to work with.
353 my $CurrentUser = RT::CurrentUser->new();
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
361 $CurrentUser->LoadByName($Username);
364 unless ( $CurrentUser->Id ) {
365 $CurrentUser->LoadByEmail($Address);
368 #If we can't get it by email address, try by name.
369 unless ( $CurrentUser->Id ) {
370 $CurrentUser->LoadByName($Address);
373 unless ( $CurrentUser->Id ) {
375 #If we couldn't load a user, determine whether to create a user
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 ) {
383 "Sender's email address was not found in the user database.";
385 # {{{ This code useful only if you've defined an AutoRejectRequest template
387 require RT::Template;
388 my $template = new RT::Template($RT::Nobody);
389 $template->Load('AutoRejectRequest');
390 $Message = $template->Content || $Message;
396 Subject => "Ticket Creation failed: user could not be created",
397 Explanation => $Message,
398 MIMEObj => $self->Entity,
399 LogLevel => 'notice' );
401 return ($CurrentUser);
408 my $NewUser = RT::User->new($RT::SystemUser);
410 my ( $Val, $Message ) = $NewUser->Create(
411 Name => ( $Username || $Address ),
412 EmailAddress => $Address,
416 Comments => 'Autocreated on ticket submission'
421 # Deal with the race condition of two account creations at once
424 $NewUser->LoadByName($Username);
427 unless ( $NewUser->Id ) {
428 $NewUser->LoadByEmail($Address);
431 unless ( $NewUser->Id ) {
432 MailError(To => $ErrorsTo,
433 Subject => "User could not be created",
435 "User creation failed in mailgateway: $Message",
436 MIMEObj => $self->Entity,
437 LogLevel => 'crit' );
442 #Load the new user object
443 $CurrentUser->LoadByEmail($Address);
445 unless ( $CurrentUser->id ) {
446 $RT::Logger->warning(
447 "Couldn't load user '$Address'." . "giving up" );
450 Subject => "User could not be loaded",
452 "User '$Address' could not be loaded in the mail gateway",
453 MIMEObj => $self->Entity,
454 LogLevel => 'crit' );
459 return ($CurrentUser);
466 # {{{ ParseCcAddressesFromHead
468 =head2 ParseCcAddressesFromHead HASHREF
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.
477 sub ParseCcAddressesFromHead {
483 CurrentUser => undef,
489 my @ToObjs = Mail::Address->parse( $self->Head->get('To') );
490 my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') );
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) );
501 push ( @Addresses, $Address );
508 # {{{ ParseSenderAdddressFromHead
510 =head2 ParseSenderAddressFromHead
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)
517 sub ParseSenderAddressFromHead {
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) );
529 # {{{ ParseErrorsToAdddressFromHead
531 =head2 ParseErrorsToAddressFromHead
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)
538 sub ParseErrorsToAddressFromHead {
541 #Figure out who's sending this message.
543 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
545 # If there's a header of that name
546 my $headerobj = $self->Head->get($header);
548 my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj);
550 # If it's got actual useful content...
551 return ($addr) if ($addr);
558 # {{{ ParseAddressFromHeader
560 =head2 ParseAddressFromHeader ADDRESS
562 Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name
566 sub ParseAddressFromHeader {
570 my @Addresses = Mail::Address->parse($Addr);
572 my $AddrObj = $Addresses[0];
574 unless ( ref($AddrObj) ) {
575 return ( undef, undef );
578 my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
580 #Lets take the from and load a user object.
581 my $Address = $AddrObj->address;
583 return ( $Address, $Name );
590 =item IsRTaddress ADDRESS
592 Takes a single parameter, an email address.
593 Returns true if that address matches the $RTAddressRegexp.
594 Returns false, otherwise.
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" );
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/ ) {
622 # {{{ CullRTAddresses
624 =item CullRTAddresses ARRAY
626 Takes a single argument, an array of email addresses.
627 Returns the same array with any IsRTAddress()es weeded out.
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");
639 sub CullRTAddresses {
644 foreach my $addr( @addresses ) {
645 push (@addrlist, $addr) unless IsRTAddress("", $addr);
653 # {{{ LookupExternalUserInfo
656 # LookupExternalUserInfo is a site-definable method for synchronizing
657 # incoming users with an external data source.
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.
665 # If you define an AutoRejectRequest template, RT will use this
666 # template for the rejection message.
669 =item LookupExternalUserInfo
671 LookupExternalUserInfo is a site-definable method for synchronizing
672 incoming users with an external data source.
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.
680 It returns (FoundInExternalDatabase, ParamHash);
682 FoundInExternalDatabase must be set to 1 before return if the user was
683 found in the external database.
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
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
697 sub LookupExternalUserInfo {
699 my $EmailAddress = shift;
700 my $RealName = shift;
702 my $FoundInExternalDatabase = 1;
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;
710 # See RT's contributed code for examples.
711 # http://www.fsck.com/pub/rt/contrib/
712 return ($FoundInExternalDatabase, %params);
717 # {{{ Accessor methods for parsed email messages
721 Return the parsed head from this message
727 return $self->Entity->head;
732 Return the parsed Entity from this message
738 return $self->{'entity'};
742 # {{{ _SetupMIMEParser
744 =head2 _SetupMIMEParser $parser
746 A private instance method which sets up a mime parser to do its job
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?
755 ## At the same time, we should make sure that we nuke attachments
756 ## Over max size and return them
758 sub _SetupMIMEParser {
761 my $AttachmentDir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 );
763 # Set up output directory for files:
764 $parser->output_dir("$AttachmentDir");
766 #If someone includes a message, don't extract it
767 $parser->extract_nested_messages(1);
769 # Set up the prefix for files with auto-generated names:
770 $parser->output_prefix("part");
772 # If content length is <= 50000 bytes, store each msg as in-core scalar;
773 # Else, write to a disk file (the default action):
775 $parser->output_to_core(50000);
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});