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