Master to 4.2.8
[usit-rt.git] / lib / RT / Action / SendEmail.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2014 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( ALIAS => $txn_alias, FIELD => 'Type', VALUE => 'Create' );
466     $attachs->Limit(
467         ALIAS => $txn_alias,
468         FIELD => 'Type',
469         VALUE => '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 RT->Config->Get('UseOriginatorHeader')
614     ) {
615         $self->SetHeader( 'X-RT-Originator', $email );
616     }
617
618 }
619
620
621 sub DeferDigestRecipients {
622     my $self = shift;
623     $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id );
624
625     # The digest attribute will be an array of notifications that need to
626     # be sent for this transaction.  The array will have the following
627     # format for its objects.
628     # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc}
629     #                                     -> sent -> {true|false}
630     # The "sent" flag will be used by the cron job to indicate that it has
631     # run on this transaction.
632     # In a perfect world we might move this hash construction to the
633     # extension module itself.
634     my $digest_hash = {};
635
636     foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) {
637         # If we have a "PseudoTo", the "To" contains it, so we don't need to access it
638         next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) );
639         $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) );
640
641         # Store the 'daily digest' folk in an array.
642         my ( @send_now, @daily_digest, @weekly_digest, @suspended );
643
644         # Have to get the list of addresses directly from the MIME header
645         # at this point.
646         $RT::Logger->debug( Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->as_string ) );
647         foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
648             next unless $rcpt;
649             my $user_obj = RT::User->new(RT->SystemUser);
650             $user_obj->LoadByEmail($rcpt);
651             if  ( ! $user_obj->id ) {
652                 # If there's an email address in here without an associated
653                 # RT user, pass it on through.
654                 $RT::Logger->debug( "User $rcpt is not associated with an RT user object.  Send mail.");
655                 push( @send_now, $rcpt );
656                 next;
657             }
658
659             my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || '';
660             $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt");
661
662             if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) }
663             elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) }
664             elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) }
665             else { push( @send_now, $rcpt ) }
666         }
667
668         # Reset the relevant mail field.
669         $RT::Logger->debug( "Removing deferred recipients from $mailfield: line");
670         if (@send_now) {
671             $self->SetHeader( $mailfield, join( ', ', @send_now ) );
672         } else {    # No recipients!  Remove the header.
673             $self->TemplateObj->MIMEObj->head->delete($mailfield);
674         }
675
676         # Push the deferred addresses into the appropriate field in
677         # our attribute hash, with the appropriate mail header.
678         $RT::Logger->debug(
679             "Setting deferred recipients for attribute creation");
680         $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0}  for (@daily_digest);
681         $digest_hash->{'weekly'}->{$_} ={'header' =>  $mailfield, _sent => 0}  for (@weekly_digest);
682         $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 }  for (@suspended);
683     }
684
685     if ( scalar keys %$digest_hash ) {
686
687         # Save the hash so that we can add it as an attribute to the
688         # outgoing email transaction.
689         $self->{'Deferred'} = $digest_hash;
690     } else {
691         $RT::Logger->debug( "No recipients found for deferred delivery on "
692                 . "transaction #"
693                 . $self->TransactionObj->id );
694     }
695 }
696
697
698     
699 sub RecordDeferredRecipients {
700     my $self = shift;
701     return unless exists $self->{'Deferred'};
702
703     my $txn_id = $self->{'OutgoingMailTransaction'};
704     return unless $txn_id;
705
706     my $txn_obj = RT::Transaction->new( $self->CurrentUser );
707     $txn_obj->Load( $txn_id );
708     my( $ret, $msg ) = $txn_obj->AddAttribute(
709         Name => 'DeferredRecipients',
710         Content => $self->{'Deferred'}
711     );
712     $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" ) 
713         unless $ret;
714
715     return ($ret,$msg);
716 }
717
718 =head2 SquelchMailTo
719
720 Returns list of the addresses to squelch on this transaction.
721
722 =cut
723
724 sub SquelchMailTo {
725     my $self = shift;
726     return map $_->Content, $self->TransactionObj->SquelchMailTo;
727 }
728
729 =head2 RemoveInappropriateRecipients
730
731 Remove addresses that are RT addresses or that are on this transaction's blacklist
732
733 =cut
734
735 my %squelch_reasons = (
736     'not privileged'
737         => "because autogenerated messages are configured to only be sent to privileged users (RedistributeAutoGeneratedMessages)",
738     'squelch:attachment'
739         => "by RT-Squelch-Replies-To header in the incoming message",
740     'squelch:transaction'
741         => "by notification checkboxes for this transaction",
742     'squelch:ticket'
743         => "by notification checkboxes on this ticket's People page",
744 );
745
746
747 sub RemoveInappropriateRecipients {
748     my $self = shift;
749
750     my %blacklist = ();
751
752     # If there are no recipients, don't try to send the message.
753     # If the transaction has content and has the header RT-Squelch-Replies-To
754
755     my $msgid = Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->get('Message-Id') );
756     chomp $msgid;
757
758     if ( my $attachment = $self->TransactionObj->Attachments->First ) {
759
760         if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
761
762             # What do we want to do with this? It's probably (?) a bounce
763             # caused by one of the watcher addresses being broken.
764             # Default ("true") is to redistribute, for historical reasons.
765
766             my $redistribute = RT->Config->Get('RedistributeAutoGeneratedMessages');
767
768             if ( !$redistribute ) {
769
770                 # Don't send to any watchers.
771                 @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS);
772                 $RT::Logger->info( $msgid
773                         . " The incoming message was autogenerated. "
774                         . "Not redistributing this message based on site configuration."
775                 );
776             } elsif ( $redistribute eq 'privileged' ) {
777
778                 # Only send to "privileged" watchers.
779                 foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
780                     foreach my $addr ( @{ $self->{$type} } ) {
781                         my $user = RT::User->new(RT->SystemUser);
782                         $user->LoadByEmail($addr);
783                         $blacklist{ $addr } ||= 'not privileged'
784                             unless $user->id && $user->Privileged;
785                     }
786                 }
787                 $RT::Logger->info( $msgid
788                         . " The incoming message was autogenerated. "
789                         . "Not redistributing this message to unprivileged users based on site configuration."
790                 );
791             }
792         }
793
794         if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) {
795             $blacklist{ $_->address } ||= 'squelch:attachment'
796                 foreach Email::Address->parse( $squelch );
797         }
798     }
799
800     # Let's grab the SquelchMailTo attributes and push those entries
801     # into the blacklisted
802     $blacklist{ $_->Content } ||= 'squelch:transaction'
803         foreach $self->TransactionObj->SquelchMailTo;
804     $blacklist{ $_->Content } ||= 'squelch:ticket'
805         foreach $self->TicketObj->SquelchMailTo;
806
807     # canonicalize emails
808     foreach my $address ( keys %blacklist ) {
809         my $reason = delete $blacklist{ $address };
810         $blacklist{ lc $_ } = $reason
811             foreach map RT::User->CanonicalizeEmailAddress( $_->address ),
812             Email::Address->parse( $address );
813     }
814
815     $self->RecipientFilter(
816         Callback => sub {
817             return unless RT::EmailParser->IsRTAddress( $_[0] );
818             return "$_[0] appears to point to this RT instance. Skipping";
819         },
820         All => 1,
821     );
822
823     $self->RecipientFilter(
824         Callback => sub {
825             return unless $blacklist{ lc $_[0] };
826             return "$_[0] is blacklisted $squelch_reasons{ $blacklist{ lc $_[0] } }. Skipping";
827         },
828     );
829
830
831     # Cycle through the people we're sending to and pull out anyone that meets any of the callbacks
832     for my $type (@EMAIL_RECIPIENT_HEADERS) {
833         my @addrs;
834
835       ADDRESS:
836         for my $addr ( @{ $self->{$type} } ) {
837             for my $filter ( map {$_->{Callback}} @{$self->{RecipientFilter}} ) {
838                 my $skip = $filter->($addr);
839                 next unless $skip;
840                 $RT::Logger->info( "$msgid $skip" );
841                 next ADDRESS;
842             }
843             push @addrs, $addr;
844         }
845
846       NOSQUELCH_ADDRESS:
847         for my $addr ( @{ $self->{NoSquelch}{$type} } ) {
848             for my $filter ( map {$_->{Callback}} grep {$_->{All}} @{$self->{RecipientFilter}} ) {
849                 my $skip = $filter->($addr);
850                 next unless $skip;
851                 $RT::Logger->info( "$msgid $skip" );
852                 next NOSQUELCH_ADDRESS;
853             }
854             push @addrs, $addr;
855         }
856
857         @{ $self->{$type} } = @addrs;
858     }
859 }
860
861 =head2 RecipientFilter Callback => SUB, [All => 1]
862
863 Registers a filter to be applied to addresses by
864 L<RemoveInappropriateRecipients>.  The C<Callback> will be called with
865 one address at a time, and should return false if the address should
866 receive mail, or a message explaining why it should not be.  Passing a
867 true value for C<All> will cause the filter to also be applied to
868 NoSquelch (one-time Cc and Bcc) recipients as well.
869
870 =cut
871
872 sub RecipientFilter {
873     my $self = shift;
874     push @{ $self->{RecipientFilter}}, {@_};
875 }
876
877 =head2 SetReturnAddress is_comment => BOOLEAN
878
879 Calculate and set From and Reply-To headers based on the is_comment flag.
880
881 =cut
882
883 sub SetReturnAddress {
884
885     my $self = shift;
886     my %args = (
887         is_comment => 0,
888         friendly_name => undef,
889         @_
890     );
891
892     # From and Reply-To
893     # $args{is_comment} should be set if the comment address is to be used.
894     my $replyto;
895
896     if ( $args{'is_comment'} ) {
897         $replyto = $self->TicketObj->QueueObj->CommentAddress
898             || RT->Config->Get('CommentAddress');
899     } else {
900         $replyto = $self->TicketObj->QueueObj->CorrespondAddress
901             || RT->Config->Get('CorrespondAddress');
902     }
903
904     unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
905         $self->SetFrom( %args, From => $replyto );
906     }
907
908     unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
909         $self->SetHeader( 'Reply-To', "$replyto" );
910     }
911
912 }
913
914 =head2 SetFrom ( From => emailaddress )
915
916 Set the From: address for outgoing email
917
918 =cut
919
920 sub SetFrom {
921     my $self = shift;
922     my %args = @_;
923
924     if ( RT->Config->Get('UseFriendlyFromLine') ) {
925         my $friendly_name = $self->GetFriendlyName(%args);
926         $self->SetHeader(
927             'From',
928             sprintf(
929                 RT->Config->Get('FriendlyFromLineFormat'),
930                 $self->MIMEEncodeString(
931                     $friendly_name, RT->Config->Get('EmailOutputEncoding')
932                 ),
933                 $args{From}
934             ),
935         );
936     } else {
937         $self->SetHeader( 'From', $args{From} );
938     }
939 }
940
941 =head2 GetFriendlyName
942
943 Calculate the proper Friendly Name based on the creator of the transaction
944
945 =cut
946
947 sub GetFriendlyName {
948     my $self = shift;
949     my %args = (
950         is_comment => 0,
951         friendly_name => '',
952         @_
953     );
954     my $friendly_name = $args{friendly_name};
955
956     unless ( $friendly_name ) {
957         $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName;
958         if ( $friendly_name =~ /^"(.*)"$/ ) {    # a quoted string
959             $friendly_name = $1;
960         }
961     }
962
963     $friendly_name =~ s/"/\\"/g;
964     return $friendly_name;
965
966 }
967
968 =head2 SetHeader FIELD, VALUE
969
970 Set the FIELD of the current MIME object into VALUE, which should be in
971 characters, not bytes.  Returns the new header, in bytes.
972
973 =cut
974
975 sub SetHeader {
976     my $self  = shift;
977     my $field = shift;
978     my $val   = shift;
979
980     chomp $val;
981     chomp $field;
982     my $head = $self->TemplateObj->MIMEObj->head;
983     $head->fold_length( $field, 10000 );
984     $head->replace( $field, Encode::encode( "UTF-8", $val ) );
985     return $head->get($field);
986 }
987
988 =head2 SetSubject
989
990 This routine sets the subject. it does not add the rt tag. That gets done elsewhere
991 If subject is already defined via template, it uses that. otherwise, it tries to get
992 the transaction's subject.
993
994 =cut 
995
996 sub SetSubject {
997     my $self = shift;
998     my $subject;
999
1000     if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
1001         return ();
1002     }
1003
1004     # don't use Transaction->Attachments because it caches
1005     # and anything which later calls ->Attachments will be hurt
1006     # by our RowsPerPage() call.  caching is hard.
1007     my $message = RT::Attachments->new( $self->CurrentUser );
1008     $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id);
1009     $message->OrderBy( FIELD => 'id', ORDER => 'ASC' );
1010     $message->RowsPerPage(1);
1011
1012     if ( $self->{'Subject'} ) {
1013         $subject = $self->{'Subject'};
1014     } elsif ( my $first = $message->First ) {
1015         my $tmp = $first->GetHeader('Subject');
1016         $subject = defined $tmp ? $tmp : $self->TicketObj->Subject;
1017     } else {
1018         $subject = $self->TicketObj->Subject;
1019     }
1020     $subject = '' unless defined $subject;
1021     chomp $subject;
1022
1023     $subject =~ s/(\r\n|\n|\s)/ /g;
1024
1025     $self->SetHeader( 'Subject', $subject );
1026
1027 }
1028
1029 =head2 SetSubjectToken
1030
1031 This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
1032
1033 =cut
1034
1035 sub SetSubjectToken {
1036     my $self = shift;
1037
1038     my $head = $self->TemplateObj->MIMEObj->head;
1039     $self->SetHeader(
1040         Subject =>
1041             RT::Interface::Email::AddSubjectTag(
1042                 Encode::decode( "UTF-8", $head->get('Subject') ),
1043                 $self->TicketObj,
1044             ),
1045     );
1046 }
1047
1048 =head2 SetReferencesHeaders
1049
1050 Set References and In-Reply-To headers for this message.
1051
1052 =cut
1053
1054 sub SetReferencesHeaders {
1055     my $self = shift;
1056
1057     my $top = $self->TransactionObj->Message->First;
1058     unless ( $top ) {
1059         $self->SetHeader( References => $self->PseudoReference );
1060         return (undef);
1061     }
1062
1063     my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' );
1064     my @references  = split( /\s+/m, $top->GetHeader('References')  || '' );
1065     my @msgid       = split( /\s+/m, $top->GetHeader('Message-ID')  || '' );
1066
1067     # There are two main cases -- this transaction was created with
1068     # the RT Web UI, and hence we want to *not* append its Message-ID
1069     # to the References and In-Reply-To.  OR it came from an outside
1070     # source, and we should treat it as per the RFC
1071     my $org = RT->Config->Get('Organization');
1072     if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) {
1073
1074         # Make all references which are internal be to version which we
1075         # have sent out
1076
1077         for ( @references, @in_reply_to ) {
1078             s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/
1079           "<$1." . $self->TicketObj->id .
1080              "-" . $self->ScripObj->id .
1081              "-" . $self->ScripActionObj->{_Message_ID} .
1082              "@" . $org . ">"/eg
1083         }
1084
1085         # In reply to whatever the internal message was in reply to
1086         $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) );
1087
1088         # Default the references to whatever we're in reply to
1089         @references = @in_reply_to unless @references;
1090
1091         # References are unchanged from internal
1092     } else {
1093
1094         # In reply to that message
1095         $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) );
1096
1097         # Default the references to whatever we're in reply to
1098         @references = @in_reply_to unless @references;
1099
1100         # Push that message onto the end of the references
1101         push @references, @msgid;
1102     }
1103
1104     # Push pseudo-ref to the front
1105     my $pseudo_ref = $self->PseudoReference;
1106     @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references );
1107
1108     # If there are more than 10 references headers, remove all but the
1109     # first four and the last six (Gotta keep this from growing
1110     # forever)
1111     splice( @references, 4, -6 ) if ( $#references >= 10 );
1112
1113     # Add on the references
1114     $self->SetHeader( 'References', join( " ", @references ) );
1115     $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
1116
1117 }
1118
1119 =head2 PseudoReference
1120
1121 Returns a fake Message-ID: header for the ticket to allow a base level of threading
1122
1123 =cut
1124
1125 sub PseudoReference {
1126     my $self = shift;
1127     return RT::Interface::Email::PseudoReference( $self->TicketObj );
1128 }
1129
1130 =head2 SetHeaderAsEncoding($field_name, $charset_encoding)
1131
1132 This routine converts the field into specified charset encoding, then
1133 applies the MIME-Header transfer encoding.
1134
1135 =cut
1136
1137 sub SetHeaderAsEncoding {
1138     my $self = shift;
1139     my ( $field, $enc ) = ( shift, shift );
1140
1141     my $head = $self->TemplateObj->MIMEObj->head;
1142
1143     my $value = Encode::decode("UTF-8", $head->get( $field ));
1144     $value = $self->MIMEEncodeString( $value, $enc ); # Returns bytes
1145     $head->replace( $field, $value );
1146
1147 }
1148
1149 =head2 MIMEEncodeString
1150
1151 Takes a perl string and optional encoding pass it over
1152 L<RT::Interface::Email/EncodeToMIME>.
1153
1154 Basicly encode a string using B encoding according to RFC2047, returning
1155 bytes.
1156
1157 =cut
1158
1159 sub MIMEEncodeString {
1160     my $self  = shift;
1161     return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] );
1162 }
1163
1164 RT::Base->_ImportOverlays();
1165
1166 1;
1167