Upgrade 4.0.17 clean.
[usit-rt.git] / lib / RT / Interface / Email.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 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 package RT::Interface::Email;
50
51 use strict;
52 use warnings;
53
54 use Email::Address;
55 use MIME::Entity;
56 use RT::EmailParser;
57 use File::Temp;
58 use UNIVERSAL::require;
59 use Mail::Mailer ();
60 use Text::ParseWords qw/shellwords/;
61
62 BEGIN {
63     use base 'Exporter';
64     use vars qw ( @EXPORT_OK);
65
66     # set the version for version checking
67     our $VERSION = 2.0;
68
69     # your exported package globals go here,
70     # as well as any optionally exported functions
71     @EXPORT_OK = qw(
72         &CreateUser
73         &GetMessageContent
74         &CheckForLoops
75         &CheckForSuspiciousSender
76         &CheckForAutoGenerated
77         &CheckForBounce
78         &MailError
79         &ParseCcAddressesFromHead
80         &ParseSenderAddressFromHead
81         &ParseErrorsToAddressFromHead
82         &ParseAddressFromHeader
83         &Gateway);
84
85 }
86
87 =head1 NAME
88
89   RT::Interface::Email - helper functions for parsing email sent to RT
90
91 =head1 SYNOPSIS
92
93   use lib "!!RT_LIB_PATH!!";
94   use lib "!!RT_ETC_PATH!!";
95
96   use RT::Interface::Email  qw(Gateway CreateUser);
97
98 =head1 DESCRIPTION
99
100
101
102
103 =head1 METHODS
104
105 =head2 CheckForLoops HEAD
106
107 Takes a HEAD object of L<MIME::Head> class and returns true if the
108 message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
109 field of the head for test.
110
111 =cut
112
113 sub CheckForLoops {
114     my $head = shift;
115
116     # If this instance of RT sent it our, we don't want to take it in
117     my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
118     chomp ($RTLoop); # remove that newline
119     if ( $RTLoop eq RT->Config->Get('rtname') ) {
120         return 1;
121     }
122
123     # TODO: We might not trap the case where RT instance A sends a mail
124     # to RT instance B which sends a mail to ...
125     return undef;
126 }
127
128 =head2 CheckForSuspiciousSender HEAD
129
130 Takes a HEAD object of L<MIME::Head> class and returns true if sender
131 is suspicious. Suspicious means mailer daemon.
132
133 See also L</ParseSenderAddressFromHead>.
134
135 =cut
136
137 sub CheckForSuspiciousSender {
138     my $head = shift;
139
140     #if it's from a postmaster or mailer daemon, it's likely a bounce.
141
142     #TODO: better algorithms needed here - there is no standards for
143     #bounces, so it's very difficult to separate them from anything
144     #else.  At the other hand, the Return-To address is only ment to be
145     #used as an error channel, we might want to put up a separate
146     #Return-To address which is treated differently.
147
148     #TODO: search through the whole email and find the right Ticket ID.
149
150     my ( $From, $junk ) = ParseSenderAddressFromHead($head);
151
152     # If unparseable (non-ASCII), $From can come back undef
153     return undef if not defined $From;
154
155     if (   ( $From =~ /^mailer-daemon\@/i )
156         or ( $From =~ /^postmaster\@/i )
157         or ( $From eq "" ))
158     {
159         return (1);
160
161     }
162
163     return undef;
164 }
165
166 =head2 CheckForAutoGenerated HEAD
167
168 Takes a HEAD object of L<MIME::Head> class and returns true if message
169 is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated'
170 fields of the head in tests.
171
172 =cut
173
174 sub CheckForAutoGenerated {
175     my $head = shift;
176
177     my $Precedence = $head->get("Precedence") || "";
178     if ( $Precedence =~ /^(bulk|junk)/i ) {
179         return (1);
180     }
181
182     # Per RFC3834, any Auto-Submitted header which is not "no" means
183     # it is auto-generated.
184     my $AutoSubmitted = $head->get("Auto-Submitted") || "";
185     if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
186         return (1);
187     }
188
189     # First Class mailer uses this as a clue.
190     my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
191     if ( $FCJunk =~ /^true/i ) {
192         return (1);
193     }
194
195     return (0);
196 }
197
198
199 sub CheckForBounce {
200     my $head = shift;
201
202     my $ReturnPath = $head->get("Return-path") || "";
203     return ( $ReturnPath =~ /<>/ );
204 }
205
206
207 =head2 MailError PARAM HASH
208
209 Sends an error message. Takes a param hash:
210
211 =over 4
212
213 =item From - sender's address, by default is 'CorrespondAddress';
214
215 =item To - recipient, by default is 'OwnerEmail';
216
217 =item Bcc - optional Bcc recipients;
218
219 =item Subject - subject of the message, default is 'There has been an error';
220
221 =item Explanation - main content of the error, default value is 'Unexplained error';
222
223 =item MIMEObj - optional MIME entity that's attached to the error mail, as well we
224 add 'In-Reply-To' field to the error that points to this message.
225
226 =item Attach - optional text that attached to the error as 'message/rfc822' part.
227
228 =item LogLevel - log level under which we should write the subject and
229 explanation message into the log, by default we log it as critical.
230
231 =back
232
233 =cut
234
235 sub MailError {
236     my %args = (
237         To          => RT->Config->Get('OwnerEmail'),
238         Bcc         => undef,
239         From        => RT->Config->Get('CorrespondAddress'),
240         Subject     => 'There has been an error',
241         Explanation => 'Unexplained error',
242         MIMEObj     => undef,
243         Attach      => undef,
244         LogLevel    => 'crit',
245         @_
246     );
247
248     $RT::Logger->log(
249         level   => $args{'LogLevel'},
250         message => "$args{Subject}: $args{'Explanation'}",
251     ) if $args{'LogLevel'};
252
253     # the colons are necessary to make ->build include non-standard headers
254     my %entity_args = (
255         Type                    => "multipart/mixed",
256         From                    => $args{'From'},
257         Bcc                     => $args{'Bcc'},
258         To                      => $args{'To'},
259         Subject                 => $args{'Subject'},
260         'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
261     );
262
263     # only set precedence if the sysadmin wants us to
264     if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
265         $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
266     }
267
268     my $entity = MIME::Entity->build(%entity_args);
269     SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
270
271     $entity->attach( Data => $args{'Explanation'} . "\n" );
272
273     if ( $args{'MIMEObj'} ) {
274         $args{'MIMEObj'}->sync_headers;
275         $entity->add_part( $args{'MIMEObj'} );
276     }
277
278     if ( $args{'Attach'} ) {
279         $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
280
281     }
282
283     SendEmail( Entity => $entity, Bounce => 1 );
284 }
285
286
287 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
288
289 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
290 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
291 true value, the message will be marked as an autogenerated error, if
292 possible. Sets Date field of the head to now if it's not set.
293
294 If the C<X-RT-Squelch> header is set to any true value, the mail will
295 not be sent. One use is to let extensions easily cancel outgoing mail.
296
297 Ticket and Transaction arguments are optional. If Transaction is
298 specified and Ticket is not then ticket of the transaction is
299 used, but only if the transaction belongs to a ticket.
300
301 Returns 1 on success, 0 on error or -1 if message has no recipients
302 and hasn't been sent.
303
304 =head3 Signing and Encrypting
305
306 This function as well signs and/or encrypts the message according to
307 headers of a transaction's attachment or properties of a ticket's queue.
308 To get full access to the configuration Ticket and/or Transaction
309 arguments must be provided, but you can force behaviour using Sign
310 and/or Encrypt arguments.
311
312 The following precedence of arguments are used to figure out if
313 the message should be encrypted and/or signed:
314
315 * if Sign or Encrypt argument is defined then its value is used
316
317 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
318 header field then it's value is used
319
320 * else properties of a queue of the Ticket are used.
321
322 =cut
323
324 sub WillSignEncrypt {
325     my %args = @_;
326     my $attachment = delete $args{Attachment};
327     my $ticket     = delete $args{Ticket};
328
329     if ( not RT->Config->Get('GnuPG')->{'Enable'} ) {
330         $args{Sign} = $args{Encrypt} = 0;
331         return wantarray ? %args : 0;
332     }
333
334     for my $argument ( qw(Sign Encrypt) ) {
335         next if defined $args{ $argument };
336
337         if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
338             $args{$argument} = $attachment->GetHeader("X-RT-$argument");
339         } elsif ( $ticket and $argument eq "Encrypt" ) {
340             $args{Encrypt} = $ticket->QueueObj->Encrypt();
341         } elsif ( $ticket and $argument eq "Sign" ) {
342             # Note that $queue->Sign is UI-only, and that all
343             # UI-generated messages explicitly set the X-RT-Crypt header
344             # to 0 or 1; thus this path is only taken for messages
345             # generated _not_ via the web UI.
346             $args{Sign} = $ticket->QueueObj->SignAuto();
347         }
348     }
349
350     return wantarray ? %args : ($args{Sign} || $args{Encrypt});
351 }
352
353 sub SendEmail {
354     my (%args) = (
355         Entity => undef,
356         Bounce => 0,
357         Ticket => undef,
358         Transaction => undef,
359         @_,
360     );
361
362     my $TicketObj = $args{'Ticket'};
363     my $TransactionObj = $args{'Transaction'};
364
365     foreach my $arg( qw(Entity Bounce) ) {
366         next unless defined $args{ lc $arg };
367
368         $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
369         $args{ $arg } = delete $args{ lc $arg };
370     }
371
372     unless ( $args{'Entity'} ) {
373         $RT::Logger->crit( "Could not send mail without 'Entity' object" );
374         return 0;
375     }
376
377     my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
378     chomp $msgid;
379     
380     # If we don't have any recipients to send to, don't send a message;
381     unless ( $args{'Entity'}->head->get('To')
382         || $args{'Entity'}->head->get('Cc')
383         || $args{'Entity'}->head->get('Bcc') )
384     {
385         $RT::Logger->info( $msgid . " No recipients found. Not sending." );
386         return -1;
387     }
388
389     if ($args{'Entity'}->head->get('X-RT-Squelch')) {
390         $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
391         return -1;
392     }
393
394     if ( $TransactionObj && !$TicketObj
395         && $TransactionObj->ObjectType eq 'RT::Ticket' )
396     {
397         $TicketObj = $TransactionObj->Object;
398     }
399
400     if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
401         %args = WillSignEncrypt(
402             %args,
403             Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
404             Ticket     => $TicketObj,
405         );
406         my $res = SignEncrypt( %args );
407         return $res unless $res > 0;
408     }
409
410     unless ( $args{'Entity'}->head->get('Date') ) {
411         require RT::Date;
412         my $date = RT::Date->new( RT->SystemUser );
413         $date->SetToNow;
414         $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
415     }
416
417     my $mail_command = RT->Config->Get('MailCommand');
418
419     if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) {
420         $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
421         $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
422     }
423
424     # if it is a sub routine, we just return it;
425     return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
426
427     if ( $mail_command eq 'sendmailpipe' ) {
428         my $path = RT->Config->Get('SendmailPath');
429         my @args = shellwords(RT->Config->Get('SendmailArguments'));
430
431         # SetOutgoingMailFrom and bounces conflict, since they both want -f
432         if ( $args{'Bounce'} ) {
433             push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
434         } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
435             my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
436             my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
437
438             if ($TicketObj) {
439                 my $QueueName = $TicketObj->QueueObj->Name;
440                 my $QueueAddressOverride = $Overrides->{$QueueName};
441
442                 if ($QueueAddressOverride) {
443                     $OutgoingMailAddress = $QueueAddressOverride;
444                 } else {
445                     $OutgoingMailAddress ||= $TicketObj->QueueObj->CorrespondAddress
446                                              || RT->Config->Get('CorrespondAddress');
447                 }
448             }
449             elsif ($Overrides->{'Default'}) {
450                 $OutgoingMailAddress = $Overrides->{'Default'};
451             }
452
453             push @args, "-f", $OutgoingMailAddress
454                 if $OutgoingMailAddress;
455         }
456
457         # VERP
458         if ( $TransactionObj and
459              my $prefix = RT->Config->Get('VERPPrefix') and
460              my $domain = RT->Config->Get('VERPDomain') )
461         {
462             my $from = $TransactionObj->CreatorObj->EmailAddress;
463             $from =~ s/@/=/g;
464             $from =~ s/\s//g;
465             push @args, "-f", "$prefix$from\@$domain";
466         }
467
468         eval {
469             # don't ignore CHLD signal to get proper exit code
470             local $SIG{'CHLD'} = 'DEFAULT';
471
472             # if something wrong with $mail->print we will get PIPE signal, handle it
473             local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
474
475             require IPC::Open2;
476             my ($mail, $stdout);
477             my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
478                 or die "couldn't execute program: $!";
479
480             $args{'Entity'}->print($mail);
481             close $mail or die "close pipe failed: $!";
482
483             waitpid($pid, 0);
484             if ($?) {
485                 # sendmail exit statuses mostly errors with data not software
486                 # TODO: status parsing: core dump, exit on signal or EX_*
487                 my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
488                 $msg = ", interrupted by signal ". ($?&127) if $?&127;
489                 $RT::Logger->error( $msg );
490                 die $msg;
491             }
492         };
493         if ( $@ ) {
494             $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
495             if ( $TicketObj ) {
496                 _RecordSendEmailFailure( $TicketObj );
497             }
498             return 0;
499         }
500     }
501     elsif ( $mail_command eq 'smtp' ) {
502         require Net::SMTP;
503         my $smtp = do { local $@; eval { Net::SMTP->new(
504             Host  => RT->Config->Get('SMTPServer'),
505             Debug => RT->Config->Get('SMTPDebug'),
506         ) } };
507         unless ( $smtp ) {
508             $RT::Logger->crit( "Could not connect to SMTP server.");
509             if ($TicketObj) {
510                 _RecordSendEmailFailure( $TicketObj );
511             }
512             return 0;
513         }
514
515         # duplicate head as we want drop Bcc field
516         my $head = $args{'Entity'}->head->dup;
517         my @recipients = map $_->address, map 
518             Email::Address->parse($head->get($_)), qw(To Cc Bcc);                       
519         $head->delete('Bcc');
520
521         my $sender = RT->Config->Get('SMTPFrom')
522             || $args{'Entity'}->head->get('From');
523         chomp $sender;
524
525         my $status = $smtp->mail( $sender )
526             && $smtp->recipient( @recipients );
527
528         if ( $status ) {
529             $smtp->data;
530             my $fh = $smtp->tied_fh;
531             $head->print( $fh );
532             print $fh "\n";
533             $args{'Entity'}->print_body( $fh );
534             $smtp->dataend;
535         }
536         $smtp->quit;
537
538         unless ( $status ) {
539             $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
540             if ( $TicketObj ) {
541                 _RecordSendEmailFailure( $TicketObj );
542             }
543             return 0;
544         }
545     }
546     else {
547         local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
548
549         my @mailer_args = ($mail_command);
550         if ( $mail_command eq 'sendmail' ) {
551             $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
552             push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
553         }
554         else {
555             push @mailer_args, RT->Config->Get('MailParams');
556         }
557
558         unless ( $args{'Entity'}->send( @mailer_args ) ) {
559             $RT::Logger->crit( "$msgid: Could not send mail." );
560             if ( $TicketObj ) {
561                 _RecordSendEmailFailure( $TicketObj );
562             }
563             return 0;
564         }
565     }
566     return 1;
567 }
568
569 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
570
571 Loads a template. Parses it using arguments if it's not empty.
572 Returns a tuple (L<RT::Template> object, error message).
573
574 Note that even if a template object is returned MIMEObj method
575 may return undef for empty templates.
576
577 =cut
578
579 sub PrepareEmailUsingTemplate {
580     my %args = (
581         Template => '',
582         Arguments => {},
583         @_
584     );
585
586     my $template = RT::Template->new( RT->SystemUser );
587     $template->LoadGlobalTemplate( $args{'Template'} );
588     unless ( $template->id ) {
589         return (undef, "Couldn't load template '". $args{'Template'} ."'");
590     }
591     return $template if $template->IsEmpty;
592
593     my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
594     return (undef, $msg) unless $status;
595
596     return $template;
597 }
598
599 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
600
601 Sends email using a template, takes name of template, arguments for it and recipients.
602
603 =cut
604
605 sub SendEmailUsingTemplate {
606     my %args = (
607         Template => '',
608         Arguments => {},
609         To => undef,
610         Cc => undef,
611         Bcc => undef,
612         From => RT->Config->Get('CorrespondAddress'),
613         InReplyTo => undef,
614         ExtraHeaders => {},
615         @_
616     );
617
618     my ($template, $msg) = PrepareEmailUsingTemplate( %args );
619     return (0, $msg) unless $template;
620
621     my $mail = $template->MIMEObj;
622     unless ( $mail ) {
623         $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
624         return -1;
625     }
626
627     $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
628         foreach grep defined $args{$_}, qw(To Cc Bcc From);
629
630     $mail->head->set( $_ => $args{ExtraHeaders}{$_} )
631         foreach keys %{ $args{ExtraHeaders} };
632
633     SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
634
635     return SendEmail( Entity => $mail );
636 }
637
638 =head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
639
640 Forwards transaction with all attachments as 'message/rfc822'.
641
642 =cut
643
644 sub ForwardTransaction {
645     my $txn = shift;
646     my %args = ( To => '', Cc => '', Bcc => '', @_ );
647
648     my $entity = $txn->ContentAsMIME;
649
650     my ( $ret, $msg ) = SendForward( %args, Entity => $entity, Transaction => $txn );
651     if ($ret) {
652         my $ticket = $txn->TicketObj;
653         my ( $ret, $msg ) = $ticket->_NewTransaction(
654             Type  => 'Forward Transaction',
655             Field => $txn->id,
656             Data  => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
657         );
658         unless ($ret) {
659             $RT::Logger->error("Failed to create transaction: $msg");
660         }
661     }
662     return ( $ret, $msg );
663 }
664
665 =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
666
667 Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
668
669 =cut
670
671 sub ForwardTicket {
672     my $ticket = shift;
673     my %args = ( To => '', Cc => '', Bcc => '', @_ );
674
675     my $txns = $ticket->Transactions;
676     $txns->Limit(
677         FIELD    => 'Type',
678         VALUE    => $_,
679     ) for qw(Create Correspond);
680
681     my $entity = MIME::Entity->build(
682         Type        => 'multipart/mixed',
683         Description => 'forwarded ticket',
684     );
685     $entity->add_part( $_ ) foreach 
686         map $_->ContentAsMIME,
687         @{ $txns->ItemsArrayRef };
688
689     my ( $ret, $msg ) = SendForward(
690         %args,
691         Entity   => $entity,
692         Ticket   => $ticket,
693         Template => 'Forward Ticket',
694     );
695
696     if ($ret) {
697         my ( $ret, $msg ) = $ticket->_NewTransaction(
698             Type  => 'Forward Ticket',
699             Field => $ticket->id,
700             Data  => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
701         );
702         unless ($ret) {
703             $RT::Logger->error("Failed to create transaction: $msg");
704         }
705     }
706
707     return ( $ret, $msg );
708
709 }
710
711 =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
712
713 Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
714
715 =cut
716
717 sub SendForward {
718     my (%args) = (
719         Entity => undef,
720         Ticket => undef,
721         Transaction => undef,
722         Template => 'Forward',
723         To => '', Cc => '', Bcc => '',
724         @_
725     );
726
727     my $txn = $args{'Transaction'};
728     my $ticket = $args{'Ticket'};
729     $ticket ||= $txn->Object if $txn;
730
731     my $entity = $args{'Entity'};
732     unless ( $entity ) {
733         require Carp;
734         $RT::Logger->error(Carp::longmess("No entity provided"));
735         return (0, $ticket->loc("Couldn't send email"));
736     }
737
738     my ($template, $msg) = PrepareEmailUsingTemplate(
739         Template  => $args{'Template'},
740         Arguments => {
741             Ticket      => $ticket,
742             Transaction => $txn,
743         },
744     );
745
746     my $mail;
747     if ( $template ) {
748         $mail = $template->MIMEObj;
749     } else {
750         $RT::Logger->warning($msg);
751     }
752     unless ( $mail ) {
753         $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
754
755         my $description;
756         unless ( $args{'Transaction'} ) {
757             $description = 'This is forward of ticket #'. $ticket->id;
758         } else {
759             $description = 'This is forward of transaction #'
760                 . $txn->id ." of a ticket #". $txn->ObjectId;
761         }
762         $mail = MIME::Entity->build(
763             Type => 'text/plain',
764             Data => $description,
765         );
766     }
767
768     $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
769         foreach grep defined $args{$_}, qw(To Cc Bcc);
770
771     $mail->make_multipart unless $mail->is_multipart;
772     $mail->add_part( $entity );
773
774     my $from;
775     unless (defined $mail->head->get('Subject')) {
776         my $subject = '';
777         $subject = $txn->Subject if $txn;
778         $subject ||= $ticket->Subject if $ticket;
779
780         unless ( RT->Config->Get('ForwardFromUser') ) {
781             # XXX: what if want to forward txn of other object than ticket?
782             $subject = AddSubjectTag( $subject, $ticket );
783         }
784
785         $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
786     }
787
788     $mail->head->set(
789         From => EncodeToMIME(
790             String => GetForwardFrom( Transaction => $txn, Ticket => $ticket )
791         )
792     );
793
794     my $status = RT->Config->Get('ForwardFromUser')
795         # never sign if we forward from User
796         ? SendEmail( %args, Entity => $mail, Sign => 0 )
797         : SendEmail( %args, Entity => $mail );
798     return (0, $ticket->loc("Couldn't send email")) unless $status;
799     return (1, $ticket->loc("Sent email successfully"));
800 }
801
802 =head2 GetForwardFrom Ticket => undef, Transaction => undef
803
804 Resolve the From field to use in forward mail
805
806 =cut
807
808 sub GetForwardFrom {
809     my %args   = ( Ticket => undef, Transaction => undef, @_ );
810     my $txn    = $args{Transaction};
811     my $ticket = $args{Ticket} || $txn->Object;
812
813     if ( RT->Config->Get('ForwardFromUser') ) {
814         return ( $txn || $ticket )->CurrentUser->EmailAddress;
815     }
816     else {
817         return $ticket->QueueObj->CorrespondAddress
818           || RT->Config->Get('CorrespondAddress');
819     }
820 }
821
822 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
823
824 Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
825 handle errors with users' keys.
826
827 If a recipient has no key or has other problems with it, then the
828 unction sends a error to him using 'Error: public key' template.
829 Also, notifies RT's owner using template 'Error to RT owner: public key'
830 to inform that there are problems with users' keys. Then we filter
831 all bad recipients and retry.
832
833 Returns 1 on success, 0 on error and -1 if all recipients are bad and
834 had been filtered out.
835
836 =cut
837
838 sub SignEncrypt {
839     my %args = (
840         Entity => undef,
841         Sign => 0,
842         Encrypt => 0,
843         @_
844     );
845     return 1 unless $args{'Sign'} || $args{'Encrypt'};
846
847     my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
848     chomp $msgid;
849
850     $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
851     $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
852
853     require RT::Crypt::GnuPG;
854     my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
855     return 1 unless $res{'exit_code'};
856
857     my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
858
859     my @bad_recipients;
860     foreach my $line ( @status ) {
861         # if the passphrase fails, either you have a bad passphrase
862         # or gpg-agent has died.  That should get caught in Create and
863         # Update, but at least throw an error here
864         if (($line->{'Operation'}||'') eq 'PassphraseCheck'
865             && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
866             $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
867             return 0;
868         }
869         next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
870         next if $line->{'Status'} eq 'DONE';
871         $RT::Logger->error( $line->{'Message'} );
872         push @bad_recipients, $line;
873     }
874     return 0 unless @bad_recipients;
875
876     $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
877         foreach @bad_recipients;
878
879     foreach my $recipient ( @bad_recipients ) {
880         my $status = SendEmailUsingTemplate(
881             To        => $recipient->{'AddressObj'}->address,
882             Template  => 'Error: public key',
883             Arguments => {
884                 %$recipient,
885                 TicketObj      => $args{'Ticket'},
886                 TransactionObj => $args{'Transaction'},
887             },
888         );
889         unless ( $status ) {
890             $RT::Logger->error("Couldn't send 'Error: public key'");
891         }
892     }
893
894     my $status = SendEmailUsingTemplate(
895         To        => RT->Config->Get('OwnerEmail'),
896         Template  => 'Error to RT owner: public key',
897         Arguments => {
898             BadRecipients  => \@bad_recipients,
899             TicketObj      => $args{'Ticket'},
900             TransactionObj => $args{'Transaction'},
901         },
902     );
903     unless ( $status ) {
904         $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
905     }
906
907     DeleteRecipientsFromHead(
908         $args{'Entity'}->head,
909         map $_->{'AddressObj'}->address, @bad_recipients
910     );
911
912     unless ( $args{'Entity'}->head->get('To')
913           || $args{'Entity'}->head->get('Cc')
914           || $args{'Entity'}->head->get('Bcc') )
915     {
916         $RT::Logger->debug("$msgid No recipients that have public key, not sending");
917         return -1;
918     }
919
920     # redo without broken recipients
921     %res = RT::Crypt::GnuPG::SignEncrypt( %args );
922     return 0 if $res{'exit_code'};
923
924     return 1;
925 }
926
927 use MIME::Words ();
928
929 =head2 EncodeToMIME
930
931 Takes a hash with a String and a Charset. Returns the string encoded
932 according to RFC2047, using B (base64 based) encoding.
933
934 String must be a perl string, octets are returned.
935
936 If Charset is not provided then $EmailOutputEncoding config option
937 is used, or "latin-1" if that is not set.
938
939 =cut
940
941 sub EncodeToMIME {
942     my %args = (
943         String => undef,
944         Charset  => undef,
945         @_
946     );
947     my $value = $args{'String'};
948     return $value unless $value; # 0 is perfect ascii
949     my $charset  = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
950     my $encoding = 'B';
951
952     # using RFC2047 notation, sec 2.
953     # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
954
955     # An 'encoded-word' may not be more than 75 characters long
956     #
957     # MIME encoding increases 4/3*(number of bytes), and always in multiples
958     # of 4. Thus we have to find the best available value of bytes available
959     # for each chunk.
960     #
961     # First we get the integer max which max*4/3 would fit on space.
962     # Then we find the greater multiple of 3 lower or equal than $max.
963     my $max = int(
964         (   ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
965             * 3
966         ) / 4
967     );
968     $max = int( $max / 3 ) * 3;
969
970     chomp $value;
971
972     if ( $max <= 0 ) {
973
974         # gives an error...
975         $RT::Logger->crit("Can't encode! Charset or encoding too big.");
976         return ($value);
977     }
978
979     return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
980
981     $value =~ s/\s+$//;
982
983     # we need perl string to split thing char by char
984     Encode::_utf8_on($value) unless Encode::is_utf8($value);
985
986     my ( $tmp, @chunks ) = ( '', () );
987     while ( length $value ) {
988         my $char = substr( $value, 0, 1, '' );
989         my $octets = Encode::encode( $charset, $char );
990         if ( length($tmp) + length($octets) > $max ) {
991             push @chunks, $tmp;
992             $tmp = '';
993         }
994         $tmp .= $octets;
995     }
996     push @chunks, $tmp if length $tmp;
997
998     # encode an join chuncks
999     $value = join "\n ",
1000         map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
1001         @chunks;
1002     return ($value);
1003 }
1004
1005 sub CreateUser {
1006     my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
1007
1008     my $NewUser = RT::User->new( RT->SystemUser );
1009
1010     my ( $Val, $Message ) = $NewUser->Create(
1011         Name => ( $Username || $Address ),
1012         EmailAddress => $Address,
1013         RealName     => $Name,
1014         Password     => undef,
1015         Privileged   => 0,
1016         Comments     => 'Autocreated on ticket submission',
1017     );
1018
1019     unless ($Val) {
1020
1021         # Deal with the race condition of two account creations at once
1022         if ($Username) {
1023             $NewUser->LoadByName($Username);
1024         }
1025
1026         unless ( $NewUser->Id ) {
1027             $NewUser->LoadByEmail($Address);
1028         }
1029
1030         unless ( $NewUser->Id ) {
1031             MailError(
1032                 To          => $ErrorsTo,
1033                 Subject     => "User could not be created",
1034                 Explanation =>
1035                     "User creation failed in mailgateway: $Message",
1036                 MIMEObj  => $entity,
1037                 LogLevel => 'crit',
1038             );
1039         }
1040     }
1041
1042     #Load the new user object
1043     my $CurrentUser = RT::CurrentUser->new;
1044     $CurrentUser->LoadByEmail( $Address );
1045
1046     unless ( $CurrentUser->id ) {
1047         $RT::Logger->warning(
1048             "Couldn't load user '$Address'." . "giving up" );
1049         MailError(
1050             To          => $ErrorsTo,
1051             Subject     => "User could not be loaded",
1052             Explanation =>
1053                 "User  '$Address' could not be loaded in the mail gateway",
1054             MIMEObj  => $entity,
1055             LogLevel => 'crit'
1056         );
1057     }
1058
1059     return $CurrentUser;
1060 }
1061
1062
1063
1064 =head2 ParseCcAddressesFromHead HASH
1065
1066 Takes a hash containing QueueObj, Head and CurrentUser objects.
1067 Returns a list of all email addresses in the To and Cc
1068 headers b<except> the current Queue's email addresses, the CurrentUser's
1069 email address  and anything that the configuration sub RT::IsRTAddress matches.
1070
1071 =cut
1072
1073 sub ParseCcAddressesFromHead {
1074     my %args = (
1075         Head        => undef,
1076         QueueObj    => undef,
1077         CurrentUser => undef,
1078         @_
1079     );
1080
1081     my $current_address = lc $args{'CurrentUser'}->EmailAddress;
1082     my $user = $args{'CurrentUser'}->UserObj;
1083
1084     return
1085         grep $_ ne $current_address && !RT::EmailParser->IsRTAddress( $_ ),
1086         map lc $user->CanonicalizeEmailAddress( $_->address ),
1087         map Email::Address->parse( $args{'Head'}->get( $_ ) ),
1088         qw(To Cc);
1089 }
1090
1091
1092
1093 =head2 ParseSenderAddressFromHead HEAD
1094
1095 Takes a MIME::Header object. Returns (user@host, friendly name, errors)
1096 where the first two values are the From (evaluated in order of
1097 Reply-To:, From:, Sender).
1098
1099 A list of error messages may be returned even when a Sender value is
1100 found, since it could be a parse error for another (checked earlier)
1101 sender field. In this case, the errors aren't fatal, but may be useful
1102 to investigate the parse failure.
1103
1104 =cut
1105
1106 sub ParseSenderAddressFromHead {
1107     my $head = shift;
1108     my @sender_headers = ('Reply-To', 'From', 'Sender');
1109     my @errors;  # Accumulate any errors
1110
1111     #Figure out who's sending this message.
1112     foreach my $header ( @sender_headers ) {
1113         my $addr_line = $head->get($header) || next;
1114         my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1115         # only return if the address is not empty
1116         return ($addr, $name, @errors) if $addr;
1117
1118         chomp $addr_line;
1119         push @errors, "$header: $addr_line";
1120     }
1121
1122     return (undef, undef, @errors);
1123 }
1124
1125 =head2 ParseErrorsToAddressFromHead HEAD
1126
1127 Takes a MIME::Header object. Return a single value : user@host
1128 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1129 From:, Sender)
1130
1131 =cut
1132
1133 sub ParseErrorsToAddressFromHead {
1134     my $head = shift;
1135
1136     #Figure out who's sending this message.
1137
1138     foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1139
1140         # If there's a header of that name
1141         my $headerobj = $head->get($header);
1142         if ($headerobj) {
1143             my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1144
1145             # If it's got actual useful content...
1146             return ($addr) if ($addr);
1147         }
1148     }
1149 }
1150
1151
1152
1153 =head2 ParseAddressFromHeader ADDRESS
1154
1155 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1156
1157 =cut
1158
1159 sub ParseAddressFromHeader {
1160     my $Addr = shift;
1161
1162     # Some broken mailers send:  ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1163     $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1164     my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1165
1166     my ($AddrObj) = grep ref $_, @Addresses;
1167     unless ( $AddrObj ) {
1168         return ( undef, undef );
1169     }
1170
1171     return ( $AddrObj->address, $AddrObj->phrase );
1172 }
1173
1174 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1175
1176 Gets a head object and list of addresses.
1177 Deletes addresses from To, Cc or Bcc fields.
1178
1179 =cut
1180
1181 sub DeleteRecipientsFromHead {
1182     my $head = shift;
1183     my %skip = map { lc $_ => 1 } @_;
1184
1185     foreach my $field ( qw(To Cc Bcc) ) {
1186         $head->set( $field =>
1187             join ', ', map $_->format, grep !$skip{ lc $_->address },
1188                 Email::Address->parse( $head->get( $field ) )
1189         );
1190     }
1191 }
1192
1193 sub GenMessageId {
1194     my %args = (
1195         Ticket      => undef,
1196         Scrip       => undef,
1197         ScripAction => undef,
1198         @_
1199     );
1200     my $org = RT->Config->Get('Organization');
1201     my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1202     my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1203     my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1204
1205     return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1206         . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1207 }
1208
1209 sub SetInReplyTo {
1210     my %args = (
1211         Message   => undef,
1212         InReplyTo => undef,
1213         Ticket    => undef,
1214         @_
1215     );
1216     return unless $args{'Message'} && $args{'InReplyTo'};
1217
1218     my $get_header = sub {
1219         my @res;
1220         if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1221             @res = $args{'InReplyTo'}->head->get( shift );
1222         } else {
1223             @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1224         }
1225         return grep length, map { split /\s+/m, $_ } grep defined, @res;
1226     };
1227
1228     my @id = $get_header->('Message-ID');
1229     #XXX: custom header should begin with X- otherwise is violation of the standard
1230     my @rtid = $get_header->('RT-Message-ID');
1231     my @references = $get_header->('References');
1232     unless ( @references ) {
1233         @references = $get_header->('In-Reply-To');
1234     }
1235     push @references, @id, @rtid;
1236     if ( $args{'Ticket'} ) {
1237         my $pseudo_ref =  '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
1238         push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1239     }
1240     @references = splice @references, 4, -6
1241         if @references > 10;
1242
1243     my $mail = $args{'Message'};
1244     $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
1245     $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) );
1246 }
1247
1248 sub ExtractTicketId {
1249     my $entity = shift;
1250
1251     my $subject = $entity->head->get('Subject') || '';
1252     chomp $subject;
1253     return ParseTicketId( $subject );
1254 }
1255
1256 sub ParseTicketId {
1257     my $Subject = shift;
1258
1259     my $rtname = RT->Config->Get('rtname');
1260     my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1261
1262     my $id;
1263     if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
1264         $id = $1;
1265     } else {
1266         foreach my $tag ( RT->System->SubjectTag ) {
1267             next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
1268             $id = $1;
1269             last;
1270         }
1271     }
1272     return undef unless $id;
1273
1274     $RT::Logger->debug("Found a ticket ID. It's $id");
1275     return $id;
1276 }
1277
1278 sub AddSubjectTag {
1279     my $subject = shift;
1280     my $ticket  = shift;
1281     unless ( ref $ticket ) {
1282         my $tmp = RT::Ticket->new( RT->SystemUser );
1283         $tmp->Load( $ticket );
1284         $ticket = $tmp;
1285     }
1286     my $id = $ticket->id;
1287     my $queue_tag = $ticket->QueueObj->SubjectTag;
1288
1289     my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1290     unless ( $tag_re ) {
1291         my $tag = $queue_tag || RT->Config->Get('rtname');
1292         $tag_re = qr/\Q$tag\E/;
1293     } elsif ( $queue_tag ) {
1294         $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1295     }
1296     return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1297
1298     $subject =~ s/(\r\n|\n|\s)/ /g;
1299     chomp $subject;
1300     return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1301 }
1302
1303
1304 =head2 Gateway ARGSREF
1305
1306
1307 Takes parameters:
1308
1309     action
1310     queue
1311     message
1312
1313
1314 This performs all the "guts" of the mail rt-mailgate program, and is
1315 designed to be called from the web interface with a message, user
1316 object, and so on.
1317
1318 Can also take an optional 'ticket' parameter; this ticket id overrides
1319 any ticket id found in the subject.
1320
1321 Returns:
1322
1323     An array of:
1324
1325     (status code, message, optional ticket object)
1326
1327     status code is a numeric value.
1328
1329       for temporary failures, the status code should be -75
1330
1331       for permanent failures which are handled by RT, the status code
1332       should be 0
1333
1334       for succces, the status code should be 1
1335
1336
1337
1338 =cut
1339
1340 sub _LoadPlugins {
1341     my @mail_plugins = @_;
1342
1343     my @res;
1344     foreach my $plugin (@mail_plugins) {
1345         if ( ref($plugin) eq "CODE" ) {
1346             push @res, $plugin;
1347         } elsif ( !ref $plugin ) {
1348             my $Class = $plugin;
1349             $Class = "RT::Interface::Email::" . $Class
1350                 unless $Class =~ /^RT::/;
1351             $Class->require or
1352                 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1353
1354             no strict 'refs';
1355             unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1356                 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1357                 next;
1358             }
1359             push @res, $Class;
1360         } else {
1361             $RT::Logger->crit( "$plugin - is not class name or code reference");
1362         }
1363     }
1364     return @res;
1365 }
1366
1367 sub Gateway {
1368     my $argsref = shift;
1369     my %args    = (
1370         action  => 'correspond',
1371         queue   => '1',
1372         ticket  => undef,
1373         message => undef,
1374         %$argsref
1375     );
1376
1377     my $SystemTicket;
1378     my $Right;
1379
1380     # Validate the action
1381     my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1382     unless ($status) {
1383         return (
1384             -75,
1385             "Invalid 'action' parameter "
1386                 . $actions[0]
1387                 . " for queue "
1388                 . $args{'queue'},
1389             undef
1390         );
1391     }
1392
1393     my $parser = RT::EmailParser->new();
1394     $parser->SmartParseMIMEEntityFromScalar(
1395         Message => $args{'message'},
1396         Decode => 0,
1397         Exact => 1,
1398     );
1399
1400     my $Message = $parser->Entity();
1401     unless ($Message) {
1402         MailError(
1403             Subject     => "RT Bounce: Unparseable message",
1404             Explanation => "RT couldn't process the message below",
1405             Attach      => $args{'message'}
1406         );
1407
1408         return ( 0,
1409             "Failed to parse this message. Something is likely badly wrong with the message"
1410         );
1411     }
1412
1413     my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1414     push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1415     @mail_plugins = _LoadPlugins( @mail_plugins );
1416
1417     my %skip_plugin;
1418     foreach my $class( grep !ref, @mail_plugins ) {
1419         # check if we should apply filter before decoding
1420         my $check_cb = do {
1421             no strict 'refs';
1422             *{ $class . "::ApplyBeforeDecode" }{CODE};
1423         };
1424         next unless defined $check_cb;
1425         next unless $check_cb->(
1426             Message       => $Message,
1427             RawMessageRef => \$args{'message'},
1428         );
1429
1430         $skip_plugin{ $class }++;
1431
1432         my $Code = do {
1433             no strict 'refs';
1434             *{ $class . "::GetCurrentUser" }{CODE};
1435         };
1436         my ($status, $msg) = $Code->(
1437             Message       => $Message,
1438             RawMessageRef => \$args{'message'},
1439         );
1440         next if $status > 0;
1441
1442         if ( $status == -2 ) {
1443             return (1, $msg, undef);
1444         } elsif ( $status == -1 ) {
1445             return (0, $msg, undef);
1446         }
1447     }
1448     @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1449     $parser->_DecodeBodies;
1450     $parser->RescueOutlook;
1451     $parser->_PostProcessNewEntity;
1452
1453     my $head = $Message->head;
1454     my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1455
1456     my $MessageId = $head->get('Message-ID')
1457         || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1458
1459     #Pull apart the subject line
1460     my $Subject = $head->get('Subject') || '';
1461     chomp $Subject;
1462     
1463     # Lets check for mail loops of various sorts.
1464     my ($should_store_machine_generated_message, $IsALoop, $result);
1465     ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1466       _HandleMachineGeneratedMail(
1467         Message  => $Message,
1468         ErrorsTo => $ErrorsTo,
1469         Subject  => $Subject,
1470         MessageId => $MessageId
1471     );
1472
1473     # Do not pass loop messages to MailPlugins, to make sure the loop
1474     # is broken, unless $RT::StoreLoops is set.
1475     if ($IsALoop && !$should_store_machine_generated_message) {
1476         return ( 0, $result, undef );
1477     }
1478     # }}}
1479
1480     $args{'ticket'} ||= ExtractTicketId( $Message );
1481
1482     # ExtractTicketId may have been overridden, and edited the Subject
1483     my $NewSubject = $Message->head->get('Subject');
1484     chomp $NewSubject;
1485
1486     $SystemTicket = RT::Ticket->new( RT->SystemUser );
1487     $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1488     if ( $SystemTicket->id ) {
1489         $Right = 'ReplyToTicket';
1490     } else {
1491         $Right = 'CreateTicket';
1492     }
1493
1494     #Set up a queue object
1495     my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
1496     $SystemQueueObj->Load( $args{'queue'} );
1497
1498     # We can safely have no queue of we have a known-good ticket
1499     unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1500         return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1501     }
1502
1503     my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1504         MailPlugins   => \@mail_plugins,
1505         Actions       => \@actions,
1506         Message       => $Message,
1507         RawMessageRef => \$args{message},
1508         SystemTicket  => $SystemTicket,
1509         SystemQueue   => $SystemQueueObj,
1510     );
1511
1512     # If authentication fails and no new user was created, get out.
1513     if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1514
1515         # If the plugins refused to create one, they lose.
1516         unless ( $AuthStat == -1 ) {
1517             _NoAuthorizedUserFound(
1518                 Right     => $Right,
1519                 Message   => $Message,
1520                 Requestor => $ErrorsTo,
1521                 Queue     => $args{'queue'}
1522             );
1523
1524         }
1525         return ( 0, "Could not load a valid user", undef );
1526     }
1527
1528     # If we got a user, but they don't have the right to say things
1529     if ( $AuthStat == 0 ) {
1530         MailError(
1531             To          => $ErrorsTo,
1532             Subject     => "Permission Denied",
1533             Explanation =>
1534                 "You do not have permission to communicate with RT",
1535             MIMEObj => $Message
1536         );
1537         return (
1538             0,
1539             "$ErrorsTo tried to submit a message to "
1540                 . $args{'Queue'}
1541                 . " without permission.",
1542             undef
1543         );
1544     }
1545
1546
1547     unless ($should_store_machine_generated_message) {
1548         return ( 0, $result, undef );
1549     }
1550
1551     # if plugin's updated SystemTicket then update arguments
1552     $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1553
1554     my $Ticket = RT::Ticket->new($CurrentUser);
1555
1556     if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1557     {
1558
1559         my @Cc;
1560         my @Requestors = ( $CurrentUser->id );
1561
1562         if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1563             @Cc = ParseCcAddressesFromHead(
1564                 Head        => $head,
1565                 CurrentUser => $CurrentUser,
1566                 QueueObj    => $SystemQueueObj
1567             );
1568         }
1569
1570         $head->replace('X-RT-Interface' => 'Email');
1571
1572         my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1573             Queue     => $SystemQueueObj->Id,
1574             Subject   => $NewSubject,
1575             Requestor => \@Requestors,
1576             Cc        => \@Cc,
1577             MIMEObj   => $Message
1578         );
1579         if ( $id == 0 ) {
1580             MailError(
1581                 To          => $ErrorsTo,
1582                 Subject     => "Ticket creation failed: $Subject",
1583                 Explanation => $ErrStr,
1584                 MIMEObj     => $Message
1585             );
1586             return ( 0, "Ticket creation failed: $ErrStr", $Ticket );
1587         }
1588
1589         # strip comments&corresponds from the actions we don't need
1590         # to record them if we've created the ticket just now
1591         @actions = grep !/^(comment|correspond)$/, @actions;
1592         $args{'ticket'} = $id;
1593
1594     } elsif ( $args{'ticket'} ) {
1595
1596         $Ticket->Load( $args{'ticket'} );
1597         unless ( $Ticket->Id ) {
1598             my $error = "Could not find a ticket with id " . $args{'ticket'};
1599             MailError(
1600                 To          => $ErrorsTo,
1601                 Subject     => "Message not recorded: $Subject",
1602                 Explanation => $error,
1603                 MIMEObj     => $Message
1604             );
1605
1606             return ( 0, $error );
1607         }
1608         $args{'ticket'} = $Ticket->id;
1609     } else {
1610         return ( 1, "Success", $Ticket );
1611     }
1612
1613     # }}}
1614
1615     my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1616     foreach my $action (@actions) {
1617
1618         #   If the action is comment, add a comment.
1619         if ( $action =~ /^(?:comment|correspond)$/i ) {
1620             my $method = ucfirst lc $action;
1621             my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1622             unless ($status) {
1623
1624                 #Warn the sender that we couldn't actually submit the comment.
1625                 MailError(
1626                     To          => $ErrorsTo,
1627                     Subject     => "Message not recorded ($method): $Subject",
1628                     Explanation => $msg,
1629                     MIMEObj     => $Message
1630                 );
1631                 return ( 0, "Message not recorded: $msg", $Ticket );
1632             }
1633         } elsif ($unsafe_actions) {
1634             my ( $status, $msg ) = _RunUnsafeAction(
1635                 Action      => $action,
1636                 ErrorsTo    => $ErrorsTo,
1637                 Message     => $Message,
1638                 Ticket      => $Ticket,
1639                 CurrentUser => $CurrentUser,
1640             );
1641             return ($status, $msg, $Ticket) unless $status == 1;
1642         }
1643     }
1644     return ( 1, "Success", $Ticket );
1645 }
1646
1647 =head2 GetAuthenticationLevel
1648
1649     # Authentication Level
1650     # -1 - Get out.  this user has been explicitly declined
1651     # 0 - User may not do anything (Not used at the moment)
1652     # 1 - Normal user
1653     # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1654
1655 =cut
1656
1657 sub GetAuthenticationLevel {
1658     my %args = (
1659         MailPlugins   => [],
1660         Actions       => [],
1661         Message       => undef,
1662         RawMessageRef => undef,
1663         SystemTicket  => undef,
1664         SystemQueue   => undef,
1665         @_,
1666     );
1667
1668     my ( $CurrentUser, $AuthStat, $error );
1669
1670     # Initalize AuthStat so comparisons work correctly
1671     $AuthStat = -9999999;
1672
1673     # if plugin returns AuthStat -2 we skip action
1674     # NOTE: this is experimental API and it would be changed
1675     my %skip_action = ();
1676
1677     # Since this needs loading, no matter what
1678     foreach (@{ $args{MailPlugins} }) {
1679         my ($Code, $NewAuthStat);
1680         if ( ref($_) eq "CODE" ) {
1681             $Code = $_;
1682         } else {
1683             no strict 'refs';
1684             $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1685         }
1686
1687         foreach my $action (@{ $args{Actions} }) {
1688             ( $CurrentUser, $NewAuthStat ) = $Code->(
1689                 Message       => $args{Message},
1690                 RawMessageRef => $args{RawMessageRef},
1691                 CurrentUser   => $CurrentUser,
1692                 AuthLevel     => $AuthStat,
1693                 Action        => $action,
1694                 Ticket        => $args{SystemTicket},
1695                 Queue         => $args{SystemQueue},
1696             );
1697
1698 # You get the highest level of authentication you were assigned, unless you get the magic -1
1699 # If a module returns a "-1" then we discard the ticket, so.
1700             $AuthStat = $NewAuthStat
1701                 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1702
1703             last if $AuthStat == -1;
1704             $skip_action{$action}++ if $AuthStat == -2;
1705         }
1706
1707         # strip actions we should skip
1708         @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1709             if $AuthStat == -2;
1710         last unless @{$args{Actions}};
1711
1712         last if $AuthStat == -1;
1713     }
1714
1715     return $AuthStat if !wantarray;
1716
1717     return ($AuthStat, $CurrentUser, $error);
1718 }
1719
1720 sub _RunUnsafeAction {
1721     my %args = (
1722         Action      => undef,
1723         ErrorsTo    => undef,
1724         Message     => undef,
1725         Ticket      => undef,
1726         CurrentUser => undef,
1727         @_
1728     );
1729
1730     if ( $args{'Action'} =~ /^take$/i ) {
1731         my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1732         unless ($status) {
1733             MailError(
1734                 To          => $args{'ErrorsTo'},
1735                 Subject     => "Ticket not taken",
1736                 Explanation => $msg,
1737                 MIMEObj     => $args{'Message'}
1738             );
1739             return ( 0, "Ticket not taken" );
1740         }
1741     } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1742         my $new_status = $args{'Ticket'}->FirstInactiveStatus;
1743         if ($new_status) {
1744             my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
1745             unless ($status) {
1746
1747                 #Warn the sender that we couldn't actually submit the comment.
1748                 MailError(
1749                     To          => $args{'ErrorsTo'},
1750                     Subject     => "Ticket not resolved",
1751                     Explanation => $msg,
1752                     MIMEObj     => $args{'Message'}
1753                 );
1754                 return ( 0, "Ticket not resolved" );
1755             }
1756         }
1757     } else {
1758         return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} );
1759     }
1760     return ( 1, "Success" );
1761 }
1762
1763 =head2 _NoAuthorizedUserFound
1764
1765 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1766
1767 =cut
1768
1769 sub _NoAuthorizedUserFound {
1770     my %args = (
1771         Right     => undef,
1772         Message   => undef,
1773         Requestor => undef,
1774         Queue     => undef,
1775         @_
1776     );
1777
1778     # Notify the RT Admin of the failure.
1779     MailError(
1780         To          => RT->Config->Get('OwnerEmail'),
1781         Subject     => "Could not load a valid user",
1782         Explanation => <<EOT,
1783 RT could not load a valid user, and RT's configuration does not allow
1784 for the creation of a new user for this email (@{[$args{Requestor}]}).
1785
1786 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1787 queue @{[$args{'Queue'}]}.
1788
1789 EOT
1790         MIMEObj  => $args{'Message'},
1791         LogLevel => 'error'
1792     );
1793
1794     # Also notify the requestor that his request has been dropped.
1795     if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1796     MailError(
1797         To          => $args{'Requestor'},
1798         Subject     => "Could not load a valid user",
1799         Explanation => <<EOT,
1800 RT could not load a valid user, and RT's configuration does not allow
1801 for the creation of a new user for your email.
1802
1803 EOT
1804         MIMEObj  => $args{'Message'},
1805         LogLevel => 'error'
1806     );
1807     }
1808 }
1809
1810 =head2 _HandleMachineGeneratedMail
1811
1812 Takes named params:
1813     Message
1814     ErrorsTo
1815     Subject
1816
1817 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1818 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1819 "This message appears to be a loop (boolean)" );
1820
1821 =cut
1822
1823 sub _HandleMachineGeneratedMail {
1824     my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1825     my $head = $args{'Message'}->head;
1826     my $ErrorsTo = $args{'ErrorsTo'};
1827
1828     my $IsBounce = CheckForBounce($head);
1829
1830     my $IsAutoGenerated = CheckForAutoGenerated($head);
1831
1832     my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1833
1834     my $IsALoop = CheckForLoops($head);
1835
1836     my $SquelchReplies = 0;
1837
1838     my $owner_mail = RT->Config->Get('OwnerEmail');
1839
1840     #If the message is autogenerated, we need to know, so we can not
1841     # send mail to the sender
1842     if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1843         $SquelchReplies = 1;
1844         $ErrorsTo       = $owner_mail;
1845     }
1846
1847     # Warn someone if it's a loop, before we drop it on the ground
1848     if ($IsALoop) {
1849         $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1850
1851         #Should we mail it to RTOwner?
1852         if ( RT->Config->Get('LoopsToRTOwner') ) {
1853             MailError(
1854                 To          => $owner_mail,
1855                 Subject     => "RT Bounce: ".$args{'Subject'},
1856                 Explanation => "RT thinks this message may be a bounce",
1857                 MIMEObj     => $args{Message}
1858             );
1859         }
1860
1861         #Do we actually want to store it?
1862         return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1863             unless RT->Config->Get('StoreLoops');
1864     }
1865
1866     # Squelch replies if necessary
1867     # Don't let the user stuff the RT-Squelch-Replies-To header.
1868     if ( $head->get('RT-Squelch-Replies-To') ) {
1869         $head->replace(
1870             'RT-Relocated-Squelch-Replies-To',
1871             $head->get('RT-Squelch-Replies-To')
1872         );
1873         $head->delete('RT-Squelch-Replies-To');
1874     }
1875
1876     if ($SquelchReplies) {
1877
1878         # Squelch replies to the sender, and also leave a clue to
1879         # allow us to squelch ALL outbound messages. This way we
1880         # can punt the logic of "what to do when we get a bounce"
1881         # to the scrip. We might want to notify nobody. Or just
1882         # the RT Owner. Or maybe all Privileged watchers.
1883         my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1884         $head->replace( 'RT-Squelch-Replies-To',    $Sender );
1885         $head->replace( 'RT-DetectedAutoGenerated', 'true' );
1886     }
1887     return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1888 }
1889
1890 =head2 IsCorrectAction
1891
1892 Returns a list of valid actions we've found for this message
1893
1894 =cut
1895
1896 sub IsCorrectAction {
1897     my $action = shift;
1898     my @actions = grep $_, split /-/, $action;
1899     return ( 0, '(no value)' ) unless @actions;
1900     foreach ( @actions ) {
1901         return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1902     }
1903     return ( 1, @actions );
1904 }
1905
1906 sub _RecordSendEmailFailure {
1907     my $ticket = shift;
1908     if ($ticket) {
1909         $ticket->_RecordNote(
1910             NoteType => 'SystemError',
1911             Content => "Sending the previous mail has failed.  Please contact your admin, they can find more details in the logs.",
1912         );
1913         return 1;
1914     }
1915     else {
1916         $RT::Logger->error( "Can't record send email failure as ticket is missing" );
1917         return;
1918     }
1919 }
1920
1921 RT::Base->_ImportOverlays();
1922
1923 1;