1# BEGIN BPS TAGGED BLOCK {{{ 2# 3# COPYRIGHT: 4# 5# This software is Copyright (c) 1996-2021 Best Practical Solutions, LLC 6# <sales@bestpractical.com> 7# 8# (Except where explicitly superseded by other copyright notices) 9# 10# 11# LICENSE: 12# 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 16# from www.gnu.org. 17# 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. 22# 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. 28# 29# 30# CONTRIBUTION SUBMISSION POLICY: 31# 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.) 37# 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. 46# 47# END BPS TAGGED BLOCK }}} 48 49package RT::Interface::Email; 50 51use strict; 52use warnings; 53use 5.010; 54 55use RT::Interface::Email::Crypt; 56use Email::Address; 57use MIME::Entity; 58use RT::EmailParser; 59use File::Temp; 60use Mail::Mailer (); 61use Text::ParseWords qw/shellwords/; 62use RT::Util 'safe_run_child'; 63use File::Spec; 64use MIME::Words (); 65use Scope::Upper qw/unwind HERE/; 66use 5.010; 67 68=head1 NAME 69 70 RT::Interface::Email - helper functions for parsing and sending email 71 72=head1 METHODS 73 74=head2 RECEIVING MAIL 75 76=head3 Gateway ARGSREF 77 78Takes parameters: 79 80=over 81 82=item C<action> 83 84A C<-> separated list of actions to run. Standard actions, as detailed 85in L<bin/rt-mailgate>, are C<comment> and C<correspond>. The 86L<RT::Interface::Email::Action::Take> and 87L<RT::Interface::Email::Action::Resolve> plugins can be added to 88L<RT_Config/@MailPlugins> to provide C<take> and C<resolve> actions, 89respectively. 90 91=item C<queue> 92 93The queue that tickets should be created in, if no ticket id is found on 94the message. Can be either a name or an id; defaults to 1. 95 96=item C<message> 97 98The content of the message, as obtained from the MTA. 99 100=item C<ticket> 101 102Optional; this ticket id overrides any ticket number derived from the 103subject. 104 105=back 106 107Secrypts and verifies the message, decodes the transfer encoding, 108determines the user that the mail was sent from, and performs the given 109actions. 110 111Returns a list of C<(status, message, ticket)>. The C<status> is -75 112for a temporary failure (to be retried later bt the MTA), 0 for a 113permanent failure which did not result in a ticket, and 1 for a ticket 114that was found and acted on. 115 116=cut 117 118my $SCOPE; 119sub TMPFAIL { unwind (-75, $_[0], undef, => $SCOPE) } 120sub FAILURE { unwind ( 0, $_[0], $_[1], => $SCOPE) } 121sub SUCCESS { unwind ( 1, "Success", $_[0], => $SCOPE) } 122 123sub Gateway { 124 my $argsref = shift; 125 my %args = ( 126 action => 'correspond', 127 queue => '1', 128 ticket => undef, 129 message => undef, 130 %$argsref 131 ); 132 133 # Set the scope to return from with TMPFAIL/FAILURE/SUCCESS 134 $SCOPE = HERE; 135 136 # Validate the actions 137 my @actions = grep $_, split /-/, $args{action}; 138 for my $action (@actions) { 139 TMPFAIL( "Invalid 'action' parameter $action for queue $args{queue}" ) 140 unless Plugins(Method => "Handle" . ucfirst($action)); 141 } 142 143 my $parser = RT::EmailParser->new(); 144 $parser->SmartParseMIMEEntityFromScalar( 145 Message => $args{'message'}, 146 Decode => 0, 147 Exact => 1, 148 ); 149 150 my $Message = $parser->Entity(); 151 unless ($Message) { 152 MailError( 153 Subject => "RT Bounce: Unparseable message", 154 Explanation => "RT couldn't process the message below", 155 Attach => $args{'message'}, 156 FAILURE => 1, 157 ); 158 } 159 160 #Set up a queue object 161 my $SystemQueueObj = RT::Queue->new( RT->SystemUser ); 162 $SystemQueueObj->Load( $args{'queue'} ); 163 164 for my $Code ( Plugins(Method => "BeforeDecrypt") ) { 165 $Code->( 166 Message => $Message, 167 RawMessageRef => \$args{'message'}, 168 Queue => $SystemQueueObj, 169 Actions => \@actions, 170 ); 171 } 172 173 RT::Interface::Email::Crypt::VerifyDecrypt( 174 Message => $Message, 175 RawMessageRef => \$args{'message'}, 176 Queue => $SystemQueueObj, 177 ); 178 179 for my $Code ( Plugins(Method => "BeforeDecode") ) { 180 $Code->( 181 Message => $Message, 182 RawMessageRef => \$args{'message'}, 183 Queue => $SystemQueueObj, 184 Actions => \@actions, 185 ); 186 } 187 188 $parser->_DecodeBodies; 189 $parser->RescueOutlook; 190 $parser->_PostProcessNewEntity; 191 192 my $head = $Message->head; 193 my $From = Encode::decode( "UTF-8", $head->get("From") ); 194 chomp $From if defined $From; 195 196 #Pull apart the subject line 197 my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || ''); 198 chomp $Subject; 199 200 # Lets check for mail loops of various sorts. 201 my $ErrorsTo = ParseErrorsToAddressFromHead( $head ); 202 $ErrorsTo = RT->Config->Get('OwnerEmail') 203 if IsMachineGeneratedMail( 204 Message => $Message, 205 Subject => $Subject, 206 ); 207 208 # Make all errors from here on out bounce back to $ErrorsTo 209 my $bare_MailError = \&MailError; 210 no warnings 'redefine'; 211 local *MailError = sub { 212 $bare_MailError->(To => $ErrorsTo, MIMEObj => $Message, @_) 213 }; 214 215 $args{'ticket'} ||= ExtractTicketId( $Message ); 216 217 my $SystemTicket = RT::Ticket->new( RT->SystemUser ); 218 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ; 219 220 # We can safely have no queue of we have a known-good ticket 221 TMPFAIL("RT couldn't find the queue: " . $args{'queue'}) 222 unless $SystemTicket->id || $SystemQueueObj->id; 223 224 my $CurrentUser = GetCurrentUser( 225 Message => $Message, 226 RawMessageRef => \$args{message}, 227 Ticket => $SystemTicket, 228 Queue => $SystemQueueObj, 229 ); 230 231 # We only care about ACLs on the _first_ action, as later actions 232 # may have gotten rights by the time they happen. 233 CheckACL( 234 Action => $actions[0], 235 Message => $Message, 236 CurrentUser => $CurrentUser, 237 Ticket => $SystemTicket, 238 Queue => $SystemQueueObj, 239 ); 240 241 $head->replace('X-RT-Interface' => 'Email'); 242 243 my $Ticket = RT::Ticket->new($CurrentUser); 244 $Ticket->Load( $SystemTicket->Id ); 245 246 for my $action (@actions) { 247 HandleAction( 248 Action => $action, 249 Subject => $Subject, 250 Message => $Message, 251 CurrentUser => $CurrentUser, 252 Ticket => $Ticket, 253 TicketId => $args{ticket}, 254 Queue => $SystemQueueObj, 255 ); 256 } 257 SUCCESS( $Ticket ); 258} 259 260=head3 Plugins Method => C<name>, Code => 0 261 262Returns the list of subroutine references for the given method C<name> 263from the configured L<RT_Config/@MailPlugins>. If C<Code> is passed a 264true value, includes anonymous subroutines found in C<@MailPlugins>. 265 266=cut 267 268sub Plugins { 269 my %args = ( 270 Add => undef, 271 Code => 0, 272 Method => undef, 273 @_ 274 ); 275 state $INIT; 276 state @PLUGINS; 277 278 if ($args{Add} or !$INIT) { 279 my @mail_plugins = $INIT ? () : RT->Config->Get('MailPlugins'); 280 push @mail_plugins, @{$args{Add}} if $args{Add}; 281 282 foreach my $plugin (@mail_plugins) { 283 if ( ref($plugin) eq "CODE" ) { 284 push @PLUGINS, $plugin; 285 } elsif ( !ref $plugin ) { 286 my $Class = $plugin; 287 $Class = "RT::Interface::Email::" . $Class 288 unless $Class =~ /^RT::/; 289 $Class->require or 290 do { $RT::Logger->error("Couldn't load $Class: $@"); next }; 291 292 unless ( $Class->DOES( "RT::Interface::Email::Role" ) ) { 293 $RT::Logger->crit( "$Class does not implement RT::Interface::Email::Role. Mail plugins from RT 4.2 and earlier are not forward-compatible with RT 4.4."); 294 next; 295 } 296 push @PLUGINS, $Class; 297 } else { 298 $RT::Logger->crit( "$plugin - is not class name or code reference"); 299 } 300 } 301 $INIT = 1; 302 } 303 304 my @list = @PLUGINS; 305 @list = grep {not ref} @list unless $args{Code}; 306 @list = grep {$_} map {ref $_ ? $_ : $_->can($args{Method})} @list if $args{Method}; 307 return @list; 308} 309 310=head3 GetCurrentUser Message => C<message>, Ticket => C<ticket>, Queue => C<queue> 311 312Dispatches to the C<@MailPlugins> to find one the provides 313C<GetCurrentUser> that recognizes the current user. Mail plugins are 314tried one at a time, and stops after the first to return a current user. 315Anonymous subroutine references found in C<@MailPlugins> are treated as 316C<GetCurrentUser> methods. 317 318The default GetCurrentUser authenticator simply looks at the From: 319address, and loads or creates a user accordingly; see 320L<RT::Interface::Email::Auth::MailFrom>. 321 322Returns the current user; on failure of any plugin to do so, stops 323processing with a permanent failure and sends a generic "Permission 324Denied" mail to the user. 325 326=cut 327 328sub GetCurrentUser { 329 my %args = ( 330 Message => undef, 331 RawMessageRef => undef, 332 Ticket => undef, 333 Queue => undef, 334 @_, 335 ); 336 337 # Since this needs loading, no matter what 338 for my $Code ( Plugins(Code => 1, Method => "GetCurrentUser") ) { 339 my $CurrentUser = $Code->( 340 Message => $args{Message}, 341 RawMessageRef => $args{RawMessageRef}, 342 Ticket => $args{Ticket}, 343 Queue => $args{Queue}, 344 ); 345 return $CurrentUser if $CurrentUser and $CurrentUser->id; 346 } 347 348 # None of the GetCurrentUser plugins found a user. This is 349 # rare; some non-Auth::MailFrom authentication plugin which 350 # doesn't always return a current user? 351 MailError( 352 Subject => "Permission Denied", 353 Explanation => "You do not have permission to communicate with RT", 354 FAILURE => 1, 355 ); 356} 357 358=head3 CheckACL Action => C<action>, CurrentUser => C<user>, Ticket => C<ticket>, Queue => C<queue> 359 360Checks that the currentuser can perform a particular action. While RT's 361standard permission controls apply, this allows a better error message, 362or more limited restrictions on the email gateway. 363 364Each plugin in C<@MailPlugins> which provides C<CheckACL> is given a 365chance to allow the action. If any returns a true value, it 366short-circuits all later plugins. Note that plugins may short-circuit 367and abort with failure of their own accord. 368 369Aborts processing, sending a "Permission Denied" mail to the user with 370the last plugin's failure message, on failure. 371 372=cut 373 374sub CheckACL { 375 my %args = ( 376 Action => undef, 377 Message => undef, 378 CurrentUser => undef, 379 Ticket => undef, 380 Queue => undef, 381 @_, 382 ); 383 384 for my $Code ( Plugins( Method => "CheckACL" ) ) { 385 return if $Code->( 386 Message => $args{Message}, 387 CurrentUser => $args{CurrentUser}, 388 Action => $args{Action}, 389 Ticket => $args{Ticket}, 390 Queue => $args{Queue}, 391 ); 392 } 393 394 # Nobody said yes, and nobody said FAILURE; fail closed 395 MailError( 396 Subject => "Permission Denied", 397 Explanation => "You have no permission to $args{Action}", 398 FAILURE => 1, 399 ); 400} 401 402=head3 HandleAction Action => C<action>, Message => C<message>, Ticket => C<ticket>, Queue => C<queue> 403 404Dispatches to the first plugin in C<@MailPlugins> which provides a 405C<HandleFoo> where C<Foo> is C<ucfirst(action)>. 406 407=cut 408 409sub HandleAction { 410 my %args = ( 411 Action => undef, 412 Subject => undef, 413 Message => undef, 414 Ticket => undef, 415 TicketId => undef, 416 Queue => undef, 417 @_ 418 ); 419 420 my $action = delete $args{Action}; 421 my ($code) = Plugins(Method => "Handle" . ucfirst($action)); 422 TMPFAIL( "Invalid 'action' parameter $action for queue ".$args{Queue}->Name ) 423 unless $code; 424 425 $code->(%args); 426} 427 428 429=head3 ParseSenderAddressFromHead HEAD 430 431Takes a L<MIME::Header> object. Returns a list of (email address, 432friendly name, errors) where the address and name are the first address 433found in C<Reply-To>, C<From>, or C<Sender>. 434 435A list of error messages may be returned even when an address is found, 436since it could be a parse error for another (checked earlier) sender 437field. In this case, the errors aren't fatal, but may be useful to 438investigate the parse failure. 439 440=cut 441 442sub ParseSenderAddressFromHead { 443 my $head = shift; 444 my @errors; # Accumulate any errors 445 446 foreach my $header ( 'Reply-To', 'From', 'Sender' ) { 447 my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next; 448 my ($addr) = RT::EmailParser->ParseEmailAddress( $addr_line ); 449 return ($addr->address, $addr->phrase, @errors) if $addr; 450 451 chomp $addr_line; 452 push @errors, "$header: $addr_line"; 453 } 454 455 return (undef, undef, @errors); 456} 457 458=head3 ParseErrorsToAddressFromHead HEAD 459 460Takes a L<MIME::Header> object. Returns the first email address found in 461C<Return-path>, C<Errors-To>, C<Reply-To>, C<From>, or C<Sender>. 462 463=cut 464 465sub ParseErrorsToAddressFromHead { 466 my $head = shift; 467 468 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) { 469 my $value = Encode::decode( "UTF-8", $head->get($header) ); 470 next unless $value; 471 472 my ( $email ) = RT::EmailParser->ParseEmailAddress($value); 473 return $email->address if $email; 474 } 475} 476 477=head3 IsMachineGeneratedMail Message => C<message> 478 479Checks if the mail is machine-generated (via a bounce, mail headers, 480 481=cut 482 483sub IsMachineGeneratedMail { 484 my %args = ( 485 Message => undef, 486 Subject => undef, 487 @_ 488 ); 489 my $head = $args{'Message'}->head; 490 491 my $IsAutoGenerated = CheckForAutoGenerated($head); 492 my $IsALoop = CheckForLoops($head); 493 494 my $owner_mail = RT->Config->Get('OwnerEmail'); 495 496 # Don't let the user stuff the RT-Squelch-Replies-To header. 497 $head->delete('RT-Squelch-Replies-To'); 498 499 # If the message is autogenerated, we need to know, so we can not 500 # send mail to the sender 501 return unless $IsAutoGenerated || $IsALoop; 502 503 # Warn someone if it's a loop, before we drop it on the ground 504 if ($IsALoop) { 505 my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') ); 506 $RT::Logger->crit("RT Received mail ($MessageId) from itself."); 507 508 #Should we mail it to RTOwner? 509 if ( RT->Config->Get('LoopsToRTOwner') ) { 510 MailError( 511 To => $owner_mail, 512 Subject => "RT Bounce: ".$args{'Subject'}, 513 Explanation => "RT thinks this message may be a bounce", 514 ); 515 } 516 517 #Do we actually want to store it? 518 FAILURE( "Message is a bounce" ) unless RT->Config->Get('StoreLoops'); 519 } 520 521 # Squelch replies to the sender, and also leave a clue to 522 # allow us to squelch ALL outbound messages. This way we 523 # can punt the logic of "what to do when we get a bounce" 524 # to the scrip. We might want to notify nobody. Or just 525 # the RT Owner. Or maybe all Privileged watchers. 526 my ( $Sender ) = ParseSenderAddressFromHead($head); 527 $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) ); 528 $head->replace( 'RT-DetectedAutoGenerated', 'true' ); 529 530 return 1; 531} 532 533=head3 CheckForLoops HEAD 534 535Takes a L<MIME::Head> object and returns true if the message was sent by 536this RT instance, by checking the C<X-RT-Loop-Prevention> header. 537 538=cut 539 540sub CheckForLoops { 541 my $head = shift; 542 543 # If this instance of RT sent it our, we don't want to take it in 544 my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" ); 545 chomp ($RTLoop); # remove that newline 546 if ( $RTLoop eq RT->Config->Get('rtname') ) { 547 return 1; 548 } 549 550 # TODO: We might not trap the case where RT instance A sends a mail 551 # to RT instance B which sends a mail to ... 552 return undef; 553} 554 555=head3 CheckForAutoGenerated HEAD 556 557Takes a HEAD object of L<MIME::Head> class and returns true if message is 558autogenerated. Checks C<Precedence>, RFC3834 C<Auto-Submitted>, and 559C<X-FC-Machinegenerated> fields of the head in tests. 560 561=cut 562 563sub CheckForAutoGenerated { 564 my $head = shift; 565 566 # Bounces, via return-path 567 my $ReturnPath = $head->get("Return-path") || ""; 568 return 1 if $ReturnPath =~ /<>/; 569 570 # Bounces, via mailer-daemon or postmaster 571 my ( $From ) = ParseSenderAddressFromHead($head); 572 return 1 if defined $From and $From =~ /^mailer-daemon\@/i; 573 return 1 if defined $From and $From =~ /^postmaster\@/i; 574 return 1 if defined $From and $From eq ""; 575 576 # Bulk or junk messages are auto-generated 577 return 1 if grep {/^(bulk|junk)/i} $head->get_all("Precedence"); 578 579 # Per RFC3834, any Auto-Submitted header which is not "no" means 580 # it is auto-generated. 581 my $AutoSubmitted = $head->get("Auto-Submitted") || ""; 582 return 1 if length $AutoSubmitted and $AutoSubmitted ne "no"; 583 584 # First Class mailer uses this as a clue. 585 my $FCJunk = $head->get("X-FC-Machinegenerated") || ""; 586 return 1 if $FCJunk =~ /^true/i; 587 588 return 0; 589} 590 591=head3 ExtractTicketId 592 593Passed a L<MIME::Entity> object, and returns a either ticket id or undef 594to signal 'new ticket'. 595 596This is a great entry point if you need to customize how ticket ids are 597handled for your site. L<RT::Extension::RepliesToResolved> demonstrates 598one possible use for this extension. 599 600If the Subject of the L<MIME::Entity> is modified, the updated subject 601will be used during ticket creation. 602 603=cut 604 605sub ExtractTicketId { 606 my $entity = shift; 607 608 my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' ); 609 chomp $subject; 610 return ParseTicketId( $subject, $entity ); 611} 612 613=head3 ParseTicketId 614 615Takes a string (the email subject) and searches for [subjecttag #id] 616 617For customizations, the L<MIME::Entity> object is passed as the second 618argument. 619 620Returns the id if a match is found. Otherwise returns undef. 621 622=cut 623 624sub ParseTicketId { 625 my $Subject = shift; 626 my $Entity = shift; 627 628 my $rtname = RT->Config->Get('rtname'); 629 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i; 630 631 # We use @captures and pull out the last capture value to guard against 632 # someone using (...) instead of (?:...) in $EmailSubjectTagRegex. 633 my $id; 634 if ( my @captures = $Subject =~ m{\[(?:http://)?$test_name\s+\#(\d+)\s*\]}i ) { 635 $id = $captures[-1]; 636 } else { 637 foreach my $tag ( RT->System->SubjectTag ) { 638 next unless my @captures = $Subject =~ m{\[(?:http://)?\Q$tag\E\s+\#(\d+)\s*\]}i; 639 $id = $captures[-1]; 640 last; 641 } 642 } 643 return undef unless $id; 644 645 $RT::Logger->debug("Found a ticket ID. It's $id"); 646 return $id; 647} 648 649=head3 MailError PARAM HASH 650 651Sends an error message. Takes a param hash: 652 653=over 4 654 655=item From 656 657Sender's address, defaults to L<RT_Config/$CorrespondAddress>; 658 659=item To 660 661Recipient, defaults to L<RT_Config/$OwnerEmail>; 662 663=item Subject 664 665Subject of the message, defaults to C<There has been an error>; 666 667=item Explanation 668 669Main content of the error, default value is C<Unexplained error>; 670 671=item MIMEObj 672 673Optional L<MIME::Entity> that is attached to the error mail. 674Additionally, the C<In-Reply-To> header will point to this message. 675 676=item Attach 677 678Optional text that attached to the error as a C<message/rfc822> part. 679 680=item LogLevel 681 682Log level the subject and explanation is written to the log; defaults to 683C<critical>. 684 685=back 686 687=cut 688 689sub MailError { 690 my %args = ( 691 To => RT->Config->Get('OwnerEmail'), 692 From => RT->Config->Get('CorrespondAddress'), 693 Subject => 'There has been an error', 694 Explanation => 'Unexplained error', 695 MIMEObj => undef, 696 Attach => undef, 697 LogLevel => 'crit', 698 FAILURE => 0, 699 @_ 700 ); 701 702 $RT::Logger->log( 703 level => $args{'LogLevel'}, 704 message => "$args{Subject}: $args{'Explanation'}", 705 ) if $args{'LogLevel'}; 706 707 # the colons are necessary to make ->build include non-standard headers 708 my %entity_args = ( 709 Type => "multipart/mixed", 710 From => Encode::encode( "UTF-8", $args{'From'} ), 711 To => Encode::encode( "UTF-8", $args{'To'} ), 712 Subject => EncodeToMIME( String => $args{'Subject'} ), 713 'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ), 714 ); 715 716 # only set precedence if the sysadmin wants us to 717 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) { 718 $entity_args{'Precedence:'} = 719 Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') ); 720 } 721 722 my $entity = MIME::Entity->build(%entity_args); 723 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} ); 724 725 $entity->attach( 726 Type => "text/plain", 727 Charset => "UTF-8", 728 Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ), 729 ); 730 731 if ( $args{'MIMEObj'} ) { 732 $args{'MIMEObj'}->sync_headers; 733 $entity->add_part( $args{'MIMEObj'} ); 734 } 735 736 if ( $args{'Attach'} ) { 737 $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' ); 738 739 } 740 741 SendEmail( Entity => $entity, Bounce => 1 ); 742 743 FAILURE( "$args{Subject}: $args{Explanation}" ) if $args{FAILURE}; 744} 745 746sub _OutgoingMailFrom { 747 my $TicketObj = shift; 748 749 my $MailFrom = RT->Config->Get('SetOutgoingMailFrom'); 750 my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef; 751 my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {}; 752 753 if ($TicketObj) { 754 my $Queue = $TicketObj->QueueObj; 755 my $QueueAddressOverride = $Overrides->{$Queue->id} 756 || $Overrides->{$Queue->Name}; 757 758 if ($QueueAddressOverride) { 759 $OutgoingMailAddress = $QueueAddressOverride; 760 } else { 761 $OutgoingMailAddress ||= $Queue->CorrespondAddress 762 || RT->Config->Get('CorrespondAddress'); 763 } 764 } 765 elsif ($Overrides->{'Default'}) { 766 $OutgoingMailAddress = $Overrides->{'Default'}; 767 } 768 769 return $OutgoingMailAddress; 770} 771 772=head2 SENDING EMAIL 773 774=head3 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ] 775 776Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using 777RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a 778true value, the message will be marked as an autogenerated error, if 779possible. Sets Date field of the head to now if it's not set. 780 781If the C<X-RT-Squelch> header is set to any true value, the mail will 782not be sent. One use is to let extensions easily cancel outgoing mail. 783 784Ticket and Transaction arguments are optional. If Transaction is 785specified and Ticket is not then ticket of the transaction is 786used, but only if the transaction belongs to a ticket. 787 788Returns 1 on success, 0 on error or -1 if message has no recipients 789and hasn't been sent. 790 791=head3 Signing and Encrypting 792 793This function as well signs and/or encrypts the message according to 794headers of a transaction's attachment or properties of a ticket's queue. 795To get full access to the configuration Ticket and/or Transaction 796arguments must be provided, but you can force behaviour using Sign 797and/or Encrypt arguments. 798 799The following precedence of arguments are used to figure out if 800the message should be encrypted and/or signed: 801 802* if Sign or Encrypt argument is defined then its value is used 803 804* else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt 805header field then it's value is used 806 807* else properties of a queue of the Ticket are used. 808 809=cut 810 811sub SendEmail { 812 my (%args) = ( 813 Entity => undef, 814 Bounce => 0, 815 Ticket => undef, 816 Transaction => undef, 817 @_, 818 ); 819 820 my $TicketObj = $args{'Ticket'}; 821 my $TransactionObj = $args{'Transaction'}; 822 823 unless ( $args{'Entity'} ) { 824 $RT::Logger->crit( "Could not send mail without 'Entity' object" ); 825 return 0; 826 } 827 828 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' ); 829 chomp $msgid; 830 831 # If we don't have any recipients to send to, don't send a message; 832 unless ( $args{'Entity'}->head->get('To') 833 || $args{'Entity'}->head->get('Cc') 834 || $args{'Entity'}->head->get('Bcc') ) 835 { 836 $RT::Logger->info( $msgid . " No recipients found. Not sending." ); 837 return -1; 838 } 839 840 if ($args{'Entity'}->head->get('X-RT-Squelch')) { 841 $RT::Logger->info( $msgid . " Squelch header found. Not sending." ); 842 return -1; 843 } 844 845 if (my $precedence = RT->Config->Get('DefaultMailPrecedence') 846 and !$args{'Entity'}->head->get("Precedence") 847 ) { 848 if ($TicketObj) { 849 my $Overrides = RT->Config->Get('OverrideMailPrecedence') || {}; 850 my $Queue = $TicketObj->QueueObj; 851 852 $precedence = $Overrides->{$Queue->id} 853 if exists $Overrides->{$Queue->id}; 854 $precedence = $Overrides->{$Queue->Name} 855 if exists $Overrides->{$Queue->Name}; 856 } 857 858 $args{'Entity'}->head->replace( 'Precedence', Encode::encode("UTF-8",$precedence) ) 859 if $precedence; 860 } 861 862 if ( $TransactionObj && !$TicketObj 863 && $TransactionObj->ObjectType eq 'RT::Ticket' ) 864 { 865 $TicketObj = $TransactionObj->Object; 866 } 867 868 my $head = $args{'Entity'}->head; 869 unless ( $head->get('Date') ) { 870 require RT::Date; 871 my $date = RT::Date->new( RT->SystemUser ); 872 $date->SetToNow; 873 $head->replace( 'Date', Encode::encode("UTF-8",$date->RFC2822( Timezone => 'server' ) ) ); 874 } 875 unless ( $head->get('MIME-Version') ) { 876 # We should never have to set the MIME-Version header 877 $head->replace( 'MIME-Version', '1.0' ); 878 } 879 unless ( $head->get('Content-Transfer-Encoding') ) { 880 # fsck.com #5959: Since RT sends 8bit mail, we should say so. 881 $head->replace( 'Content-Transfer-Encoding', '8bit' ); 882 } 883 884 if ( RT->Config->Get('Crypt')->{'Enable'} ) { 885 %args = WillSignEncrypt( 886 %args, 887 Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef, 888 Ticket => $TicketObj, 889 ); 890 if ($TicketObj) { 891 $args{'Queue'} = $TicketObj->QueueObj; 892 } 893 my $res = SignEncrypt( %args ); 894 return $res unless $res > 0; 895 } 896 897 my $mail_command = RT->Config->Get('MailCommand'); 898 899 # if it is a sub routine, we just return it; 900 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' ); 901 902 if ( $mail_command eq 'sendmailpipe' ) { 903 my $path = RT->Config->Get('SendmailPath'); 904 my @args = shellwords(RT->Config->Get('SendmailArguments')); 905 push @args, "-t" unless grep {$_ eq "-t"} @args; 906 907 # SetOutgoingMailFrom and bounces conflict, since they both want -f 908 if ( $args{'Bounce'} ) { 909 push @args, shellwords(RT->Config->Get('SendmailBounceArguments')); 910 } elsif ( RT->Config->Get('SetOutgoingMailFrom') ) { 911 my $OutgoingMailAddress = _OutgoingMailFrom($TicketObj); 912 913 push @args, "-f", $OutgoingMailAddress 914 if $OutgoingMailAddress; 915 } 916 917 # VERP 918 if ( $TransactionObj and 919 my $prefix = RT->Config->Get('VERPPrefix') and 920 my $domain = RT->Config->Get('VERPDomain') ) 921 { 922 my $from = $TransactionObj->CreatorObj->EmailAddress; 923 $from =~ s/@/=/g; 924 $from =~ s/\s//g; 925 push @args, "-f", "$prefix$from\@$domain"; 926 } 927 928 eval { 929 # don't ignore CHLD signal to get proper exit code 930 local $SIG{'CHLD'} = 'DEFAULT'; 931 932 # if something wrong with $mail->print we will get PIPE signal, handle it 933 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" }; 934 935 require IPC::Open2; 936 my ($mail, $stdout); 937 my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args ) 938 or die "couldn't execute program: $!"; 939 940 $args{'Entity'}->print($mail); 941 close $mail or die "close pipe failed: $!"; 942 943 waitpid($pid, 0); 944 if ($?) { 945 # sendmail exit statuses mostly errors with data not software 946 # TODO: status parsing: core dump, exit on signal or EX_* 947 my $msg = "$msgid: `$path @args` exited with code ". ($?>>8); 948 $msg = ", interrupted by signal ". ($?&127) if $?&127; 949 $RT::Logger->error( $msg ); 950 die $msg; 951 } 952 }; 953 if ( $@ ) { 954 $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ ); 955 if ( $TicketObj ) { 956 _RecordSendEmailFailure( $TicketObj ); 957 } 958 return 0; 959 } 960 } elsif ( $mail_command eq 'mbox' ) { 961 my $now = RT::Date->new(RT->SystemUser); 962 $now->SetToNow; 963 964 state $logfile; 965 unless ($logfile) { 966 my $when = $now->ISO( Timezone => "server" ); 967 $when =~ s/\s+/-/g; 968 $logfile = "$RT::VarPath/$when.mbox"; 969 $RT::Logger->info("Storing outgoing emails in $logfile"); 970 } 971 my $fh; 972 unless (open($fh, ">>", $logfile)) { 973 $RT::Logger->crit( "Can't open mbox file $logfile: $!" ); 974 return 0; 975 } 976 my $content = $args{Entity}->stringify; 977 $content =~ s/^(>*From )/>$1/mg; 978 my $user = $ENV{USER} || getpwuid($<); 979 print $fh "From $user\@localhost ".localtime()."\n"; 980 print $fh $content, "\n"; 981 close $fh; 982 } else { 983 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'}); 984 985 my @mailer_args = ($mail_command); 986 if ( $mail_command eq 'sendmail' ) { 987 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath'); 988 push @mailer_args, grep {$_ ne "-t"} 989 split(/\s+/, RT->Config->Get('SendmailArguments')); 990 } elsif ( $mail_command eq 'testfile' ) { 991 unless ($Mail::Mailer::testfile::config{outfile}) { 992 $Mail::Mailer::testfile::config{outfile} = File::Temp->new; 993 $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}"); 994 } 995 } else { 996 push @mailer_args, RT->Config->Get('MailParams'); 997 } 998 999 unless ( $args{'Entity'}->send( @mailer_args ) ) { 1000 $RT::Logger->crit( "$msgid: Could not send mail." ); 1001 if ( $TicketObj ) { 1002 _RecordSendEmailFailure( $TicketObj ); 1003 } 1004 return 0; 1005 } 1006 } 1007 return 1; 1008} 1009 1010=head3 PrepareEmailUsingTemplate Template => '', Arguments => {} 1011 1012Loads a template. Parses it using arguments if it's not empty. 1013Returns a tuple (L<RT::Template> object, error message). 1014 1015Note that even if a template object is returned MIMEObj method 1016may return undef for empty templates. 1017 1018=cut 1019 1020sub PrepareEmailUsingTemplate { 1021 my %args = ( 1022 Template => '', 1023 Arguments => {}, 1024 @_ 1025 ); 1026 1027 my $template = RT::Template->new( RT->SystemUser ); 1028 $template->LoadGlobalTemplate( $args{'Template'} ); 1029 unless ( $template->id ) { 1030 return (undef, "Couldn't load template '". $args{'Template'} ."'"); 1031 } 1032 return $template if $template->IsEmpty; 1033 1034 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } ); 1035 return (undef, $msg) unless $status; 1036 1037 return $template; 1038} 1039 1040=head3 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => '' 1041 1042Sends email using a template, takes name of template, arguments for it and recipients. 1043 1044=cut 1045 1046sub SendEmailUsingTemplate { 1047 my %args = ( 1048 Template => '', 1049 Arguments => {}, 1050 To => undef, 1051 Cc => undef, 1052 Bcc => undef, 1053 From => RT->Config->Get('CorrespondAddress'), 1054 InReplyTo => undef, 1055 ExtraHeaders => {}, 1056 @_ 1057 ); 1058 1059 my ($template, $msg) = PrepareEmailUsingTemplate( %args ); 1060 return (0, $msg) unless $template; 1061 1062 my $mail = $template->MIMEObj; 1063 unless ( $mail ) { 1064 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty"); 1065 return -1; 1066 } 1067 1068 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ $_ } ) ) 1069 foreach grep defined $args{$_}, qw(To Cc Bcc From); 1070 1071 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) ) 1072 foreach keys %{ $args{ExtraHeaders} }; 1073 1074 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} ); 1075 1076 return SendEmail( Entity => $mail ); 1077} 1078 1079=head3 GetForwardFrom Ticket => undef, Transaction => undef 1080 1081Resolve the From field to use in forward mail 1082 1083=cut 1084 1085sub GetForwardFrom { 1086 my %args = ( Ticket => undef, Transaction => undef, @_ ); 1087 my $txn = $args{Transaction}; 1088 my $ticket = $args{Ticket} || $txn->Object; 1089 1090 if ( RT->Config->Get('ForwardFromUser') ) { 1091 return ( $txn || $ticket )->CurrentUser->EmailAddress; 1092 } 1093 else { 1094 return $ticket->QueueObj->CorrespondAddress 1095 || RT->Config->Get('CorrespondAddress'); 1096 } 1097} 1098 1099=head3 GetForwardAttachments Ticket => undef, Transaction => undef 1100 1101Resolve the Attachments to forward 1102 1103=cut 1104 1105sub GetForwardAttachments { 1106 my %args = ( Ticket => undef, Transaction => undef, @_ ); 1107 my $txn = $args{Transaction}; 1108 my $ticket = $args{Ticket} || $txn->Object; 1109 1110 my $attachments = RT::Attachments->new( $ticket->CurrentUser ); 1111 if ($txn) { 1112 $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id ); 1113 } 1114 else { 1115 $attachments->LimitByTicket( $ticket->id ); 1116 $attachments->Limit( 1117 ALIAS => $attachments->TransactionAlias, 1118 FIELD => 'Type', 1119 OPERATOR => 'IN', 1120 VALUE => [ qw(Create Correspond) ], 1121 ); 1122 } 1123 return $attachments; 1124} 1125 1126sub WillSignEncrypt { 1127 my %args = @_; 1128 my $attachment = delete $args{Attachment}; 1129 my $ticket = delete $args{Ticket}; 1130 1131 if ( not RT->Config->Get('Crypt')->{'Enable'} ) { 1132 $args{Sign} = $args{Encrypt} = 0; 1133 return wantarray ? %args : 0; 1134 } 1135 1136 for my $argument ( qw(Sign Encrypt) ) { 1137 next if defined $args{ $argument }; 1138 1139 if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) { 1140 $args{$argument} = $attachment->GetHeader("X-RT-$argument"); 1141 } elsif ( $ticket and $argument eq "Encrypt" ) { 1142 $args{Encrypt} = $ticket->QueueObj->Encrypt(); 1143 } elsif ( $ticket and $argument eq "Sign" ) { 1144 # Note that $queue->Sign is UI-only, and that all 1145 # UI-generated messages explicitly set the X-RT-Crypt header 1146 # to 0 or 1; thus this path is only taken for messages 1147 # generated _not_ via the web UI. 1148 $args{Sign} = $ticket->QueueObj->SignAuto(); 1149 } 1150 } 1151 1152 return wantarray ? %args : ($args{Sign} || $args{Encrypt}); 1153} 1154 1155=head3 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0 1156 1157Signs and encrypts message using L<RT::Crypt>, but as well handle errors 1158with users' keys. 1159 1160If a recipient has no key or has other problems with it, then the 1161unction sends a error to him using 'Error: public key' template. 1162Also, notifies RT's owner using template 'Error to RT owner: public key' 1163to inform that there are problems with users' keys. Then we filter 1164all bad recipients and retry. 1165 1166Returns 1 on success, 0 on error and -1 if all recipients are bad and 1167had been filtered out. 1168 1169=cut 1170 1171sub SignEncrypt { 1172 my %args = ( 1173 Entity => undef, 1174 Sign => 0, 1175 Encrypt => 0, 1176 @_ 1177 ); 1178 return 1 unless $args{'Sign'} || $args{'Encrypt'}; 1179 1180 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' ); 1181 chomp $msgid; 1182 1183 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'}; 1184 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'}; 1185 1186 my %res = RT::Crypt->SignEncrypt( %args ); 1187 return 1 unless $res{'exit_code'}; 1188 1189 my @status = RT::Crypt->ParseStatus( 1190 Protocol => $res{'Protocol'}, Status => $res{'status'}, 1191 ); 1192 1193 my @bad_recipients; 1194 foreach my $line ( @status ) { 1195 # if the passphrase fails, either you have a bad passphrase 1196 # or gpg-agent has died. That should get caught in Create and 1197 # Update, but at least throw an error here 1198 if (($line->{'Operation'}||'') eq 'PassphraseCheck' 1199 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) { 1200 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" ); 1201 return 0; 1202 } 1203 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck'; 1204 next if $line->{'Status'} eq 'DONE'; 1205 $RT::Logger->error( $line->{'Message'} ); 1206 push @bad_recipients, $line; 1207 } 1208 return 0 unless @bad_recipients; 1209 1210 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0] 1211 foreach @bad_recipients; 1212 1213 foreach my $recipient ( @bad_recipients ) { 1214 my $status = SendEmailUsingTemplate( 1215 To => $recipient->{'AddressObj'}->address, 1216 Template => 'Error: public key', 1217 Arguments => { 1218 %$recipient, 1219 TicketObj => $args{'Ticket'}, 1220 TransactionObj => $args{'Transaction'}, 1221 }, 1222 ); 1223 unless ( $status ) { 1224 $RT::Logger->error("Couldn't send 'Error: public key'"); 1225 } 1226 } 1227 1228 my $status = SendEmailUsingTemplate( 1229 To => RT->Config->Get('OwnerEmail'), 1230 Template => 'Error to RT owner: public key', 1231 Arguments => { 1232 BadRecipients => \@bad_recipients, 1233 TicketObj => $args{'Ticket'}, 1234 TransactionObj => $args{'Transaction'}, 1235 }, 1236 ); 1237 unless ( $status ) { 1238 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'"); 1239 } 1240 1241 DeleteRecipientsFromHead( 1242 $args{'Entity'}->head, 1243 map $_->{'AddressObj'}->address, @bad_recipients 1244 ); 1245 1246 unless ( $args{'Entity'}->head->get('To') 1247 || $args{'Entity'}->head->get('Cc') 1248 || $args{'Entity'}->head->get('Bcc') ) 1249 { 1250 $RT::Logger->debug("$msgid No recipients that have public key, not sending"); 1251 return -1; 1252 } 1253 1254 # redo without broken recipients 1255 %res = RT::Crypt->SignEncrypt( %args ); 1256 return 0 if $res{'exit_code'}; 1257 1258 return 1; 1259} 1260 1261=head3 DeleteRecipientsFromHead HEAD RECIPIENTS 1262 1263Gets a head object and list of addresses. 1264Deletes addresses from To, Cc or Bcc fields. 1265 1266=cut 1267 1268sub DeleteRecipientsFromHead { 1269 my $head = shift; 1270 my %skip = map { lc $_ => 1 } @_; 1271 1272 foreach my $field ( qw(To Cc Bcc) ) { 1273 $head->replace( $field => Encode::encode( "UTF-8", 1274 join ', ', map $_->format, grep !$skip{ lc $_->address }, 1275 Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) ) 1276 ); 1277 } 1278} 1279 1280=head3 EncodeToMIME 1281 1282Takes a hash with a String and a Charset. Returns the string encoded 1283according to RFC2047, using B (base64 based) encoding. 1284 1285String must be a perl string, octets are returned. 1286 1287If Charset is not provided then $EmailOutputEncoding config option 1288is used, or "latin-1" if that is not set. 1289 1290=cut 1291 1292sub EncodeToMIME { 1293 my %args = ( 1294 String => undef, 1295 Charset => undef, 1296 @_ 1297 ); 1298 my $value = $args{'String'}; 1299 return $value unless $value; # 0 is perfect ascii 1300 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding'); 1301 my $encoding = 'B'; 1302 1303 # using RFC2047 notation, sec 2. 1304 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?=" 1305 1306 # An 'encoded-word' may not be more than 75 characters long 1307 # 1308 # MIME encoding increases 4/3*(number of bytes), and always in multiples 1309 # of 4. Thus we have to find the best available value of bytes available 1310 # for each chunk. 1311 # 1312 # First we get the integer max which max*4/3 would fit on space. 1313 # Then we find the greater multiple of 3 lower or equal than $max. 1314 my $max = int( 1315 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) ) 1316 * 3 1317 ) / 4 1318 ); 1319 $max = int( $max / 3 ) * 3; 1320 1321 chomp $value; 1322 1323 if ( $max <= 0 ) { 1324 1325 # gives an error... 1326 $RT::Logger->crit("Can't encode! Charset or encoding too big."); 1327 return ($value); 1328 } 1329 1330 return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s; 1331 1332 $value =~ s/\s+$//; 1333 1334 my ( $tmp, @chunks ) = ( '', () ); 1335 while ( length $value ) { 1336 my $char = substr( $value, 0, 1, '' ); 1337 my $octets = Encode::encode( $charset, $char ); 1338 if ( length($tmp) + length($octets) > $max ) { 1339 push @chunks, $tmp; 1340 $tmp = ''; 1341 } 1342 $tmp .= $octets; 1343 } 1344 push @chunks, $tmp if length $tmp; 1345 1346 # encode an join chuncks 1347 $value = join "\n ", 1348 map MIME::Words::encode_mimeword( $_, $encoding, $charset ), 1349 @chunks; 1350 return ($value); 1351} 1352 1353sub GenMessageId { 1354 my %args = ( 1355 Ticket => undef, 1356 Scrip => undef, 1357 ScripAction => undef, 1358 @_ 1359 ); 1360 my $org = RT->Config->Get('Organization'); 1361 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0; 1362 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0; 1363 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0; 1364 1365 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.' 1366 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ; 1367} 1368 1369sub SetInReplyTo { 1370 my %args = ( 1371 Message => undef, 1372 InReplyTo => undef, 1373 Ticket => undef, 1374 @_ 1375 ); 1376 return unless $args{'Message'} && $args{'InReplyTo'}; 1377 1378 my $get_header = sub { 1379 my @res; 1380 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) { 1381 @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift ); 1382 } else { 1383 @res = $args{'InReplyTo'}->GetHeader( shift ) || ''; 1384 } 1385 return grep length, map { split /\s+/m, $_ } grep defined, @res; 1386 }; 1387 1388 my @id = $get_header->('Message-ID'); 1389 #XXX: custom header should begin with X- otherwise is violation of the standard 1390 my @rtid = $get_header->('RT-Message-ID'); 1391 my @references = $get_header->('References'); 1392 unless ( @references ) { 1393 @references = $get_header->('In-Reply-To'); 1394 } 1395 push @references, @id, @rtid; 1396 if ( $args{'Ticket'} ) { 1397 my $pseudo_ref = PseudoReference( $args{'Ticket'} ); 1398 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references; 1399 } 1400 splice @references, 4, -6 1401 if @references > 10; 1402 1403 my $mail = $args{'Message'}; 1404 $mail->head->replace( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid; 1405 $mail->head->replace( 'References' => Encode::encode( "UTF-8", join ' ', @references) ); 1406} 1407 1408sub PseudoReference { 1409 my $ticket = shift; 1410 return '<RT-Ticket-'. $ticket->id .'@'. RT->Config->Get('Organization') .'>'; 1411} 1412 1413 1414sub AddSubjectTag { 1415 my $subject = shift; 1416 my $ticket = shift; 1417 unless ( ref $ticket ) { 1418 my $tmp = RT::Ticket->new( RT->SystemUser ); 1419 $tmp->Load( $ticket ); 1420 $ticket = $tmp; 1421 } 1422 my $id = $ticket->id; 1423 my $queue_tag = $ticket->QueueObj->SubjectTag; 1424 1425 my $tag_re = RT->Config->Get('EmailSubjectTagRegex'); 1426 unless ( $tag_re ) { 1427 my $tag = $queue_tag || RT->Config->Get('rtname'); 1428 $tag_re = qr/\Q$tag\E/; 1429 } elsif ( $queue_tag ) { 1430 $tag_re = qr/$tag_re|\Q$queue_tag\E/; 1431 } 1432 return $subject if $subject =~ /\[$tag_re\s+#$id\]/; 1433 1434 $subject =~ s/(\r\n|\n|\s)/ /g; 1435 chomp $subject; 1436 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject"; 1437} 1438 1439sub _RecordSendEmailFailure { 1440 my $ticket = shift; 1441 if ($ticket) { 1442 $ticket->_NewTransaction( 1443 Type => "SystemError", 1444 Data => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.", #loc 1445 ActivateScrips => 0, 1446 ); 1447 return 1; 1448 } 1449 else { 1450 $RT::Logger->error( "Can't record send email failure as ticket is missing" ); 1451 return; 1452 } 1453} 1454 1455=head3 ConvertHTMLToText HTML 1456 1457Takes HTML characters and converts it to plain text characters. 1458Appropriate for generating a plain text part from an HTML part of an 1459email. Returns undef if conversion fails. 1460 1461=cut 1462 1463sub ConvertHTMLToText { 1464 return _HTMLFormatter()->(@_); 1465} 1466 1467sub _HTMLFormatter { 1468 state $formatter; 1469 return $formatter if defined $formatter; 1470 1471 my $wanted = RT->Config->Get("HTMLFormatter"); 1472 1473 my @order; 1474 if ($wanted) { 1475 @order = ($wanted, "core"); 1476 } else { 1477 @order = ("w3m", "elinks", "links", "html2text", "lynx", "core"); 1478 } 1479 # Always fall back to core, even if it is not listed 1480 for my $prog (@order) { 1481 if ($prog eq "core") { 1482 RT->Logger->debug("Using internal Perl HTML -> text conversion"); 1483 require HTML::FormatText::WithLinks::AndTables; 1484 $formatter = \&_HTMLFormatText; 1485 } else { 1486 unless (HTML::FormatExternal->require) { 1487 RT->Logger->warn("HTML::FormatExternal is not installed; falling back to internal perl formatter") 1488 if $wanted; 1489 next; 1490 } 1491 1492 my $path = $prog =~ s{(.*/)}{} ? $1 : undef; 1493 my $package = "HTML::FormatText::" . ucfirst($prog); 1494 unless ($package->require) { 1495 RT->Logger->warn("$prog is not a valid formatter provided by HTML::FormatExternal") 1496 if $wanted; 1497 next; 1498 } 1499 1500 if ($path) { 1501 local $ENV{PATH} = $path; 1502 local $ENV{HOME} = File::Spec->tmpdir(); 1503 if (not defined $package->program_version) { 1504 RT->Logger->warn("Could not find or run external '$prog' HTML formatter in $path$prog") 1505 if $wanted; 1506 next; 1507 } 1508 } else { 1509 local $ENV{PATH} = '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin' 1510 unless defined $ENV{PATH}; 1511 local $ENV{HOME} = File::Spec->tmpdir(); 1512 if (not defined $package->program_version) { 1513 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") 1514 if $wanted; 1515 next; 1516 } 1517 } 1518 1519 RT->Logger->debug("Using $prog for HTML -> text conversion"); 1520 $formatter = sub { 1521 my $html = shift; 1522 my $text = RT::Util::safe_run_child { 1523 local $ENV{PATH} = $path || $ENV{PATH} 1524 || '/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin'; 1525 local $ENV{HOME} = File::Spec->tmpdir(); 1526 $package->format_string( 1527 Encode::encode( "UTF-8", $html ), 1528 input_charset => "UTF-8", 1529 output_charset => "UTF-8", 1530 leftmargin => 0, rightmargin => 78 1531 ); 1532 }; 1533 $text = Encode::decode( "UTF-8", $text ); 1534 return $text; 1535 }; 1536 } 1537 RT->Config->Set( HTMLFormatter => $prog ); 1538 last; 1539 } 1540 return $formatter; 1541} 1542 1543sub _HTMLFormatText { 1544 my $html = shift; 1545 1546 my $text; 1547 eval { 1548 $text = HTML::FormatText::WithLinks::AndTables->convert( 1549 $html => { 1550 leftmargin => 0, 1551 rightmargin => 78, 1552 no_rowspacing => 1, 1553 before_link => '', 1554 after_link => ' (%l)', 1555 footnote => '', 1556 skip_linked_urls => 1, 1557 with_emphasis => 0, 1558 } 1559 ); 1560 $text //= ''; 1561 }; 1562 $RT::Logger->error("Failed to downgrade HTML to plain text: $@") if $@; 1563 return $text; 1564} 1565 1566 1567RT::Base->_ImportOverlays(); 1568 15691; 1570