rt/lib/RT/Interface/Email.pm

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