rt/lib/RT/Interface/Email.pm

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