1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
6 # <jesse@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
49 package RT::Interface::Email;
58 use UNIVERSAL::require;
63 use vars qw ( @EXPORT_OK);
65 # set the version for version checking
68 # your exported package globals go here,
69 # as well as any optionally exported functions
74 &CheckForSuspiciousSender
75 &CheckForAutoGenerated
78 &ParseCcAddressesFromHead
79 &ParseSenderAddressFromHead
80 &ParseErrorsToAddressFromHead
81 &ParseAddressFromHeader
88 RT::Interface::Email - helper functions for parsing email sent to RT
92 use lib "!!RT_LIB_PATH!!";
93 use lib "!!RT_ETC_PATH!!";
95 use RT::Interface::Email qw(Gateway CreateUser);
104 =head2 CheckForLoops HEAD
106 Takes a HEAD object of L<MIME::Head> class and returns true if the
107 message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
108 field of the head for test.
115 # If this instance of RT sent it our, we don't want to take it in
116 my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
117 chomp ($RTLoop); # remove that newline
118 if ( $RTLoop eq RT->Config->Get('rtname') ) {
122 # TODO: We might not trap the case where RT instance A sends a mail
123 # to RT instance B which sends a mail to ...
127 =head2 CheckForSuspiciousSender HEAD
129 Takes a HEAD object of L<MIME::Head> class and returns true if sender
130 is suspicious. Suspicious means mailer daemon.
132 See also L</ParseSenderAddressFromHead>.
136 sub CheckForSuspiciousSender {
139 #if it's from a postmaster or mailer daemon, it's likely a bounce.
141 #TODO: better algorithms needed here - there is no standards for
142 #bounces, so it's very difficult to separate them from anything
143 #else. At the other hand, the Return-To address is only ment to be
144 #used as an error channel, we might want to put up a separate
145 #Return-To address which is treated differently.
147 #TODO: search through the whole email and find the right Ticket ID.
149 my ( $From, $junk ) = ParseSenderAddressFromHead($head);
151 if ( ( $From =~ /^mailer-daemon\@/i )
152 or ( $From =~ /^postmaster\@/i )
162 =head2 CheckForAutoGenerated HEAD
164 Takes a HEAD object of L<MIME::Head> class and returns true if message
165 is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated'
166 fields of the head in tests.
170 sub CheckForAutoGenerated {
173 my $Precedence = $head->get("Precedence") || "";
174 if ( $Precedence =~ /^(bulk|junk)/i ) {
178 # Per RFC3834, any Auto-Submitted header which is not "no" means
179 # it is auto-generated.
180 my $AutoSubmitted = $head->get("Auto-Submitted") || "";
181 if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
185 # First Class mailer uses this as a clue.
186 my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
187 if ( $FCJunk =~ /^true/i ) {
198 my $ReturnPath = $head->get("Return-path") || "";
199 return ( $ReturnPath =~ /<>/ );
203 =head2 MailError PARAM HASH
205 Sends an error message. Takes a param hash:
209 =item From - sender's address, by default is 'CorrespondAddress';
211 =item To - recipient, by default is 'OwnerEmail';
213 =item Bcc - optional Bcc recipients;
215 =item Subject - subject of the message, default is 'There has been an error';
217 =item Explanation - main content of the error, default value is 'Unexplained error';
219 =item MIMEObj - optional MIME entity that's attached to the error mail, as well we
220 add 'In-Reply-To' field to the error that points to this message.
222 =item Attach - optional text that attached to the error as 'message/rfc822' part.
224 =item LogLevel - log level under which we should write explanation message into the
225 log, by default we log it as critical.
233 To => RT->Config->Get('OwnerEmail'),
235 From => RT->Config->Get('CorrespondAddress'),
236 Subject => 'There has been an error',
237 Explanation => 'Unexplained error',
245 level => $args{'LogLevel'},
246 message => $args{'Explanation'}
247 ) if $args{'LogLevel'};
248 # the colons are necessary to make ->build include non-standard headers
249 my $entity = MIME::Entity->build(
250 Type => "multipart/mixed",
251 From => $args{'From'},
254 Subject => $args{'Subject'},
255 'Precedence:' => 'bulk',
256 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
258 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
260 $entity->attach( Data => $args{'Explanation'} . "\n" );
262 if ( $args{'MIMEObj'} ) {
263 $args{'MIMEObj'}->sync_headers;
264 $entity->add_part( $args{'MIMEObj'} );
267 if ( $args{'Attach'} ) {
268 $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
272 SendEmail( Entity => $entity, Bounce => 1 );
276 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
278 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
279 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
280 true value, the message will be marked as an autogenerated error, if
281 possible. Sets Date field of the head to now if it's not set.
283 Ticket and Transaction arguments are optional. If Transaction is
284 specified and Ticket is not then ticket of the transaction is
285 used, but only if the transaction belongs to a ticket.
287 Returns 1 on success, 0 on error or -1 if message has no recipients
288 and hasn't been sent.
290 =head3 Signing and Encrypting
292 This function as well signs and/or encrypts the message according to
293 headers of a transaction's attachment or properties of a ticket's queue.
294 To get full access to the configuration Ticket and/or Transaction
295 arguments must be provided, but you can force behaviour using Sign
296 and/or Encrypt arguments.
298 The following precedence of arguments are used to figure out if
299 the message should be encrypted and/or signed:
301 * if Sign or Encrypt argument is defined then its value is used
303 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
304 header field then it's value is used
306 * else properties of a queue of the Ticket are used.
315 Transaction => undef,
319 my $TicketObj = $args{'Ticket'};
320 my $TransactionObj = $args{'Transaction'};
322 foreach my $arg( qw(Entity Bounce) ) {
323 next unless defined $args{ lc $arg };
325 $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
326 $args{ $arg } = delete $args{ lc $arg };
329 unless ( $args{'Entity'} ) {
330 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
334 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
337 # If we don't have any recipients to send to, don't send a message;
338 unless ( $args{'Entity'}->head->get('To')
339 || $args{'Entity'}->head->get('Cc')
340 || $args{'Entity'}->head->get('Bcc') )
342 $RT::Logger->info( $msgid . " No recipients found. Not sending." );
346 if ( $TransactionObj && !$TicketObj
347 && $TransactionObj->ObjectType eq 'RT::Ticket' )
349 $TicketObj = $TransactionObj->Object;
352 if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
356 $attachment = $TransactionObj->Attachments->First
359 foreach my $argument ( qw(Sign Encrypt) ) {
360 next if defined $args{ $argument };
362 if ( $attachment && defined $attachment->GetHeader("X-RT-$argument") ) {
363 $crypt{$argument} = $attachment->GetHeader("X-RT-$argument");
364 } elsif ( $TicketObj ) {
365 $crypt{$argument} = $TicketObj->QueueObj->$argument();
369 my $res = SignEncrypt( %args, %crypt );
370 return $res unless $res > 0;
373 unless ( $args{'Entity'}->head->get('Date') ) {
375 my $date = RT::Date->new( $RT::SystemUser );
377 $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
380 my $mail_command = RT->Config->Get('MailCommand');
382 if ($mail_command eq 'testfile') {
383 $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
386 # if it is a sub routine, we just return it;
387 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
389 if ( $mail_command eq 'sendmailpipe' ) {
390 my $path = RT->Config->Get('SendmailPath');
391 my $args = RT->Config->Get('SendmailArguments');
393 # SetOutgoingMailFrom
394 if ( RT->Config->Get('SetOutgoingMailFrom') ) {
395 my $OutgoingMailAddress;
398 my $QueueName = $TicketObj->QueueObj->Name;
399 my $QueueAddressOverride = RT->Config->Get('OverrideOutgoingMailFrom')->{$QueueName};
401 if ($QueueAddressOverride) {
402 $OutgoingMailAddress = $QueueAddressOverride;
404 $OutgoingMailAddress = $TicketObj->QueueObj->CorrespondAddress;
408 $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'};
410 $args .= " -f $OutgoingMailAddress"
411 if $OutgoingMailAddress;
414 # Set Bounce Arguments
415 $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'};
418 if ( $TransactionObj and
419 my $prefix = RT->Config->Get('VERPPrefix') and
420 my $domain = RT->Config->Get('VERPDomain') )
422 my $from = $TransactionObj->CreatorObj->EmailAddress;
425 $args .= " -f $prefix$from\@$domain";
429 # don't ignore CHLD signal to get proper exit code
430 local $SIG{'CHLD'} = 'DEFAULT';
432 open my $mail, "|$path $args" or die "couldn't execute program: $!";
434 # if something wrong with $mail->print we will get PIPE signal, handle it
435 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
436 $args{'Entity'}->print($mail);
438 unless ( close $mail ) {
439 die "close pipe failed: $!" if $!; # system error
440 # sendmail exit statuses mostly errors with data not software
441 # TODO: status parsing: core dump, exit on signal or EX_*
442 my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8);
443 $msg = ", interrupted by signal ". ($?&127) if $?&127;
444 $RT::Logger->error( $msg );
448 $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ );
452 elsif ( $mail_command eq 'smtp' ) {
454 my $smtp = do { local $@; eval { Net::SMTP->new(
455 Host => RT->Config->Get('SMTPServer'),
456 Debug => RT->Config->Get('SMTPDebug'),
459 $RT::Logger->crit( "Could not connect to SMTP server.");
463 # duplicate head as we want drop Bcc field
464 my $head = $args{'Entity'}->head->dup;
465 my @recipients = map $_->address, map
466 Email::Address->parse($head->get($_)), qw(To Cc Bcc);
467 $head->delete('Bcc');
469 my $sender = RT->Config->Get('SMTPFrom')
470 || $args{'Entity'}->head->get('From');
473 my $status = $smtp->mail( $sender )
474 && $smtp->recipient( @recipients );
478 my $fh = $smtp->tied_fh;
481 $args{'Entity'}->print_body( $fh );
487 $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
492 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
494 my @mailer_args = ($mail_command);
495 if ( $mail_command eq 'sendmail' ) {
496 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
497 push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
500 push @mailer_args, RT->Config->Get('MailParams');
503 unless ( $args{'Entity'}->send( @mailer_args ) ) {
504 $RT::Logger->crit( "$msgid: Could not send mail." );
511 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
513 Loads a template. Parses it using arguments if it's not empty.
514 Returns a tuple (L<RT::Template> object, error message).
516 Note that even if a template object is returned MIMEObj method
517 may return undef for empty templates.
521 sub PrepareEmailUsingTemplate {
528 my $template = RT::Template->new( $RT::SystemUser );
529 $template->LoadGlobalTemplate( $args{'Template'} );
530 unless ( $template->id ) {
531 return (undef, "Couldn't load template '". $args{'Template'} ."'");
533 return $template if $template->IsEmpty;
535 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
536 return (undef, $msg) unless $status;
541 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
543 Sends email using a template, takes name of template, arguments for it and recipients.
547 sub SendEmailUsingTemplate {
554 From => RT->Config->Get('CorrespondAddress'),
559 my ($template, $msg) = PrepareEmailUsingTemplate( %args );
560 return (0, $msg) unless $template;
562 my $mail = $template->MIMEObj;
564 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
568 $mail->head->set( $_ => $args{ $_ } )
569 foreach grep defined $args{$_}, qw(To Cc Bcc From);
571 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
573 return SendEmail( Entity => $mail );
576 =head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
578 Forwards transaction with all attachments as 'message/rfc822'.
582 sub ForwardTransaction {
584 my %args = ( To => '', Cc => '', Bcc => '', @_ );
586 my $entity = $txn->ContentAsMIME;
588 return SendForward( %args, Entity => $entity, Transaction => $txn );
591 =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
593 Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
599 my %args = ( To => '', Cc => '', Bcc => '', @_ );
601 my $txns = $ticket->Transactions;
605 ) for qw(Create Correspond);
607 my $entity = MIME::Entity->build(
608 Type => 'multipart/mixed',
610 $entity->add_part( $_ ) foreach
611 map $_->ContentAsMIME,
612 @{ $txns->ItemsArrayRef };
614 return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' );
617 =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
619 Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
627 Transaction => undef,
628 Template => 'Forward',
629 To => '', Cc => '', Bcc => '',
633 my $txn = $args{'Transaction'};
634 my $ticket = $args{'Ticket'};
635 $ticket ||= $txn->Object if $txn;
637 my $entity = $args{'Entity'};
640 $RT::Logger->error(Carp::longmess("No entity provided"));
641 return (0, $ticket->loc("Couldn't send email"));
644 my ($template, $msg) = PrepareEmailUsingTemplate(
645 Template => $args{'Template'},
654 $mail = $template->MIMEObj;
656 $RT::Logger->warning($msg);
659 $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
662 unless ( $args{'Transaction'} ) {
663 $description = 'This is forward of ticket #'. $ticket->id;
665 $description = 'This is forward of transaction #'
666 . $txn->id ." of a ticket #". $txn->ObjectId;
668 $mail = MIME::Entity->build(
669 Type => 'text/plain',
670 Data => $description,
674 $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
675 foreach grep defined $args{$_}, qw(To Cc Bcc);
678 Type => 'message/rfc822',
679 Disposition => 'attachment',
680 Description => 'forwarded message',
681 Data => $entity->as_string,
686 $subject = $txn->Subject if $txn;
687 $subject ||= $ticket->Subject if $ticket;
688 if ( RT->Config->Get('ForwardFromUser') ) {
689 $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress;
691 # XXX: what if want to forward txn of other object than ticket?
692 $subject = AddSubjectTag( $subject, $ticket );
693 $from = $ticket->QueueObj->CorrespondAddress
694 || RT->Config->Get('CorrespondAddress');
696 $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
697 $mail->head->set( From => EncodeToMIME( String => $from ) );
699 my $status = RT->Config->Get('ForwardFromUser')
700 # never sign if we forward from User
701 ? SendEmail( %args, Entity => $mail, Sign => 0 )
702 : SendEmail( %args, Entity => $mail );
703 return (0, $ticket->loc("Couldn't send email")) unless $status;
704 return (1, $ticket->loc("Send email successfully"));
707 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
709 Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
710 handle errors with users' keys.
712 If a recipient has no key or has other problems with it, then the
713 unction sends a error to him using 'Error: public key' template.
714 Also, notifies RT's owner using template 'Error to RT owner: public key'
715 to inform that there are problems with users' keys. Then we filter
716 all bad recipients and retry.
718 Returns 1 on success, 0 on error and -1 if all recipients are bad and
719 had been filtered out.
730 return 1 unless $args{'Sign'} || $args{'Encrypt'};
732 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
735 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
736 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
738 require RT::Crypt::GnuPG;
739 my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
740 return 1 unless $res{'exit_code'};
742 my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
745 foreach my $line ( @status ) {
746 # if the passphrase fails, either you have a bad passphrase
747 # or gpg-agent has died. That should get caught in Create and
748 # Update, but at least throw an error here
749 if (($line->{'Operation'}||'') eq 'PassphraseCheck'
750 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
751 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
754 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
755 next if $line->{'Status'} eq 'DONE';
756 $RT::Logger->error( $line->{'Message'} );
757 push @bad_recipients, $line;
759 return 0 unless @bad_recipients;
761 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
762 foreach @bad_recipients;
764 foreach my $recipient ( @bad_recipients ) {
765 my $status = SendEmailUsingTemplate(
766 To => $recipient->{'AddressObj'}->address,
767 Template => 'Error: public key',
770 TicketObj => $args{'Ticket'},
771 TransactionObj => $args{'Transaction'},
775 $RT::Logger->error("Couldn't send 'Error: public key'");
779 my $status = SendEmailUsingTemplate(
780 To => RT->Config->Get('OwnerEmail'),
781 Template => 'Error to RT owner: public key',
783 BadRecipients => \@bad_recipients,
784 TicketObj => $args{'Ticket'},
785 TransactionObj => $args{'Transaction'},
789 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
792 DeleteRecipientsFromHead(
793 $args{'Entity'}->head,
794 map $_->{'AddressObj'}->address, @bad_recipients
797 unless ( $args{'Entity'}->head->get('To')
798 || $args{'Entity'}->head->get('Cc')
799 || $args{'Entity'}->head->get('Bcc') )
801 $RT::Logger->debug("$msgid No recipients that have public key, not sending");
805 # redo without broken recipients
806 %res = RT::Crypt::GnuPG::SignEncrypt( %args );
807 return 0 if $res{'exit_code'};
816 Takes a hash with a String and a Charset. Returns the string encoded
817 according to RFC2047, using B (base64 based) encoding.
819 String must be a perl string, octets are returned.
821 If Charset is not provided then $EmailOutputEncoding config option
822 is used, or "latin-1" if that is not set.
832 my $value = $args{'String'};
833 return $value unless $value; # 0 is perfect ascii
834 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
837 # using RFC2047 notation, sec 2.
838 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
840 # An 'encoded-word' may not be more than 75 characters long
842 # MIME encoding increases 4/3*(number of bytes), and always in multiples
843 # of 4. Thus we have to find the best available value of bytes available
846 # First we get the integer max which max*4/3 would fit on space.
847 # Then we find the greater multiple of 3 lower or equal than $max.
849 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
853 $max = int( $max / 3 ) * 3;
860 $RT::Logger->crit("Can't encode! Charset or encoding too big.");
864 return ($value) unless $value =~ /[^\x20-\x7e]/;
868 # we need perl string to split thing char by char
869 Encode::_utf8_on($value) unless Encode::is_utf8($value);
871 my ( $tmp, @chunks ) = ( '', () );
872 while ( length $value ) {
873 my $char = substr( $value, 0, 1, '' );
874 my $octets = Encode::encode( $charset, $char );
875 if ( length($tmp) + length($octets) > $max ) {
881 push @chunks, $tmp if length $tmp;
883 # encode an join chuncks
885 map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
891 my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
893 my $NewUser = RT::User->new( $RT::SystemUser );
895 my ( $Val, $Message ) = $NewUser->Create(
896 Name => ( $Username || $Address ),
897 EmailAddress => $Address,
901 Comments => 'Autocreated on ticket submission',
906 # Deal with the race condition of two account creations at once
908 $NewUser->LoadByName($Username);
911 unless ( $NewUser->Id ) {
912 $NewUser->LoadByEmail($Address);
915 unless ( $NewUser->Id ) {
918 Subject => "User could not be created",
920 "User creation failed in mailgateway: $Message",
927 #Load the new user object
928 my $CurrentUser = new RT::CurrentUser;
929 $CurrentUser->LoadByEmail( $Address );
931 unless ( $CurrentUser->id ) {
932 $RT::Logger->warning(
933 "Couldn't load user '$Address'." . "giving up" );
936 Subject => "User could not be loaded",
938 "User '$Address' could not be loaded in the mail gateway",
949 =head2 ParseCcAddressesFromHead HASH
951 Takes a hash containing QueueObj, Head and CurrentUser objects.
952 Returns a list of all email addresses in the To and Cc
953 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
954 email address and anything that the configuration sub RT::IsRTAddress matches.
958 sub ParseCcAddressesFromHead {
962 CurrentUser => undef,
968 map Email::Address->parse( $args{'Head'}->get( $_ ) ),
972 foreach my $address ( @recipients ) {
973 $address = $args{'CurrentUser'}->UserObj->CanonicalizeEmailAddress( $address );
974 next if lc $args{'CurrentUser'}->EmailAddress eq $address;
975 next if lc $args{'QueueObj'}->CorrespondAddress eq $address;
976 next if lc $args{'QueueObj'}->CommentAddress eq $address;
977 next if RT::EmailParser->IsRTAddress( $address );
986 =head2 ParseSenderAddressFromHead HEAD
988 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
989 of the From (evaluated in order of Reply-To:, From:, Sender)
993 sub ParseSenderAddressFromHead {
996 #Figure out who's sending this message.
997 foreach my $header ('Reply-To', 'From', 'Sender') {
998 my $addr_line = $head->get($header) || next;
999 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1000 # only return if the address is not empty
1001 return ($addr, $name) if $addr;
1004 return (undef, undef);
1007 =head2 ParseErrorsToAddressFromHead HEAD
1009 Takes a MIME::Header object. Return a single value : user@host
1010 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1015 sub ParseErrorsToAddressFromHead {
1018 #Figure out who's sending this message.
1020 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1022 # If there's a header of that name
1023 my $headerobj = $head->get($header);
1025 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1027 # If it's got actual useful content...
1028 return ($addr) if ($addr);
1035 =head2 ParseAddressFromHeader ADDRESS
1037 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1041 sub ParseAddressFromHeader {
1044 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1045 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1046 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1048 my ($AddrObj) = grep ref $_, @Addresses;
1049 unless ( $AddrObj ) {
1050 return ( undef, undef );
1053 my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
1055 #Lets take the from and load a user object.
1056 my $Address = $AddrObj->address;
1058 return ( $Address, $Name );
1061 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1063 Gets a head object and list of addresses.
1064 Deletes addresses from To, Cc or Bcc fields.
1068 sub DeleteRecipientsFromHead {
1070 my %skip = map { lc $_ => 1 } @_;
1072 foreach my $field ( qw(To Cc Bcc) ) {
1073 $head->set( $field =>
1074 join ', ', map $_->format, grep !$skip{ lc $_->address },
1075 Email::Address->parse( $head->get( $field ) )
1084 ScripAction => undef,
1087 my $org = RT->Config->Get('Organization');
1088 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1089 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1090 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1092 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1093 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1103 return unless $args{'Message'} && $args{'InReplyTo'};
1105 my $get_header = sub {
1107 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1108 @res = $args{'InReplyTo'}->head->get( shift );
1110 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1112 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1115 my @id = $get_header->('Message-ID');
1116 #XXX: custom header should begin with X- otherwise is violation of the standard
1117 my @rtid = $get_header->('RT-Message-ID');
1118 my @references = $get_header->('References');
1119 unless ( @references ) {
1120 @references = $get_header->('In-Reply-To');
1122 push @references, @id, @rtid;
1123 if ( $args{'Ticket'} ) {
1124 my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
1125 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1127 @references = splice @references, 4, -6
1128 if @references > 10;
1130 my $mail = $args{'Message'};
1131 $mail->head->set( 'In-Reply-To' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid;
1132 $mail->head->set( 'References' => join ' ', @references );
1136 my $Subject = shift;
1138 my $rtname = RT->Config->Get('rtname');
1139 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1142 if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
1145 foreach my $tag ( RT->System->SubjectTag ) {
1146 next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
1151 return undef unless $id;
1153 $RT::Logger->debug("Found a ticket ID. It's $id");
1158 my $subject = shift;
1160 unless ( ref $ticket ) {
1161 my $tmp = RT::Ticket->new( $RT::SystemUser );
1162 $tmp->Load( $ticket );
1165 my $id = $ticket->id;
1166 my $queue_tag = $ticket->QueueObj->SubjectTag;
1168 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1169 unless ( $tag_re ) {
1170 my $tag = $queue_tag || RT->Config->Get('rtname');
1171 $tag_re = qr/\Q$tag\E/;
1172 } elsif ( $queue_tag ) {
1173 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1175 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1177 $subject =~ s/(\r\n|\n|\s)/ /gi;
1179 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1183 =head2 Gateway ARGSREF
1193 This performs all the "guts" of the mail rt-mailgate program, and is
1194 designed to be called from the web interface with a message, user
1197 Can also take an optional 'ticket' parameter; this ticket id overrides
1198 any ticket id found in the subject.
1204 (status code, message, optional ticket object)
1206 status code is a numeric value.
1208 for temporary failures, the status code should be -75
1210 for permanent failures which are handled by RT, the status code
1213 for succces, the status code should be 1
1220 my @mail_plugins = @_;
1223 foreach my $plugin (@mail_plugins) {
1224 if ( ref($plugin) eq "CODE" ) {
1226 } elsif ( !ref $plugin ) {
1227 my $Class = $plugin;
1228 $Class = "RT::Interface::Email::" . $Class
1229 unless $Class =~ /^RT::Interface::Email::/;
1231 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1234 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1235 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1240 $RT::Logger->crit( "$plugin - is not class name or code reference");
1247 my $argsref = shift;
1249 action => 'correspond',
1259 # Validate the action
1260 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1264 "Invalid 'action' parameter "
1272 my $parser = RT::EmailParser->new();
1273 $parser->SmartParseMIMEEntityFromScalar(
1274 Message => $args{'message'},
1279 my $Message = $parser->Entity();
1282 Subject => "RT Bounce: Unparseable message",
1283 Explanation => "RT couldn't process the message below",
1284 Attach => $args{'message'}
1288 "Failed to parse this message. Something is likely badly wrong with the message"
1292 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1293 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1294 @mail_plugins = _LoadPlugins( @mail_plugins );
1297 foreach my $class( grep !ref, @mail_plugins ) {
1298 # check if we should apply filter before decoding
1301 *{ $class . "::ApplyBeforeDecode" }{CODE};
1303 next unless defined $check_cb;
1304 next unless $check_cb->(
1305 Message => $Message,
1306 RawMessageRef => \$args{'message'},
1309 $skip_plugin{ $class }++;
1313 *{ $class . "::GetCurrentUser" }{CODE};
1315 my ($status, $msg) = $Code->(
1316 Message => $Message,
1317 RawMessageRef => \$args{'message'},
1319 next if $status > 0;
1321 if ( $status == -2 ) {
1322 return (1, $msg, undef);
1323 } elsif ( $status == -1 ) {
1324 return (0, $msg, undef);
1327 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1328 $parser->_DecodeBodies;
1329 $parser->_PostProcessNewEntity;
1331 my $head = $Message->head;
1332 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1334 my $MessageId = $head->get('Message-ID')
1335 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1337 #Pull apart the subject line
1338 my $Subject = $head->get('Subject') || '';
1341 # {{{ Lets check for mail loops of various sorts.
1342 my ($should_store_machine_generated_message, $IsALoop, $result);
1343 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1344 _HandleMachineGeneratedMail(
1345 Message => $Message,
1346 ErrorsTo => $ErrorsTo,
1347 Subject => $Subject,
1348 MessageId => $MessageId
1351 # Do not pass loop messages to MailPlugins, to make sure the loop
1352 # is broken, unless $RT::StoreLoops is set.
1353 if ($IsALoop && !$should_store_machine_generated_message) {
1354 return ( 0, $result, undef );
1358 $args{'ticket'} ||= ParseTicketId( $Subject );
1360 $SystemTicket = RT::Ticket->new( $RT::SystemUser );
1361 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1362 if ( $SystemTicket->id ) {
1363 $Right = 'ReplyToTicket';
1365 $Right = 'CreateTicket';
1368 #Set up a queue object
1369 my $SystemQueueObj = RT::Queue->new( $RT::SystemUser );
1370 $SystemQueueObj->Load( $args{'queue'} );
1372 # We can safely have no queue of we have a known-good ticket
1373 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1374 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1377 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1378 MailPlugins => \@mail_plugins,
1379 Actions => \@actions,
1380 Message => $Message,
1381 RawMessageRef => \$args{message},
1382 SystemTicket => $SystemTicket,
1383 SystemQueue => $SystemQueueObj,
1386 # {{{ If authentication fails and no new user was created, get out.
1387 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1389 # If the plugins refused to create one, they lose.
1390 unless ( $AuthStat == -1 ) {
1391 _NoAuthorizedUserFound(
1393 Message => $Message,
1394 Requestor => $ErrorsTo,
1395 Queue => $args{'queue'}
1399 return ( 0, "Could not load a valid user", undef );
1402 # If we got a user, but they don't have the right to say things
1403 if ( $AuthStat == 0 ) {
1406 Subject => "Permission Denied",
1408 "You do not have permission to communicate with RT",
1413 "$ErrorsTo tried to submit a message to "
1415 . " without permission.",
1421 unless ($should_store_machine_generated_message) {
1422 return ( 0, $result, undef );
1425 # if plugin's updated SystemTicket then update arguments
1426 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1428 my $Ticket = RT::Ticket->new($CurrentUser);
1430 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1434 my @Requestors = ( $CurrentUser->id );
1436 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1437 @Cc = ParseCcAddressesFromHead(
1439 CurrentUser => $CurrentUser,
1440 QueueObj => $SystemQueueObj
1444 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1445 Queue => $SystemQueueObj->Id,
1446 Subject => $Subject,
1447 Requestor => \@Requestors,
1454 Subject => "Ticket creation failed: $Subject",
1455 Explanation => $ErrStr,
1458 return ( 0, "Ticket creation failed: $ErrStr", $Ticket );
1461 # strip comments&corresponds from the actions we don't need
1462 # to record them if we've created the ticket just now
1463 @actions = grep !/^(comment|correspond)$/, @actions;
1464 $args{'ticket'} = $id;
1466 } elsif ( $args{'ticket'} ) {
1468 $Ticket->Load( $args{'ticket'} );
1469 unless ( $Ticket->Id ) {
1470 my $error = "Could not find a ticket with id " . $args{'ticket'};
1473 Subject => "Message not recorded: $Subject",
1474 Explanation => $error,
1478 return ( 0, $error );
1480 $args{'ticket'} = $Ticket->id;
1482 return ( 1, "Success", $Ticket );
1487 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1488 foreach my $action (@actions) {
1490 # If the action is comment, add a comment.
1491 if ( $action =~ /^(?:comment|correspond)$/i ) {
1492 my $method = ucfirst lc $action;
1493 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1496 #Warn the sender that we couldn't actually submit the comment.
1499 Subject => "Message not recorded: $Subject",
1500 Explanation => $msg,
1503 return ( 0, "Message not recorded: $msg", $Ticket );
1505 } elsif ($unsafe_actions) {
1506 my ( $status, $msg ) = _RunUnsafeAction(
1508 ErrorsTo => $ErrorsTo,
1509 Message => $Message,
1511 CurrentUser => $CurrentUser,
1513 return ($status, $msg, $Ticket) unless $status == 1;
1516 return ( 1, "Success", $Ticket );
1519 =head2 GetAuthenticationLevel
1521 # Authentication Level
1522 # -1 - Get out. this user has been explicitly declined
1523 # 0 - User may not do anything (Not used at the moment)
1525 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1529 sub GetAuthenticationLevel {
1534 RawMessageRef => undef,
1535 SystemTicket => undef,
1536 SystemQueue => undef,
1540 my ( $CurrentUser, $AuthStat, $error );
1542 # Initalize AuthStat so comparisons work correctly
1543 $AuthStat = -9999999;
1545 # if plugin returns AuthStat -2 we skip action
1546 # NOTE: this is experimental API and it would be changed
1547 my %skip_action = ();
1549 # Since this needs loading, no matter what
1550 foreach (@{ $args{MailPlugins} }) {
1551 my ($Code, $NewAuthStat);
1552 if ( ref($_) eq "CODE" ) {
1556 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1559 foreach my $action (@{ $args{Actions} }) {
1560 ( $CurrentUser, $NewAuthStat ) = $Code->(
1561 Message => $args{Message},
1562 RawMessageRef => $args{RawMessageRef},
1563 CurrentUser => $CurrentUser,
1564 AuthLevel => $AuthStat,
1566 Ticket => $args{SystemTicket},
1567 Queue => $args{SystemQueue},
1570 # You get the highest level of authentication you were assigned, unless you get the magic -1
1571 # If a module returns a "-1" then we discard the ticket, so.
1572 $AuthStat = $NewAuthStat
1573 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1575 last if $AuthStat == -1;
1576 $skip_action{$action}++ if $AuthStat == -2;
1579 # strip actions we should skip
1580 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1582 last unless @{$args{Actions}};
1584 last if $AuthStat == -1;
1587 return $AuthStat if !wantarray;
1589 return ($AuthStat, $CurrentUser, $error);
1592 sub _RunUnsafeAction {
1598 CurrentUser => undef,
1602 if ( $args{'Action'} =~ /^take$/i ) {
1603 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1606 To => $args{'ErrorsTo'},
1607 Subject => "Ticket not taken",
1608 Explanation => $msg,
1609 MIMEObj => $args{'Message'}
1611 return ( 0, "Ticket not taken" );
1613 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1614 my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved');
1617 #Warn the sender that we couldn't actually submit the comment.
1619 To => $args{'ErrorsTo'},
1620 Subject => "Ticket not resolved",
1621 Explanation => $msg,
1622 MIMEObj => $args{'Message'}
1624 return ( 0, "Ticket not resolved" );
1627 return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} );
1629 return ( 1, "Success" );
1632 =head2 _NoAuthorizedUserFound
1634 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1638 sub _NoAuthorizedUserFound {
1647 # Notify the RT Admin of the failure.
1649 To => RT->Config->Get('OwnerEmail'),
1650 Subject => "Could not load a valid user",
1651 Explanation => <<EOT,
1652 RT could not load a valid user, and RT's configuration does not allow
1653 for the creation of a new user for this email (@{[$args{Requestor}]}).
1655 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1656 queue @{[$args{'Queue'}]}.
1659 MIMEObj => $args{'Message'},
1663 # Also notify the requestor that his request has been dropped.
1664 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1666 To => $args{'Requestor'},
1667 Subject => "Could not load a valid user",
1668 Explanation => <<EOT,
1669 RT could not load a valid user, and RT's configuration does not allow
1670 for the creation of a new user for your email.
1673 MIMEObj => $args{'Message'},
1679 =head2 _HandleMachineGeneratedMail
1686 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1687 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1688 "This message appears to be a loop (boolean)" );
1692 sub _HandleMachineGeneratedMail {
1693 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1694 my $head = $args{'Message'}->head;
1695 my $ErrorsTo = $args{'ErrorsTo'};
1697 my $IsBounce = CheckForBounce($head);
1699 my $IsAutoGenerated = CheckForAutoGenerated($head);
1701 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1703 my $IsALoop = CheckForLoops($head);
1705 my $SquelchReplies = 0;
1707 my $owner_mail = RT->Config->Get('OwnerEmail');
1709 #If the message is autogenerated, we need to know, so we can not
1710 # send mail to the sender
1711 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1712 $SquelchReplies = 1;
1713 $ErrorsTo = $owner_mail;
1716 # Warn someone if it's a loop, before we drop it on the ground
1718 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1720 #Should we mail it to RTOwner?
1721 if ( RT->Config->Get('LoopsToRTOwner') ) {
1724 Subject => "RT Bounce: ".$args{'Subject'},
1725 Explanation => "RT thinks this message may be a bounce",
1726 MIMEObj => $args{Message}
1730 #Do we actually want to store it?
1731 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1732 unless RT->Config->Get('StoreLoops');
1735 # Squelch replies if necessary
1736 # Don't let the user stuff the RT-Squelch-Replies-To header.
1737 if ( $head->get('RT-Squelch-Replies-To') ) {
1739 'RT-Relocated-Squelch-Replies-To',
1740 $head->get('RT-Squelch-Replies-To')
1742 $head->delete('RT-Squelch-Replies-To');
1745 if ($SquelchReplies) {
1747 # Squelch replies to the sender, and also leave a clue to
1748 # allow us to squelch ALL outbound messages. This way we
1749 # can punt the logic of "what to do when we get a bounce"
1750 # to the scrip. We might want to notify nobody. Or just
1751 # the RT Owner. Or maybe all Privileged watchers.
1752 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1753 $head->add( 'RT-Squelch-Replies-To', $Sender );
1754 $head->add( 'RT-DetectedAutoGenerated', 'true' );
1756 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1759 =head2 IsCorrectAction
1761 Returns a list of valid actions we've found for this message
1765 sub IsCorrectAction {
1767 my @actions = grep $_, split /-/, $action;
1768 return ( 0, '(no value)' ) unless @actions;
1769 foreach ( @actions ) {
1770 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1772 return ( 1, @actions );
1775 eval "require RT::Interface::Email_Vendor";
1776 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm} );
1777 eval "require RT::Interface::Email_Local";
1778 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Local.pm} );