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