rt/lib/RT/Interface/Email.pm

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