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