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