rt/lib/RT/Interface/Email.pm

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