lib/RT/Interface/Email.pm

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