rt/lib/RT/Action/SendEmail.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2015 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
  49 # Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
  50
  51 package RT::Action::SendEmail;
  52
  53 use strict;
  54 use warnings;
  55
  56 use base qw(RT::Action);
  57
  58 use RT::EmailParser;
  59 use RT::Interface::Email;
  60 use Email::Address;
  61 our @EMAIL_RECIPIENT_HEADERS = qw(To Cc Bcc);
  62
  63
  64 =head1 NAME
  65
  66 RT::Action::SendEmail - An Action which users can use to send mail
  67 or can subclassed for more specialized mail sending behavior.
  68 RT::Action::AutoReply is a good example subclass.
  69
  70 =head1 SYNOPSIS
  71
  72   use base 'RT::Action::SendEmail';
  73
  74 =head1 DESCRIPTION
  75
  76 Basically, you create another module RT::Action::YourAction which ISA
  77 RT::Action::SendEmail.
  78
  79 =head1 METHODS
  80
  81 =head2 CleanSlate
  82
  83 Cleans class-wide options, like L</AttachTickets>.
  84
  85 =cut
  86
  87 sub CleanSlate {
  88     my $self = shift;
  89     $self->AttachTickets(undef);
  90 }
  91
  92 =head2 Commit
  93
  94 Sends the prepared message and writes outgoing record into DB if the feature is
  95 activated in the config.
  96
  97 =cut
  98
  99 sub Commit {
 100     my $self = shift;
 101
 102     return abs $self->SendMessage( $self->TemplateObj->MIMEObj )
 103         unless RT->Config->Get('RecordOutgoingEmail');
 104
 105     $self->DeferDigestRecipients();
 106     my $message = $self->TemplateObj->MIMEObj;
 107
 108     my $orig_message;
 109     $orig_message = $message->dup if RT::Interface::Email::WillSignEncrypt(
 110         Attachment => $self->TransactionObj->Attachments->First,
 111         Ticket     => $self->TicketObj,
 112     );
 113
 114     my ($ret) = $self->SendMessage($message);
 115     return abs( $ret ) if $ret <= 0;
 116
 117     if ($orig_message) {
 118         $message->attach(
 119             Type        => 'application/x-rt-original-message',
 120             Disposition => 'inline',
 121             Data        => $orig_message->as_string,
 122         );
 123     }
 124     $self->RecordOutgoingMailTransaction($message);
 125     $self->RecordDeferredRecipients();
 126     return 1;
 127 }
 128
 129 =head2 Prepare
 130
 131 Builds an outgoing email we're going to send using scrip's template.
 132
 133 =cut
 134
 135 sub Prepare {
 136     my $self = shift;
 137
 138     unless ( $self->TemplateObj->MIMEObj ) {
 139         my ( $result, $message ) = $self->TemplateObj->Parse(
 140             Argument       => $self->Argument,
 141             TicketObj      => $self->TicketObj,
 142             TransactionObj => $self->TransactionObj
 143         );
 144         if ( !$result ) {
 145             return (undef);
 146         }
 147     }
 148
 149     my $MIMEObj = $self->TemplateObj->MIMEObj;
 150
 151     # Header
 152     $self->SetRTSpecialHeaders();
 153
 154     my %seen;
 155     foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
 156         @{ $self->{$type} }
 157             = grep defined && length && !$seen{ lc $_ }++,
 158             @{ $self->{$type} };
 159     }
 160
 161     $self->RemoveInappropriateRecipients();
 162
 163     # Go add all the Tos, Ccs and Bccs that we need to to the message to
 164     # make it happy, but only if we actually have values in those arrays.
 165
 166 # TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc
 167
 168     for my $header (@EMAIL_RECIPIENT_HEADERS) {
 169
 170         $self->SetHeader( $header, join( ', ', @{ $self->{$header} } ) )
 171           if (!$MIMEObj->head->get($header)
 172             && $self->{$header}
 173             && @{ $self->{$header} } );
 174     }
 175     # PseudoTo (fake to headers) shouldn't get matched for message recipients.
 176     # If we don't have any 'To' header (but do have other recipients), drop in
 177     # the pseudo-to header.
 178     $self->SetHeader( 'To', join( ', ', @{ $self->{'PseudoTo'} } ) )
 179         if $self->{'PseudoTo'}
 180             && @{ $self->{'PseudoTo'} }
 181             && !$MIMEObj->head->get('To')
 182             && ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc') );
 183
 184     # For security reasons, we only send out textual mails.
 185     foreach my $part ( grep !$_->is_multipart, $MIMEObj->parts_DFS ) {
 186         my $type = $part->mime_type || 'text/plain';
 187         $type = 'text/plain' unless RT::I18N::IsTextualContentType($type);
 188         $part->head->mime_attr( "Content-Type" => $type );
 189         # utf-8 here is for _FindOrGuessCharset in I18N.pm
 190         # it's not the final charset/encoding sent
 191         $part->head->mime_attr( "Content-Type.charset" => 'utf-8' );
 192     }
 193
 194     RT::I18N::SetMIMEEntityToEncoding(
 195         Entity        => $MIMEObj,
 196         Encoding      => RT->Config->Get('EmailOutputEncoding'),
 197         PreserveWords => 1,
 198         IsOut         => 1,
 199     );
 200
 201     # Build up a MIME::Entity that looks like the original message.
 202     $self->AddAttachments if ( $MIMEObj->head->get('RT-Attach-Message')
 203                                && ( $MIMEObj->head->get('RT-Attach-Message') !~ /^(n|no|0|off|false)$/i ) );
 204
 205     $self->AddTickets;
 206
 207     my $attachment = $self->TransactionObj->Attachments->First;
 208     if ($attachment
 209         && !(
 210                $attachment->GetHeader('X-RT-Encrypt')
 211             || $self->TicketObj->QueueObj->Encrypt
 212         )
 213         )
 214     {
 215         $attachment->SetHeader( 'X-RT-Encrypt' => 1 )
 216             if ( $attachment->GetHeader("X-RT-Incoming-Encryption") || '' ) eq
 217             'Success';
 218     }
 219
 220     return 1;
 221 }
 222
 223 =head2 To
 224
 225 Returns an array of L<Email::Address> objects containing all the To: recipients for this notification
 226
 227 =cut
 228
 229 sub To {
 230     my $self = shift;
 231     return ( $self->AddressesFromHeader('To') );
 232 }
 233
 234 =head2 Cc
 235
 236 Returns an array of L<Email::Address> objects containing all the Cc: recipients for this notification
 237
 238 =cut
 239
 240 sub Cc {
 241     my $self = shift;
 242     return ( $self->AddressesFromHeader('Cc') );
 243 }
 244
 245 =head2 Bcc
 246
 247 Returns an array of L<Email::Address> objects containing all the Bcc: recipients for this notification
 248
 249 =cut
 250
 251 sub Bcc {
 252     my $self = shift;
 253     return ( $self->AddressesFromHeader('Bcc') );
 254
 255 }
 256
 257 sub AddressesFromHeader {
 258     my $self      = shift;
 259     my $field     = shift;
 260     my $header    = Encode::decode("UTF-8",$self->TemplateObj->MIMEObj->head->get($field));
 261     my @addresses = Email::Address->parse($header);
 262
 263     return (@addresses);
 264 }
 265
 266 =head2 SendMessage MIMEObj
 267
 268 sends the message using RT's preferred API.
 269 TODO: Break this out to a separate module
 270
 271 =cut
 272
 273 sub SendMessage {
 274
 275     # DO NOT SHIFT @_ in this subroutine.  It breaks Hook::LexWrap's
 276     # ability to pass @_ to a 'post' routine.
 277     my ( $self, $MIMEObj ) = @_;
 278
 279     my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') );
 280     chomp $msgid;
 281
 282     $self->ScripActionObj->{_Message_ID}++;
 283
 284     $RT::Logger->info( $msgid . " #"
 285             . $self->TicketObj->id . "/"
 286             . $self->TransactionObj->id
 287             . " - Scrip "
 288             . ($self->ScripObj->id || '#rule'). " "
 289             . ( $self->ScripObj->Description || '' ) );
 290
 291     my $status = RT::Interface::Email::SendEmail(
 292         Entity      => $MIMEObj,
 293         Ticket      => $self->TicketObj,
 294         Transaction => $self->TransactionObj,
 295     );
 296
 297
 298     return $status unless ($status > 0 || exists $self->{'Deferred'});
 299
 300     my $success = $msgid . " sent ";
 301     foreach (@EMAIL_RECIPIENT_HEADERS) {
 302         my $recipients = Encode::decode( "UTF-8", $MIMEObj->head->get($_) );
 303         $success .= " $_: " . $recipients if $recipients;
 304     }
 305
 306     if( exists $self->{'Deferred'} ) {
 307         for (qw(daily weekly susp)) {
 308             $success .= "\nBatched email $_ for: ". join(", ", keys %{ $self->{'Deferred'}{ $_ } } )
 309                 if exists $self->{'Deferred'}{ $_ };
 310         }
 311     }
 312
 313     $success =~ s/\n//g;
 314
 315     $RT::Logger->info($success);
 316
 317     return (1);
 318 }
 319
 320 =head2 AddAttachments
 321
 322 Takes any attachments to this transaction and attaches them to the message
 323 we're building.
 324
 325 =cut
 326
 327 sub AddAttachments {
 328     my $self = shift;
 329
 330     my $MIMEObj = $self->TemplateObj->MIMEObj;
 331
 332     $MIMEObj->head->delete('RT-Attach-Message');
 333
 334     my $attachments = RT::Attachments->new( RT->SystemUser );
 335     $attachments->Limit(
 336         FIELD => 'TransactionId',
 337         VALUE => $self->TransactionObj->Id
 338     );
 339
 340     # Don't attach anything blank
 341     $attachments->LimitNotEmpty;
 342     $attachments->OrderBy( FIELD => 'id' );
 343
 344     # We want to make sure that we don't include the attachment that's
 345     # being used as the "Content" of this message" unless that attachment's
 346     # content type is not like text/...
 347     my $transaction_content_obj = $self->TransactionObj->ContentObj;
 348
 349     if (   $transaction_content_obj
 350         && $transaction_content_obj->ContentType =~ m{text/}i )
 351     {
 352         # If this was part of a multipart/alternative, skip all of the kids
 353         my $parent = $transaction_content_obj->ParentObj;
 354         if ($parent and $parent->Id and $parent->ContentType eq "multipart/alternative") {
 355             $attachments->Limit(
 356                 ENTRYAGGREGATOR => 'AND',
 357                 FIELD           => 'parent',
 358                 OPERATOR        => '!=',
 359                 VALUE           => $parent->Id,
 360             );
 361         } else {
 362             $attachments->Limit(
 363                 ENTRYAGGREGATOR => 'AND',
 364                 FIELD           => 'id',
 365                 OPERATOR        => '!=',
 366                 VALUE           => $transaction_content_obj->Id,
 367             );
 368         }
 369     }
 370
 371     # attach any of this transaction's attachments
 372     my $seen_attachment = 0;
 373     while ( my $attach = $attachments->Next ) {
 374         if ( !$seen_attachment ) {
 375             $MIMEObj->make_multipart( 'mixed', Force => 1 );
 376             $seen_attachment = 1;
 377         }
 378         $self->AddAttachment($attach);
 379     }
 380 }
 381
 382 =head2 AddAttachment $attachment
 383
 384 Takes one attachment object of L<RT::Attachment> class and attaches it to the message
 385 we're building.
 386
 387 =cut
 388
 389 sub AddAttachment {
 390     my $self    = shift;
 391     my $attach  = shift;
 392     my $MIMEObj = shift || $self->TemplateObj->MIMEObj;
 393
 394     # $attach->TransactionObj may not always be $self->TransactionObj
 395     return unless $attach->Id
 396               and $attach->TransactionObj->CurrentUserCanSee;
 397
 398     # ->attach expects just the disposition type; extract it if we have the header
 399     # or default to "attachment"
 400     my $disp = ($attach->GetHeader('Content-Disposition') || '')
 401                     =~ /^\s*(inline|attachment)/i ? $1 : "attachment";
 402
 403     $MIMEObj->attach(
 404         Type        => $attach->ContentType,
 405         Charset     => $attach->OriginalEncoding,
 406         Data        => $attach->OriginalContent,
 407         Disposition => $disp,
 408         Filename    => $self->MIMEEncodeString( $attach->Filename ),
 409         Id          => $attach->GetHeader('Content-ID'),
 410         'RT-Attachment:' => $self->TicketObj->Id . "/"
 411             . $self->TransactionObj->Id . "/"
 412             . $attach->id,
 413         Encoding => '-SUGGEST',
 414     );
 415 }
 416
 417 =head2 AttachTickets [@IDs]
 418
 419 Returns or set list of ticket's IDs that should be attached to an outgoing message.
 420
 421 B<Note> this method works as a class method and setup things global, so you have to
 422 clean list by passing undef as argument.
 423
 424 =cut
 425
 426 {
 427     my $list = [];
 428
 429     sub AttachTickets {
 430         my $self = shift;
 431         $list = [ grep defined, @_ ] if @_;
 432         return @$list;
 433     }
 434 }
 435
 436 =head2 AddTickets
 437
 438 Attaches tickets to the current message, list of tickets' ids get from
 439 L</AttachTickets> method.
 440
 441 =cut
 442
 443 sub AddTickets {
 444     my $self = shift;
 445     $self->AddTicket($_) foreach $self->AttachTickets;
 446     return;
 447 }
 448
 449 =head2 AddTicket $ID
 450
 451 Attaches a ticket with ID to the message.
 452
 453 Each ticket is attached as multipart entity and all its messages and attachments
 454 are attached as sub entities in order of creation, but only if transaction type
 455 is Create or Correspond.
 456
 457 =cut
 458
 459 sub AddTicket {
 460     my $self = shift;
 461     my $tid  = shift;
 462
 463     my $attachs   = RT::Attachments->new( $self->TransactionObj->CreatorObj );
 464     my $txn_alias = $attachs->TransactionAlias;
 465     $attachs->Limit(
 466         ALIAS    => $txn_alias,
 467         FIELD    => 'Type',
 468         OPERATOR => 'IN',
 469         VALUE    => [qw(Create Correspond)],
 470     );
 471     $attachs->LimitByTicket($tid);
 472     $attachs->LimitNotEmpty;
 473     $attachs->OrderBy( FIELD => 'Created' );
 474
 475     my $ticket_mime = MIME::Entity->build(
 476         Type        => 'multipart/mixed',
 477         Top         => 0,
 478         Description => "ticket #$tid",
 479     );
 480     while ( my $attachment = $attachs->Next ) {
 481         $self->AddAttachment( $attachment, $ticket_mime );
 482     }
 483     if ( $ticket_mime->parts ) {
 484         my $email_mime = $self->TemplateObj->MIMEObj;
 485         $email_mime->make_multipart;
 486         $email_mime->add_part($ticket_mime);
 487     }
 488     return;
 489 }
 490
 491 =head2 RecordOutgoingMailTransaction MIMEObj
 492
 493 Record a transaction in RT with this outgoing message for future record-keeping purposes
 494
 495 =cut
 496
 497 sub RecordOutgoingMailTransaction {
 498     my $self    = shift;
 499     my $MIMEObj = shift;
 500
 501     my @parts = $MIMEObj->parts;
 502     my @attachments;
 503     my @keep;
 504     foreach my $part (@parts) {
 505         my $attach = $part->head->get('RT-Attachment');
 506         if ($attach) {
 507             $RT::Logger->debug(
 508                 "We found an attachment. we want to not record it.");
 509             push @attachments, $attach;
 510         } else {
 511             $RT::Logger->debug("We found a part. we want to record it.");
 512             push @keep, $part;
 513         }
 514     }
 515     $MIMEObj->parts( \@keep );
 516     foreach my $attachment (@attachments) {
 517         $MIMEObj->head->add( 'RT-Attachment', $attachment );
 518     }
 519
 520     RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
 521
 522     my $transaction
 523         = RT::Transaction->new( $self->TransactionObj->CurrentUser );
 524
 525 # XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
 526
 527     my $type;
 528     if ( $self->TransactionObj->Type eq 'Comment' ) {
 529         $type = 'CommentEmailRecord';
 530     } else {
 531         $type = 'EmailRecord';
 532     }
 533
 534     my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') );
 535     chomp $msgid;
 536
 537     my ( $id, $msg ) = $transaction->Create(
 538         Ticket         => $self->TicketObj->Id,
 539         Type           => $type,
 540         Data           => $msgid,
 541         MIMEObj        => $MIMEObj,
 542         ActivateScrips => 0
 543     );
 544
 545     if ($id) {
 546         $self->{'OutgoingMailTransaction'} = $id;
 547     } else {
 548         $RT::Logger->warning(
 549             "Could not record outgoing message transaction: $msg");
 550     }
 551     return $id;
 552 }
 553
 554 =head2 SetRTSpecialHeaders
 555
 556 This routine adds all the random headers that RT wants in a mail message
 557 that don't matter much to anybody else.
 558
 559 =cut
 560
 561 sub SetRTSpecialHeaders {
 562     my $self = shift;
 563
 564     $self->SetSubject();
 565     $self->SetSubjectToken();
 566     $self->SetHeaderAsEncoding( 'Subject',
 567         RT->Config->Get('EmailOutputEncoding') )
 568         if ( RT->Config->Get('EmailOutputEncoding') );
 569     $self->SetReturnAddress();
 570     $self->SetReferencesHeaders();
 571
 572     unless ( $self->TemplateObj->MIMEObj->head->get('Message-ID') ) {
 573
 574         # Get Message-ID for this txn
 575         my $msgid = "";
 576         if ( my $msg = $self->TransactionObj->Message->First ) {
 577             $msgid = $msg->GetHeader("RT-Message-ID")
 578                 || $msg->GetHeader("Message-ID");
 579         }
 580
 581         # If there is one, and we can parse it, then base our Message-ID on it
 582         if (    $msgid
 583             and $msgid
 584             =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\QRT->Config->Get('Organization')\E>$/
 585                          "<$1." . $self->TicketObj->id
 586                           . "-" . $self->ScripObj->id
 587                           . "-" . $self->ScripActionObj->{_Message_ID}
 588                           . "@" . RT->Config->Get('Organization') . ">"/eg
 589             and $2 == $self->TicketObj->id
 590             )
 591         {
 592             $self->SetHeader( "Message-ID" => $msgid );
 593         } else {
 594             $self->SetHeader(
 595                 'Message-ID' => RT::Interface::Email::GenMessageId(
 596                     Ticket      => $self->TicketObj,
 597                     Scrip       => $self->ScripObj,
 598                     ScripAction => $self->ScripActionObj
 599                 ),
 600             );
 601         }
 602     }
 603
 604     $self->SetHeader( 'X-RT-Loop-Prevention', RT->Config->Get('rtname') );
 605     $self->SetHeader( 'X-RT-Ticket',
 606         RT->Config->Get('rtname') . " #" . $self->TicketObj->id() );
 607     $self->SetHeader( 'X-Managed-by',
 608         "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
 609
 610 # XXX, TODO: use /ShowUser/ShowUserEntry(or something like that) when it would be
 611 #            refactored into user's method.
 612     if ( my $email = $self->TransactionObj->CreatorObj->EmailAddress
 613          and ! defined $self->TemplateObj->MIMEObj->head->get("RT-Originator")
 614          and RT->Config->Get('UseOriginatorHeader')
 615     ) {
 616         $self->SetHeader( 'X-RT-Originator', $email );
 617     }
 618
 619 }
 620
 621
 622 sub DeferDigestRecipients {
 623     my $self = shift;
 624     $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id );
 625
 626     # The digest attribute will be an array of notifications that need to
 627     # be sent for this transaction.  The array will have the following
 628     # format for its objects.
 629     # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc}
 630     #                                     -> sent -> {true|false}
 631     # The "sent" flag will be used by the cron job to indicate that it has
 632     # run on this transaction.
 633     # In a perfect world we might move this hash construction to the
 634     # extension module itself.
 635     my $digest_hash = {};
 636
 637     foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) {
 638         # If we have a "PseudoTo", the "To" contains it, so we don't need to access it
 639         next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) );
 640         $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) );
 641
 642         # Store the 'daily digest' folk in an array.
 643         my ( @send_now, @daily_digest, @weekly_digest, @suspended );
 644
 645         # Have to get the list of addresses directly from the MIME header
 646         # at this point.
 647         $RT::Logger->debug( Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->as_string ) );
 648         foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
 649             next unless $rcpt;
 650             my $user_obj = RT::User->new(RT->SystemUser);
 651             $user_obj->LoadByEmail($rcpt);
 652             if  ( ! $user_obj->id ) {
 653                 # If there's an email address in here without an associated
 654                 # RT user, pass it on through.
 655                 $RT::Logger->debug( "User $rcpt is not associated with an RT user object.  Send mail.");
 656                 push( @send_now, $rcpt );
 657                 next;
 658             }
 659
 660             my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || '';
 661             $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt");
 662
 663             if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) }
 664             elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) }
 665             elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) }
 666             else { push( @send_now, $rcpt ) }
 667         }
 668
 669         # Reset the relevant mail field.
 670         $RT::Logger->debug( "Removing deferred recipients from $mailfield: line");
 671         if (@send_now) {
 672             $self->SetHeader( $mailfield, join( ', ', @send_now ) );
 673         } else {    # No recipients!  Remove the header.
 674             $self->TemplateObj->MIMEObj->head->delete($mailfield);
 675         }
 676
 677         # Push the deferred addresses into the appropriate field in
 678         # our attribute hash, with the appropriate mail header.
 679         $RT::Logger->debug(
 680             "Setting deferred recipients for attribute creation");
 681         $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0}  for (@daily_digest);
 682         $digest_hash->{'weekly'}->{$_} ={'header' =>  $mailfield, _sent => 0}  for (@weekly_digest);
 683         $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 }  for (@suspended);
 684     }
 685
 686     if ( scalar keys %$digest_hash ) {
 687
 688         # Save the hash so that we can add it as an attribute to the
 689         # outgoing email transaction.
 690         $self->{'Deferred'} = $digest_hash;
 691     } else {
 692         $RT::Logger->debug( "No recipients found for deferred delivery on "
 693                 . "transaction #"
 694                 . $self->TransactionObj->id );
 695     }
 696 }
 697
 698
 699
 700 sub RecordDeferredRecipients {
 701     my $self = shift;
 702     return unless exists $self->{'Deferred'};
 703
 704     my $txn_id = $self->{'OutgoingMailTransaction'};
 705     return unless $txn_id;
 706
 707     my $txn_obj = RT::Transaction->new( $self->CurrentUser );
 708     $txn_obj->Load( $txn_id );
 709     my( $ret, $msg ) = $txn_obj->AddAttribute(
 710         Name => 'DeferredRecipients',
 711         Content => $self->{'Deferred'}
 712     );
 713     $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" )
 714         unless $ret;
 715
 716     return ($ret,$msg);
 717 }
 718
 719 =head2 SquelchMailTo
 720
 721 Returns list of the addresses to squelch on this transaction.
 722
 723 =cut
 724
 725 sub SquelchMailTo {
 726     my $self = shift;
 727     return map $_->Content, $self->TransactionObj->SquelchMailTo;
 728 }
 729
 730 =head2 RemoveInappropriateRecipients
 731
 732 Remove addresses that are RT addresses or that are on this transaction's blacklist
 733
 734 =cut
 735
 736 my %squelch_reasons = (
 737     'not privileged'
 738         => "because autogenerated messages are configured to only be sent to privileged users (RedistributeAutoGeneratedMessages)",
 739     'squelch:attachment'
 740         => "by RT-Squelch-Replies-To header in the incoming message",
 741     'squelch:transaction'
 742         => "by notification checkboxes for this transaction",
 743     'squelch:ticket'
 744         => "by notification checkboxes on this ticket's People page",
 745 );
 746
 747
 748 sub RemoveInappropriateRecipients {
 749     my $self = shift;
 750
 751     my %blacklist = ();
 752
 753     # If there are no recipients, don't try to send the message.
 754     # If the transaction has content and has the header RT-Squelch-Replies-To
 755
 756     my $msgid = Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->get('Message-Id') );
 757     chomp $msgid;
 758
 759     if ( my $attachment = $self->TransactionObj->Attachments->First ) {
 760
 761         if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
 762
 763             # What do we want to do with this? It's probably (?) a bounce
 764             # caused by one of the watcher addresses being broken.
 765             # Default ("true") is to redistribute, for historical reasons.
 766
 767             my $redistribute = RT->Config->Get('RedistributeAutoGeneratedMessages');
 768
 769             if ( !$redistribute ) {
 770
 771                 # Don't send to any watchers.
 772                 @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS);
 773                 $RT::Logger->info( $msgid
 774                         . " The incoming message was autogenerated. "
 775                         . "Not redistributing this message based on site configuration."
 776                 );
 777             } elsif ( $redistribute eq 'privileged' ) {
 778
 779                 # Only send to "privileged" watchers.
 780                 foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
 781                     foreach my $addr ( @{ $self->{$type} } ) {
 782                         my $user = RT::User->new(RT->SystemUser);
 783                         $user->LoadByEmail($addr);
 784                         $blacklist{ $addr } ||= 'not privileged'
 785                             unless $user->id && $user->Privileged;
 786                     }
 787                 }
 788                 $RT::Logger->info( $msgid
 789                         . " The incoming message was autogenerated. "
 790                         . "Not redistributing this message to unprivileged users based on site configuration."
 791                 );
 792             }
 793         }
 794
 795         if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) {
 796             $blacklist{ $_->address } ||= 'squelch:attachment'
 797                 foreach Email::Address->parse( $squelch );
 798         }
 799     }
 800
 801     # Let's grab the SquelchMailTo attributes and push those entries
 802     # into the blacklisted
 803     $blacklist{ $_->Content } ||= 'squelch:transaction'
 804         foreach $self->TransactionObj->SquelchMailTo;
 805     $blacklist{ $_->Content } ||= 'squelch:ticket'
 806         foreach $self->TicketObj->SquelchMailTo;
 807
 808     # canonicalize emails
 809     foreach my $address ( keys %blacklist ) {
 810         my $reason = delete $blacklist{ $address };
 811         $blacklist{ lc $_ } = $reason
 812             foreach map RT::User->CanonicalizeEmailAddress( $_->address ),
 813             Email::Address->parse( $address );
 814     }
 815
 816     $self->RecipientFilter(
 817         Callback => sub {
 818             return unless RT::EmailParser->IsRTAddress( $_[0] );
 819             return "$_[0] appears to point to this RT instance. Skipping";
 820         },
 821         All => 1,
 822     );
 823
 824     $self->RecipientFilter(
 825         Callback => sub {
 826             return unless $blacklist{ lc $_[0] };
 827             return "$_[0] is blacklisted $squelch_reasons{ $blacklist{ lc $_[0] } }. Skipping";
 828         },
 829     );
 830
 831
 832     # Cycle through the people we're sending to and pull out anyone that meets any of the callbacks
 833     for my $type (@EMAIL_RECIPIENT_HEADERS) {
 834         my @addrs;
 835
 836       ADDRESS:
 837         for my $addr ( @{ $self->{$type} } ) {
 838             for my $filter ( map {$_->{Callback}} @{$self->{RecipientFilter}} ) {
 839                 my $skip = $filter->($addr);
 840                 next unless $skip;
 841                 $RT::Logger->info( "$msgid $skip" );
 842                 next ADDRESS;
 843             }
 844             push @addrs, $addr;
 845         }
 846
 847       NOSQUELCH_ADDRESS:
 848         for my $addr ( @{ $self->{NoSquelch}{$type} } ) {
 849             for my $filter ( map {$_->{Callback}} grep {$_->{All}} @{$self->{RecipientFilter}} ) {
 850                 my $skip = $filter->($addr);
 851                 next unless $skip;
 852                 $RT::Logger->info( "$msgid $skip" );
 853                 next NOSQUELCH_ADDRESS;
 854             }
 855             push @addrs, $addr;
 856         }
 857
 858         @{ $self->{$type} } = @addrs;
 859     }
 860 }
 861
 862 =head2 RecipientFilter Callback => SUB, [All => 1]
 863
 864 Registers a filter to be applied to addresses by
 865 L<RemoveInappropriateRecipients>.  The C<Callback> will be called with
 866 one address at a time, and should return false if the address should
 867 receive mail, or a message explaining why it should not be.  Passing a
 868 true value for C<All> will cause the filter to also be applied to
 869 NoSquelch (one-time Cc and Bcc) recipients as well.
 870
 871 =cut
 872
 873 sub RecipientFilter {
 874     my $self = shift;
 875     push @{ $self->{RecipientFilter}}, {@_};
 876 }
 877
 878 =head2 SetReturnAddress is_comment => BOOLEAN
 879
 880 Calculate and set From and Reply-To headers based on the is_comment flag.
 881
 882 =cut
 883
 884 sub SetReturnAddress {
 885
 886     my $self = shift;
 887     my %args = (
 888         is_comment => 0,
 889         friendly_name => undef,
 890         @_
 891     );
 892
 893     # From and Reply-To
 894     # $args{is_comment} should be set if the comment address is to be used.
 895     my $replyto;
 896
 897     if ( $args{'is_comment'} ) {
 898         $replyto = $self->TicketObj->QueueObj->CommentAddress
 899             || RT->Config->Get('CommentAddress');
 900     } else {
 901         $replyto = $self->TicketObj->QueueObj->CorrespondAddress
 902             || RT->Config->Get('CorrespondAddress');
 903     }
 904
 905     unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
 906         $self->SetFrom( %args, From => $replyto );
 907     }
 908
 909     unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
 910         $self->SetHeader( 'Reply-To', "$replyto" );
 911     }
 912
 913 }
 914
 915 =head2 SetFrom ( From => emailaddress )
 916
 917 Set the From: address for outgoing email
 918
 919 =cut
 920
 921 sub SetFrom {
 922     my $self = shift;
 923     my %args = @_;
 924
 925     my $from = $args{From};
 926
 927     if ( RT->Config->Get('UseFriendlyFromLine') ) {
 928         my $friendly_name = $self->GetFriendlyName(%args);
 929         $from =
 930             sprintf(
 931                 RT->Config->Get('FriendlyFromLineFormat'),
 932                 $self->MIMEEncodeString(
 933                     $friendly_name, RT->Config->Get('EmailOutputEncoding')
 934                 ),
 935                 $args{From}
 936             );
 937     }
 938
 939     $self->SetHeader( 'From', $from );
 940
 941     #also set Sender:, otherwise MTAs add a nonsensical value like rt@machine,
 942     #and then Outlook prepends "rt@machine on behalf of" to the From: header
 943     $self->SetHeader( 'Sender', $from );
 944 }
 945
 946 =head2 GetFriendlyName
 947
 948 Calculate the proper Friendly Name based on the creator of the transaction
 949
 950 =cut
 951
 952 sub GetFriendlyName {
 953     my $self = shift;
 954     my %args = (
 955         is_comment => 0,
 956         friendly_name => '',
 957         @_
 958     );
 959     my $friendly_name = $args{friendly_name};
 960
 961     unless ( $friendly_name ) {
 962         $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName;
 963         if ( $friendly_name =~ /^"(.*)"$/ ) {    # a quoted string
 964             $friendly_name = $1;
 965         }
 966     }
 967
 968     $friendly_name =~ s/"/\\"/g;
 969     return $friendly_name;
 970
 971 }
 972
 973 =head2 SetHeader FIELD, VALUE
 974
 975 Set the FIELD of the current MIME object into VALUE, which should be in
 976 characters, not bytes.  Returns the new header, in bytes.
 977
 978 =cut
 979
 980 sub SetHeader {
 981     my $self  = shift;
 982     my $field = shift;
 983     my $val   = shift;
 984
 985     chomp $val;
 986     chomp $field;
 987     my $head = $self->TemplateObj->MIMEObj->head;
 988     $head->fold_length( $field, 10000 );
 989     $head->replace( $field, Encode::encode( "UTF-8", $val ) );
 990     return $head->get($field);
 991 }
 992
 993 =head2 SetSubject
 994
 995 This routine sets the subject. it does not add the rt tag. That gets done elsewhere
 996 If subject is already defined via template, it uses that. otherwise, it tries to get
 997 the transaction's subject.
 998
 999 =cut
1000
1001 sub SetSubject {
1002     my $self = shift;
1003     my $subject;
1004
1005     if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
1006         return ();
1007     }
1008
1009     # don't use Transaction->Attachments because it caches
1010     # and anything which later calls ->Attachments will be hurt
1011     # by our RowsPerPage() call.  caching is hard.
1012     my $message = RT::Attachments->new( $self->CurrentUser );
1013     $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id);
1014     $message->OrderBy( FIELD => 'id', ORDER => 'ASC' );
1015     $message->RowsPerPage(1);
1016
1017     if ( $self->{'Subject'} ) {
1018         $subject = $self->{'Subject'};
1019     } elsif ( my $first = $message->First ) {
1020         my $tmp = $first->GetHeader('Subject');
1021         $subject = defined $tmp ? $tmp : $self->TicketObj->Subject;
1022     } else {
1023         $subject = $self->TicketObj->Subject;
1024     }
1025     $subject = '' unless defined $subject;
1026     chomp $subject;
1027
1028     $subject =~ s/(\r\n|\n|\s)/ /g;
1029
1030     $self->SetHeader( 'Subject', $subject );
1031
1032 }
1033
1034 =head2 SetSubjectToken
1035
1036 This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
1037
1038 =cut
1039
1040 sub SetSubjectToken {
1041     my $self = shift;
1042
1043     my $head = $self->TemplateObj->MIMEObj->head;
1044     $self->SetHeader(
1045         Subject =>
1046             RT::Interface::Email::AddSubjectTag(
1047                 Encode::decode( "UTF-8", $head->get('Subject') ),
1048                 $self->TicketObj,
1049             ),
1050     );
1051 }
1052
1053 =head2 SetReferencesHeaders
1054
1055 Set References and In-Reply-To headers for this message.
1056
1057 =cut
1058
1059 sub SetReferencesHeaders {
1060     my $self = shift;
1061
1062     my $top = $self->TransactionObj->Message->First;
1063     unless ( $top ) {
1064         $self->SetHeader( References => $self->PseudoReference );
1065         return (undef);
1066     }
1067
1068     my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' );
1069     my @references  = split( /\s+/m, $top->GetHeader('References')  || '' );
1070     my @msgid       = split( /\s+/m, $top->GetHeader('Message-ID')  || '' );
1071
1072     # There are two main cases -- this transaction was created with
1073     # the RT Web UI, and hence we want to *not* append its Message-ID
1074     # to the References and In-Reply-To.  OR it came from an outside
1075     # source, and we should treat it as per the RFC
1076     my $org = RT->Config->Get('Organization');
1077     if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) {
1078
1079         # Make all references which are internal be to version which we
1080         # have sent out
1081
1082         for ( @references, @in_reply_to ) {
1083             s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/
1084           "<$1." . $self->TicketObj->id .
1085              "-" . $self->ScripObj->id .
1086              "-" . $self->ScripActionObj->{_Message_ID} .
1087              "@" . $org . ">"/eg
1088         }
1089
1090         # In reply to whatever the internal message was in reply to
1091         $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) );
1092
1093         # Default the references to whatever we're in reply to
1094         @references = @in_reply_to unless @references;
1095
1096         # References are unchanged from internal
1097     } else {
1098
1099         # In reply to that message
1100         $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) );
1101
1102         # Default the references to whatever we're in reply to
1103         @references = @in_reply_to unless @references;
1104
1105         # Push that message onto the end of the references
1106         push @references, @msgid;
1107     }
1108
1109     # Push pseudo-ref to the front
1110     my $pseudo_ref = $self->PseudoReference;
1111     @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references );
1112
1113     # If there are more than 10 references headers, remove all but the
1114     # first four and the last six (Gotta keep this from growing
1115     # forever)
1116     splice( @references, 4, -6 ) if ( $#references >= 10 );
1117
1118     # Add on the references
1119     $self->SetHeader( 'References', join( " ", @references ) );
1120     $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
1121
1122 }
1123
1124 =head2 PseudoReference
1125
1126 Returns a fake Message-ID: header for the ticket to allow a base level of threading
1127
1128 =cut
1129
1130 sub PseudoReference {
1131     my $self = shift;
1132     return RT::Interface::Email::PseudoReference( $self->TicketObj );
1133 }
1134
1135 =head2 SetHeaderAsEncoding($field_name, $charset_encoding)
1136
1137 This routine converts the field into specified charset encoding, then
1138 applies the MIME-Header transfer encoding.
1139
1140 =cut
1141
1142 sub SetHeaderAsEncoding {
1143     my $self = shift;
1144     my ( $field, $enc ) = ( shift, shift );
1145
1146     my $head = $self->TemplateObj->MIMEObj->head;
1147
1148     my $value = Encode::decode("UTF-8", $head->get( $field ));
1149     $value = $self->MIMEEncodeString( $value, $enc ); # Returns bytes
1150     $head->replace( $field, $value );
1151
1152 }
1153
1154 =head2 MIMEEncodeString
1155
1156 Takes a perl string and optional encoding pass it over
1157 L<RT::Interface::Email/EncodeToMIME>.
1158
1159 Basicly encode a string using B encoding according to RFC2047, returning
1160 bytes.
1161
1162 =cut
1163
1164 sub MIMEEncodeString {
1165     my $self  = shift;
1166     return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] );
1167 }
1168
1169 RT::Base->_ImportOverlays();
1170
1171 1;
1172