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