1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
6 # <jesse@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
49 package RT::Interface::Email;
58 use UNIVERSAL::require;
63 use vars qw ( @EXPORT_OK);
65 # set the version for version checking
68 # your exported package globals go here,
69 # as well as any optionally exported functions
74 &CheckForSuspiciousSender
75 &CheckForAutoGenerated
78 &ParseCcAddressesFromHead
79 &ParseSenderAddressFromHead
80 &ParseErrorsToAddressFromHead
81 &ParseAddressFromHeader
88 RT::Interface::Email - helper functions for parsing email sent to RT
92 use lib "!!RT_LIB_PATH!!";
93 use lib "!!RT_ETC_PATH!!";
95 use RT::Interface::Email qw(Gateway CreateUser);
104 =head2 CheckForLoops HEAD
106 Takes a HEAD object of L<MIME::Head> class and returns true if the
107 message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
108 field of the head for test.
115 # If this instance of RT sent it our, we don't want to take it in
116 my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
117 chomp ($RTLoop); # remove that newline
118 if ( $RTLoop eq RT->Config->Get('rtname') ) {
122 # TODO: We might not trap the case where RT instance A sends a mail
123 # to RT instance B which sends a mail to ...
127 =head2 CheckForSuspiciousSender HEAD
129 Takes a HEAD object of L<MIME::Head> class and returns true if sender
130 is suspicious. Suspicious means mailer daemon.
132 See also L</ParseSenderAddressFromHead>.
136 sub CheckForSuspiciousSender {
139 #if it's from a postmaster or mailer daemon, it's likely a bounce.
141 #TODO: better algorithms needed here - there is no standards for
142 #bounces, so it's very difficult to separate them from anything
143 #else. At the other hand, the Return-To address is only ment to be
144 #used as an error channel, we might want to put up a separate
145 #Return-To address which is treated differently.
147 #TODO: search through the whole email and find the right Ticket ID.
149 my ( $From, $junk ) = ParseSenderAddressFromHead($head);
151 if ( ( $From =~ /^mailer-daemon\@/i )
152 or ( $From =~ /^postmaster\@/i )
162 =head2 CheckForAutoGenerated HEAD
164 Takes a HEAD object of L<MIME::Head> class and returns true if message
165 is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated'
166 fields of the head in tests.
170 sub CheckForAutoGenerated {
173 my $Precedence = $head->get("Precedence") || "";
174 if ( $Precedence =~ /^(bulk|junk)/i ) {
178 # Per RFC3834, any Auto-Submitted header which is not "no" means
179 # it is auto-generated.
180 my $AutoSubmitted = $head->get("Auto-Submitted") || "";
181 if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
185 # First Class mailer uses this as a clue.
186 my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
187 if ( $FCJunk =~ /^true/i ) {
198 my $ReturnPath = $head->get("Return-path") || "";
199 return ( $ReturnPath =~ /<>/ );
203 =head2 MailError PARAM HASH
205 Sends an error message. Takes a param hash:
209 =item From - sender's address, by default is 'CorrespondAddress';
211 =item To - recipient, by default is 'OwnerEmail';
213 =item Bcc - optional Bcc recipients;
215 =item Subject - subject of the message, default is 'There has been an error';
217 =item Explanation - main content of the error, default value is 'Unexplained error';
219 =item MIMEObj - optional MIME entity that's attached to the error mail, as well we
220 add 'In-Reply-To' field to the error that points to this message.
222 =item Attach - optional text that attached to the error as 'message/rfc822' part.
224 =item LogLevel - log level under which we should write explanation message into the
225 log, by default we log it as critical.
233 To => RT->Config->Get('OwnerEmail'),
235 From => RT->Config->Get('CorrespondAddress'),
236 Subject => 'There has been an error',
237 Explanation => 'Unexplained error',
245 level => $args{'LogLevel'},
246 message => $args{'Explanation'}
247 ) if $args{'LogLevel'};
249 # the colons are necessary to make ->build include non-standard headers
251 Type => "multipart/mixed",
252 From => $args{'From'},
255 Subject => $args{'Subject'},
256 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
259 # only set precedence if the sysadmin wants us to
260 if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
261 $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
264 my $entity = MIME::Entity->build(%entity_args);
265 SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
267 $entity->attach( Data => $args{'Explanation'} . "\n" );
269 if ( $args{'MIMEObj'} ) {
270 $args{'MIMEObj'}->sync_headers;
271 $entity->add_part( $args{'MIMEObj'} );
274 if ( $args{'Attach'} ) {
275 $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
279 SendEmail( Entity => $entity, Bounce => 1 );
283 =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
285 Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
286 RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
287 true value, the message will be marked as an autogenerated error, if
288 possible. Sets Date field of the head to now if it's not set.
290 If the C<X-RT-Squelch> header is set to any true value, the mail will
291 not be sent. One use is to let extensions easily cancel outgoing mail.
293 Ticket and Transaction arguments are optional. If Transaction is
294 specified and Ticket is not then ticket of the transaction is
295 used, but only if the transaction belongs to a ticket.
297 Returns 1 on success, 0 on error or -1 if message has no recipients
298 and hasn't been sent.
300 =head3 Signing and Encrypting
302 This function as well signs and/or encrypts the message according to
303 headers of a transaction's attachment or properties of a ticket's queue.
304 To get full access to the configuration Ticket and/or Transaction
305 arguments must be provided, but you can force behaviour using Sign
306 and/or Encrypt arguments.
308 The following precedence of arguments are used to figure out if
309 the message should be encrypted and/or signed:
311 * if Sign or Encrypt argument is defined then its value is used
313 * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
314 header field then it's value is used
316 * else properties of a queue of the Ticket are used.
325 Transaction => undef,
329 my $TicketObj = $args{'Ticket'};
330 my $TransactionObj = $args{'Transaction'};
332 foreach my $arg( qw(Entity Bounce) ) {
333 next unless defined $args{ lc $arg };
335 $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
336 $args{ $arg } = delete $args{ lc $arg };
339 unless ( $args{'Entity'} ) {
340 $RT::Logger->crit( "Could not send mail without 'Entity' object" );
344 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
347 # If we don't have any recipients to send to, don't send a message;
348 unless ( $args{'Entity'}->head->get('To')
349 || $args{'Entity'}->head->get('Cc')
350 || $args{'Entity'}->head->get('Bcc') )
352 $RT::Logger->info( $msgid . " No recipients found. Not sending." );
356 if ($args{'Entity'}->head->get('X-RT-Squelch')) {
357 $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
361 if ( $TransactionObj && !$TicketObj
362 && $TransactionObj->ObjectType eq 'RT::Ticket' )
364 $TicketObj = $TransactionObj->Object;
367 if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
371 $attachment = $TransactionObj->Attachments->First
374 foreach my $argument ( qw(Sign Encrypt) ) {
375 next if defined $args{ $argument };
377 if ( $attachment && defined $attachment->GetHeader("X-RT-$argument") ) {
378 $crypt{$argument} = $attachment->GetHeader("X-RT-$argument");
379 } elsif ( $TicketObj ) {
380 $crypt{$argument} = $TicketObj->QueueObj->$argument();
384 my $res = SignEncrypt( %args, %crypt );
385 return $res unless $res > 0;
388 unless ( $args{'Entity'}->head->get('Date') ) {
390 my $date = RT::Date->new( $RT::SystemUser );
392 $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
395 my $mail_command = RT->Config->Get('MailCommand');
397 if ($mail_command eq 'testfile') {
398 $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
401 # if it is a sub routine, we just return it;
402 return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
404 if ( $mail_command eq 'sendmailpipe' ) {
405 my $path = RT->Config->Get('SendmailPath');
406 my $args = RT->Config->Get('SendmailArguments');
408 # SetOutgoingMailFrom
409 if ( RT->Config->Get('SetOutgoingMailFrom') ) {
410 my $OutgoingMailAddress;
413 my $QueueName = $TicketObj->QueueObj->Name;
414 my $QueueAddressOverride = RT->Config->Get('OverrideOutgoingMailFrom')->{$QueueName};
416 if ($QueueAddressOverride) {
417 $OutgoingMailAddress = $QueueAddressOverride;
419 $OutgoingMailAddress = $TicketObj->QueueObj->CorrespondAddress;
423 $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'};
425 $args .= " -f $OutgoingMailAddress"
426 if $OutgoingMailAddress;
429 # Set Bounce Arguments
430 $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'};
433 if ( $TransactionObj and
434 my $prefix = RT->Config->Get('VERPPrefix') and
435 my $domain = RT->Config->Get('VERPDomain') )
437 my $from = $TransactionObj->CreatorObj->EmailAddress;
440 $args .= " -f $prefix$from\@$domain";
444 # don't ignore CHLD signal to get proper exit code
445 local $SIG{'CHLD'} = 'DEFAULT';
447 open my $mail, "|$path $args" or die "couldn't execute program: $!";
449 # if something wrong with $mail->print we will get PIPE signal, handle it
450 local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
451 $args{'Entity'}->print($mail);
453 unless ( close $mail ) {
454 die "close pipe failed: $!" if $!; # system error
455 # sendmail exit statuses mostly errors with data not software
456 # TODO: status parsing: core dump, exit on signal or EX_*
457 my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8);
458 $msg = ", interrupted by signal ". ($?&127) if $?&127;
459 $RT::Logger->error( $msg );
463 $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ );
467 elsif ( $mail_command eq 'smtp' ) {
469 my $smtp = do { local $@; eval { Net::SMTP->new(
470 Host => RT->Config->Get('SMTPServer'),
471 Debug => RT->Config->Get('SMTPDebug'),
474 $RT::Logger->crit( "Could not connect to SMTP server.");
478 # duplicate head as we want drop Bcc field
479 my $head = $args{'Entity'}->head->dup;
480 my @recipients = map $_->address, map
481 Email::Address->parse($head->get($_)), qw(To Cc Bcc);
482 $head->delete('Bcc');
484 my $sender = RT->Config->Get('SMTPFrom')
485 || $args{'Entity'}->head->get('From');
488 my $status = $smtp->mail( $sender )
489 && $smtp->recipient( @recipients );
493 my $fh = $smtp->tied_fh;
496 $args{'Entity'}->print_body( $fh );
502 $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
507 local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
509 my @mailer_args = ($mail_command);
510 if ( $mail_command eq 'sendmail' ) {
511 $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
512 push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
515 push @mailer_args, RT->Config->Get('MailParams');
518 unless ( $args{'Entity'}->send( @mailer_args ) ) {
519 $RT::Logger->crit( "$msgid: Could not send mail." );
526 =head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
528 Loads a template. Parses it using arguments if it's not empty.
529 Returns a tuple (L<RT::Template> object, error message).
531 Note that even if a template object is returned MIMEObj method
532 may return undef for empty templates.
536 sub PrepareEmailUsingTemplate {
543 my $template = RT::Template->new( $RT::SystemUser );
544 $template->LoadGlobalTemplate( $args{'Template'} );
545 unless ( $template->id ) {
546 return (undef, "Couldn't load template '". $args{'Template'} ."'");
548 return $template if $template->IsEmpty;
550 my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
551 return (undef, $msg) unless $status;
556 =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
558 Sends email using a template, takes name of template, arguments for it and recipients.
562 sub SendEmailUsingTemplate {
569 From => RT->Config->Get('CorrespondAddress'),
574 my ($template, $msg) = PrepareEmailUsingTemplate( %args );
575 return (0, $msg) unless $template;
577 my $mail = $template->MIMEObj;
579 $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
583 $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
584 foreach grep defined $args{$_}, qw(To Cc Bcc From);
586 SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
588 return SendEmail( Entity => $mail );
591 =head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
593 Forwards transaction with all attachments as 'message/rfc822'.
597 sub ForwardTransaction {
599 my %args = ( To => '', Cc => '', Bcc => '', @_ );
601 my $entity = $txn->ContentAsMIME;
603 return SendForward( %args, Entity => $entity, Transaction => $txn );
606 =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
608 Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
614 my %args = ( To => '', Cc => '', Bcc => '', @_ );
616 my $txns = $ticket->Transactions;
620 ) for qw(Create Correspond);
622 my $entity = MIME::Entity->build(
623 Type => 'multipart/mixed',
625 $entity->add_part( $_ ) foreach
626 map $_->ContentAsMIME,
627 @{ $txns->ItemsArrayRef };
629 return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' );
632 =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
634 Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
642 Transaction => undef,
643 Template => 'Forward',
644 To => '', Cc => '', Bcc => '',
648 my $txn = $args{'Transaction'};
649 my $ticket = $args{'Ticket'};
650 $ticket ||= $txn->Object if $txn;
652 my $entity = $args{'Entity'};
655 $RT::Logger->error(Carp::longmess("No entity provided"));
656 return (0, $ticket->loc("Couldn't send email"));
659 my ($template, $msg) = PrepareEmailUsingTemplate(
660 Template => $args{'Template'},
669 $mail = $template->MIMEObj;
671 $RT::Logger->warning($msg);
674 $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
677 unless ( $args{'Transaction'} ) {
678 $description = 'This is forward of ticket #'. $ticket->id;
680 $description = 'This is forward of transaction #'
681 . $txn->id ." of a ticket #". $txn->ObjectId;
683 $mail = MIME::Entity->build(
684 Type => 'text/plain',
685 Data => $description,
689 $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
690 foreach grep defined $args{$_}, qw(To Cc Bcc);
693 Type => 'message/rfc822',
694 Disposition => 'attachment',
695 Description => 'forwarded message',
696 Data => $entity->as_string,
701 $subject = $txn->Subject if $txn;
702 $subject ||= $ticket->Subject if $ticket;
703 if ( RT->Config->Get('ForwardFromUser') ) {
704 $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress;
706 # XXX: what if want to forward txn of other object than ticket?
707 $subject = AddSubjectTag( $subject, $ticket );
708 $from = $ticket->QueueObj->CorrespondAddress
709 || RT->Config->Get('CorrespondAddress');
711 $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
712 $mail->head->set( From => EncodeToMIME( String => $from ) );
714 my $status = RT->Config->Get('ForwardFromUser')
715 # never sign if we forward from User
716 ? SendEmail( %args, Entity => $mail, Sign => 0 )
717 : SendEmail( %args, Entity => $mail );
718 return (0, $ticket->loc("Couldn't send email")) unless $status;
719 return (1, $ticket->loc("Send email successfully"));
722 =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
724 Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
725 handle errors with users' keys.
727 If a recipient has no key or has other problems with it, then the
728 unction sends a error to him using 'Error: public key' template.
729 Also, notifies RT's owner using template 'Error to RT owner: public key'
730 to inform that there are problems with users' keys. Then we filter
731 all bad recipients and retry.
733 Returns 1 on success, 0 on error and -1 if all recipients are bad and
734 had been filtered out.
745 return 1 unless $args{'Sign'} || $args{'Encrypt'};
747 my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
750 $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
751 $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
753 require RT::Crypt::GnuPG;
754 my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
755 return 1 unless $res{'exit_code'};
757 my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
760 foreach my $line ( @status ) {
761 # if the passphrase fails, either you have a bad passphrase
762 # or gpg-agent has died. That should get caught in Create and
763 # Update, but at least throw an error here
764 if (($line->{'Operation'}||'') eq 'PassphraseCheck'
765 && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
766 $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
769 next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
770 next if $line->{'Status'} eq 'DONE';
771 $RT::Logger->error( $line->{'Message'} );
772 push @bad_recipients, $line;
774 return 0 unless @bad_recipients;
776 $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
777 foreach @bad_recipients;
779 foreach my $recipient ( @bad_recipients ) {
780 my $status = SendEmailUsingTemplate(
781 To => $recipient->{'AddressObj'}->address,
782 Template => 'Error: public key',
785 TicketObj => $args{'Ticket'},
786 TransactionObj => $args{'Transaction'},
790 $RT::Logger->error("Couldn't send 'Error: public key'");
794 my $status = SendEmailUsingTemplate(
795 To => RT->Config->Get('OwnerEmail'),
796 Template => 'Error to RT owner: public key',
798 BadRecipients => \@bad_recipients,
799 TicketObj => $args{'Ticket'},
800 TransactionObj => $args{'Transaction'},
804 $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
807 DeleteRecipientsFromHead(
808 $args{'Entity'}->head,
809 map $_->{'AddressObj'}->address, @bad_recipients
812 unless ( $args{'Entity'}->head->get('To')
813 || $args{'Entity'}->head->get('Cc')
814 || $args{'Entity'}->head->get('Bcc') )
816 $RT::Logger->debug("$msgid No recipients that have public key, not sending");
820 # redo without broken recipients
821 %res = RT::Crypt::GnuPG::SignEncrypt( %args );
822 return 0 if $res{'exit_code'};
831 Takes a hash with a String and a Charset. Returns the string encoded
832 according to RFC2047, using B (base64 based) encoding.
834 String must be a perl string, octets are returned.
836 If Charset is not provided then $EmailOutputEncoding config option
837 is used, or "latin-1" if that is not set.
847 my $value = $args{'String'};
848 return $value unless $value; # 0 is perfect ascii
849 my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
852 # using RFC2047 notation, sec 2.
853 # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
855 # An 'encoded-word' may not be more than 75 characters long
857 # MIME encoding increases 4/3*(number of bytes), and always in multiples
858 # of 4. Thus we have to find the best available value of bytes available
861 # First we get the integer max which max*4/3 would fit on space.
862 # Then we find the greater multiple of 3 lower or equal than $max.
864 ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
868 $max = int( $max / 3 ) * 3;
875 $RT::Logger->crit("Can't encode! Charset or encoding too big.");
879 return ($value) unless $value =~ /[^\x20-\x7e]/;
883 # we need perl string to split thing char by char
884 Encode::_utf8_on($value) unless Encode::is_utf8($value);
886 my ( $tmp, @chunks ) = ( '', () );
887 while ( length $value ) {
888 my $char = substr( $value, 0, 1, '' );
889 my $octets = Encode::encode( $charset, $char );
890 if ( length($tmp) + length($octets) > $max ) {
896 push @chunks, $tmp if length $tmp;
898 # encode an join chuncks
900 map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
906 my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
908 my $NewUser = RT::User->new( $RT::SystemUser );
910 my ( $Val, $Message ) = $NewUser->Create(
911 Name => ( $Username || $Address ),
912 EmailAddress => $Address,
916 Comments => 'Autocreated on ticket submission',
921 # Deal with the race condition of two account creations at once
923 $NewUser->LoadByName($Username);
926 unless ( $NewUser->Id ) {
927 $NewUser->LoadByEmail($Address);
930 unless ( $NewUser->Id ) {
933 Subject => "User could not be created",
935 "User creation failed in mailgateway: $Message",
942 #Load the new user object
943 my $CurrentUser = new RT::CurrentUser;
944 $CurrentUser->LoadByEmail( $Address );
946 unless ( $CurrentUser->id ) {
947 $RT::Logger->warning(
948 "Couldn't load user '$Address'." . "giving up" );
951 Subject => "User could not be loaded",
953 "User '$Address' could not be loaded in the mail gateway",
964 =head2 ParseCcAddressesFromHead HASH
966 Takes a hash containing QueueObj, Head and CurrentUser objects.
967 Returns a list of all email addresses in the To and Cc
968 headers b<except> the current Queue\'s email addresses, the CurrentUser\'s
969 email address and anything that the configuration sub RT::IsRTAddress matches.
973 sub ParseCcAddressesFromHead {
977 CurrentUser => undef,
981 my $current_address = lc $args{'CurrentUser'}->EmailAddress;
982 my $user = $args{'CurrentUser'}->UserObj;
985 grep $_ ne $current_address && !RT::EmailParser->IsRTAddress( $_ ),
986 map lc $user->CanonicalizeEmailAddress( $_->address ),
987 map Email::Address->parse( $args{'Head'}->get( $_ ) ),
993 =head2 ParseSenderAddressFromHead HEAD
995 Takes a MIME::Header object. Returns a tuple: (user@host, friendly name)
996 of the From (evaluated in order of Reply-To:, From:, Sender)
1000 sub ParseSenderAddressFromHead {
1003 #Figure out who's sending this message.
1004 foreach my $header ('Reply-To', 'From', 'Sender') {
1005 my $addr_line = $head->get($header) || next;
1006 my ($addr, $name) = ParseAddressFromHeader( $addr_line );
1007 # only return if the address is not empty
1008 return ($addr, $name) if $addr;
1011 return (undef, undef);
1014 =head2 ParseErrorsToAddressFromHead HEAD
1016 Takes a MIME::Header object. Return a single value : user@host
1017 of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
1022 sub ParseErrorsToAddressFromHead {
1025 #Figure out who's sending this message.
1027 foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
1029 # If there's a header of that name
1030 my $headerobj = $head->get($header);
1032 my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
1034 # If it's got actual useful content...
1035 return ($addr) if ($addr);
1042 =head2 ParseAddressFromHeader ADDRESS
1044 Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
1048 sub ParseAddressFromHeader {
1051 # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
1052 $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
1053 my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
1055 my ($AddrObj) = grep ref $_, @Addresses;
1056 unless ( $AddrObj ) {
1057 return ( undef, undef );
1060 my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address );
1062 #Lets take the from and load a user object.
1063 my $Address = $AddrObj->address;
1065 return ( $Address, $Name );
1068 =head2 DeleteRecipientsFromHead HEAD RECIPIENTS
1070 Gets a head object and list of addresses.
1071 Deletes addresses from To, Cc or Bcc fields.
1075 sub DeleteRecipientsFromHead {
1077 my %skip = map { lc $_ => 1 } @_;
1079 foreach my $field ( qw(To Cc Bcc) ) {
1080 $head->set( $field =>
1081 join ', ', map $_->format, grep !$skip{ lc $_->address },
1082 Email::Address->parse( $head->get( $field ) )
1091 ScripAction => undef,
1094 my $org = RT->Config->Get('Organization');
1095 my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
1096 my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
1097 my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
1099 return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
1100 . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
1110 return unless $args{'Message'} && $args{'InReplyTo'};
1112 my $get_header = sub {
1114 if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
1115 @res = $args{'InReplyTo'}->head->get( shift );
1117 @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
1119 return grep length, map { split /\s+/m, $_ } grep defined, @res;
1122 my @id = $get_header->('Message-ID');
1123 #XXX: custom header should begin with X- otherwise is violation of the standard
1124 my @rtid = $get_header->('RT-Message-ID');
1125 my @references = $get_header->('References');
1126 unless ( @references ) {
1127 @references = $get_header->('In-Reply-To');
1129 push @references, @id, @rtid;
1130 if ( $args{'Ticket'} ) {
1131 my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
1132 push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
1134 @references = splice @references, 4, -6
1135 if @references > 10;
1137 my $mail = $args{'Message'};
1138 $mail->head->set( 'In-Reply-To' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid;
1139 $mail->head->set( 'References' => join ' ', @references );
1143 my $Subject = shift;
1145 my $rtname = RT->Config->Get('rtname');
1146 my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
1149 if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
1152 foreach my $tag ( RT->System->SubjectTag ) {
1153 next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
1158 return undef unless $id;
1160 $RT::Logger->debug("Found a ticket ID. It's $id");
1165 my $subject = shift;
1167 unless ( ref $ticket ) {
1168 my $tmp = RT::Ticket->new( $RT::SystemUser );
1169 $tmp->Load( $ticket );
1172 my $id = $ticket->id;
1173 my $queue_tag = $ticket->QueueObj->SubjectTag;
1175 my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
1176 unless ( $tag_re ) {
1177 my $tag = $queue_tag || RT->Config->Get('rtname');
1178 $tag_re = qr/\Q$tag\E/;
1179 } elsif ( $queue_tag ) {
1180 $tag_re = qr/$tag_re|\Q$queue_tag\E/;
1182 return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
1184 $subject =~ s/(\r\n|\n|\s)/ /gi;
1186 return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
1190 =head2 Gateway ARGSREF
1200 This performs all the "guts" of the mail rt-mailgate program, and is
1201 designed to be called from the web interface with a message, user
1204 Can also take an optional 'ticket' parameter; this ticket id overrides
1205 any ticket id found in the subject.
1211 (status code, message, optional ticket object)
1213 status code is a numeric value.
1215 for temporary failures, the status code should be -75
1217 for permanent failures which are handled by RT, the status code
1220 for succces, the status code should be 1
1227 my @mail_plugins = @_;
1230 foreach my $plugin (@mail_plugins) {
1231 if ( ref($plugin) eq "CODE" ) {
1233 } elsif ( !ref $plugin ) {
1234 my $Class = $plugin;
1235 $Class = "RT::Interface::Email::" . $Class
1236 unless $Class =~ /^RT::Interface::Email::/;
1238 do { $RT::Logger->error("Couldn't load $Class: $@"); next };
1241 unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
1242 $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
1247 $RT::Logger->crit( "$plugin - is not class name or code reference");
1254 my $argsref = shift;
1256 action => 'correspond',
1266 # Validate the action
1267 my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
1271 "Invalid 'action' parameter "
1279 my $parser = RT::EmailParser->new();
1280 $parser->SmartParseMIMEEntityFromScalar(
1281 Message => $args{'message'},
1286 my $Message = $parser->Entity();
1289 Subject => "RT Bounce: Unparseable message",
1290 Explanation => "RT couldn't process the message below",
1291 Attach => $args{'message'}
1295 "Failed to parse this message. Something is likely badly wrong with the message"
1299 my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
1300 push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
1301 @mail_plugins = _LoadPlugins( @mail_plugins );
1304 foreach my $class( grep !ref, @mail_plugins ) {
1305 # check if we should apply filter before decoding
1308 *{ $class . "::ApplyBeforeDecode" }{CODE};
1310 next unless defined $check_cb;
1311 next unless $check_cb->(
1312 Message => $Message,
1313 RawMessageRef => \$args{'message'},
1316 $skip_plugin{ $class }++;
1320 *{ $class . "::GetCurrentUser" }{CODE};
1322 my ($status, $msg) = $Code->(
1323 Message => $Message,
1324 RawMessageRef => \$args{'message'},
1326 next if $status > 0;
1328 if ( $status == -2 ) {
1329 return (1, $msg, undef);
1330 } elsif ( $status == -1 ) {
1331 return (0, $msg, undef);
1334 @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
1335 $parser->_DecodeBodies;
1336 $parser->_PostProcessNewEntity;
1338 my $head = $Message->head;
1339 my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
1341 my $MessageId = $head->get('Message-ID')
1342 || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
1344 #Pull apart the subject line
1345 my $Subject = $head->get('Subject') || '';
1348 # {{{ Lets check for mail loops of various sorts.
1349 my ($should_store_machine_generated_message, $IsALoop, $result);
1350 ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
1351 _HandleMachineGeneratedMail(
1352 Message => $Message,
1353 ErrorsTo => $ErrorsTo,
1354 Subject => $Subject,
1355 MessageId => $MessageId
1358 # Do not pass loop messages to MailPlugins, to make sure the loop
1359 # is broken, unless $RT::StoreLoops is set.
1360 if ($IsALoop && !$should_store_machine_generated_message) {
1361 return ( 0, $result, undef );
1365 $args{'ticket'} ||= ParseTicketId( $Subject );
1367 $SystemTicket = RT::Ticket->new( $RT::SystemUser );
1368 $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
1369 if ( $SystemTicket->id ) {
1370 $Right = 'ReplyToTicket';
1372 $Right = 'CreateTicket';
1375 #Set up a queue object
1376 my $SystemQueueObj = RT::Queue->new( $RT::SystemUser );
1377 $SystemQueueObj->Load( $args{'queue'} );
1379 # We can safely have no queue of we have a known-good ticket
1380 unless ( $SystemTicket->id || $SystemQueueObj->id ) {
1381 return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
1384 my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
1385 MailPlugins => \@mail_plugins,
1386 Actions => \@actions,
1387 Message => $Message,
1388 RawMessageRef => \$args{message},
1389 SystemTicket => $SystemTicket,
1390 SystemQueue => $SystemQueueObj,
1393 # {{{ If authentication fails and no new user was created, get out.
1394 if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
1396 # If the plugins refused to create one, they lose.
1397 unless ( $AuthStat == -1 ) {
1398 _NoAuthorizedUserFound(
1400 Message => $Message,
1401 Requestor => $ErrorsTo,
1402 Queue => $args{'queue'}
1406 return ( 0, "Could not load a valid user", undef );
1409 # If we got a user, but they don't have the right to say things
1410 if ( $AuthStat == 0 ) {
1413 Subject => "Permission Denied",
1415 "You do not have permission to communicate with RT",
1420 "$ErrorsTo tried to submit a message to "
1422 . " without permission.",
1428 unless ($should_store_machine_generated_message) {
1429 return ( 0, $result, undef );
1432 # if plugin's updated SystemTicket then update arguments
1433 $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
1435 my $Ticket = RT::Ticket->new($CurrentUser);
1437 if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
1441 my @Requestors = ( $CurrentUser->id );
1443 if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
1444 @Cc = ParseCcAddressesFromHead(
1446 CurrentUser => $CurrentUser,
1447 QueueObj => $SystemQueueObj
1451 my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
1452 Queue => $SystemQueueObj->Id,
1453 Subject => $Subject,
1454 Requestor => \@Requestors,
1461 Subject => "Ticket creation failed: $Subject",
1462 Explanation => $ErrStr,
1465 return ( 0, "Ticket creation failed: $ErrStr", $Ticket );
1468 # strip comments&corresponds from the actions we don't need
1469 # to record them if we've created the ticket just now
1470 @actions = grep !/^(comment|correspond)$/, @actions;
1471 $args{'ticket'} = $id;
1473 } elsif ( $args{'ticket'} ) {
1475 $Ticket->Load( $args{'ticket'} );
1476 unless ( $Ticket->Id ) {
1477 my $error = "Could not find a ticket with id " . $args{'ticket'};
1480 Subject => "Message not recorded: $Subject",
1481 Explanation => $error,
1485 return ( 0, $error );
1487 $args{'ticket'} = $Ticket->id;
1489 return ( 1, "Success", $Ticket );
1494 my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
1495 foreach my $action (@actions) {
1497 # If the action is comment, add a comment.
1498 if ( $action =~ /^(?:comment|correspond)$/i ) {
1499 my $method = ucfirst lc $action;
1500 my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
1503 #Warn the sender that we couldn't actually submit the comment.
1506 Subject => "Message not recorded: $Subject",
1507 Explanation => $msg,
1510 return ( 0, "Message not recorded: $msg", $Ticket );
1512 } elsif ($unsafe_actions) {
1513 my ( $status, $msg ) = _RunUnsafeAction(
1515 ErrorsTo => $ErrorsTo,
1516 Message => $Message,
1518 CurrentUser => $CurrentUser,
1520 return ($status, $msg, $Ticket) unless $status == 1;
1523 return ( 1, "Success", $Ticket );
1526 =head2 GetAuthenticationLevel
1528 # Authentication Level
1529 # -1 - Get out. this user has been explicitly declined
1530 # 0 - User may not do anything (Not used at the moment)
1532 # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
1536 sub GetAuthenticationLevel {
1541 RawMessageRef => undef,
1542 SystemTicket => undef,
1543 SystemQueue => undef,
1547 my ( $CurrentUser, $AuthStat, $error );
1549 # Initalize AuthStat so comparisons work correctly
1550 $AuthStat = -9999999;
1552 # if plugin returns AuthStat -2 we skip action
1553 # NOTE: this is experimental API and it would be changed
1554 my %skip_action = ();
1556 # Since this needs loading, no matter what
1557 foreach (@{ $args{MailPlugins} }) {
1558 my ($Code, $NewAuthStat);
1559 if ( ref($_) eq "CODE" ) {
1563 $Code = *{ $_ . "::GetCurrentUser" }{CODE};
1566 foreach my $action (@{ $args{Actions} }) {
1567 ( $CurrentUser, $NewAuthStat ) = $Code->(
1568 Message => $args{Message},
1569 RawMessageRef => $args{RawMessageRef},
1570 CurrentUser => $CurrentUser,
1571 AuthLevel => $AuthStat,
1573 Ticket => $args{SystemTicket},
1574 Queue => $args{SystemQueue},
1577 # You get the highest level of authentication you were assigned, unless you get the magic -1
1578 # If a module returns a "-1" then we discard the ticket, so.
1579 $AuthStat = $NewAuthStat
1580 if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
1582 last if $AuthStat == -1;
1583 $skip_action{$action}++ if $AuthStat == -2;
1586 # strip actions we should skip
1587 @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
1589 last unless @{$args{Actions}};
1591 last if $AuthStat == -1;
1594 return $AuthStat if !wantarray;
1596 return ($AuthStat, $CurrentUser, $error);
1599 sub _RunUnsafeAction {
1605 CurrentUser => undef,
1609 if ( $args{'Action'} =~ /^take$/i ) {
1610 my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
1613 To => $args{'ErrorsTo'},
1614 Subject => "Ticket not taken",
1615 Explanation => $msg,
1616 MIMEObj => $args{'Message'}
1618 return ( 0, "Ticket not taken" );
1620 } elsif ( $args{'Action'} =~ /^resolve$/i ) {
1621 my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved');
1624 #Warn the sender that we couldn't actually submit the comment.
1626 To => $args{'ErrorsTo'},
1627 Subject => "Ticket not resolved",
1628 Explanation => $msg,
1629 MIMEObj => $args{'Message'}
1631 return ( 0, "Ticket not resolved" );
1634 return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} );
1636 return ( 1, "Success" );
1639 =head2 _NoAuthorizedUserFound
1641 Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
1645 sub _NoAuthorizedUserFound {
1654 # Notify the RT Admin of the failure.
1656 To => RT->Config->Get('OwnerEmail'),
1657 Subject => "Could not load a valid user",
1658 Explanation => <<EOT,
1659 RT could not load a valid user, and RT's configuration does not allow
1660 for the creation of a new user for this email (@{[$args{Requestor}]}).
1662 You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
1663 queue @{[$args{'Queue'}]}.
1666 MIMEObj => $args{'Message'},
1670 # Also notify the requestor that his request has been dropped.
1671 if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
1673 To => $args{'Requestor'},
1674 Subject => "Could not load a valid user",
1675 Explanation => <<EOT,
1676 RT could not load a valid user, and RT's configuration does not allow
1677 for the creation of a new user for your email.
1680 MIMEObj => $args{'Message'},
1686 =head2 _HandleMachineGeneratedMail
1693 Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
1694 Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
1695 "This message appears to be a loop (boolean)" );
1699 sub _HandleMachineGeneratedMail {
1700 my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
1701 my $head = $args{'Message'}->head;
1702 my $ErrorsTo = $args{'ErrorsTo'};
1704 my $IsBounce = CheckForBounce($head);
1706 my $IsAutoGenerated = CheckForAutoGenerated($head);
1708 my $IsSuspiciousSender = CheckForSuspiciousSender($head);
1710 my $IsALoop = CheckForLoops($head);
1712 my $SquelchReplies = 0;
1714 my $owner_mail = RT->Config->Get('OwnerEmail');
1716 #If the message is autogenerated, we need to know, so we can not
1717 # send mail to the sender
1718 if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
1719 $SquelchReplies = 1;
1720 $ErrorsTo = $owner_mail;
1723 # Warn someone if it's a loop, before we drop it on the ground
1725 $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
1727 #Should we mail it to RTOwner?
1728 if ( RT->Config->Get('LoopsToRTOwner') ) {
1731 Subject => "RT Bounce: ".$args{'Subject'},
1732 Explanation => "RT thinks this message may be a bounce",
1733 MIMEObj => $args{Message}
1737 #Do we actually want to store it?
1738 return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
1739 unless RT->Config->Get('StoreLoops');
1742 # Squelch replies if necessary
1743 # Don't let the user stuff the RT-Squelch-Replies-To header.
1744 if ( $head->get('RT-Squelch-Replies-To') ) {
1746 'RT-Relocated-Squelch-Replies-To',
1747 $head->get('RT-Squelch-Replies-To')
1749 $head->delete('RT-Squelch-Replies-To');
1752 if ($SquelchReplies) {
1754 # Squelch replies to the sender, and also leave a clue to
1755 # allow us to squelch ALL outbound messages. This way we
1756 # can punt the logic of "what to do when we get a bounce"
1757 # to the scrip. We might want to notify nobody. Or just
1758 # the RT Owner. Or maybe all Privileged watchers.
1759 my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
1760 $head->add( 'RT-Squelch-Replies-To', $Sender );
1761 $head->add( 'RT-DetectedAutoGenerated', 'true' );
1763 return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
1766 =head2 IsCorrectAction
1768 Returns a list of valid actions we've found for this message
1772 sub IsCorrectAction {
1774 my @actions = grep $_, split /-/, $action;
1775 return ( 0, '(no value)' ) unless @actions;
1776 foreach ( @actions ) {
1777 return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
1779 return ( 1, @actions );
1782 eval "require RT::Interface::Email_Vendor";
1783 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm} );
1784 eval "require RT::Interface::Email_Local";
1785 die $@ if ( $@ && $@ !~ qr{^Can't locate RT/Interface/Email_Local.pm} );