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 && !RT::EmailParser->IsRTAddress( $_ ),
1001 map lc $user->CanonicalizeEmailAddress( $_->address ),
1002 map Email::Address->parse( $args{'Head'}->get( $_ ) ),
1008 =head2 ParseSenderAddressFromHead HEAD
1010 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
1011 of the From (evaluated in order of Reply-To:, From:, Sender)
1015 sub ParseSenderAddressFromHead {
1018 #Figure out who's sending this message.
1019 foreach my $header ('Reply-To', 'From', 'Sender') {
1020 my $addr_line = $head->get($header) || next;
1021 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1022 # only return if the address is not empty
1023 return ($addr, $name) if $addr;
1026 return (undef, undef);
1029 =head2 ParseErrorsToAddressFromHead HEAD
1031 Takes a MIME::Header object. Return a single value : user@host
1032 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1037 sub ParseErrorsToAddressFromHead {
1040 #Figure out who's sending this message.
1042 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1044 # If there's a header of that name
1045 my $headerobj = $head->get($header);
1047 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1049 # If it's got actual useful content...
1050 return ($addr) if ($addr);
1057 =head2 ParseAddressFromHeader ADDRESS
1059 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1063 sub ParseAddressFromHeader {
1066 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1067 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1068 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1070 my ($AddrObj) = grep ref $_, @Addresses;
1071 unless ( $AddrObj ) {
1072 return ( undef, undef );
1075 my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
1077 #Lets take the from and load a user object.
1078 my $Address = $AddrObj->address;
1080 return ( $Address, $Name );
1083 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1085 Gets a head object and list of addresses.
1086 Deletes addresses from To, Cc or Bcc fields.
1090 sub DeleteRecipientsFromHead {
1092 my %skip = map { lc $_ => 1 } @_;
1094 foreach my $field ( qw(To Cc Bcc) ) {
1095 $head->set( $field =>
1096 join ', ', map $_->format, grep !$skip{ lc $_->address },
1097 Email::Address->parse( $head->get( $field ) )
1106 ScripAction => undef,
1109 my $org = RT->Config->Get('Organization');
1110 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1111 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1112 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1114 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1115 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1125 return unless $args{'Message'} && $args{'InReplyTo'};
1127 my $get_header = sub {
1129 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1130 @res = $args{'InReplyTo'}->head->get( shift );
1132 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1134 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1137 my @id = $get_header->('Message-ID');
1138 #XXX: custom header should begin with X- otherwise is violation of the standard
1139 my @rtid = $get_header->('RT-Message-ID');
1140 my @references = $get_header->('References');
1141 unless ( @references ) {
1142 @references = $get_header->('In-Reply-To');
1144 push @references, @id, @rtid;
1145 if ( $args{'Ticket'} ) {
1146 my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
1147 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1149 @references = splice @references, 4, -6
1150 if @references > 10;
1152 my $mail = $args{'Message'};
1153 $mail->head->set( 'In-Reply-To' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid;
1154 $mail->head->set( 'References' => join ' ', @references );
1158 my $Subject = shift;
1160 my $rtname = RT->Config->Get('rtname');
1161 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1164 if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
1167 foreach my $tag ( RT->System->SubjectTag ) {
1168 next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
1173 return undef unless $id;
1175 $RT::Logger->debug("Found a ticket ID. It's $id");
1180 my $subject = shift;
1182 unless ( ref $ticket ) {
1183 my $tmp = RT::Ticket->new( $RT::SystemUser );
1184 $tmp->Load( $ticket );
1187 my $id = $ticket->id;
1188 my $queue_tag = $ticket->QueueObj->SubjectTag;
1190 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1191 unless ( $tag_re ) {
1192 my $tag = $queue_tag || RT->Config->Get('rtname');
1193 $tag_re = qr/\Q$tag\E/;
1194 } elsif ( $queue_tag ) {
1195 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1197 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1199 $subject =~ s/(\r\n|\n|\s)/ /gi;
1201 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1205 =head2 Gateway ARGSREF
1215 This performs all the "guts" of the mail rt-mailgate program, and is
1216 designed to be called from the web interface with a message, user
1219 Can also take an optional 'ticket' parameter; this ticket id overrides
1220 any ticket id found in the subject.
1226 (status code, message, optional ticket object)
1228 status code is a numeric value.
1230 for temporary failures, the status code should be -75
1232 for permanent failures which are handled by RT, the status code
1235 for succces, the status code should be 1
1242 my @mail_plugins = @_;
1245 foreach my $plugin (@mail_plugins) {
1246 if ( ref($plugin) eq "CODE" ) {
1248 } elsif ( !ref $plugin ) {
1249 my $Class = $plugin;
1250 $Class = "RT::Interface::Email::" . $Class
1251 unless $Class =~ /^RT::Interface::Email::/;
1253 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1256 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1257 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1262 $RT::Logger->crit( "$plugin - is not class name or code reference");
1269 my $argsref = shift;
1271 action => 'correspond',
1281 # Validate the action
1282 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1286 "Invalid 'action' parameter "
1294 my $parser = RT::EmailParser->new();
1295 $parser->SmartParseMIMEEntityFromScalar(
1296 Message => $args{'message'},
1301 my $Message = $parser->Entity();
1304 Subject => "RT Bounce: Unparseable message",
1305 Explanation => "RT couldn't process the message below",
1306 Attach => $args{'message'}
1310 "Failed to parse this message. Something is likely badly wrong with the message"
1314 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1315 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1316 @mail_plugins = _LoadPlugins( @mail_plugins );
1319 foreach my $class( grep !ref, @mail_plugins ) {
1320 # check if we should apply filter before decoding
1323 *{ $class . "::ApplyBeforeDecode" }{CODE};
1325 next unless defined $check_cb;
1326 next unless $check_cb->(
1327 Message => $Message,
1328 RawMessageRef => \$args{'message'},
1331 $skip_plugin{ $class }++;
1335 *{ $class . "::GetCurrentUser" }{CODE};
1337 my ($status, $msg) = $Code->(
1338 Message => $Message,
1339 RawMessageRef => \$args{'message'},
1341 next if $status > 0;
1343 if ( $status == -2 ) {
1344 return (1, $msg, undef);
1345 } elsif ( $status == -1 ) {
1346 return (0, $msg, undef);
1349 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1350 $parser->_DecodeBodies;
1351 $parser->_PostProcessNewEntity;
1353 my $head = $Message->head;
1354 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1356 my $MessageId = $head->get('Message-ID')
1357 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1359 #Pull apart the subject line
1360 my $Subject = $head->get('Subject') || '';
1363 # {{{ Lets check for mail loops of various sorts.
1364 my ($should_store_machine_generated_message, $IsALoop, $result);
1365 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1366 _HandleMachineGeneratedMail(
1367 Message => $Message,
1368 ErrorsTo => $ErrorsTo,
1369 Subject => $Subject,
1370 MessageId => $MessageId
1373 # Do not pass loop messages to MailPlugins, to make sure the loop
1374 # is broken, unless $RT::StoreLoops is set.
1375 if ($IsALoop && !$should_store_machine_generated_message) {
1376 return ( 0, $result, undef );
1380 $args{'ticket'} ||= ParseTicketId( $Subject );
1382 $SystemTicket = RT::Ticket->new( $RT::SystemUser );
1383 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1384 if ( $SystemTicket->id ) {
1385 $Right = 'ReplyToTicket';
1387 $Right = 'CreateTicket';
1390 #Set up a queue object
1391 my $SystemQueueObj = RT::Queue->new( $RT::SystemUser );
1392 $SystemQueueObj->Load( $args{'queue'} );
1394 # We can safely have no queue of we have a known-good ticket
1395 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1396 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1399 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1400 MailPlugins => \@mail_plugins,
1401 Actions => \@actions,
1402 Message => $Message,
1403 RawMessageRef => \$args{message},
1404 SystemTicket => $SystemTicket,
1405 SystemQueue => $SystemQueueObj,
1408 # {{{ If authentication fails and no new user was created, get out.
1409 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1411 # If the plugins refused to create one, they lose.
1412 unless ( $AuthStat == -1 ) {
1413 _NoAuthorizedUserFound(
1415 Message => $Message,
1416 Requestor => $ErrorsTo,
1417 Queue => $args{'queue'}
1421 return ( 0, "Could not load a valid user", undef );
1424 # If we got a user, but they don't have the right to say things
1425 if ( $AuthStat == 0 ) {
1428 Subject => "Permission Denied",
1430 "You do not have permission to communicate with RT",
1435 "$ErrorsTo tried to submit a message to "
1437 . " without permission.",
1443 unless ($should_store_machine_generated_message) {
1444 return ( 0, $result, undef );
1447 # if plugin's updated SystemTicket then update arguments
1448 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1450 my $Ticket = RT::Ticket->new($CurrentUser);
1452 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1456 my @Requestors = ( $CurrentUser->id );
1458 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1459 @Cc = ParseCcAddressesFromHead(
1461 CurrentUser => $CurrentUser,
1462 QueueObj => $SystemQueueObj
1466 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1467 Queue => $SystemQueueObj->Id,
1468 Subject => $Subject,
1469 Requestor => \@Requestors,
1476 Subject => "Ticket creation failed: $Subject",
1477 Explanation => $ErrStr,
1480 return ( 0, "Ticket creation failed: $ErrStr", $Ticket );
1483 # strip comments&corresponds from the actions we don't need
1484 # to record them if we've created the ticket just now
1485 @actions = grep !/^(comment|correspond)$/, @actions;
1486 $args{'ticket'} = $id;
1488 } elsif ( $args{'ticket'} ) {
1490 $Ticket->Load( $args{'ticket'} );
1491 unless ( $Ticket->Id ) {
1492 my $error = "Could not find a ticket with id " . $args{'ticket'};
1495 Subject => "Message not recorded: $Subject",
1496 Explanation => $error,
1500 return ( 0, $error );
1502 $args{'ticket'} = $Ticket->id;
1504 return ( 1, "Success", $Ticket );
1509 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1510 foreach my $action (@actions) {
1512 # If the action is comment, add a comment.
1513 if ( $action =~ /^(?:comment|correspond)$/i ) {
1514 my $method = ucfirst lc $action;
1515 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1518 #Warn the sender that we couldn't actually submit the comment.
1521 Subject => "Message not recorded: $Subject",
1522 Explanation => $msg,
1525 return ( 0, "Message not recorded: $msg", $Ticket );
1527 } elsif ($unsafe_actions) {
1528 my ( $status, $msg ) = _RunUnsafeAction(
1530 ErrorsTo => $ErrorsTo,
1531 Message => $Message,
1533 CurrentUser => $CurrentUser,
1535 return ($status, $msg, $Ticket) unless $status == 1;
1538 return ( 1, "Success", $Ticket );
1541 =head2 GetAuthenticationLevel
1543 # Authentication Level
1544 # -1 - Get out. this user has been explicitly declined
1545 # 0 - User may not do anything (Not used at the moment)
1547 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1551 sub GetAuthenticationLevel {
1556 RawMessageRef => undef,
1557 SystemTicket => undef,
1558 SystemQueue => undef,
1562 my ( $CurrentUser, $AuthStat, $error );
1564 # Initalize AuthStat so comparisons work correctly
1565 $AuthStat = -9999999;
1567 # if plugin returns AuthStat -2 we skip action
1568 # NOTE: this is experimental API and it would be changed
1569 my %skip_action = ();
1571 # Since this needs loading, no matter what
1572 foreach (@{ $args{MailPlugins} }) {
1573 my ($Code, $NewAuthStat);
1574 if ( ref($_) eq "CODE" ) {
1578 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1581 foreach my $action (@{ $args{Actions} }) {
1582 ( $CurrentUser, $NewAuthStat ) = $Code->(
1583 Message => $args{Message},
1584 RawMessageRef => $args{RawMessageRef},
1585 CurrentUser => $CurrentUser,
1586 AuthLevel => $AuthStat,
1588 Ticket => $args{SystemTicket},
1589 Queue => $args{SystemQueue},
1592 # You get the highest level of authentication you were assigned, unless you get the magic -1
1593 # If a module returns a "-1" then we discard the ticket, so.
1594 $AuthStat = $NewAuthStat
1595 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1597 last if $AuthStat == -1;
1598 $skip_action{$action}++ if $AuthStat == -2;
1601 # strip actions we should skip
1602 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1604 last unless @{$args{Actions}};
1606 last if $AuthStat == -1;
1609 return $AuthStat if !wantarray;
1611 return ($AuthStat, $CurrentUser, $error);
1614 sub _RunUnsafeAction {
1620 CurrentUser => undef,
1624 if ( $args{'Action'} =~ /^take$/i ) {
1625 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1628 To => $args{'ErrorsTo'},
1629 Subject => "Ticket not taken",
1630 Explanation => $msg,
1631 MIMEObj => $args{'Message'}
1633 return ( 0, "Ticket not taken" );
1635 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1636 my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved');
1639 #Warn the sender that we couldn't actually submit the comment.
1641 To => $args{'ErrorsTo'},
1642 Subject => "Ticket not resolved",
1643 Explanation => $msg,
1644 MIMEObj => $args{'Message'}
1646 return ( 0, "Ticket not resolved" );
1649 return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} );
1651 return ( 1, "Success" );
1654 =head2 _NoAuthorizedUserFound
1656 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1660 sub _NoAuthorizedUserFound {
1669 # Notify the RT Admin of the failure.
1671 To => RT->Config->Get('OwnerEmail'),
1672 Subject => "Could not load a valid user",
1673 Explanation => <<EOT,
1674 RT could not load a valid user, and RT's configuration does not allow
1675 for the creation of a new user for this email (@{[$args{Requestor}]}).
1677 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1678 queue @{[$args{'Queue'}]}.
1681 MIMEObj => $args{'Message'},
1685 # Also notify the requestor that his request has been dropped.
1686 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1688 To => $args{'Requestor'},
1689 Subject => "Could not load a valid user",
1690 Explanation => <<EOT,
1691 RT could not load a valid user, and RT's configuration does not allow
1692 for the creation of a new user for your email.
1695 MIMEObj => $args{'Message'},
1701 =head2 _HandleMachineGeneratedMail
1708 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1709 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1710 "This message appears to be a loop (boolean)" );
1714 sub _HandleMachineGeneratedMail {
1715 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1716 my $head = $args{'Message'}->head;
1717 my $ErrorsTo = $args{'ErrorsTo'};
1719 my $IsBounce = CheckForBounce($head);
1721 my $IsAutoGenerated = CheckForAutoGenerated($head);
1723 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1725 my $IsALoop = CheckForLoops($head);
1727 my $SquelchReplies = 0;
1729 my $owner_mail = RT->Config->Get('OwnerEmail');
1731 #If the message is autogenerated, we need to know, so we can not
1732 # send mail to the sender
1733 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1734 $SquelchReplies = 1;
1735 $ErrorsTo = $owner_mail;
1738 # Warn someone if it's a loop, before we drop it on the ground
1740 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1742 #Should we mail it to RTOwner?
1743 if ( RT->Config->Get('LoopsToRTOwner') ) {
1746 Subject => "RT Bounce: ".$args{'Subject'},
1747 Explanation => "RT thinks this message may be a bounce",
1748 MIMEObj => $args{Message}
1752 #Do we actually want to store it?
1753 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1754 unless RT->Config->Get('StoreLoops');
1757 # Squelch replies if necessary
1758 # Don't let the user stuff the RT-Squelch-Replies-To header.
1759 if ( $head->get('RT-Squelch-Replies-To') ) {
1761 'RT-Relocated-Squelch-Replies-To',
1762 $head->get('RT-Squelch-Replies-To')
1764 $head->delete('RT-Squelch-Replies-To');
1767 if ($SquelchReplies) {
1769 # Squelch replies to the sender, and also leave a clue to
1770 # allow us to squelch ALL outbound messages. This way we
1771 # can punt the logic of "what to do when we get a bounce"
1772 # to the scrip. We might want to notify nobody. Or just
1773 # the RT Owner. Or maybe all Privileged watchers.
1774 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1775 $head->add( 'RT-Squelch-Replies-To', $Sender );
1776 $head->add( 'RT-DetectedAutoGenerated', 'true' );
1778 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1781 =head2 IsCorrectAction
1783 Returns a list of valid actions we've found for this message
1787 sub IsCorrectAction {
1789 my @actions = grep $_, split /-/, $action;
1790 return ( 0, '(no value)' ) unless @actions;
1791 foreach ( @actions ) {
1792 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1794 return ( 1, @actions );
1797 sub _RecordSendEmailFailure {
1800 $ticket->_RecordNote(
1801 NoteType => 'SystemError',
1802 Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.",
1807 $RT::Logger->error( "Can't record send email failure as ticket is missing" );
1812 eval "require RT::Interface::Email_Vendor";
1813 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm} );
1814 eval "require RT::Interface::Email_Local";
1815 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Local.pm} );