rt/lib/RT/Action/SendEmail.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2016 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 AttachableFromTransaction
 321
 322 Function (not method) that takes an L<RT::Transaction> and returns an
 323 L<RT::Attachments> collection of attachments suitable for attaching to an
 324 email.
 325
 326 =cut
 327
 328 sub AttachableFromTransaction {
 329     my $txn = shift;
 330
 331     my $attachments = RT::Attachments->new( RT->SystemUser );
 332     $attachments->Limit(
 333         FIELD => 'TransactionId',
 334         VALUE => $txn->Id
 335     );
 336
 337     # Don't attach anything blank
 338     $attachments->LimitNotEmpty;
 339     $attachments->OrderBy( FIELD => 'id' );
 340
 341     # We want to make sure that we don't include the attachment that's
 342     # being used as the "Content" of this message" unless that attachment's
 343     # content type is not like text/...
 344     my $transaction_content_obj = $txn->ContentObj;
 345
 346     if (   $transaction_content_obj
 347         && $transaction_content_obj->ContentType =~ m{text/}i )
 348     {
 349         # If this was part of a multipart/alternative, skip all of the kids
 350         my $parent = $transaction_content_obj->ParentObj;
 351         if ($parent and $parent->Id and $parent->ContentType eq "multipart/alternative") {
 352             $attachments->Limit(
 353                 ENTRYAGGREGATOR => 'AND',
 354                 FIELD           => 'parent',
 355                 OPERATOR        => '!=',
 356                 VALUE           => $parent->Id,
 357             );
 358         } else {
 359             $attachments->Limit(
 360                 ENTRYAGGREGATOR => 'AND',
 361                 FIELD           => 'id',
 362                 OPERATOR        => '!=',
 363                 VALUE           => $transaction_content_obj->Id,
 364             );
 365         }
 366     }
 367
 368     return $attachments;
 369 }
 370
 371 =head2 AddAttachments
 372
 373 Takes any attachments to this transaction and attaches them to the message
 374 we're building.
 375
 376 =cut
 377
 378 sub AddAttachments {
 379     my $self = shift;
 380
 381     my $MIMEObj = $self->TemplateObj->MIMEObj;
 382
 383     $MIMEObj->head->delete('RT-Attach-Message');
 384
 385     my $attachments = AttachableFromTransaction($self->TransactionObj);
 386
 387     # attach any of this transaction's attachments
 388     my $seen_attachment = 0;
 389     while ( my $attach = $attachments->Next ) {
 390         if ( !$seen_attachment ) {
 391             $MIMEObj->make_multipart( 'mixed', Force => 1 );
 392             $seen_attachment = 1;
 393         }
 394         $self->AddAttachment($attach);
 395     }
 396 }
 397
 398 =head2 AddAttachment $attachment
 399
 400 Takes one attachment object of L<RT::Attachment> class and attaches it to the message
 401 we're building.
 402
 403 =cut
 404
 405 sub AddAttachment {
 406     my $self    = shift;
 407     my $attach  = shift;
 408     my $MIMEObj = shift || $self->TemplateObj->MIMEObj;
 409
 410     # $attach->TransactionObj may not always be $self->TransactionObj
 411     return unless $attach->Id
 412               and $attach->TransactionObj->CurrentUserCanSee;
 413
 414     # ->attach expects just the disposition type; extract it if we have the header
 415     # or default to "attachment"
 416     my $disp = ($attach->GetHeader('Content-Disposition') || '')
 417                     =~ /^\s*(inline|attachment)/i ? $1 : "attachment";
 418
 419     $MIMEObj->attach(
 420         Type        => $attach->ContentType,
 421         Charset     => $attach->OriginalEncoding,
 422         Data        => $attach->OriginalContent,
 423         Disposition => $disp,
 424         Filename    => $self->MIMEEncodeString( $attach->Filename ),
 425         Id          => $attach->GetHeader('Content-ID'),
 426         'RT-Attachment:' => $self->TicketObj->Id . "/"
 427             . $self->TransactionObj->Id . "/"
 428             . $attach->id,
 429         Encoding => '-SUGGEST',
 430     );
 431 }
 432
 433 =head2 AttachTickets [@IDs]
 434
 435 Returns or set list of ticket's IDs that should be attached to an outgoing message.
 436
 437 B<Note> this method works as a class method and setup things global, so you have to
 438 clean list by passing undef as argument.
 439
 440 =cut
 441
 442 {
 443     my $list = [];
 444
 445     sub AttachTickets {
 446         my $self = shift;
 447         $list = [ grep defined, @_ ] if @_;
 448         return @$list;
 449     }
 450 }
 451
 452 =head2 AddTickets
 453
 454 Attaches tickets to the current message, list of tickets' ids get from
 455 L</AttachTickets> method.
 456
 457 =cut
 458
 459 sub AddTickets {
 460     my $self = shift;
 461     $self->AddTicket($_) foreach $self->AttachTickets;
 462     return;
 463 }
 464
 465 =head2 AddTicket $ID
 466
 467 Attaches a ticket with ID to the message.
 468
 469 Each ticket is attached as multipart entity and all its messages and attachments
 470 are attached as sub entities in order of creation, but only if transaction type
 471 is Create or Correspond.
 472
 473 =cut
 474
 475 sub AddTicket {
 476     my $self = shift;
 477     my $tid  = shift;
 478
 479     my $attachs   = RT::Attachments->new( $self->TransactionObj->CreatorObj );
 480     my $txn_alias = $attachs->TransactionAlias;
 481     $attachs->Limit(
 482         ALIAS    => $txn_alias,
 483         FIELD    => 'Type',
 484         OPERATOR => 'IN',
 485         VALUE    => [qw(Create Correspond)],
 486     );
 487     $attachs->LimitByTicket($tid);
 488     $attachs->LimitNotEmpty;
 489     $attachs->OrderBy( FIELD => 'Created' );
 490
 491     my $ticket_mime = MIME::Entity->build(
 492         Type        => 'multipart/mixed',
 493         Top         => 0,
 494         Description => "ticket #$tid",
 495     );
 496     while ( my $attachment = $attachs->Next ) {
 497         $self->AddAttachment( $attachment, $ticket_mime );
 498     }
 499     if ( $ticket_mime->parts ) {
 500         my $email_mime = $self->TemplateObj->MIMEObj;
 501         $email_mime->make_multipart;
 502         $email_mime->add_part($ticket_mime);
 503     }
 504     return;
 505 }
 506
 507 =head2 RecordOutgoingMailTransaction MIMEObj
 508
 509 Record a transaction in RT with this outgoing message for future record-keeping purposes
 510
 511 =cut
 512
 513 sub RecordOutgoingMailTransaction {
 514     my $self    = shift;
 515     my $MIMEObj = shift;
 516
 517     my @parts = $MIMEObj->parts;
 518     my @attachments;
 519     my @keep;
 520     foreach my $part (@parts) {
 521         my $attach = $part->head->get('RT-Attachment');
 522         if ($attach) {
 523             $RT::Logger->debug(
 524                 "We found an attachment. we want to not record it.");
 525             push @attachments, $attach;
 526         } else {
 527             $RT::Logger->debug("We found a part. we want to record it.");
 528             push @keep, $part;
 529         }
 530     }
 531     $MIMEObj->parts( \@keep );
 532     foreach my $attachment (@attachments) {
 533         $MIMEObj->head->add( 'RT-Attachment', $attachment );
 534     }
 535
 536     RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
 537
 538     my $transaction
 539         = RT::Transaction->new( $self->TransactionObj->CurrentUser );
 540
 541 # XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
 542
 543     my $type;
 544     if ( $self->TransactionObj->Type eq 'Comment' ) {
 545         $type = 'CommentEmailRecord';
 546     } else {
 547         $type = 'EmailRecord';
 548     }
 549
 550     my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') );
 551     chomp $msgid;
 552
 553     my ( $id, $msg ) = $transaction->Create(
 554         Ticket         => $self->TicketObj->Id,
 555         Type           => $type,
 556         Data           => $msgid,
 557         MIMEObj        => $MIMEObj,
 558         ActivateScrips => 0
 559     );
 560
 561     if ($id) {
 562         $self->{'OutgoingMailTransaction'} = $id;
 563     } else {
 564         $RT::Logger->warning(
 565             "Could not record outgoing message transaction: $msg");
 566     }
 567     return $id;
 568 }
 569
 570 =head2 SetRTSpecialHeaders
 571
 572 This routine adds all the random headers that RT wants in a mail message
 573 that don't matter much to anybody else.
 574
 575 =cut
 576
 577 sub SetRTSpecialHeaders {
 578     my $self = shift;
 579
 580     $self->SetSubject();
 581     $self->SetSubjectToken();
 582     $self->SetHeaderAsEncoding( 'Subject',
 583         RT->Config->Get('EmailOutputEncoding') )
 584         if ( RT->Config->Get('EmailOutputEncoding') );
 585     $self->SetReturnAddress();
 586     $self->SetReferencesHeaders();
 587
 588     unless ( $self->TemplateObj->MIMEObj->head->get('Message-ID') ) {
 589
 590         # Get Message-ID for this txn
 591         my $msgid = "";
 592         if ( my $msg = $self->TransactionObj->Message->First ) {
 593             $msgid = $msg->GetHeader("RT-Message-ID")
 594                 || $msg->GetHeader("Message-ID");
 595         }
 596
 597         # If there is one, and we can parse it, then base our Message-ID on it
 598         if (    $msgid
 599             and $msgid
 600             =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\QRT->Config->Get('Organization')\E>$/
 601                          "<$1." . $self->TicketObj->id
 602                           . "-" . $self->ScripObj->id
 603                           . "-" . $self->ScripActionObj->{_Message_ID}
 604                           . "@" . RT->Config->Get('Organization') . ">"/eg
 605             and $2 == $self->TicketObj->id
 606             )
 607         {
 608             $self->SetHeader( "Message-ID" => $msgid );
 609         } else {
 610             $self->SetHeader(
 611                 'Message-ID' => RT::Interface::Email::GenMessageId(
 612                     Ticket      => $self->TicketObj,
 613                     Scrip       => $self->ScripObj,
 614                     ScripAction => $self->ScripActionObj
 615                 ),
 616             );
 617         }
 618     }
 619
 620     $self->SetHeader( 'X-RT-Loop-Prevention', RT->Config->Get('rtname') );
 621     $self->SetHeader( 'X-RT-Ticket',
 622         RT->Config->Get('rtname') . " #" . $self->TicketObj->id() );
 623     $self->SetHeader( 'X-Managed-by',
 624         "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
 625
 626 # XXX, TODO: use /ShowUser/ShowUserEntry(or something like that) when it would be
 627 #            refactored into user's method.
 628     if ( my $email = $self->TransactionObj->CreatorObj->EmailAddress
 629          and ! defined $self->TemplateObj->MIMEObj->head->get("RT-Originator")
 630          and RT->Config->Get('UseOriginatorHeader')
 631     ) {
 632         $self->SetHeader( 'X-RT-Originator', $email );
 633     }
 634
 635 }
 636
 637
 638 sub DeferDigestRecipients {
 639     my $self = shift;
 640     $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id );
 641
 642     # The digest attribute will be an array of notifications that need to
 643     # be sent for this transaction.  The array will have the following
 644     # format for its objects.
 645     # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc}
 646     #                                     -> sent -> {true|false}
 647     # The "sent" flag will be used by the cron job to indicate that it has
 648     # run on this transaction.
 649     # In a perfect world we might move this hash construction to the
 650     # extension module itself.
 651     my $digest_hash = {};
 652
 653     foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) {
 654         # If we have a "PseudoTo", the "To" contains it, so we don't need to access it
 655         next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) );
 656         $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) );
 657
 658         # Store the 'daily digest' folk in an array.
 659         my ( @send_now, @daily_digest, @weekly_digest, @suspended );
 660
 661         # Have to get the list of addresses directly from the MIME header
 662         # at this point.
 663         $RT::Logger->debug( Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->as_string ) );
 664         foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
 665             next unless $rcpt;
 666             my $user_obj = RT::User->new(RT->SystemUser);
 667             $user_obj->LoadByEmail($rcpt);
 668             if  ( ! $user_obj->id ) {
 669                 # If there's an email address in here without an associated
 670                 # RT user, pass it on through.
 671                 $RT::Logger->debug( "User $rcpt is not associated with an RT user object.  Send mail.");
 672                 push( @send_now, $rcpt );
 673                 next;
 674             }
 675
 676             my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || '';
 677             $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt");
 678
 679             if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) }
 680             elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) }
 681             elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) }
 682             else { push( @send_now, $rcpt ) }
 683         }
 684
 685         # Reset the relevant mail field.
 686         $RT::Logger->debug( "Removing deferred recipients from $mailfield: line");
 687         if (@send_now) {
 688             $self->SetHeader( $mailfield, join( ', ', @send_now ) );
 689         } else {    # No recipients!  Remove the header.
 690             $self->TemplateObj->MIMEObj->head->delete($mailfield);
 691         }
 692
 693         # Push the deferred addresses into the appropriate field in
 694         # our attribute hash, with the appropriate mail header.
 695         $RT::Logger->debug(
 696             "Setting deferred recipients for attribute creation");
 697         $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0}  for (@daily_digest);
 698         $digest_hash->{'weekly'}->{$_} ={'header' =>  $mailfield, _sent => 0}  for (@weekly_digest);
 699         $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 }  for (@suspended);
 700     }
 701
 702     if ( scalar keys %$digest_hash ) {
 703
 704         # Save the hash so that we can add it as an attribute to the
 705         # outgoing email transaction.
 706         $self->{'Deferred'} = $digest_hash;
 707     } else {
 708         $RT::Logger->debug( "No recipients found for deferred delivery on "
 709                 . "transaction #"
 710                 . $self->TransactionObj->id );
 711     }
 712 }
 713
 714
 715
 716 sub RecordDeferredRecipients {
 717     my $self = shift;
 718     return unless exists $self->{'Deferred'};
 719
 720     my $txn_id = $self->{'OutgoingMailTransaction'};
 721     return unless $txn_id;
 722
 723     my $txn_obj = RT::Transaction->new( $self->CurrentUser );
 724     $txn_obj->Load( $txn_id );
 725     my( $ret, $msg ) = $txn_obj->AddAttribute(
 726         Name => 'DeferredRecipients',
 727         Content => $self->{'Deferred'}
 728     );
 729     $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" )
 730         unless $ret;
 731
 732     return ($ret,$msg);
 733 }
 734
 735 =head2 SquelchMailTo
 736
 737 Returns list of the addresses to squelch on this transaction.
 738
 739 =cut
 740
 741 sub SquelchMailTo {
 742     my $self = shift;
 743     return map $_->Content, $self->TransactionObj->SquelchMailTo;
 744 }
 745
 746 =head2 RemoveInappropriateRecipients
 747
 748 Remove addresses that are RT addresses or that are on this transaction's blacklist
 749
 750 =cut
 751
 752 my %squelch_reasons = (
 753     'not privileged'
 754         => "because autogenerated messages are configured to only be sent to privileged users (RedistributeAutoGeneratedMessages)",
 755     'squelch:attachment'
 756         => "by RT-Squelch-Replies-To header in the incoming message",
 757     'squelch:transaction'
 758         => "by notification checkboxes for this transaction",
 759     'squelch:ticket'
 760         => "by notification checkboxes on this ticket's People page",
 761 );
 762
 763
 764 sub RemoveInappropriateRecipients {
 765     my $self = shift;
 766
 767     my %blacklist = ();
 768
 769     # If there are no recipients, don't try to send the message.
 770     # If the transaction has content and has the header RT-Squelch-Replies-To
 771
 772     my $msgid = Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->get('Message-Id') );
 773     chomp $msgid;
 774
 775     if ( my $attachment = $self->TransactionObj->Attachments->First ) {
 776
 777         if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
 778
 779             # What do we want to do with this? It's probably (?) a bounce
 780             # caused by one of the watcher addresses being broken.
 781             # Default ("true") is to redistribute, for historical reasons.
 782
 783             my $redistribute = RT->Config->Get('RedistributeAutoGeneratedMessages');
 784
 785             if ( !$redistribute ) {
 786
 787                 # Don't send to any watchers.
 788                 @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS);
 789                 $RT::Logger->info( $msgid
 790                         . " The incoming message was autogenerated. "
 791                         . "Not redistributing this message based on site configuration."
 792                 );
 793             } elsif ( $redistribute eq 'privileged' ) {
 794
 795                 # Only send to "privileged" watchers.
 796                 foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
 797                     foreach my $addr ( @{ $self->{$type} } ) {
 798                         my $user = RT::User->new(RT->SystemUser);
 799                         $user->LoadByEmail($addr);
 800                         $blacklist{ $addr } ||= 'not privileged'
 801                             unless $user->id && $user->Privileged;
 802                     }
 803                 }
 804                 $RT::Logger->info( $msgid
 805                         . " The incoming message was autogenerated. "
 806                         . "Not redistributing this message to unprivileged users based on site configuration."
 807                 );
 808             }
 809         }
 810
 811         if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) {
 812             $blacklist{ $_->address } ||= 'squelch:attachment'
 813                 foreach Email::Address->parse( $squelch );
 814         }
 815     }
 816
 817     # Let's grab the SquelchMailTo attributes and push those entries
 818     # into the blacklisted
 819     $blacklist{ $_->Content } ||= 'squelch:transaction'
 820         foreach $self->TransactionObj->SquelchMailTo;
 821     $blacklist{ $_->Content } ||= 'squelch:ticket'
 822         foreach $self->TicketObj->SquelchMailTo;
 823
 824     # canonicalize emails
 825     foreach my $address ( keys %blacklist ) {
 826         my $reason = delete $blacklist{ $address };
 827         $blacklist{ lc $_ } = $reason
 828             foreach map RT::User->CanonicalizeEmailAddress( $_->address ),
 829             Email::Address->parse( $address );
 830     }
 831
 832     $self->RecipientFilter(
 833         Callback => sub {
 834             return unless RT::EmailParser->IsRTAddress( $_[0] );
 835             return "$_[0] appears to point to this RT instance. Skipping";
 836         },
 837         All => 1,
 838     );
 839
 840     $self->RecipientFilter(
 841         Callback => sub {
 842             return unless $blacklist{ lc $_[0] };
 843             return "$_[0] is blacklisted $squelch_reasons{ $blacklist{ lc $_[0] } }. Skipping";
 844         },
 845     );
 846
 847
 848     # Cycle through the people we're sending to and pull out anyone that meets any of the callbacks
 849     for my $type (@EMAIL_RECIPIENT_HEADERS) {
 850         my @addrs;
 851
 852       ADDRESS:
 853         for my $addr ( @{ $self->{$type} } ) {
 854             for my $filter ( map {$_->{Callback}} @{$self->{RecipientFilter}} ) {
 855                 my $skip = $filter->($addr);
 856                 next unless $skip;
 857                 $RT::Logger->info( "$msgid $skip" );
 858                 next ADDRESS;
 859             }
 860             push @addrs, $addr;
 861         }
 862
 863       NOSQUELCH_ADDRESS:
 864         for my $addr ( @{ $self->{NoSquelch}{$type} } ) {
 865             for my $filter ( map {$_->{Callback}} grep {$_->{All}} @{$self->{RecipientFilter}} ) {
 866                 my $skip = $filter->($addr);
 867                 next unless $skip;
 868                 $RT::Logger->info( "$msgid $skip" );
 869                 next NOSQUELCH_ADDRESS;
 870             }
 871             push @addrs, $addr;
 872         }
 873
 874         @{ $self->{$type} } = @addrs;
 875     }
 876 }
 877
 878 =head2 RecipientFilter Callback => SUB, [All => 1]
 879
 880 Registers a filter to be applied to addresses by
 881 L<RemoveInappropriateRecipients>.  The C<Callback> will be called with
 882 one address at a time, and should return false if the address should
 883 receive mail, or a message explaining why it should not be.  Passing a
 884 true value for C<All> will cause the filter to also be applied to
 885 NoSquelch (one-time Cc and Bcc) recipients as well.
 886
 887 =cut
 888
 889 sub RecipientFilter {
 890     my $self = shift;
 891     push @{ $self->{RecipientFilter}}, {@_};
 892 }
 893
 894 =head2 SetReturnAddress is_comment => BOOLEAN
 895
 896 Calculate and set From and Reply-To headers based on the is_comment flag.
 897
 898 =cut
 899
 900 sub SetReturnAddress {
 901
 902     my $self = shift;
 903     my %args = (
 904         is_comment => 0,
 905         friendly_name => undef,
 906         @_
 907     );
 908
 909     # From and Reply-To
 910     # $args{is_comment} should be set if the comment address is to be used.
 911     my $replyto;
 912
 913     if ( $args{'is_comment'} ) {
 914         $replyto = $self->TicketObj->QueueObj->CommentAddress
 915             || RT->Config->Get('CommentAddress');
 916     } else {
 917         $replyto = $self->TicketObj->QueueObj->CorrespondAddress
 918             || RT->Config->Get('CorrespondAddress');
 919     }
 920
 921     unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
 922         $self->SetFrom( %args, From => $replyto );
 923     }
 924
 925     unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
 926         $self->SetHeader( 'Reply-To', "$replyto" );
 927     }
 928
 929 }
 930
 931 =head2 SetFrom ( From => emailaddress )
 932
 933 Set the From: address for outgoing email
 934
 935 =cut
 936
 937 sub SetFrom {
 938     my $self = shift;
 939     my %args = @_;
 940
 941     my $from = $args{From};
 942
 943     if ( RT->Config->Get('UseFriendlyFromLine') ) {
 944         my $friendly_name = $self->GetFriendlyName(%args);
 945         $from =
 946             sprintf(
 947                 RT->Config->Get('FriendlyFromLineFormat'),
 948                 $self->MIMEEncodeString(
 949                     $friendly_name, RT->Config->Get('EmailOutputEncoding')
 950                 ),
 951                 $args{From}
 952             );
 953     }
 954
 955     $self->SetHeader( 'From', $from );
 956
 957     #also set Sender:, otherwise MTAs add a nonsensical value like rt@machine,
 958     #and then Outlook prepends "rt@machine on behalf of" to the From: header
 959     $self->SetHeader( 'Sender', $from );
 960 }
 961
 962 =head2 GetFriendlyName
 963
 964 Calculate the proper Friendly Name based on the creator of the transaction
 965
 966 =cut
 967
 968 sub GetFriendlyName {
 969     my $self = shift;
 970     my %args = (
 971         is_comment => 0,
 972         friendly_name => '',
 973         @_
 974     );
 975     my $friendly_name = $args{friendly_name};
 976
 977     unless ( $friendly_name ) {
 978         $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName;
 979         if ( $friendly_name =~ /^"(.*)"$/ ) {    # a quoted string
 980             $friendly_name = $1;
 981         }
 982     }
 983
 984     $friendly_name =~ s/"/\\"/g;
 985     return $friendly_name;
 986
 987 }
 988
 989 =head2 SetHeader FIELD, VALUE
 990
 991 Set the FIELD of the current MIME object into VALUE, which should be in
 992 characters, not bytes.  Returns the new header, in bytes.
 993
 994 =cut
 995
 996 sub SetHeader {
 997     my $self  = shift;
 998     my $field = shift;
 999     my $val   = shift;
1000
1001     chomp $val;
1002     chomp $field;
1003     my $head = $self->TemplateObj->MIMEObj->head;
1004     $head->fold_length( $field, 10000 );
1005     $head->replace( $field, Encode::encode( "UTF-8", $val ) );
1006     return $head->get($field);
1007 }
1008
1009 =head2 SetSubject
1010
1011 This routine sets the subject. it does not add the rt tag. That gets done elsewhere
1012 If subject is already defined via template, it uses that. otherwise, it tries to get
1013 the transaction's subject.
1014
1015 =cut
1016
1017 sub SetSubject {
1018     my $self = shift;
1019     my $subject;
1020
1021     if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
1022         return ();
1023     }
1024
1025     # don't use Transaction->Attachments because it caches
1026     # and anything which later calls ->Attachments will be hurt
1027     # by our RowsPerPage() call.  caching is hard.
1028     my $message = RT::Attachments->new( $self->CurrentUser );
1029     $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id);
1030     $message->OrderBy( FIELD => 'id', ORDER => 'ASC' );
1031     $message->RowsPerPage(1);
1032
1033     if ( $self->{'Subject'} ) {
1034         $subject = $self->{'Subject'};
1035     } elsif ( my $first = $message->First ) {
1036         my $tmp = $first->GetHeader('Subject');
1037         $subject = defined $tmp ? $tmp : $self->TicketObj->Subject;
1038     } else {
1039         $subject = $self->TicketObj->Subject;
1040     }
1041     $subject = '' unless defined $subject;
1042     chomp $subject;
1043
1044     $subject =~ s/(\r\n|\n|\s)/ /g;
1045
1046     $self->SetHeader( 'Subject', $subject );
1047
1048 }
1049
1050 =head2 SetSubjectToken
1051
1052 This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
1053
1054 =cut
1055
1056 sub SetSubjectToken {
1057     my $self = shift;
1058
1059     my $head = $self->TemplateObj->MIMEObj->head;
1060     $self->SetHeader(
1061         Subject =>
1062             RT::Interface::Email::AddSubjectTag(
1063                 Encode::decode( "UTF-8", $head->get('Subject') ),
1064                 $self->TicketObj,
1065             ),
1066     );
1067 }
1068
1069 =head2 SetReferencesHeaders
1070
1071 Set References and In-Reply-To headers for this message.
1072
1073 =cut
1074
1075 sub SetReferencesHeaders {
1076     my $self = shift;
1077
1078     my $top = $self->TransactionObj->Message->First;
1079     unless ( $top ) {
1080         $self->SetHeader( References => $self->PseudoReference );
1081         return (undef);
1082     }
1083
1084     my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' );
1085     my @references  = split( /\s+/m, $top->GetHeader('References')  || '' );
1086     my @msgid       = split( /\s+/m, $top->GetHeader('Message-ID')  || '' );
1087
1088     # There are two main cases -- this transaction was created with
1089     # the RT Web UI, and hence we want to *not* append its Message-ID
1090     # to the References and In-Reply-To.  OR it came from an outside
1091     # source, and we should treat it as per the RFC
1092     my $org = RT->Config->Get('Organization');
1093     if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) {
1094
1095         # Make all references which are internal be to version which we
1096         # have sent out
1097
1098         for ( @references, @in_reply_to ) {
1099             s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/
1100           "<$1." . $self->TicketObj->id .
1101              "-" . $self->ScripObj->id .
1102              "-" . $self->ScripActionObj->{_Message_ID} .
1103              "@" . $org . ">"/eg
1104         }
1105
1106         # In reply to whatever the internal message was in reply to
1107         $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) );
1108
1109         # Default the references to whatever we're in reply to
1110         @references = @in_reply_to unless @references;
1111
1112         # References are unchanged from internal
1113     } else {
1114
1115         # In reply to that message
1116         $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) );
1117
1118         # Default the references to whatever we're in reply to
1119         @references = @in_reply_to unless @references;
1120
1121         # Push that message onto the end of the references
1122         push @references, @msgid;
1123     }
1124
1125     # Push pseudo-ref to the front
1126     my $pseudo_ref = $self->PseudoReference;
1127     @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references );
1128
1129     # If there are more than 10 references headers, remove all but the
1130     # first four and the last six (Gotta keep this from growing
1131     # forever)
1132     splice( @references, 4, -6 ) if ( $#references >= 10 );
1133
1134     # Add on the references
1135     $self->SetHeader( 'References', join( " ", @references ) );
1136     $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
1137
1138 }
1139
1140 =head2 PseudoReference
1141
1142 Returns a fake Message-ID: header for the ticket to allow a base level of threading
1143
1144 =cut
1145
1146 sub PseudoReference {
1147     my $self = shift;
1148     return RT::Interface::Email::PseudoReference( $self->TicketObj );
1149 }
1150
1151 =head2 SetHeaderAsEncoding($field_name, $charset_encoding)
1152
1153 This routine converts the field into specified charset encoding, then
1154 applies the MIME-Header transfer encoding.
1155
1156 =cut
1157
1158 sub SetHeaderAsEncoding {
1159     my $self = shift;
1160     my ( $field, $enc ) = ( shift, shift );
1161
1162     my $head = $self->TemplateObj->MIMEObj->head;
1163
1164     my $value = Encode::decode("UTF-8", $head->get( $field ));
1165     $value = $self->MIMEEncodeString( $value, $enc ); # Returns bytes
1166     $head->replace( $field, $value );
1167
1168 }
1169
1170 =head2 MIMEEncodeString
1171
1172 Takes a perl string and optional encoding pass it over
1173 L<RT::Interface::Email/EncodeToMIME>.
1174
1175 Basicly encode a string using B encoding according to RFC2047, returning
1176 bytes.
1177
1178 =cut
1179
1180 sub MIMEEncodeString {
1181     my $self  = shift;
1182     return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] );
1183 }
1184
1185 RT::Base->_ImportOverlays();
1186
1187 1;
1188