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