1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC
6 # <sales@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'};
249 # the colons are necessary to make ->build include non-standard headers
251 Type => "multipart/mixed",
252 From => $args{'From'},
255 Subject => $args{'Subject'},
256 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
259 # only set precedence if the sysadmin wants us to
260 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
261 $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
264 my $entity = MIME::Entity->build(%entity_args);
265 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
267 $entity->attach( Data => $args{'Explanation'} . "\n" );
269 if ( $args{'MIMEObj'} ) {
270 $args{'MIMEObj'}->sync_headers;
271 $entity->add_part( $args{'MIMEObj'} );
274 if ( $args{'Attach'} ) {
275 $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
279 SendEmail( Entity => $entity, Bounce => 1 );
283 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
285 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
286 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
287 true value, the message will be marked as an autogenerated error, if
288 possible. Sets Date field of the head to now if it's not set.
290 If the C<X-RT-Squelch> header is set to any true value, the mail will
291 not be sent. One use is to let extensions easily cancel outgoing mail.
293 Ticket and Transaction arguments are optional. If Transaction is
294 specified and Ticket is not then ticket of the transaction is
295 used, but only if the transaction belongs to a ticket.
297 Returns 1 on success, 0 on error or -1 if message has no recipients
298 and hasn't been sent.
300 =head3 Signing and Encrypting
302 This function as well signs and/or encrypts the message according to
303 headers of a transaction's attachment or properties of a ticket's queue.
304 To get full access to the configuration Ticket and/or Transaction
305 arguments must be provided, but you can force behaviour using Sign
306 and/or Encrypt arguments.
308 The following precedence of arguments are used to figure out if
309 the message should be encrypted and/or signed:
311 * if Sign or Encrypt argument is defined then its value is used
313 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
314 header field then it's value is used
316 * else properties of a queue of the Ticket are used.
325 Transaction => undef,
329 my $TicketObj = $args{'Ticket'};
330 my $TransactionObj = $args{'Transaction'};
332 foreach my $arg( qw(Entity Bounce) ) {
333 next unless defined $args{ lc $arg };
335 $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
336 $args{ $arg } = delete $args{ lc $arg };
339 unless ( $args{'Entity'} ) {
340 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
344 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
347 # If we don't have any recipients to send to, don't send a message;
348 unless ( $args{'Entity'}->head->get('To')
349 || $args{'Entity'}->head->get('Cc')
350 || $args{'Entity'}->head->get('Bcc') )
352 $RT::Logger->info( $msgid . " No recipients found. Not sending." );
356 if ($args{'Entity'}->head->get('X-RT-Squelch')) {
357 $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
361 if ( $TransactionObj && !$TicketObj
362 && $TransactionObj->ObjectType eq 'RT::Ticket' )
364 $TicketObj = $TransactionObj->Object;
367 if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
371 $attachment = $TransactionObj->Attachments->First
374 foreach my $argument ( qw(Sign Encrypt) ) {
375 next if defined $args{ $argument };
377 if ( $attachment && defined $attachment->GetHeader("X-RT-$argument") ) {
378 $crypt{$argument} = $attachment->GetHeader("X-RT-$argument");
379 } elsif ( $TicketObj ) {
380 $crypt{$argument} = $TicketObj->QueueObj->$argument();
384 my $res = SignEncrypt( %args, %crypt );
385 return $res unless $res > 0;
388 unless ( $args{'Entity'}->head->get('Date') ) {
390 my $date = RT::Date->new( $RT::SystemUser );
392 $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
395 my $mail_command = RT->Config->Get('MailCommand');
397 if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) {
398 $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
399 $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
402 # if it is a sub routine, we just return it;
403 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
405 if ( $mail_command eq 'sendmailpipe' ) {
406 my $path = RT->Config->Get('SendmailPath');
407 my $args = RT->Config->Get('SendmailArguments');
409 # SetOutgoingMailFrom
410 if ( RT->Config->Get('SetOutgoingMailFrom') ) {
411 my $OutgoingMailAddress;
414 my $QueueName = $TicketObj->QueueObj->Name;
415 my $QueueAddressOverride = RT->Config->Get('OverrideOutgoingMailFrom')->{$QueueName};
417 if ($QueueAddressOverride) {
418 $OutgoingMailAddress = $QueueAddressOverride;
420 $OutgoingMailAddress = $TicketObj->QueueObj->CorrespondAddress;
424 $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'};
426 $args .= " -f $OutgoingMailAddress"
427 if $OutgoingMailAddress;
430 # Set Bounce Arguments
431 $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'};
434 if ( $TransactionObj and
435 my $prefix = RT->Config->Get('VERPPrefix') and
436 my $domain = RT->Config->Get('VERPDomain') )
438 my $from = $TransactionObj->CreatorObj->EmailAddress;
441 $args .= " -f $prefix$from\@$domain";
445 # don't ignore CHLD signal to get proper exit code
446 local $SIG{'CHLD'} = 'DEFAULT';
448 open( my $mail, '|-', "$path $args >/dev/null" )
449 or die "couldn't execute program: $!";
451 # if something wrong with $mail->print we will get PIPE signal, handle it
452 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
453 $args{'Entity'}->print($mail);
455 unless ( close $mail ) {
456 die "close pipe failed: $!" if $!; # system error
457 # sendmail exit statuses mostly errors with data not software
458 # TODO: status parsing: core dump, exit on signal or EX_*
459 my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8);
460 $msg = ", interrupted by signal ". ($?&127) if $?&127;
461 $RT::Logger->error( $msg );
466 $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ );
468 _RecordSendEmailFailure( $TicketObj );
473 elsif ( $mail_command eq 'smtp' ) {
475 my $smtp = do { local $@; eval { Net::SMTP->new(
476 Host => RT->Config->Get('SMTPServer'),
477 Debug => RT->Config->Get('SMTPDebug'),
480 $RT::Logger->crit( "Could not connect to SMTP server.");
482 _RecordSendEmailFailure( $TicketObj );
487 # duplicate head as we want drop Bcc field
488 my $head = $args{'Entity'}->head->dup;
489 my @recipients = map $_->address, map
490 Email::Address->parse($head->get($_)), qw(To Cc Bcc);
491 $head->delete('Bcc');
493 my $sender = RT->Config->Get('SMTPFrom')
494 || $args{'Entity'}->head->get('From');
497 my $status = $smtp->mail( $sender )
498 && $smtp->recipient( @recipients );
502 my $fh = $smtp->tied_fh;
505 $args{'Entity'}->print_body( $fh );
511 $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
513 _RecordSendEmailFailure( $TicketObj );
519 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
521 my @mailer_args = ($mail_command);
522 if ( $mail_command eq 'sendmail' ) {
523 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
524 push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
527 push @mailer_args, RT->Config->Get('MailParams');
530 unless ( $args{'Entity'}->send( @mailer_args ) ) {
531 $RT::Logger->crit( "$msgid: Could not send mail." );
533 _RecordSendEmailFailure( $TicketObj );
541 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
543 Loads a template. Parses it using arguments if it's not empty.
544 Returns a tuple (L<RT::Template> object, error message).
546 Note that even if a template object is returned MIMEObj method
547 may return undef for empty templates.
551 sub PrepareEmailUsingTemplate {
558 my $template = RT::Template->new( $RT::SystemUser );
559 $template->LoadGlobalTemplate( $args{'Template'} );
560 unless ( $template->id ) {
561 return (undef, "Couldn't load template '". $args{'Template'} ."'");
563 return $template if $template->IsEmpty;
565 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
566 return (undef, $msg) unless $status;
571 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
573 Sends email using a template, takes name of template, arguments for it and recipients.
577 sub SendEmailUsingTemplate {
584 From => RT->Config->Get('CorrespondAddress'),
589 my ($template, $msg) = PrepareEmailUsingTemplate( %args );
590 return (0, $msg) unless $template;
592 my $mail = $template->MIMEObj;
594 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
598 $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
599 foreach grep defined $args{$_}, qw(To Cc Bcc From);
601 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
603 return SendEmail( Entity => $mail );
606 =head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
608 Forwards transaction with all attachments as 'message/rfc822'.
612 sub ForwardTransaction {
614 my %args = ( To => '', Cc => '', Bcc => '', @_ );
616 my $entity = $txn->ContentAsMIME;
618 return SendForward( %args, Entity => $entity, Transaction => $txn );
621 =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
623 Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
629 my %args = ( To => '', Cc => '', Bcc => '', @_ );
631 my $txns = $ticket->Transactions;
635 ) for qw(Create Correspond);
637 my $entity = MIME::Entity->build(
638 Type => 'multipart/mixed',
640 $entity->add_part( $_ ) foreach
641 map $_->ContentAsMIME,
642 @{ $txns->ItemsArrayRef };
644 return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' );
647 =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
649 Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
657 Transaction => undef,
658 Template => 'Forward',
659 To => '', Cc => '', Bcc => '',
663 my $txn = $args{'Transaction'};
664 my $ticket = $args{'Ticket'};
665 $ticket ||= $txn->Object if $txn;
667 my $entity = $args{'Entity'};
670 $RT::Logger->error(Carp::longmess("No entity provided"));
671 return (0, $ticket->loc("Couldn't send email"));
674 my ($template, $msg) = PrepareEmailUsingTemplate(
675 Template => $args{'Template'},
684 $mail = $template->MIMEObj;
686 $RT::Logger->warning($msg);
689 $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
692 unless ( $args{'Transaction'} ) {
693 $description = 'This is forward of ticket #'. $ticket->id;
695 $description = 'This is forward of transaction #'
696 . $txn->id ." of a ticket #". $txn->ObjectId;
698 $mail = MIME::Entity->build(
699 Type => 'text/plain',
700 Data => $description,
704 $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
705 foreach grep defined $args{$_}, qw(To Cc Bcc);
708 Type => 'message/rfc822',
709 Disposition => 'attachment',
710 Description => 'forwarded message',
711 Data => $entity->as_string,
716 $subject = $txn->Subject if $txn;
717 $subject ||= $ticket->Subject if $ticket;
718 if ( RT->Config->Get('ForwardFromUser') ) {
719 $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress;
721 # XXX: what if want to forward txn of other object than ticket?
722 $subject = AddSubjectTag( $subject, $ticket );
723 $from = $ticket->QueueObj->CorrespondAddress
724 || RT->Config->Get('CorrespondAddress');
726 $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
727 $mail->head->set( From => EncodeToMIME( String => $from ) );
729 my $status = RT->Config->Get('ForwardFromUser')
730 # never sign if we forward from User
731 ? SendEmail( %args, Entity => $mail, Sign => 0 )
732 : SendEmail( %args, Entity => $mail );
733 return (0, $ticket->loc("Couldn't send email")) unless $status;
734 return (1, $ticket->loc("Send email successfully"));
737 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
739 Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
740 handle errors with users' keys.
742 If a recipient has no key or has other problems with it, then the
743 unction sends a error to him using 'Error: public key' template.
744 Also, notifies RT's owner using template 'Error to RT owner: public key'
745 to inform that there are problems with users' keys. Then we filter
746 all bad recipients and retry.
748 Returns 1 on success, 0 on error and -1 if all recipients are bad and
749 had been filtered out.
760 return 1 unless $args{'Sign'} || $args{'Encrypt'};
762 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
765 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
766 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
768 require RT::Crypt::GnuPG;
769 my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
770 return 1 unless $res{'exit_code'};
772 my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
775 foreach my $line ( @status ) {
776 # if the passphrase fails, either you have a bad passphrase
777 # or gpg-agent has died. That should get caught in Create and
778 # Update, but at least throw an error here
779 if (($line->{'Operation'}||'') eq 'PassphraseCheck'
780 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
781 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
784 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
785 next if $line->{'Status'} eq 'DONE';
786 $RT::Logger->error( $line->{'Message'} );
787 push @bad_recipients, $line;
789 return 0 unless @bad_recipients;
791 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
792 foreach @bad_recipients;
794 foreach my $recipient ( @bad_recipients ) {
795 my $status = SendEmailUsingTemplate(
796 To => $recipient->{'AddressObj'}->address,
797 Template => 'Error: public key',
800 TicketObj => $args{'Ticket'},
801 TransactionObj => $args{'Transaction'},
805 $RT::Logger->error("Couldn't send 'Error: public key'");
809 my $status = SendEmailUsingTemplate(
810 To => RT->Config->Get('OwnerEmail'),
811 Template => 'Error to RT owner: public key',
813 BadRecipients => \@bad_recipients,
814 TicketObj => $args{'Ticket'},
815 TransactionObj => $args{'Transaction'},
819 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
822 DeleteRecipientsFromHead(
823 $args{'Entity'}->head,
824 map $_->{'AddressObj'}->address, @bad_recipients
827 unless ( $args{'Entity'}->head->get('To')
828 || $args{'Entity'}->head->get('Cc')
829 || $args{'Entity'}->head->get('Bcc') )
831 $RT::Logger->debug("$msgid No recipients that have public key, not sending");
835 # redo without broken recipients
836 %res = RT::Crypt::GnuPG::SignEncrypt( %args );
837 return 0 if $res{'exit_code'};
846 Takes a hash with a String and a Charset. Returns the string encoded
847 according to RFC2047, using B (base64 based) encoding.
849 String must be a perl string, octets are returned.
851 If Charset is not provided then $EmailOutputEncoding config option
852 is used, or "latin-1" if that is not set.
862 my $value = $args{'String'};
863 return $value unless $value; # 0 is perfect ascii
864 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
867 # using RFC2047 notation, sec 2.
868 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
870 # An 'encoded-word' may not be more than 75 characters long
872 # MIME encoding increases 4/3*(number of bytes), and always in multiples
873 # of 4. Thus we have to find the best available value of bytes available
876 # First we get the integer max which max*4/3 would fit on space.
877 # Then we find the greater multiple of 3 lower or equal than $max.
879 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
883 $max = int( $max / 3 ) * 3;
890 $RT::Logger->crit("Can't encode! Charset or encoding too big.");
894 return ($value) unless $value =~ /[^\x20-\x7e]/;
898 # we need perl string to split thing char by char
899 Encode::_utf8_on($value) unless Encode::is_utf8($value);
901 my ( $tmp, @chunks ) = ( '', () );
902 while ( length $value ) {
903 my $char = substr( $value, 0, 1, '' );
904 my $octets = Encode::encode( $charset, $char );
905 if ( length($tmp) + length($octets) > $max ) {
911 push @chunks, $tmp if length $tmp;
913 # encode an join chuncks
915 map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
921 my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
923 my $NewUser = RT::User->new( $RT::SystemUser );
925 my ( $Val, $Message ) = $NewUser->Create(
926 Name => ( $Username || $Address ),
927 EmailAddress => $Address,
931 Comments => 'Autocreated on ticket submission',
936 # Deal with the race condition of two account creations at once
938 $NewUser->LoadByName($Username);
941 unless ( $NewUser->Id ) {
942 $NewUser->LoadByEmail($Address);
945 unless ( $NewUser->Id ) {
948 Subject => "User could not be created",
950 "User creation failed in mailgateway: $Message",
957 #Load the new user object
958 my $CurrentUser = new RT::CurrentUser;
959 $CurrentUser->LoadByEmail( $Address );
961 unless ( $CurrentUser->id ) {
962 $RT::Logger->warning(
963 "Couldn't load user '$Address'." . "giving up" );
966 Subject => "User could not be loaded",
968 "User '$Address' could not be loaded in the mail gateway",
979 =head2 ParseCcAddressesFromHead HASH
981 Takes a hash containing QueueObj, Head and CurrentUser objects.
982 Returns a list of all email addresses in the To and Cc
983 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
984 email address and anything that the configuration sub RT::IsRTAddress matches.
988 sub ParseCcAddressesFromHead {
992 CurrentUser => undef,
996 my $current_address = lc $args{'CurrentUser'}->EmailAddress;
997 my $user = $args{'CurrentUser'}->UserObj;
1000 grep { $_ ne $current_address
1001 && !RT::EmailParser->IsRTAddress( $_ )
1002 && !IgnoreCcAddress( $_ )
1004 map lc $user->CanonicalizeEmailAddress( $_->address ),
1005 map Email::Address->parse( $args{'Head'}->get( $_ ) ),
1009 =head2 IgnoreCcAddress ADDRESS
1011 Returns true if ADDRESS matches the $IgnoreCcRegexp config variable.
1015 sub IgnoreCcAddress {
1016 my $address = shift;
1017 if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) {
1018 return 1 if $address =~ /$address_re/i;
1023 =head2 ParseSenderAddressFromHead HEAD
1025 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
1026 of the From (evaluated in order of Reply-To:, From:, Sender)
1030 sub ParseSenderAddressFromHead {
1033 #Figure out who's sending this message.
1034 foreach my $header ('Reply-To', 'From', 'Sender') {
1035 my $addr_line = $head->get($header) || next;
1036 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1037 # only return if the address is not empty
1038 return ($addr, $name) if $addr;
1041 return (undef, undef);
1044 =head2 ParseErrorsToAddressFromHead HEAD
1046 Takes a MIME::Header object. Return a single value : user@host
1047 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1052 sub ParseErrorsToAddressFromHead {
1055 #Figure out who's sending this message.
1057 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1059 # If there's a header of that name
1060 my $headerobj = $head->get($header);
1062 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1064 # If it's got actual useful content...
1065 return ($addr) if ($addr);
1072 =head2 ParseAddressFromHeader ADDRESS
1074 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1078 sub ParseAddressFromHeader {
1081 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1082 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1083 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1085 my ($AddrObj) = grep ref $_, @Addresses;
1086 unless ( $AddrObj ) {
1087 return ( undef, undef );
1090 my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
1092 #Lets take the from and load a user object.
1093 my $Address = $AddrObj->address;
1095 return ( $Address, $Name );
1098 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1100 Gets a head object and list of addresses.
1101 Deletes addresses from To, Cc or Bcc fields.
1105 sub DeleteRecipientsFromHead {
1107 my %skip = map { lc $_ => 1 } @_;
1109 foreach my $field ( qw(To Cc Bcc) ) {
1110 $head->set( $field =>
1111 join ', ', map $_->format, grep !$skip{ lc $_->address },
1112 Email::Address->parse( $head->get( $field ) )
1121 ScripAction => undef,
1124 my $org = RT->Config->Get('Organization');
1125 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1126 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1127 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1129 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1130 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1140 return unless $args{'Message'} && $args{'InReplyTo'};
1142 my $get_header = sub {
1144 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1145 @res = $args{'InReplyTo'}->head->get( shift );
1147 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1149 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1152 my @id = $get_header->('Message-ID');
1153 #XXX: custom header should begin with X- otherwise is violation of the standard
1154 my @rtid = $get_header->('RT-Message-ID');
1155 my @references = $get_header->('References');
1156 unless ( @references ) {
1157 @references = $get_header->('In-Reply-To');
1159 push @references, @id, @rtid;
1160 if ( $args{'Ticket'} ) {
1161 my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
1162 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1164 @references = splice @references, 4, -6
1165 if @references > 10;
1167 my $mail = $args{'Message'};
1168 $mail->head->set( 'In-Reply-To' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid;
1169 $mail->head->set( 'References' => join ' ', @references );
1173 my $Subject = shift;
1175 my $rtname = RT->Config->Get('rtname');
1176 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1179 if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
1182 foreach my $tag ( RT->System->SubjectTag ) {
1183 next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
1188 return undef unless $id;
1190 $RT::Logger->debug("Found a ticket ID. It's $id");
1195 my $subject = shift;
1197 unless ( ref $ticket ) {
1198 my $tmp = RT::Ticket->new( $RT::SystemUser );
1199 $tmp->Load( $ticket );
1202 my $id = $ticket->id;
1203 my $queue_tag = $ticket->QueueObj->SubjectTag;
1205 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1206 unless ( $tag_re ) {
1207 my $tag = $queue_tag || RT->Config->Get('rtname');
1208 $tag_re = qr/\Q$tag\E/;
1209 } elsif ( $queue_tag ) {
1210 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1212 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1214 $subject =~ s/(\r\n|\n|\s)/ /gi;
1216 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1220 =head2 Gateway ARGSREF
1230 This performs all the "guts" of the mail rt-mailgate program, and is
1231 designed to be called from the web interface with a message, user
1234 Can also take an optional 'ticket' parameter; this ticket id overrides
1235 any ticket id found in the subject.
1241 (status code, message, optional ticket object)
1243 status code is a numeric value.
1245 for temporary failures, the status code should be -75
1247 for permanent failures which are handled by RT, the status code
1250 for succces, the status code should be 1
1257 my @mail_plugins = @_;
1260 foreach my $plugin (@mail_plugins) {
1261 if ( ref($plugin) eq "CODE" ) {
1263 } elsif ( !ref $plugin ) {
1264 my $Class = $plugin;
1265 $Class = "RT::Interface::Email::" . $Class
1266 unless $Class =~ /^RT::Interface::Email::/;
1268 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1271 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1272 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1277 $RT::Logger->crit( "$plugin - is not class name or code reference");
1284 my $argsref = shift;
1286 action => 'correspond',
1296 # Validate the action
1297 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1301 "Invalid 'action' parameter "
1309 my $parser = RT::EmailParser->new();
1310 $parser->SmartParseMIMEEntityFromScalar(
1311 Message => $args{'message'},
1316 my $Message = $parser->Entity();
1319 Subject => "RT Bounce: Unparseable message",
1320 Explanation => "RT couldn't process the message below",
1321 Attach => $args{'message'}
1325 "Failed to parse this message. Something is likely badly wrong with the message"
1329 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1330 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1331 @mail_plugins = _LoadPlugins( @mail_plugins );
1334 foreach my $class( grep !ref, @mail_plugins ) {
1335 # check if we should apply filter before decoding
1338 *{ $class . "::ApplyBeforeDecode" }{CODE};
1340 next unless defined $check_cb;
1341 next unless $check_cb->(
1342 Message => $Message,
1343 RawMessageRef => \$args{'message'},
1346 $skip_plugin{ $class }++;
1350 *{ $class . "::GetCurrentUser" }{CODE};
1352 my ($status, $msg) = $Code->(
1353 Message => $Message,
1354 RawMessageRef => \$args{'message'},
1356 next if $status > 0;
1358 if ( $status == -2 ) {
1359 return (1, $msg, undef);
1360 } elsif ( $status == -1 ) {
1361 return (0, $msg, undef);
1364 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1365 $parser->_DecodeBodies;
1366 $parser->_PostProcessNewEntity;
1368 my $head = $Message->head;
1369 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1371 my $MessageId = $head->get('Message-ID')
1372 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1374 #Pull apart the subject line
1375 my $Subject = $head->get('Subject') || '';
1378 # {{{ Lets check for mail loops of various sorts.
1379 my ($should_store_machine_generated_message, $IsALoop, $result);
1380 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1381 _HandleMachineGeneratedMail(
1382 Message => $Message,
1383 ErrorsTo => $ErrorsTo,
1384 Subject => $Subject,
1385 MessageId => $MessageId
1388 # Do not pass loop messages to MailPlugins, to make sure the loop
1389 # is broken, unless $RT::StoreLoops is set.
1390 if ($IsALoop && !$should_store_machine_generated_message) {
1391 return ( 0, $result, undef );
1395 $args{'ticket'} ||= ParseTicketId( $Subject );
1397 $SystemTicket = RT::Ticket->new( $RT::SystemUser );
1398 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1399 if ( $SystemTicket->id ) {
1400 $Right = 'ReplyToTicket';
1402 $Right = 'CreateTicket';
1405 #Set up a queue object
1406 my $SystemQueueObj = RT::Queue->new( $RT::SystemUser );
1407 $SystemQueueObj->Load( $args{'queue'} );
1409 # We can safely have no queue of we have a known-good ticket
1410 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1411 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1414 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1415 MailPlugins => \@mail_plugins,
1416 Actions => \@actions,
1417 Message => $Message,
1418 RawMessageRef => \$args{message},
1419 SystemTicket => $SystemTicket,
1420 SystemQueue => $SystemQueueObj,
1423 # {{{ If authentication fails and no new user was created, get out.
1424 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1426 # If the plugins refused to create one, they lose.
1427 unless ( $AuthStat == -1 ) {
1428 _NoAuthorizedUserFound(
1430 Message => $Message,
1431 Requestor => $ErrorsTo,
1432 Queue => $args{'queue'}
1436 return ( 0, "Could not load a valid user", undef );
1439 # If we got a user, but they don't have the right to say things
1440 if ( $AuthStat == 0 ) {
1443 Subject => "Permission Denied",
1445 "You do not have permission to communicate with RT",
1450 "$ErrorsTo tried to submit a message to "
1452 . " without permission.",
1458 unless ($should_store_machine_generated_message) {
1459 return ( 0, $result, undef );
1462 # if plugin's updated SystemTicket then update arguments
1463 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1465 my $Ticket = RT::Ticket->new($CurrentUser);
1467 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1471 my @Requestors = ( $CurrentUser->id );
1473 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1474 @Cc = ParseCcAddressesFromHead(
1476 CurrentUser => $CurrentUser,
1477 QueueObj => $SystemQueueObj
1481 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1482 Queue => $SystemQueueObj->Id,
1483 Subject => $Subject,
1484 Requestor => \@Requestors,
1491 Subject => "Ticket creation failed: $Subject",
1492 Explanation => $ErrStr,
1495 return ( 0, "Ticket creation failed: $ErrStr", $Ticket );
1498 # strip comments&corresponds from the actions we don't need
1499 # to record them if we've created the ticket just now
1500 @actions = grep !/^(comment|correspond)$/, @actions;
1501 $args{'ticket'} = $id;
1503 } elsif ( $args{'ticket'} ) {
1505 $Ticket->Load( $args{'ticket'} );
1506 unless ( $Ticket->Id ) {
1507 my $error = "Could not find a ticket with id " . $args{'ticket'};
1510 Subject => "Message not recorded: $Subject",
1511 Explanation => $error,
1515 return ( 0, $error );
1517 $args{'ticket'} = $Ticket->id;
1519 return ( 1, "Success", $Ticket );
1524 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1525 foreach my $action (@actions) {
1527 # If the action is comment, add a comment.
1528 if ( $action =~ /^(?:comment|correspond)$/i ) {
1529 my $method = ucfirst lc $action;
1530 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1533 #Warn the sender that we couldn't actually submit the comment.
1536 Subject => "Message not recorded: $Subject",
1537 Explanation => $msg,
1540 return ( 0, "Message not recorded: $msg", $Ticket );
1542 } elsif ($unsafe_actions) {
1543 my ( $status, $msg ) = _RunUnsafeAction(
1545 ErrorsTo => $ErrorsTo,
1546 Message => $Message,
1548 CurrentUser => $CurrentUser,
1550 return ($status, $msg, $Ticket) unless $status == 1;
1553 return ( 1, "Success", $Ticket );
1556 =head2 GetAuthenticationLevel
1558 # Authentication Level
1559 # -1 - Get out. this user has been explicitly declined
1560 # 0 - User may not do anything (Not used at the moment)
1562 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1566 sub GetAuthenticationLevel {
1571 RawMessageRef => undef,
1572 SystemTicket => undef,
1573 SystemQueue => undef,
1577 my ( $CurrentUser, $AuthStat, $error );
1579 # Initalize AuthStat so comparisons work correctly
1580 $AuthStat = -9999999;
1582 # if plugin returns AuthStat -2 we skip action
1583 # NOTE: this is experimental API and it would be changed
1584 my %skip_action = ();
1586 # Since this needs loading, no matter what
1587 foreach (@{ $args{MailPlugins} }) {
1588 my ($Code, $NewAuthStat);
1589 if ( ref($_) eq "CODE" ) {
1593 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1596 foreach my $action (@{ $args{Actions} }) {
1597 ( $CurrentUser, $NewAuthStat ) = $Code->(
1598 Message => $args{Message},
1599 RawMessageRef => $args{RawMessageRef},
1600 CurrentUser => $CurrentUser,
1601 AuthLevel => $AuthStat,
1603 Ticket => $args{SystemTicket},
1604 Queue => $args{SystemQueue},
1607 # You get the highest level of authentication you were assigned, unless you get the magic -1
1608 # If a module returns a "-1" then we discard the ticket, so.
1609 $AuthStat = $NewAuthStat
1610 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1612 last if $AuthStat == -1;
1613 $skip_action{$action}++ if $AuthStat == -2;
1616 # strip actions we should skip
1617 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1619 last unless @{$args{Actions}};
1621 last if $AuthStat == -1;
1624 return $AuthStat if !wantarray;
1626 return ($AuthStat, $CurrentUser, $error);
1629 sub _RunUnsafeAction {
1635 CurrentUser => undef,
1639 if ( $args{'Action'} =~ /^take$/i ) {
1640 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1643 To => $args{'ErrorsTo'},
1644 Subject => "Ticket not taken",
1645 Explanation => $msg,
1646 MIMEObj => $args{'Message'}
1648 return ( 0, "Ticket not taken" );
1650 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1651 my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved');
1654 #Warn the sender that we couldn't actually submit the comment.
1656 To => $args{'ErrorsTo'},
1657 Subject => "Ticket not resolved",
1658 Explanation => $msg,
1659 MIMEObj => $args{'Message'}
1661 return ( 0, "Ticket not resolved" );
1664 return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} );
1666 return ( 1, "Success" );
1669 =head2 _NoAuthorizedUserFound
1671 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1675 sub _NoAuthorizedUserFound {
1684 # Notify the RT Admin of the failure.
1686 To => RT->Config->Get('OwnerEmail'),
1687 Subject => "Could not load a valid user",
1688 Explanation => <<EOT,
1689 RT could not load a valid user, and RT's configuration does not allow
1690 for the creation of a new user for this email (@{[$args{Requestor}]}).
1692 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1693 queue @{[$args{'Queue'}]}.
1696 MIMEObj => $args{'Message'},
1700 # Also notify the requestor that his request has been dropped.
1701 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1703 To => $args{'Requestor'},
1704 Subject => "Could not load a valid user",
1705 Explanation => <<EOT,
1706 RT could not load a valid user, and RT's configuration does not allow
1707 for the creation of a new user for your email.
1710 MIMEObj => $args{'Message'},
1716 =head2 _HandleMachineGeneratedMail
1723 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1724 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1725 "This message appears to be a loop (boolean)" );
1729 sub _HandleMachineGeneratedMail {
1730 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1731 my $head = $args{'Message'}->head;
1732 my $ErrorsTo = $args{'ErrorsTo'};
1734 my $IsBounce = CheckForBounce($head);
1736 my $IsAutoGenerated = CheckForAutoGenerated($head);
1738 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1740 my $IsALoop = CheckForLoops($head);
1742 my $SquelchReplies = 0;
1744 my $owner_mail = RT->Config->Get('OwnerEmail');
1746 #If the message is autogenerated, we need to know, so we can not
1747 # send mail to the sender
1748 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1749 $SquelchReplies = 1;
1750 $ErrorsTo = $owner_mail;
1753 # Warn someone if it's a loop, before we drop it on the ground
1755 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1757 #Should we mail it to RTOwner?
1758 if ( RT->Config->Get('LoopsToRTOwner') ) {
1761 Subject => "RT Bounce: ".$args{'Subject'},
1762 Explanation => "RT thinks this message may be a bounce",
1763 MIMEObj => $args{Message}
1767 #Do we actually want to store it?
1768 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1769 unless RT->Config->Get('StoreLoops');
1772 # Squelch replies if necessary
1773 # Don't let the user stuff the RT-Squelch-Replies-To header.
1774 if ( $head->get('RT-Squelch-Replies-To') ) {
1776 'RT-Relocated-Squelch-Replies-To',
1777 $head->get('RT-Squelch-Replies-To')
1779 $head->delete('RT-Squelch-Replies-To');
1782 if ($SquelchReplies) {
1784 # Squelch replies to the sender, and also leave a clue to
1785 # allow us to squelch ALL outbound messages. This way we
1786 # can punt the logic of "what to do when we get a bounce"
1787 # to the scrip. We might want to notify nobody. Or just
1788 # the RT Owner. Or maybe all Privileged watchers.
1789 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1790 $head->add( 'RT-Squelch-Replies-To', $Sender );
1791 $head->add( 'RT-DetectedAutoGenerated', 'true' );
1793 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1796 =head2 IsCorrectAction
1798 Returns a list of valid actions we've found for this message
1802 sub IsCorrectAction {
1804 my @actions = grep $_, split /-/, $action;
1805 return ( 0, '(no value)' ) unless @actions;
1806 foreach ( @actions ) {
1807 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1809 return ( 1, @actions );
1812 sub _RecordSendEmailFailure {
1815 $ticket->_RecordNote(
1816 NoteType => 'SystemError',
1817 Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.",
1822 $RT::Logger->error( "Can't record send email failure as ticket is missing" );
1827 RT::Base->_ImportOverlays();