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