1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2016 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;
60 use Text::ParseWords qw/shellwords/;
61 use RT::Util 'safe_run_child';
66 use vars qw ( @EXPORT_OK);
68 # your exported package globals go here,
69 # as well as any optionally exported functions
73 &CheckForSuspiciousSender
74 &CheckForAutoGenerated
77 &ParseCcAddressesFromHead
78 &ParseSenderAddressFromHead
79 &ParseErrorsToAddressFromHead
80 &ParseAddressFromHeader
87 RT::Interface::Email - helper functions for parsing email sent to RT
91 use lib "!!RT_LIB_PATH!!";
92 use lib "!!RT_ETC_PATH!!";
94 use RT::Interface::Email qw(Gateway CreateUser);
103 =head2 CheckForLoops HEAD
105 Takes a HEAD object of L<MIME::Head> class and returns true if the
106 message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
107 field of the head for test.
114 # If this instance of RT sent it our, we don't want to take it in
115 my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" );
116 chomp ($RTLoop); # remove that newline
117 if ( $RTLoop eq RT->Config->Get('rtname') ) {
121 # TODO: We might not trap the case where RT instance A sends a mail
122 # to RT instance B which sends a mail to ...
126 =head2 CheckForSuspiciousSender HEAD
128 Takes a HEAD object of L<MIME::Head> class and returns true if sender
129 is suspicious. Suspicious means mailer daemon.
131 See also L</ParseSenderAddressFromHead>.
135 sub CheckForSuspiciousSender {
138 #if it's from a postmaster or mailer daemon, it's likely a bounce.
140 #TODO: better algorithms needed here - there is no standards for
141 #bounces, so it's very difficult to separate them from anything
142 #else. At the other hand, the Return-To address is only ment to be
143 #used as an error channel, we might want to put up a separate
144 #Return-To address which is treated differently.
146 #TODO: search through the whole email and find the right Ticket ID.
148 my ( $From, $junk ) = ParseSenderAddressFromHead($head);
150 # If unparseable (non-ASCII), $From can come back undef
151 return undef if not defined $From;
153 if ( ( $From =~ /^mailer-daemon\@/i )
154 or ( $From =~ /^postmaster\@/i )
164 =head2 CheckForAutoGenerated HEAD
166 Takes a HEAD object of L<MIME::Head> class and returns true if message is
167 autogenerated. Checks C<Precedence>, C<Auto-Submitted>, and
168 C<X-FC-Machinegenerated> fields of the head in tests.
172 sub CheckForAutoGenerated {
175 if (grep { /^(bulk|junk)/i } $head->get_all("Precedence")) {
179 # Per RFC3834, any Auto-Submitted header which is not "no" means
180 # it is auto-generated.
181 my $AutoSubmitted = $head->get("Auto-Submitted") || "";
182 if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
186 # First Class mailer uses this as a clue.
187 my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
188 if ( $FCJunk =~ /^true/i ) {
199 my $ReturnPath = $head->get("Return-path") || "";
200 return ( $ReturnPath =~ /<>/ );
204 =head2 MailError PARAM HASH
206 Sends an error message. Takes a param hash:
210 =item From - sender's address, by default is 'CorrespondAddress';
212 =item To - recipient, by default is 'OwnerEmail';
214 =item Bcc - optional Bcc recipients;
216 =item Subject - subject of the message, default is 'There has been an error';
218 =item Explanation - main content of the error, default value is 'Unexplained error';
220 =item MIMEObj - optional MIME entity that's attached to the error mail, as well we
221 add 'In-Reply-To' field to the error that points to this message.
223 =item Attach - optional text that attached to the error as 'message/rfc822' part.
225 =item LogLevel - log level under which we should write the subject and
226 explanation message into the log, by default we log it as critical.
234 To => RT->Config->Get('OwnerEmail'),
236 From => RT->Config->Get('CorrespondAddress'),
237 Subject => 'There has been an error',
238 Explanation => 'Unexplained error',
246 level => $args{'LogLevel'},
247 message => "$args{Subject}: $args{'Explanation'}",
248 ) if $args{'LogLevel'};
250 # the colons are necessary to make ->build include non-standard headers
252 Type => "multipart/mixed",
253 From => Encode::encode( "UTF-8", $args{'From'} ),
254 Bcc => Encode::encode( "UTF-8", $args{'Bcc'} ),
255 To => Encode::encode( "UTF-8", $args{'To'} ),
256 Subject => EncodeToMIME( String => $args{'Subject'} ),
257 'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ),
260 # only set precedence if the sysadmin wants us to
261 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
262 $entity_args{'Precedence:'} =
263 Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') );
266 my $entity = MIME::Entity->build(%entity_args);
267 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
270 Type => "text/plain",
272 Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ),
275 if ( $args{'MIMEObj'} ) {
276 $args{'MIMEObj'}->sync_headers;
277 $entity->add_part( $args{'MIMEObj'} );
280 if ( $args{'Attach'} ) {
281 $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' );
285 SendEmail( Entity => $entity, Bounce => 1 );
289 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
291 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
292 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
293 true value, the message will be marked as an autogenerated error, if
294 possible. Sets Date field of the head to now if it's not set.
296 If the C<X-RT-Squelch> header is set to any true value, the mail will
297 not be sent. One use is to let extensions easily cancel outgoing mail.
299 Ticket and Transaction arguments are optional. If Transaction is
300 specified and Ticket is not then ticket of the transaction is
301 used, but only if the transaction belongs to a ticket.
303 Returns 1 on success, 0 on error or -1 if message has no recipients
304 and hasn't been sent.
306 =head3 Signing and Encrypting
308 This function as well signs and/or encrypts the message according to
309 headers of a transaction's attachment or properties of a ticket's queue.
310 To get full access to the configuration Ticket and/or Transaction
311 arguments must be provided, but you can force behaviour using Sign
312 and/or Encrypt arguments.
314 The following precedence of arguments are used to figure out if
315 the message should be encrypted and/or signed:
317 * if Sign or Encrypt argument is defined then its value is used
319 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
320 header field then it's value is used
322 * else properties of a queue of the Ticket are used.
326 sub WillSignEncrypt {
328 my $attachment = delete $args{Attachment};
329 my $ticket = delete $args{Ticket};
331 if ( not RT->Config->Get('Crypt')->{'Enable'} ) {
332 $args{Sign} = $args{Encrypt} = 0;
333 return wantarray ? %args : 0;
336 for my $argument ( qw(Sign Encrypt) ) {
337 next if defined $args{ $argument };
339 if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
340 $args{$argument} = $attachment->GetHeader("X-RT-$argument");
341 } elsif ( $ticket and $argument eq "Encrypt" ) {
342 $args{Encrypt} = $ticket->QueueObj->Encrypt();
343 } elsif ( $ticket and $argument eq "Sign" ) {
344 # Note that $queue->Sign is UI-only, and that all
345 # UI-generated messages explicitly set the X-RT-Crypt header
346 # to 0 or 1; thus this path is only taken for messages
347 # generated _not_ via the web UI.
348 $args{Sign} = $ticket->QueueObj->SignAuto();
352 return wantarray ? %args : ($args{Sign} || $args{Encrypt});
360 Transaction => undef,
364 my $TicketObj = $args{'Ticket'};
365 my $TransactionObj = $args{'Transaction'};
367 unless ( $args{'Entity'} ) {
368 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
372 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
375 # If we don't have any recipients to send to, don't send a message;
376 unless ( $args{'Entity'}->head->get('To')
377 || $args{'Entity'}->head->get('Cc')
378 || $args{'Entity'}->head->get('Bcc') )
380 $RT::Logger->info( $msgid . " No recipients found. Not sending." );
384 if ($args{'Entity'}->head->get('X-RT-Squelch')) {
385 $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
389 if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
390 and !$args{'Entity'}->head->get("Precedence")
392 $args{'Entity'}->head->replace( 'Precedence', Encode::encode("UTF-8",$precedence) );
395 if ( $TransactionObj && !$TicketObj
396 && $TransactionObj->ObjectType eq 'RT::Ticket' )
398 $TicketObj = $TransactionObj->Object;
401 my $head = $args{'Entity'}->head;
402 unless ( $head->get('Date') ) {
404 my $date = RT::Date->new( RT->SystemUser );
406 $head->replace( 'Date', Encode::encode("UTF-8",$date->RFC2822( Timezone => 'server' ) ) );
408 unless ( $head->get('MIME-Version') ) {
409 # We should never have to set the MIME-Version header
410 $head->replace( 'MIME-Version', '1.0' );
412 unless ( $head->get('Content-Transfer-Encoding') ) {
413 # fsck.com #5959: Since RT sends 8bit mail, we should say so.
414 $head->replace( 'Content-Transfer-Encoding', '8bit' );
417 if ( RT->Config->Get('Crypt')->{'Enable'} ) {
418 %args = WillSignEncrypt(
420 Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
421 Ticket => $TicketObj,
423 my $res = SignEncrypt( %args );
424 return $res unless $res > 0;
427 my $mail_command = RT->Config->Get('MailCommand');
429 # if it is a sub routine, we just return it;
430 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
432 if ( $mail_command eq 'sendmailpipe' ) {
433 my $path = RT->Config->Get('SendmailPath');
434 my @args = shellwords(RT->Config->Get('SendmailArguments'));
435 push @args, "-t" unless grep {$_ eq "-t"} @args;
437 # SetOutgoingMailFrom and bounces conflict, since they both want -f
438 if ( $args{'Bounce'} ) {
439 push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
440 } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
441 my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
442 my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
445 my $Queue = $TicketObj->QueueObj;
446 my $QueueAddressOverride = $Overrides->{$Queue->id}
447 || $Overrides->{$Queue->Name};
449 if ($QueueAddressOverride) {
450 $OutgoingMailAddress = $QueueAddressOverride;
452 $OutgoingMailAddress ||= $Queue->CorrespondAddress
453 || RT->Config->Get('CorrespondAddress');
456 elsif ($Overrides->{'Default'}) {
457 $OutgoingMailAddress = $Overrides->{'Default'};
460 push @args, "-f", $OutgoingMailAddress
461 if $OutgoingMailAddress;
465 if ( $TransactionObj and
466 my $prefix = RT->Config->Get('VERPPrefix') and
467 my $domain = RT->Config->Get('VERPDomain') )
469 my $from = $TransactionObj->CreatorObj->EmailAddress;
472 push @args, "-f", "$prefix$from\@$domain";
476 # don't ignore CHLD signal to get proper exit code
477 local $SIG{'CHLD'} = 'DEFAULT';
479 # if something wrong with $mail->print we will get PIPE signal, handle it
480 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
484 my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
485 or die "couldn't execute program: $!";
487 $args{'Entity'}->print($mail);
488 close $mail or die "close pipe failed: $!";
492 # sendmail exit statuses mostly errors with data not software
493 # TODO: status parsing: core dump, exit on signal or EX_*
494 my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
495 $msg = ", interrupted by signal ". ($?&127) if $?&127;
496 $RT::Logger->error( $msg );
501 $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
503 _RecordSendEmailFailure( $TicketObj );
507 } elsif ( $mail_command eq 'mbox' ) {
508 my $now = RT::Date->new(RT->SystemUser);
513 my $when = $now->ISO( Timezone => "server" );
515 $logfile = "$RT::VarPath/$when.mbox";
516 $RT::Logger->info("Storing outgoing emails in $logfile");
520 unless (open($fh, ">>", $logfile)) {
521 $RT::Logger->crit( "Can't open mbox file $logfile: $!" );
524 my $content = $args{Entity}->stringify;
525 $content =~ s/^(>*From )/>$1/mg;
526 print $fh "From $ENV{USER}\@localhost ".localtime()."\n";
527 print $fh $content, "\n";
530 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
532 my @mailer_args = ($mail_command);
533 if ( $mail_command eq 'sendmail' ) {
534 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
535 push @mailer_args, grep {$_ ne "-t"}
536 split(/\s+/, RT->Config->Get('SendmailArguments'));
537 } elsif ( $mail_command eq 'testfile' ) {
538 unless ($Mail::Mailer::testfile::config{outfile}) {
539 $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
540 $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
543 push @mailer_args, RT->Config->Get('MailParams');
546 unless ( $args{'Entity'}->send( @mailer_args ) ) {
547 $RT::Logger->crit( "$msgid: Could not send mail." );
549 _RecordSendEmailFailure( $TicketObj );
557 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
559 Loads a template. Parses it using arguments if it's not empty.
560 Returns a tuple (L<RT::Template> object, error message).
562 Note that even if a template object is returned MIMEObj method
563 may return undef for empty templates.
567 sub PrepareEmailUsingTemplate {
574 my $template = RT::Template->new( RT->SystemUser );
575 $template->LoadGlobalTemplate( $args{'Template'} );
576 unless ( $template->id ) {
577 return (undef, "Couldn't load template '". $args{'Template'} ."'");
579 return $template if $template->IsEmpty;
581 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
582 return (undef, $msg) unless $status;
587 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
589 Sends email using a template, takes name of template, arguments for it and recipients.
593 sub SendEmailUsingTemplate {
600 From => RT->Config->Get('CorrespondAddress'),
606 my ($template, $msg) = PrepareEmailUsingTemplate( %args );
607 return (0, $msg) unless $template;
609 my $mail = $template->MIMEObj;
611 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
615 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ $_ } ) )
616 foreach grep defined $args{$_}, qw(To Cc Bcc From);
618 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) )
619 foreach keys %{ $args{ExtraHeaders} };
621 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
623 return SendEmail( Entity => $mail );
626 =head2 GetForwardFrom Ticket => undef, Transaction => undef
628 Resolve the From field to use in forward mail
633 my %args = ( Ticket => undef, Transaction => undef, @_ );
634 my $txn = $args{Transaction};
635 my $ticket = $args{Ticket} || $txn->Object;
637 if ( RT->Config->Get('ForwardFromUser') ) {
638 return ( $txn || $ticket )->CurrentUser->EmailAddress;
641 return $ticket->QueueObj->CorrespondAddress
642 || RT->Config->Get('CorrespondAddress');
646 =head2 GetForwardAttachments Ticket => undef, Transaction => undef
648 Resolve the Attachments to forward
652 sub GetForwardAttachments {
653 my %args = ( Ticket => undef, Transaction => undef, @_ );
654 my $txn = $args{Transaction};
655 my $ticket = $args{Ticket} || $txn->Object;
657 my $attachments = RT::Attachments->new( $ticket->CurrentUser );
659 $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id );
662 $attachments->LimitByTicket( $ticket->id );
664 ALIAS => $attachments->TransactionAlias,
667 VALUE => [ qw(Create Correspond) ],
674 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
676 Signs and encrypts message using L<RT::Crypt>, but as well handle errors
679 If a recipient has no key or has other problems with it, then the
680 unction sends a error to him using 'Error: public key' template.
681 Also, notifies RT's owner using template 'Error to RT owner: public key'
682 to inform that there are problems with users' keys. Then we filter
683 all bad recipients and retry.
685 Returns 1 on success, 0 on error and -1 if all recipients are bad and
686 had been filtered out.
697 return 1 unless $args{'Sign'} || $args{'Encrypt'};
699 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
702 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
703 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
705 my %res = RT::Crypt->SignEncrypt( %args );
706 return 1 unless $res{'exit_code'};
708 my @status = RT::Crypt->ParseStatus(
709 Protocol => $res{'Protocol'}, Status => $res{'status'},
713 foreach my $line ( @status ) {
714 # if the passphrase fails, either you have a bad passphrase
715 # or gpg-agent has died. That should get caught in Create and
716 # Update, but at least throw an error here
717 if (($line->{'Operation'}||'') eq 'PassphraseCheck'
718 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
719 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
722 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
723 next if $line->{'Status'} eq 'DONE';
724 $RT::Logger->error( $line->{'Message'} );
725 push @bad_recipients, $line;
727 return 0 unless @bad_recipients;
729 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
730 foreach @bad_recipients;
732 foreach my $recipient ( @bad_recipients ) {
733 my $status = SendEmailUsingTemplate(
734 To => $recipient->{'AddressObj'}->address,
735 Template => 'Error: public key',
738 TicketObj => $args{'Ticket'},
739 TransactionObj => $args{'Transaction'},
743 $RT::Logger->error("Couldn't send 'Error: public key'");
747 my $status = SendEmailUsingTemplate(
748 To => RT->Config->Get('OwnerEmail'),
749 Template => 'Error to RT owner: public key',
751 BadRecipients => \@bad_recipients,
752 TicketObj => $args{'Ticket'},
753 TransactionObj => $args{'Transaction'},
757 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
760 DeleteRecipientsFromHead(
761 $args{'Entity'}->head,
762 map $_->{'AddressObj'}->address, @bad_recipients
765 unless ( $args{'Entity'}->head->get('To')
766 || $args{'Entity'}->head->get('Cc')
767 || $args{'Entity'}->head->get('Bcc') )
769 $RT::Logger->debug("$msgid No recipients that have public key, not sending");
773 # redo without broken recipients
774 %res = RT::Crypt->SignEncrypt( %args );
775 return 0 if $res{'exit_code'};
784 Takes a hash with a String and a Charset. Returns the string encoded
785 according to RFC2047, using B (base64 based) encoding.
787 String must be a perl string, octets are returned.
789 If Charset is not provided then $EmailOutputEncoding config option
790 is used, or "latin-1" if that is not set.
800 my $value = $args{'String'};
801 return $value unless $value; # 0 is perfect ascii
802 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
805 # using RFC2047 notation, sec 2.
806 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
808 # An 'encoded-word' may not be more than 75 characters long
810 # MIME encoding increases 4/3*(number of bytes), and always in multiples
811 # of 4. Thus we have to find the best available value of bytes available
814 # First we get the integer max which max*4/3 would fit on space.
815 # Then we find the greater multiple of 3 lower or equal than $max.
817 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
821 $max = int( $max / 3 ) * 3;
828 $RT::Logger->crit("Can't encode! Charset or encoding too big.");
832 return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
836 my ( $tmp, @chunks ) = ( '', () );
837 while ( length $value ) {
838 my $char = substr( $value, 0, 1, '' );
839 my $octets = Encode::encode( $charset, $char );
840 if ( length($tmp) + length($octets) > $max ) {
846 push @chunks, $tmp if length $tmp;
848 # encode an join chuncks
850 map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
856 my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
858 my $NewUser = RT::User->new( RT->SystemUser );
860 my ( $Val, $Message ) = $NewUser->Create(
861 Name => ( $Username || $Address ),
862 EmailAddress => $Address,
866 Comments => 'Autocreated on ticket submission',
871 # Deal with the race condition of two account creations at once
873 $NewUser->LoadByName($Username);
876 unless ( $NewUser->Id ) {
877 $NewUser->LoadByEmail($Address);
880 unless ( $NewUser->Id ) {
883 Subject => "User could not be created",
885 "User creation failed in mailgateway: $Message",
892 #Load the new user object
893 my $CurrentUser = RT::CurrentUser->new;
894 $CurrentUser->LoadByEmail( $Address );
896 unless ( $CurrentUser->id ) {
897 $RT::Logger->warning(
898 "Couldn't load user '$Address'." . "giving up" );
901 Subject => "User could not be loaded",
903 "User '$Address' could not be loaded in the mail gateway",
914 =head2 ParseCcAddressesFromHead HASH
916 Takes a hash containing QueueObj, Head and CurrentUser objects.
917 Returns a list of all email addresses in the To and Cc
918 headers b<except> the current Queue's email addresses, the CurrentUser's
919 email address and anything that the configuration sub RT::IsRTAddress matches.
923 sub ParseCcAddressesFromHead {
927 CurrentUser => undef,
931 my $current_address = lc $args{'CurrentUser'}->EmailAddress;
932 my $user = $args{'CurrentUser'}->UserObj;
935 grep { $_ ne $current_address
936 && !RT::EmailParser->IsRTAddress( $_ )
937 && !IgnoreCcAddress( $_ )
939 map lc $user->CanonicalizeEmailAddress( $_->address ),
940 map RT::EmailParser->CleanupAddresses( Email::Address->parse(
941 Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
945 =head2 IgnoreCcAddress ADDRESS
947 Returns true if ADDRESS matches the $IgnoreCcRegexp config variable.
951 sub IgnoreCcAddress {
953 if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) {
954 return 1 if $address =~ /$address_re/i;
959 =head2 ParseSenderAddressFromHead HEAD
961 Takes a MIME::Header object. Returns (user@host, friendly name, errors)
962 where the first two values are the From (evaluated in order of
963 Reply-To:, From:, Sender).
965 A list of error messages may be returned even when a Sender value is
966 found, since it could be a parse error for another (checked earlier)
967 sender field. In this case, the errors aren't fatal, but may be useful
968 to investigate the parse failure.
972 sub ParseSenderAddressFromHead {
974 my @sender_headers = ('Reply-To', 'From', 'Sender');
975 my @errors; # Accumulate any errors
977 #Figure out who's sending this message.
978 foreach my $header ( @sender_headers ) {
979 my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
980 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
981 # only return if the address is not empty
982 return ($addr, $name, @errors) if $addr;
985 push @errors, "$header: $addr_line";
988 return (undef, undef, @errors);
991 =head2 ParseErrorsToAddressFromHead HEAD
993 Takes a MIME::Header object. Return a single value : user@host
994 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
999 sub ParseErrorsToAddressFromHead {
1002 #Figure out who's sending this message.
1004 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1006 # If there's a header of that name
1007 my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
1009 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1011 # If it's got actual useful content...
1012 return ($addr) if ($addr);
1019 =head2 ParseAddressFromHeader ADDRESS
1021 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1025 sub ParseAddressFromHeader {
1028 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1029 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1030 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1032 my ($AddrObj) = grep ref $_, @Addresses;
1033 unless ( $AddrObj ) {
1034 return ( undef, undef );
1037 return ( $AddrObj->address, $AddrObj->phrase );
1040 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1042 Gets a head object and list of addresses.
1043 Deletes addresses from To, Cc or Bcc fields.
1047 sub DeleteRecipientsFromHead {
1049 my %skip = map { lc $_ => 1 } @_;
1051 foreach my $field ( qw(To Cc Bcc) ) {
1052 $head->replace( $field => Encode::encode( "UTF-8",
1053 join ', ', map $_->format, grep !$skip{ lc $_->address },
1054 Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) )
1063 ScripAction => undef,
1066 my $org = RT->Config->Get('Organization');
1067 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1068 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1069 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1071 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1072 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1082 return unless $args{'Message'} && $args{'InReplyTo'};
1084 my $get_header = sub {
1086 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1087 @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift );
1089 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1091 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1094 my @id = $get_header->('Message-ID');
1095 #XXX: custom header should begin with X- otherwise is violation of the standard
1096 my @rtid = $get_header->('RT-Message-ID');
1097 my @references = $get_header->('References');
1098 unless ( @references ) {
1099 @references = $get_header->('In-Reply-To');
1101 push @references, @id, @rtid;
1102 if ( $args{'Ticket'} ) {
1103 my $pseudo_ref = PseudoReference( $args{'Ticket'} );
1104 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1106 splice @references, 4, -6
1107 if @references > 10;
1109 my $mail = $args{'Message'};
1110 $mail->head->replace( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
1111 $mail->head->replace( 'References' => Encode::encode( "UTF-8", join ' ', @references) );
1114 sub PseudoReference {
1116 return '<RT-Ticket-'. $ticket->id .'@'. RT->Config->Get('Organization') .'>';
1119 =head2 ExtractTicketId
1121 Passed a MIME::Entity. Returns a ticket id or undef to signal 'new ticket'.
1123 This is a great entry point if you need to customize how ticket ids are
1124 handled for your site. RT-Extension-RepliesToResolved demonstrates one
1125 possible use for this extension.
1127 If the Subject of this ticket is modified, it will be reloaded by the
1128 mail gateway code before Ticket creation.
1132 sub ExtractTicketId {
1135 my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' );
1137 return ParseTicketId( $subject );
1140 =head2 ParseTicketId
1142 Takes a string and searches for [subjecttag #id]
1144 Returns the id if a match is found. Otherwise returns undef.
1149 my $Subject = shift;
1151 my $rtname = RT->Config->Get('rtname');
1152 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1154 # We use @captures and pull out the last capture value to guard against
1155 # someone using (...) instead of (?:...) in $EmailSubjectTagRegex.
1157 if ( my @captures = $Subject =~ /\[$test_name\s+\#(\d+)\s*\]/i ) {
1158 $id = $captures[-1];
1160 foreach my $tag ( RT->System->SubjectTag ) {
1161 next unless my @captures = $Subject =~ /\[\Q$tag\E\s+\#(\d+)\s*\]/i;
1162 $id = $captures[-1];
1166 return undef unless $id;
1168 $RT::Logger->debug("Found a ticket ID. It's $id");
1173 my $subject = shift;
1175 unless ( ref $ticket ) {
1176 my $tmp = RT::Ticket->new( RT->SystemUser );
1177 $tmp->Load( $ticket );
1180 my $id = $ticket->id;
1181 my $queue_tag = $ticket->QueueObj->SubjectTag;
1183 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1184 unless ( $tag_re ) {
1185 my $tag = $queue_tag || RT->Config->Get('rtname');
1186 $tag_re = qr/\Q$tag\E/;
1187 } elsif ( $queue_tag ) {
1188 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1190 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1192 $subject =~ s/(\r\n|\n|\s)/ /g;
1194 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1198 =head2 Gateway ARGSREF
1208 This performs all the "guts" of the mail rt-mailgate program, and is
1209 designed to be called from the web interface with a message, user
1212 Can also take an optional 'ticket' parameter; this ticket id overrides
1213 any ticket id found in the subject.
1219 (status code, message, optional ticket object)
1221 status code is a numeric value.
1223 for temporary failures, the status code should be -75
1225 for permanent failures which are handled by RT, the status code
1228 for succces, the status code should be 1
1235 my @mail_plugins = @_;
1238 foreach my $plugin (@mail_plugins) {
1239 if ( ref($plugin) eq "CODE" ) {
1241 } elsif ( !ref $plugin ) {
1242 my $Class = $plugin;
1243 $Class = "RT::Interface::Email::" . $Class
1244 unless $Class =~ /^RT::/;
1246 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1249 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1250 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1255 $RT::Logger->crit( "$plugin - is not class name or code reference");
1262 my $argsref = shift;
1264 action => 'correspond',
1274 # Validate the action
1275 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1279 "Invalid 'action' parameter "
1287 my $parser = RT::EmailParser->new();
1288 $parser->SmartParseMIMEEntityFromScalar(
1289 Message => $args{'message'},
1294 my $Message = $parser->Entity();
1297 Subject => "RT Bounce: Unparseable message",
1298 Explanation => "RT couldn't process the message below",
1299 Attach => $args{'message'}
1303 "Failed to parse this message. Something is likely badly wrong with the message"
1307 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1308 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1309 @mail_plugins = _LoadPlugins( @mail_plugins );
1311 #Set up a queue object
1312 my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
1313 $SystemQueueObj->Load( $args{'queue'} );
1316 foreach my $class( grep !ref, @mail_plugins ) {
1317 # check if we should apply filter before decoding
1320 *{ $class . "::ApplyBeforeDecode" }{CODE};
1322 next unless defined $check_cb;
1323 next unless $check_cb->(
1324 Message => $Message,
1325 RawMessageRef => \$args{'message'},
1326 Queue => $SystemQueueObj,
1327 Actions => \@actions,
1330 $skip_plugin{ $class }++;
1334 *{ $class . "::GetCurrentUser" }{CODE};
1336 my ($status, $msg) = $Code->(
1337 Message => $Message,
1338 RawMessageRef => \$args{'message'},
1339 Queue => $SystemQueueObj,
1340 Actions => \@actions,
1342 next if $status > 0;
1344 if ( $status == -2 ) {
1345 return (1, $msg, undef);
1346 } elsif ( $status == -1 ) {
1347 return (0, $msg, undef);
1350 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1351 $parser->_DecodeBodies;
1352 $parser->RescueOutlook;
1353 $parser->_PostProcessNewEntity;
1355 my $head = $Message->head;
1356 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1357 my $Sender = (ParseSenderAddressFromHead( $head ))[0];
1358 my $From = Encode::decode( "UTF-8", $head->get("From") );
1359 chomp $From if defined $From;
1361 my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') )
1362 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1364 #Pull apart the subject line
1365 my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || '');
1368 # Lets check for mail loops of various sorts.
1369 my ($should_store_machine_generated_message, $IsALoop, $result);
1370 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1371 _HandleMachineGeneratedMail(
1372 Message => $Message,
1373 ErrorsTo => $ErrorsTo,
1374 Subject => $Subject,
1375 MessageId => $MessageId
1378 # Do not pass loop messages to MailPlugins, to make sure the loop
1379 # is broken, unless $RT::StoreLoops is set.
1380 if ($IsALoop && !$should_store_machine_generated_message) {
1381 return ( 0, $result, undef );
1385 $args{'ticket'} ||= ExtractTicketId( $Message );
1387 # ExtractTicketId may have been overridden, and edited the Subject
1388 my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') );
1391 $SystemTicket = RT::Ticket->new( RT->SystemUser );
1392 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1393 if ( $SystemTicket->id ) {
1394 $Right = 'ReplyToTicket';
1396 $Right = 'CreateTicket';
1399 # We can safely have no queue of we have a known-good ticket
1400 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1401 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1404 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1405 MailPlugins => \@mail_plugins,
1406 Actions => \@actions,
1407 Message => $Message,
1408 RawMessageRef => \$args{message},
1409 SystemTicket => $SystemTicket,
1410 SystemQueue => $SystemQueueObj,
1413 # If authentication fails and no new user was created, get out.
1414 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1416 # If the plugins refused to create one, they lose.
1417 unless ( $AuthStat == -1 ) {
1418 _NoAuthorizedUserFound(
1420 Message => $Message,
1421 Requestor => $ErrorsTo,
1422 Queue => $args{'queue'}
1426 return ( 0, "Could not load a valid user", undef );
1429 # If we got a user, but they don't have the right to say things
1430 if ( $AuthStat == 0 ) {
1433 Subject => "Permission Denied",
1435 "You do not have permission to communicate with RT",
1440 ($CurrentUser->EmailAddress || $CurrentUser->Name)
1441 . " ($Sender) tried to submit a message to "
1443 . " without permission.",
1449 unless ($should_store_machine_generated_message) {
1450 return ( 0, $result, undef );
1453 $head->replace('X-RT-Interface' => 'Email');
1455 # if plugin's updated SystemTicket then update arguments
1456 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1458 my $Ticket = RT::Ticket->new($CurrentUser);
1460 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1464 my @Requestors = ( $CurrentUser->id );
1466 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1467 @Cc = ParseCcAddressesFromHead(
1469 CurrentUser => $CurrentUser,
1470 QueueObj => $SystemQueueObj
1474 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1475 Queue => $SystemQueueObj->Id,
1476 Subject => $NewSubject,
1477 Requestor => \@Requestors,
1484 Subject => "Ticket creation failed: $Subject",
1485 Explanation => $ErrStr,
1488 return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket );
1491 # strip comments&corresponds from the actions we don't need
1492 # to record them if we've created the ticket just now
1493 @actions = grep !/^(comment|correspond)$/, @actions;
1494 $args{'ticket'} = $id;
1496 } elsif ( $args{'ticket'} ) {
1498 $Ticket->Load( $args{'ticket'} );
1499 unless ( $Ticket->Id ) {
1500 my $error = "Could not find a ticket with id " . $args{'ticket'};
1503 Subject => "Message not recorded: $Subject",
1504 Explanation => $error,
1508 return ( 0, $error );
1510 $args{'ticket'} = $Ticket->id;
1512 return ( 1, "Success", $Ticket );
1517 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1518 foreach my $action (@actions) {
1520 # If the action is comment, add a comment.
1521 if ( $action =~ /^(?:comment|correspond)$/i ) {
1522 my $method = ucfirst lc $action;
1523 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1526 #Warn the sender that we couldn't actually submit the comment.
1529 Subject => "Message not recorded ($method): $Subject",
1530 Explanation => $msg,
1533 return ( 0, "Message From: $From not recorded: $msg", $Ticket );
1535 } elsif ($unsafe_actions) {
1536 my ( $status, $msg ) = _RunUnsafeAction(
1538 ErrorsTo => $ErrorsTo,
1539 Message => $Message,
1541 CurrentUser => $CurrentUser,
1543 return ($status, $msg, $Ticket) unless $status == 1;
1546 return ( 1, "Success", $Ticket );
1549 =head2 GetAuthenticationLevel
1551 # Authentication Level
1552 # -1 - Get out. this user has been explicitly declined
1553 # 0 - User may not do anything (Not used at the moment)
1555 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1559 sub GetAuthenticationLevel {
1564 RawMessageRef => undef,
1565 SystemTicket => undef,
1566 SystemQueue => undef,
1570 my ( $CurrentUser, $AuthStat, $error );
1572 # Initalize AuthStat so comparisons work correctly
1573 $AuthStat = -9999999;
1575 # if plugin returns AuthStat -2 we skip action
1576 # NOTE: this is experimental API and it would be changed
1577 my %skip_action = ();
1579 # Since this needs loading, no matter what
1580 foreach (@{ $args{MailPlugins} }) {
1581 my ($Code, $NewAuthStat);
1582 if ( ref($_) eq "CODE" ) {
1586 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1589 foreach my $action (@{ $args{Actions} }) {
1590 ( $CurrentUser, $NewAuthStat ) = $Code->(
1591 Message => $args{Message},
1592 RawMessageRef => $args{RawMessageRef},
1593 CurrentUser => $CurrentUser,
1594 AuthLevel => $AuthStat,
1596 Ticket => $args{SystemTicket},
1597 Queue => $args{SystemQueue},
1600 # You get the highest level of authentication you were assigned, unless you get the magic -1
1601 # If a module returns a "-1" then we discard the ticket, so.
1602 $AuthStat = $NewAuthStat
1603 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1605 last if $AuthStat == -1;
1606 $skip_action{$action}++ if $AuthStat == -2;
1609 # strip actions we should skip
1610 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1612 last unless @{$args{Actions}};
1614 last if $AuthStat == -1;
1617 return $AuthStat if !wantarray;
1619 return ($AuthStat, $CurrentUser, $error);
1622 sub _RunUnsafeAction {
1628 CurrentUser => undef,
1632 my $From = Encode::decode( "UTF-8", $args{Message}->head->get("From") );
1634 if ( $args{'Action'} =~ /^take$/i ) {
1635 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1638 To => $args{'ErrorsTo'},
1639 Subject => "Ticket not taken",
1640 Explanation => $msg,
1641 MIMEObj => $args{'Message'}
1643 return ( 0, "Ticket not taken, by email From: $From" );
1645 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1646 my $new_status = $args{'Ticket'}->FirstInactiveStatus;
1648 my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
1651 #Warn the sender that we couldn't actually submit the comment.
1653 To => $args{'ErrorsTo'},
1654 Subject => "Ticket not resolved",
1655 Explanation => $msg,
1656 MIMEObj => $args{'Message'}
1658 return ( 0, "Ticket not resolved, by email From: $From" );
1662 return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} );
1664 return ( 1, "Success" );
1667 =head2 _NoAuthorizedUserFound
1669 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1673 sub _NoAuthorizedUserFound {
1682 # Notify the RT Admin of the failure.
1684 To => RT->Config->Get('OwnerEmail'),
1685 Subject => "Could not load a valid user",
1686 Explanation => <<EOT,
1687 RT could not load a valid user, and RT's configuration does not allow
1688 for the creation of a new user for this email (@{[$args{Requestor}]}).
1690 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1691 queue @{[$args{'Queue'}]}.
1694 MIMEObj => $args{'Message'},
1698 # Also notify the requestor that his request has been dropped.
1699 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1701 To => $args{'Requestor'},
1702 Subject => "Could not load a valid user",
1703 Explanation => <<EOT,
1704 RT could not load a valid user, and RT's configuration does not allow
1705 for the creation of a new user for your email.
1708 MIMEObj => $args{'Message'},
1714 =head2 _HandleMachineGeneratedMail
1721 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1722 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1723 "This message appears to be a loop (boolean)" );
1727 sub _HandleMachineGeneratedMail {
1728 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1729 my $head = $args{'Message'}->head;
1730 my $ErrorsTo = $args{'ErrorsTo'};
1732 my $IsBounce = CheckForBounce($head);
1734 my $IsAutoGenerated = CheckForAutoGenerated($head);
1736 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1738 my $IsALoop = CheckForLoops($head);
1740 my $SquelchReplies = 0;
1742 my $owner_mail = RT->Config->Get('OwnerEmail');
1744 #If the message is autogenerated, we need to know, so we can not
1745 # send mail to the sender
1746 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1747 $SquelchReplies = 1;
1748 $ErrorsTo = $owner_mail;
1751 # Warn someone if it's a loop, before we drop it on the ground
1753 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1755 #Should we mail it to RTOwner?
1756 if ( RT->Config->Get('LoopsToRTOwner') ) {
1759 Subject => "RT Bounce: ".$args{'Subject'},
1760 Explanation => "RT thinks this message may be a bounce",
1761 MIMEObj => $args{Message}
1765 #Do we actually want to store it?
1766 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1767 unless RT->Config->Get('StoreLoops');
1770 # Squelch replies if necessary
1771 # Don't let the user stuff the RT-Squelch-Replies-To header.
1772 if ( $head->get('RT-Squelch-Replies-To') ) {
1774 'RT-Relocated-Squelch-Replies-To',
1775 $head->get('RT-Squelch-Replies-To')
1777 $head->delete('RT-Squelch-Replies-To');
1780 if ($SquelchReplies) {
1782 # Squelch replies to the sender, and also leave a clue to
1783 # allow us to squelch ALL outbound messages. This way we
1784 # can punt the logic of "what to do when we get a bounce"
1785 # to the scrip. We might want to notify nobody. Or just
1786 # the RT Owner. Or maybe all Privileged watchers.
1787 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1788 $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) );
1789 $head->replace( 'RT-DetectedAutoGenerated', 'true' );
1791 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1794 =head2 IsCorrectAction
1796 Returns a list of valid actions we've found for this message
1800 sub IsCorrectAction {
1802 my @actions = grep $_, split /-/, $action;
1803 return ( 0, '(no value)' ) unless @actions;
1804 foreach ( @actions ) {
1805 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1807 return ( 1, @actions );
1810 sub _RecordSendEmailFailure {
1813 $ticket->_NewTransaction(
1814 Type => "SystemError",
1815 Data => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.", #loc
1816 ActivateScrips => 0,
1821 $RT::Logger->error( "Can't record send email failure as ticket is missing" );
1826 =head2 ConvertHTMLToText HTML
1828 Takes HTML characters and converts it to plain text characters.
1829 Appropriate for generating a plain text part from an HTML part of an
1830 email. Returns undef if conversion fails.
1834 sub ConvertHTMLToText {
1835 return _HTMLFormatter()->(@_);
1838 sub _HTMLFormatter {
1840 return $formatter if defined $formatter;
1842 my $wanted = RT->Config->Get("HTMLFormatter");
1846 @order = ($wanted, "core");
1848 @order = ("w3m", "elinks", "links", "html2text", "lynx", "core");
1850 # Always fall back to core, even if it is not listed
1851 for my $prog (@order) {
1852 if ($prog eq "core") {
1853 RT->Logger->debug("Using internal Perl HTML -> text conversion");
1854 require HTML::FormatText::WithLinks::AndTables;
1855 $formatter = \&_HTMLFormatText;
1857 unless (HTML::FormatExternal->require) {
1858 RT->Logger->warn("HTML::FormatExternal is not installed; falling back to internal perl formatter")
1863 my $path = $prog =~ s{(.*/)}{} ? $1 : undef;
1864 my $package = "HTML::FormatText::" . ucfirst($prog);
1865 unless ($package->require) {
1866 RT->Logger->warn("$prog is not a valid formatter provided by HTML::FormatExternal")
1872 local $ENV{PATH} = $path;
1873 local $ENV{HOME} = File::Spec->tmpdir();
1874 if (not defined $package->program_version) {
1875 RT->Logger->warn("Could not find or run external '$prog' HTML formatter in $path$prog")
1880 local $ENV{PATH} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin'
1881 unless defined $ENV{PATH};
1882 local $ENV{HOME} = File::Spec->tmpdir();
1883 if (not defined $package->program_version) {
1884 RT->Logger->warn("Could not find or run external '$prog' HTML formatter in \$PATH ($ENV{PATH}) -- you may need to install it or provide the full path")
1890 RT->Logger->debug("Using $prog for HTML -> text conversion");
1893 my $text = RT::Util::safe_run_child {
1894 local $ENV{PATH} = $path || $ENV{PATH}
1895 || '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin';
1896 local $ENV{HOME} = File::Spec->tmpdir();
1897 $package->format_string(
1898 Encode::encode( "UTF-8", $html ),
1899 input_charset => "UTF-8",
1900 output_charset => "UTF-8",
1901 leftmargin => 0, rightmargin => 78
1904 $text = Encode::decode( "UTF-8", $text );
1908 RT->Config->Set( HTMLFormatter => $prog );
1914 sub _HTMLFormatText {
1919 $text = HTML::FormatText::WithLinks::AndTables->convert(
1925 after_link => ' (%l)',
1927 skip_linked_urls => 1,
1933 $RT::Logger->error("Failed to downgrade HTML to plain text: $@") if $@;
1938 RT::Base->_ImportOverlays();