Master to 4.2.8
[usit-rt.git] / lib / RT / Interface / Email.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
320f0092 5# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
84fb5b46
MKG
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
49package RT::Interface::Email;
50
51use strict;
52use warnings;
53
54use Email::Address;
55use MIME::Entity;
56use RT::EmailParser;
57use File::Temp;
84fb5b46
MKG
58use Mail::Mailer ();
59use Text::ParseWords qw/shellwords/;
60
61BEGIN {
62 use base 'Exporter';
63 use vars qw ( @EXPORT_OK);
64
84fb5b46
MKG
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
103Takes a HEAD object of L<MIME::Head> class and returns true if the
104message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
105field of the head for test.
106
107=cut
108
109sub CheckForLoops {
110 my $head = shift;
111
112 # If this instance of RT sent it our, we don't want to take it in
c33a4027 113 my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" );
84fb5b46
MKG
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
126Takes a HEAD object of L<MIME::Head> class and returns true if sender
127is suspicious. Suspicious means mailer daemon.
128
129See also L</ParseSenderAddressFromHead>.
130
131=cut
132
133sub 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
403d7b0b
MKG
148 # If unparseable (non-ASCII), $From can come back undef
149 return undef if not defined $From;
150
84fb5b46
MKG
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
c33a4027
MKG
164Takes a HEAD object of L<MIME::Head> class and returns true if message is
165autogenerated. Checks C<Precedence>, C<Auto-Submitted>, and
166C<X-FC-Machinegenerated> fields of the head in tests.
84fb5b46
MKG
167
168=cut
169
170sub CheckForAutoGenerated {
171 my $head = shift;
172
c33a4027 173 if (grep { /^(bulk|junk)/i } $head->get_all("Precedence")) {
84fb5b46
MKG
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
194sub 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
204Sends 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
219add '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
5b0d0914
MKG
223=item LogLevel - log level under which we should write the subject and
224explanation message into the log, by default we log it as critical.
84fb5b46
MKG
225
226=back
227
228=cut
229
230sub 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'},
5b0d0914 245 message => "$args{Subject}: $args{'Explanation'}",
84fb5b46
MKG
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",
c33a4027
MKG
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') ),
84fb5b46
MKG
256 );
257
258 # only set precedence if the sysadmin wants us to
259 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
c33a4027
MKG
260 $entity_args{'Precedence:'} =
261 Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') );
84fb5b46
MKG
262 }
263
264 my $entity = MIME::Entity->build(%entity_args);
265 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
266
c33a4027
MKG
267 $entity->attach(
268 Type => "text/plain",
269 Charset => "UTF-8",
270 Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ),
271 );
84fb5b46
MKG
272
273 if ( $args{'MIMEObj'} ) {
274 $args{'MIMEObj'}->sync_headers;
275 $entity->add_part( $args{'MIMEObj'} );
276 }
277
278 if ( $args{'Attach'} ) {
c33a4027 279 $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' );
84fb5b46
MKG
280
281 }
282
283 SendEmail( Entity => $entity, Bounce => 1 );
284}
285
286
287=head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
288
289Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
290RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
291true value, the message will be marked as an autogenerated error, if
292possible. Sets Date field of the head to now if it's not set.
293
294If the C<X-RT-Squelch> header is set to any true value, the mail will
295not be sent. One use is to let extensions easily cancel outgoing mail.
296
297Ticket and Transaction arguments are optional. If Transaction is
298specified and Ticket is not then ticket of the transaction is
299used, but only if the transaction belongs to a ticket.
300
301Returns 1 on success, 0 on error or -1 if message has no recipients
302and hasn't been sent.
303
304=head3 Signing and Encrypting
305
306This function as well signs and/or encrypts the message according to
307headers of a transaction's attachment or properties of a ticket's queue.
308To get full access to the configuration Ticket and/or Transaction
309arguments must be provided, but you can force behaviour using Sign
310and/or Encrypt arguments.
311
312The following precedence of arguments are used to figure out if
313the 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
318header field then it's value is used
319
320* else properties of a queue of the Ticket are used.
321
322=cut
323
dab09ea8
MKG
324sub WillSignEncrypt {
325 my %args = @_;
326 my $attachment = delete $args{Attachment};
327 my $ticket = delete $args{Ticket};
328
af59614d 329 if ( not RT->Config->Get('Crypt')->{'Enable'} ) {
dab09ea8
MKG
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
84fb5b46
MKG
353sub 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
84fb5b46
MKG
365 unless ( $args{'Entity'} ) {
366 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
367 return 0;
368 }
369
c33a4027 370 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
84fb5b46
MKG
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
af59614d
MKG
387 if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
388 and !$args{'Entity'}->head->get("Precedence")
389 ) {
c33a4027 390 $args{'Entity'}->head->replace( 'Precedence', Encode::encode("UTF-8",$precedence) );
af59614d
MKG
391 }
392
84fb5b46
MKG
393 if ( $TransactionObj && !$TicketObj
394 && $TransactionObj->ObjectType eq 'RT::Ticket' )
395 {
396 $TicketObj = $TransactionObj->Object;
397 }
398
af59614d
MKG
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;
c33a4027 404 $head->replace( 'Date', Encode::encode("UTF-8",$date->RFC2822( Timezone => 'server' ) ) );
af59614d
MKG
405 }
406 unless ( $head->get('MIME-Version') ) {
407 # We should never have to set the MIME-Version header
c33a4027 408 $head->replace( 'MIME-Version', '1.0' );
af59614d
MKG
409 }
410 unless ( $head->get('Content-Transfer-Encoding') ) {
411 # fsck.com #5959: Since RT sends 8bit mail, we should say so.
c33a4027 412 $head->replace( 'Content-Transfer-Encoding', '8bit' );
af59614d
MKG
413 }
414
415 if ( RT->Config->Get('Crypt')->{'Enable'} ) {
dab09ea8
MKG
416 %args = WillSignEncrypt(
417 %args,
418 Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
419 Ticket => $TicketObj,
420 );
421 my $res = SignEncrypt( %args );
84fb5b46
MKG
422 return $res unless $res > 0;
423 }
424
84fb5b46
MKG
425 my $mail_command = RT->Config->Get('MailCommand');
426
84fb5b46
MKG
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'));
af59614d 433 push @args, "-t" unless grep {$_ eq "-t"} @args;
84fb5b46
MKG
434
435 # SetOutgoingMailFrom and bounces conflict, since they both want -f
436 if ( $args{'Bounce'} ) {
437 push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
01e3b242
MKG
438 } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
439 my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
440 my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
84fb5b46
MKG
441
442 if ($TicketObj) {
c33a4027
MKG
443 my $Queue = $TicketObj->QueueObj;
444 my $QueueAddressOverride = $Overrides->{$Queue->id}
445 || $Overrides->{$Queue->Name};
84fb5b46
MKG
446
447 if ($QueueAddressOverride) {
448 $OutgoingMailAddress = $QueueAddressOverride;
449 } else {
c33a4027
MKG
450 $OutgoingMailAddress ||= $Queue->CorrespondAddress
451 || RT->Config->Get('CorrespondAddress');
84fb5b46
MKG
452 }
453 }
01e3b242
MKG
454 elsif ($Overrides->{'Default'}) {
455 $OutgoingMailAddress = $Overrides->{'Default'};
456 }
84fb5b46
MKG
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 }
84fb5b46
MKG
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');
af59614d
MKG
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 {
84fb5b46
MKG
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
536Loads a template. Parses it using arguments if it's not empty.
537Returns a tuple (L<RT::Template> object, error message).
538
539Note that even if a template object is returned MIMEObj method
540may return undef for empty templates.
541
542=cut
543
544sub 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
566Sends email using a template, takes name of template, arguments for it and recipients.
567
568=cut
569
570sub 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
c33a4027 592 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ $_ } ) )
84fb5b46
MKG
593 foreach grep defined $args{$_}, qw(To Cc Bcc From);
594
c33a4027 595 $mail->head->replace( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) )
84fb5b46
MKG
596 foreach keys %{ $args{ExtraHeaders} };
597
598 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
599
600 return SendEmail( Entity => $mail );
601}
602
af59614d 603=head2 GetForwardFrom Ticket => undef, Transaction => undef
84fb5b46 604
af59614d 605Resolve the From field to use in forward mail
84fb5b46
MKG
606
607=cut
608
af59614d
MKG
609sub GetForwardFrom {
610 my %args = ( Ticket => undef, Transaction => undef, @_ );
611 my $txn = $args{Transaction};
612 my $ticket = $args{Ticket} || $txn->Object;
84fb5b46 613
af59614d
MKG
614 if ( RT->Config->Get('ForwardFromUser') ) {
615 return ( $txn || $ticket )->CurrentUser->EmailAddress;
84fb5b46 616 }
af59614d
MKG
617 else {
618 return $ticket->QueueObj->CorrespondAddress
619 || RT->Config->Get('CorrespondAddress');
84fb5b46 620 }
84fb5b46
MKG
621}
622
af59614d 623=head2 GetForwardAttachments Ticket => undef, Transaction => undef
84fb5b46 624
af59614d 625Resolve the Attachments to forward
84fb5b46
MKG
626
627=cut
628
af59614d 629sub GetForwardAttachments {
84fb5b46
MKG
630 my %args = ( Ticket => undef, Transaction => undef, @_ );
631 my $txn = $args{Transaction};
632 my $ticket = $args{Ticket} || $txn->Object;
633
af59614d
MKG
634 my $attachments = RT::Attachments->new( $ticket->CurrentUser );
635 if ($txn) {
636 $attachments->Limit( FIELD => 'TransactionId', VALUE => $txn->id );
84fb5b46
MKG
637 }
638 else {
af59614d
MKG
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 }
84fb5b46 648 }
af59614d 649 return $attachments;
84fb5b46
MKG
650}
651
af59614d 652
84fb5b46
MKG
653=head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
654
af59614d
MKG
655Signs and encrypts message using L<RT::Crypt>, but as well handle errors
656with users' keys.
84fb5b46
MKG
657
658If a recipient has no key or has other problems with it, then the
659unction sends a error to him using 'Error: public key' template.
660Also, notifies RT's owner using template 'Error to RT owner: public key'
661to inform that there are problems with users' keys. Then we filter
662all bad recipients and retry.
663
664Returns 1 on success, 0 on error and -1 if all recipients are bad and
665had been filtered out.
666
667=cut
668
669sub SignEncrypt {
670 my %args = (
671 Entity => undef,
672 Sign => 0,
673 Encrypt => 0,
674 @_
675 );
676 return 1 unless $args{'Sign'} || $args{'Encrypt'};
677
c33a4027 678 my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
84fb5b46
MKG
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
af59614d 684 my %res = RT::Crypt->SignEncrypt( %args );
84fb5b46
MKG
685 return 1 unless $res{'exit_code'};
686
af59614d
MKG
687 my @status = RT::Crypt->ParseStatus(
688 Protocol => $res{'Protocol'}, Status => $res{'status'},
689 );
84fb5b46
MKG
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
af59614d 753 %res = RT::Crypt->SignEncrypt( %args );
84fb5b46
MKG
754 return 0 if $res{'exit_code'};
755
756 return 1;
757}
758
759use MIME::Words ();
760
761=head2 EncodeToMIME
762
763Takes a hash with a String and a Charset. Returns the string encoded
764according to RFC2047, using B (base64 based) encoding.
765
766String must be a perl string, octets are returned.
767
768If Charset is not provided then $EmailOutputEncoding config option
769is used, or "latin-1" if that is not set.
770
771=cut
772
773sub 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
84fb5b46
MKG
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
834sub 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
895Takes a hash containing QueueObj, Head and CurrentUser objects.
896Returns a list of all email addresses in the To and Cc
403d7b0b 897headers b<except> the current Queue's email addresses, the CurrentUser's
84fb5b46
MKG
898email address and anything that the configuration sub RT::IsRTAddress matches.
899
900=cut
901
902sub 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 ),
c33a4027
MKG
916 map RT::EmailParser->CleanupAddresses( Email::Address->parse(
917 Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
84fb5b46
MKG
918 qw(To Cc);
919}
920
921
922
923=head2 ParseSenderAddressFromHead HEAD
924
403d7b0b
MKG
925Takes a MIME::Header object. Returns (user@host, friendly name, errors)
926where the first two values are the From (evaluated in order of
927Reply-To:, From:, Sender).
928
929A list of error messages may be returned even when a Sender value is
930found, since it could be a parse error for another (checked earlier)
931sender field. In this case, the errors aren't fatal, but may be useful
932to investigate the parse failure.
84fb5b46
MKG
933
934=cut
935
936sub ParseSenderAddressFromHead {
937 my $head = shift;
403d7b0b
MKG
938 my @sender_headers = ('Reply-To', 'From', 'Sender');
939 my @errors; # Accumulate any errors
84fb5b46
MKG
940
941 #Figure out who's sending this message.
403d7b0b 942 foreach my $header ( @sender_headers ) {
c33a4027 943 my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
84fb5b46
MKG
944 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
945 # only return if the address is not empty
403d7b0b
MKG
946 return ($addr, $name, @errors) if $addr;
947
948 chomp $addr_line;
949 push @errors, "$header: $addr_line";
84fb5b46
MKG
950 }
951
403d7b0b 952 return (undef, undef, @errors);
84fb5b46
MKG
953}
954
955=head2 ParseErrorsToAddressFromHead HEAD
956
957Takes a MIME::Header object. Return a single value : user@host
958of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
959From:, Sender)
960
961=cut
962
963sub 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
c33a4027 971 my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
84fb5b46
MKG
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
985Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
986
987=cut
988
989sub 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
1006Gets a head object and list of addresses.
1007Deletes addresses from To, Cc or Bcc fields.
1008
1009=cut
1010
1011sub DeleteRecipientsFromHead {
1012 my $head = shift;
1013 my %skip = map { lc $_ => 1 } @_;
1014
1015 foreach my $field ( qw(To Cc Bcc) ) {
c33a4027 1016 $head->replace( $field => Encode::encode( "UTF-8",
84fb5b46 1017 join ', ', map $_->format, grep !$skip{ lc $_->address },
c33a4027 1018 Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) )
84fb5b46
MKG
1019 );
1020 }
1021}
1022
1023sub 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
1039sub 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') ) {
c33a4027 1051 @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift );
84fb5b46
MKG
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'} ) {
af59614d 1067 my $pseudo_ref = PseudoReference( $args{'Ticket'} );
84fb5b46
MKG
1068 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1069 }
af59614d 1070 splice @references, 4, -6
84fb5b46
MKG
1071 if @references > 10;
1072
1073 my $mail = $args{'Message'};
c33a4027
MKG
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) );
dab09ea8
MKG
1076}
1077
af59614d
MKG
1078sub PseudoReference {
1079 my $ticket = shift;
1080 return '<RT-Ticket-'. $ticket->id .'@'. RT->Config->Get('Organization') .'>';
1081}
1082
c33a4027
MKG
1083=head2 ExtractTicketId
1084
1085Passed a MIME::Entity. Returns a ticket id or undef to signal 'new ticket'.
1086
1087This is a great entry point if you need to customize how ticket ids are
1088handled for your site. RT-Extension-RepliesToResolved demonstrates one
1089possible use for this extension.
1090
1091If the Subject of this ticket is modified, it will be reloaded by the
1092mail gateway code before Ticket creation.
1093
1094=cut
1095
dab09ea8
MKG
1096sub ExtractTicketId {
1097 my $entity = shift;
1098
c33a4027 1099 my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' );
dab09ea8
MKG
1100 chomp $subject;
1101 return ParseTicketId( $subject );
84fb5b46
MKG
1102}
1103
c33a4027
MKG
1104=head2 ParseTicketId
1105
1106Takes a string and searches for [subjecttag #id]
1107
1108Returns the id if a match is found. Otherwise returns undef.
1109
1110=cut
1111
84fb5b46
MKG
1112sub 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
af59614d
MKG
1118 # We use @captures and pull out the last capture value to guard against
1119 # someone using (...) instead of (?:...) in $EmailSubjectTagRegex.
84fb5b46 1120 my $id;
af59614d
MKG
1121 if ( my @captures = $Subject =~ /\[$test_name\s+\#(\d+)\s*\]/i ) {
1122 $id = $captures[-1];
84fb5b46
MKG
1123 } else {
1124 foreach my $tag ( RT->System->SubjectTag ) {
af59614d
MKG
1125 next unless my @captures = $Subject =~ /\[\Q$tag\E\s+\#(\d+)\s*\]/i;
1126 $id = $captures[-1];
84fb5b46
MKG
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
1136sub 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
1165Takes parameters:
1166
1167 action
1168 queue
1169 message
1170
1171
1172This performs all the "guts" of the mail rt-mailgate program, and is
1173designed to be called from the web interface with a message, user
1174object, and so on.
1175
1176Can also take an optional 'ticket' parameter; this ticket id overrides
1177any ticket id found in the subject.
1178
1179Returns:
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
1198sub _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
1225sub 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
af59614d
MKG
1275 #Set up a queue object
1276 my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
1277 $SystemQueueObj->Load( $args{'queue'} );
1278
84fb5b46
MKG
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'},
af59614d
MKG
1290 Queue => $SystemQueueObj,
1291 Actions => \@actions,
84fb5b46
MKG
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'},
af59614d
MKG
1303 Queue => $SystemQueueObj,
1304 Actions => \@actions,
84fb5b46
MKG
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;
403d7b0b 1316 $parser->RescueOutlook;
84fb5b46
MKG
1317 $parser->_PostProcessNewEntity;
1318
1319 my $head = $Message->head;
1320 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
af59614d 1321 my $Sender = (ParseSenderAddressFromHead( $head ))[0];
c33a4027 1322 my $From = Encode::decode( "UTF-8", $head->get("From") );
af59614d 1323 chomp $From if defined $From;
84fb5b46 1324
c33a4027 1325 my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') )
84fb5b46
MKG
1326 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1327
1328 #Pull apart the subject line
c33a4027 1329 my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || '');
84fb5b46
MKG
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
dab09ea8 1349 $args{'ticket'} ||= ExtractTicketId( $Message );
84fb5b46 1350
403d7b0b 1351 # ExtractTicketId may have been overridden, and edited the Subject
c33a4027 1352 my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') );
403d7b0b
MKG
1353 chomp $NewSubject;
1354
84fb5b46
MKG
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
84fb5b46
MKG
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,
af59614d
MKG
1404 ($CurrentUser->EmailAddress || $CurrentUser->Name)
1405 . " ($Sender) tried to submit a message to "
84fb5b46
MKG
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
403d7b0b
MKG
1436 $head->replace('X-RT-Interface' => 'Email');
1437
84fb5b46
MKG
1438 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1439 Queue => $SystemQueueObj->Id,
403d7b0b 1440 Subject => $NewSubject,
84fb5b46
MKG
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 );
af59614d 1452 return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket );
84fb5b46
MKG
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,
5b0d0914 1493 Subject => "Message not recorded ($method): $Subject",
84fb5b46
MKG
1494 Explanation => $msg,
1495 MIMEObj => $Message
1496 );
af59614d 1497 return ( 0, "Message From: $From not recorded: $msg", $Ticket );
84fb5b46
MKG
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
1523sub 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
1586sub _RunUnsafeAction {
1587 my %args = (
1588 Action => undef,
1589 ErrorsTo => undef,
1590 Message => undef,
1591 Ticket => undef,
1592 CurrentUser => undef,
1593 @_
1594 );
1595
c33a4027 1596 my $From = Encode::decode( "UTF-8", $args{Message}->head->get("From") );
af59614d 1597
84fb5b46
MKG
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 );
af59614d 1607 return ( 0, "Ticket not taken, by email From: $From" );
84fb5b46
MKG
1608 }
1609 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
dab09ea8
MKG
1610 my $new_status = $args{'Ticket'}->FirstInactiveStatus;
1611 if ($new_status) {
1612 my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
1613 unless ($status) {
84fb5b46 1614
dab09ea8
MKG
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 );
af59614d 1622 return ( 0, "Ticket not resolved, by email From: $From" );
dab09ea8 1623 }
84fb5b46
MKG
1624 }
1625 } else {
af59614d 1626 return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} );
84fb5b46
MKG
1627 }
1628 return ( 1, "Success" );
1629}
1630
1631=head2 _NoAuthorizedUserFound
1632
1633Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1634
1635=cut
1636
1637sub _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,
1651RT could not load a valid user, and RT's configuration does not allow
1652for the creation of a new user for this email (@{[$args{Requestor}]}).
1653
1654You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1655queue @{[$args{'Queue'}]}.
1656
1657EOT
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,
1668RT could not load a valid user, and RT's configuration does not allow
1669for the creation of a new user for your email.
1670
1671EOT
1672 MIMEObj => $args{'Message'},
1673 LogLevel => 'error'
1674 );
1675 }
1676}
1677
1678=head2 _HandleMachineGeneratedMail
1679
1680Takes named params:
1681 Message
1682 ErrorsTo
1683 Subject
1684
1685Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1686Returns 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
1691sub _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);
c33a4027 1752 $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) );
84fb5b46
MKG
1753 $head->replace( 'RT-DetectedAutoGenerated', 'true' );
1754 }
1755 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1756}
1757
1758=head2 IsCorrectAction
1759
1760Returns a list of valid actions we've found for this message
1761
1762=cut
1763
1764sub 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
1774sub _RecordSendEmailFailure {
1775 my $ticket = shift;
1776 if ($ticket) {
c33a4027
MKG
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,
84fb5b46
MKG
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
af59614d
MKG
1790=head2 ConvertHTMLToText HTML
1791
320f0092
MKG
1792Takes HTML and converts it to plain text. Appropriate for generating a
1793plain text part from an HTML part of an email. Returns undef if
1794conversion fails.
af59614d
MKG
1795
1796=cut
1797
1798sub ConvertHTMLToText {
1799 my $html = shift;
1800
1801 require HTML::FormatText::WithLinks::AndTables;
320f0092
MKG
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;
af59614d
MKG
1820}
1821
320f0092 1822
84fb5b46
MKG
1823RT::Base->_ImportOverlays();
1824
18251;