rt/lib/RT/Interface/Email.pm

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