rt/lib/RT/Interface/Email.pm

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