# BEGIN BPS TAGGED BLOCK {{{ # # COPYRIGHT: # # This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC # # # (Except where explicitly superseded by other copyright notices) # # # LICENSE: # # This work is made available to you under the terms of Version 2 of # the GNU General Public License. A copy of that license should have # been provided with this software, but in any event can be snarfed # from www.gnu.org. # # This work is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA # 02110-1301 or visit their web page on the internet at # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. # # # CONTRIBUTION SUBMISSION POLICY: # # (The following paragraph is not intended to limit the rights granted # to you to modify and distribute this software under the terms of # the GNU General Public License and is only of importance to you if # you choose to contribute your changes and enhancements to the # community by submitting them to Best Practical Solutions, LLC.) # # By intentionally submitting any modifications, corrections or # derivatives to this work, or any other work intended for use with # Request Tracker, to Best Practical Solutions, LLC, you confirm that # you are the copyright holder for those contributions and you grant # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, # royalty-free, perpetual, license to use, copy, create derivative # works based on those contributions, and sublicense and distribute # those contributions and any derivatives thereof. # # END BPS TAGGED BLOCK }}} package RT::Interface::Email; use strict; use warnings; use Email::Address; use MIME::Entity; use RT::EmailParser; use File::Temp; use UNIVERSAL::require; use Mail::Mailer (); BEGIN { use base 'Exporter'; use vars qw ( @EXPORT_OK); # set the version for version checking our $VERSION = 2.0; # your exported package globals go here, # as well as any optionally exported functions @EXPORT_OK = qw( &CreateUser &GetMessageContent &CheckForLoops &CheckForSuspiciousSender &CheckForAutoGenerated &CheckForBounce &MailError &ParseCcAddressesFromHead &ParseSenderAddressFromHead &ParseErrorsToAddressFromHead &ParseAddressFromHeader &Gateway); } =head1 NAME RT::Interface::Email - helper functions for parsing email sent to RT =head1 SYNOPSIS use lib "!!RT_LIB_PATH!!"; use lib "!!RT_ETC_PATH!!"; use RT::Interface::Email qw(Gateway CreateUser); =head1 DESCRIPTION =head1 METHODS =head2 CheckForLoops HEAD Takes a HEAD object of L class and returns true if the message's been sent by this RT instance. Uses "X-RT-Loop-Prevention" field of the head for test. =cut sub CheckForLoops { my $head = shift; # If this instance of RT sent it our, we don't want to take it in my $RTLoop = $head->get("X-RT-Loop-Prevention") || ""; chomp ($RTLoop); # remove that newline if ( $RTLoop eq RT->Config->Get('rtname') ) { return 1; } # TODO: We might not trap the case where RT instance A sends a mail # to RT instance B which sends a mail to ... return undef; } =head2 CheckForSuspiciousSender HEAD Takes a HEAD object of L class and returns true if sender is suspicious. Suspicious means mailer daemon. See also L. =cut sub CheckForSuspiciousSender { my $head = shift; #if it's from a postmaster or mailer daemon, it's likely a bounce. #TODO: better algorithms needed here - there is no standards for #bounces, so it's very difficult to separate them from anything #else. At the other hand, the Return-To address is only ment to be #used as an error channel, we might want to put up a separate #Return-To address which is treated differently. #TODO: search through the whole email and find the right Ticket ID. my ( $From, $junk ) = ParseSenderAddressFromHead($head); if ( ( $From =~ /^mailer-daemon\@/i ) or ( $From =~ /^postmaster\@/i ) or ( $From eq "" )) { return (1); } return undef; } =head2 CheckForAutoGenerated HEAD Takes a HEAD object of L class and returns true if message is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated' fields of the head in tests. =cut sub CheckForAutoGenerated { my $head = shift; my $Precedence = $head->get("Precedence") || ""; if ( $Precedence =~ /^(bulk|junk)/i ) { return (1); } # Per RFC3834, any Auto-Submitted header which is not "no" means # it is auto-generated. my $AutoSubmitted = $head->get("Auto-Submitted") || ""; if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) { return (1); } # First Class mailer uses this as a clue. my $FCJunk = $head->get("X-FC-Machinegenerated") || ""; if ( $FCJunk =~ /^true/i ) { return (1); } return (0); } sub CheckForBounce { my $head = shift; my $ReturnPath = $head->get("Return-path") || ""; return ( $ReturnPath =~ /<>/ ); } =head2 MailError PARAM HASH Sends an error message. Takes a param hash: =over 4 =item From - sender's address, by default is 'CorrespondAddress'; =item To - recipient, by default is 'OwnerEmail'; =item Bcc - optional Bcc recipients; =item Subject - subject of the message, default is 'There has been an error'; =item Explanation - main content of the error, default value is 'Unexplained error'; =item MIMEObj - optional MIME entity that's attached to the error mail, as well we add 'In-Reply-To' field to the error that points to this message. =item Attach - optional text that attached to the error as 'message/rfc822' part. =item LogLevel - log level under which we should write explanation message into the log, by default we log it as critical. =back =cut sub MailError { my %args = ( To => RT->Config->Get('OwnerEmail'), Bcc => undef, From => RT->Config->Get('CorrespondAddress'), Subject => 'There has been an error', Explanation => 'Unexplained error', MIMEObj => undef, Attach => undef, LogLevel => 'crit', @_ ); $RT::Logger->log( level => $args{'LogLevel'}, message => $args{'Explanation'} ) if $args{'LogLevel'}; # the colons are necessary to make ->build include non-standard headers my %entity_args = ( Type => "multipart/mixed", From => $args{'From'}, Bcc => $args{'Bcc'}, To => $args{'To'}, Subject => $args{'Subject'}, 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'), ); # only set precedence if the sysadmin wants us to if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) { $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence'); } my $entity = MIME::Entity->build(%entity_args); SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} ); $entity->attach( Data => $args{'Explanation'} . "\n" ); if ( $args{'MIMEObj'} ) { $args{'MIMEObj'}->sync_headers; $entity->add_part( $args{'MIMEObj'} ); } if ( $args{'Attach'} ) { $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' ); } SendEmail( Entity => $entity, Bounce => 1 ); } =head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ] Sends an email (passed as a L object C) using RT's outgoing mail configuration. If C is passed, and is a true value, the message will be marked as an autogenerated error, if possible. Sets Date field of the head to now if it's not set. If the C header is set to any true value, the mail will not be sent. One use is to let extensions easily cancel outgoing mail. Ticket and Transaction arguments are optional. If Transaction is specified and Ticket is not then ticket of the transaction is used, but only if the transaction belongs to a ticket. Returns 1 on success, 0 on error or -1 if message has no recipients and hasn't been sent. =head3 Signing and Encrypting This function as well signs and/or encrypts the message according to headers of a transaction's attachment or properties of a ticket's queue. To get full access to the configuration Ticket and/or Transaction arguments must be provided, but you can force behaviour using Sign and/or Encrypt arguments. The following precedence of arguments are used to figure out if the message should be encrypted and/or signed: * if Sign or Encrypt argument is defined then its value is used * else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt header field then it's value is used * else properties of a queue of the Ticket are used. =cut sub SendEmail { my (%args) = ( Entity => undef, Bounce => 0, Ticket => undef, Transaction => undef, @_, ); my $TicketObj = $args{'Ticket'}; my $TransactionObj = $args{'Transaction'}; foreach my $arg( qw(Entity Bounce) ) { next unless defined $args{ lc $arg }; $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead"); $args{ $arg } = delete $args{ lc $arg }; } unless ( $args{'Entity'} ) { $RT::Logger->crit( "Could not send mail without 'Entity' object" ); return 0; } my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; chomp $msgid; # If we don't have any recipients to send to, don't send a message; unless ( $args{'Entity'}->head->get('To') || $args{'Entity'}->head->get('Cc') || $args{'Entity'}->head->get('Bcc') ) { $RT::Logger->info( $msgid . " No recipients found. Not sending." ); return -1; } if ($args{'Entity'}->head->get('X-RT-Squelch')) { $RT::Logger->info( $msgid . " Squelch header found. Not sending." ); return -1; } if ( $TransactionObj && !$TicketObj && $TransactionObj->ObjectType eq 'RT::Ticket' ) { $TicketObj = $TransactionObj->Object; } if ( RT->Config->Get('GnuPG')->{'Enable'} ) { my %crypt; my $attachment; $attachment = $TransactionObj->Attachments->First if $TransactionObj; foreach my $argument ( qw(Sign Encrypt) ) { next if defined $args{ $argument }; if ( $attachment && defined $attachment->GetHeader("X-RT-$argument") ) { $crypt{$argument} = $attachment->GetHeader("X-RT-$argument"); } elsif ( $TicketObj ) { $crypt{$argument} = $TicketObj->QueueObj->$argument(); } } my $res = SignEncrypt( %args, %crypt ); return $res unless $res > 0; } unless ( $args{'Entity'}->head->get('Date') ) { require RT::Date; my $date = RT::Date->new( $RT::SystemUser ); $date->SetToNow; $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) ); } my $mail_command = RT->Config->Get('MailCommand'); if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) { $Mail::Mailer::testfile::config{outfile} = File::Temp->new; $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}"); } # if it is a sub routine, we just return it; return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' ); if ( $mail_command eq 'sendmailpipe' ) { my $path = RT->Config->Get('SendmailPath'); my $args = RT->Config->Get('SendmailArguments'); # SetOutgoingMailFrom if ( RT->Config->Get('SetOutgoingMailFrom') ) { my $OutgoingMailAddress; if ($TicketObj) { my $QueueName = $TicketObj->QueueObj->Name; my $QueueAddressOverride = RT->Config->Get('OverrideOutgoingMailFrom')->{$QueueName}; if ($QueueAddressOverride) { $OutgoingMailAddress = $QueueAddressOverride; } else { $OutgoingMailAddress = $TicketObj->QueueObj->CorrespondAddress; } } $OutgoingMailAddress ||= RT->Config->Get('OverrideOutgoingMailFrom')->{'Default'}; $args .= " -f $OutgoingMailAddress" if $OutgoingMailAddress; } # Set Bounce Arguments $args .= ' '. RT->Config->Get('SendmailBounceArguments') if $args{'Bounce'}; # VERP if ( $TransactionObj and my $prefix = RT->Config->Get('VERPPrefix') and my $domain = RT->Config->Get('VERPDomain') ) { my $from = $TransactionObj->CreatorObj->EmailAddress; $from =~ s/@/=/g; $from =~ s/\s//g; $args .= " -f $prefix$from\@$domain"; } eval { # don't ignore CHLD signal to get proper exit code local $SIG{'CHLD'} = 'DEFAULT'; open( my $mail, '|-', "$path $args >/dev/null" ) or die "couldn't execute program: $!"; # if something wrong with $mail->print we will get PIPE signal, handle it local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" }; $args{'Entity'}->print($mail); unless ( close $mail ) { die "close pipe failed: $!" if $!; # system error # sendmail exit statuses mostly errors with data not software # TODO: status parsing: core dump, exit on signal or EX_* my $msg = "$msgid: `$path $args` exitted with code ". ($?>>8); $msg = ", interrupted by signal ". ($?&127) if $?&127; $RT::Logger->error( $msg ); die $msg; } }; if ( $@ ) { $RT::Logger->crit( "$msgid: Could not send mail with command `$path $args`: " . $@ ); if ( $TicketObj ) { _RecordSendEmailFailure( $TicketObj ); } return 0; } } elsif ( $mail_command eq 'smtp' ) { require Net::SMTP; my $smtp = do { local $@; eval { Net::SMTP->new( Host => RT->Config->Get('SMTPServer'), Debug => RT->Config->Get('SMTPDebug'), ) } }; unless ( $smtp ) { $RT::Logger->crit( "Could not connect to SMTP server."); if ($TicketObj) { _RecordSendEmailFailure( $TicketObj ); } return 0; } # duplicate head as we want drop Bcc field my $head = $args{'Entity'}->head->dup; my @recipients = map $_->address, map Email::Address->parse($head->get($_)), qw(To Cc Bcc); $head->delete('Bcc'); my $sender = RT->Config->Get('SMTPFrom') || $args{'Entity'}->head->get('From'); chomp $sender; my $status = $smtp->mail( $sender ) && $smtp->recipient( @recipients ); if ( $status ) { $smtp->data; my $fh = $smtp->tied_fh; $head->print( $fh ); print $fh "\n"; $args{'Entity'}->print_body( $fh ); $smtp->dataend; } $smtp->quit; unless ( $status ) { $RT::Logger->crit( "$msgid: Could not send mail via SMTP." ); if ( $TicketObj ) { _RecordSendEmailFailure( $TicketObj ); } return 0; } } else { local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'}); my @mailer_args = ($mail_command); if ( $mail_command eq 'sendmail' ) { $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath'); push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments')); } else { push @mailer_args, RT->Config->Get('MailParams'); } unless ( $args{'Entity'}->send( @mailer_args ) ) { $RT::Logger->crit( "$msgid: Could not send mail." ); if ( $TicketObj ) { _RecordSendEmailFailure( $TicketObj ); } return 0; } } return 1; } =head2 PrepareEmailUsingTemplate Template => '', Arguments => {} Loads a template. Parses it using arguments if it's not empty. Returns a tuple (L object, error message). Note that even if a template object is returned MIMEObj method may return undef for empty templates. =cut sub PrepareEmailUsingTemplate { my %args = ( Template => '', Arguments => {}, @_ ); my $template = RT::Template->new( $RT::SystemUser ); $template->LoadGlobalTemplate( $args{'Template'} ); unless ( $template->id ) { return (undef, "Couldn't load template '". $args{'Template'} ."'"); } return $template if $template->IsEmpty; my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } ); return (undef, $msg) unless $status; return $template; } =head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => '' Sends email using a template, takes name of template, arguments for it and recipients. =cut sub SendEmailUsingTemplate { my %args = ( Template => '', Arguments => {}, To => undef, Cc => undef, Bcc => undef, From => RT->Config->Get('CorrespondAddress'), InReplyTo => undef, @_ ); my ($template, $msg) = PrepareEmailUsingTemplate( %args ); return (0, $msg) unless $template; my $mail = $template->MIMEObj; unless ( $mail ) { $RT::Logger->info("Message is not sent as template #". $template->id ." is empty"); return -1; } $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) ) foreach grep defined $args{$_}, qw(To Cc Bcc From); SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} ); return SendEmail( Entity => $mail ); } =head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => '' Forwards transaction with all attachments as 'message/rfc822'. =cut sub ForwardTransaction { my $txn = shift; my %args = ( To => '', Cc => '', Bcc => '', @_ ); my $entity = $txn->ContentAsMIME; return SendForward( %args, Entity => $entity, Transaction => $txn ); } =head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => '' Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'. =cut sub ForwardTicket { my $ticket = shift; my %args = ( To => '', Cc => '', Bcc => '', @_ ); my $txns = $ticket->Transactions; $txns->Limit( FIELD => 'Type', VALUE => $_, ) for qw(Create Correspond); my $entity = MIME::Entity->build( Type => 'multipart/mixed', ); $entity->add_part( $_ ) foreach map $_->ContentAsMIME, @{ $txns->ItemsArrayRef }; return SendForward( %args, Entity => $entity, Ticket => $ticket, Template => 'Forward Ticket' ); } =head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => '' Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template. =cut sub SendForward { my (%args) = ( Entity => undef, Ticket => undef, Transaction => undef, Template => 'Forward', To => '', Cc => '', Bcc => '', @_ ); my $txn = $args{'Transaction'}; my $ticket = $args{'Ticket'}; $ticket ||= $txn->Object if $txn; my $entity = $args{'Entity'}; unless ( $entity ) { require Carp; $RT::Logger->error(Carp::longmess("No entity provided")); return (0, $ticket->loc("Couldn't send email")); } my ($template, $msg) = PrepareEmailUsingTemplate( Template => $args{'Template'}, Arguments => { Ticket => $ticket, Transaction => $txn, }, ); my $mail; if ( $template ) { $mail = $template->MIMEObj; } else { $RT::Logger->warning($msg); } unless ( $mail ) { $RT::Logger->warning("Couldn't generate email using template '$args{Template}'"); my $description; unless ( $args{'Transaction'} ) { $description = 'This is forward of ticket #'. $ticket->id; } else { $description = 'This is forward of transaction #' . $txn->id ." of a ticket #". $txn->ObjectId; } $mail = MIME::Entity->build( Type => 'text/plain', Data => $description, ); } $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) ) foreach grep defined $args{$_}, qw(To Cc Bcc); $mail->attach( Type => 'message/rfc822', Disposition => 'attachment', Description => 'forwarded message', Data => $entity->as_string, ); my $from; my $subject = ''; $subject = $txn->Subject if $txn; $subject ||= $ticket->Subject if $ticket; if ( RT->Config->Get('ForwardFromUser') ) { $from = ($txn || $ticket)->CurrentUser->UserObj->EmailAddress; } else { # XXX: what if want to forward txn of other object than ticket? $subject = AddSubjectTag( $subject, $ticket ); $from = $ticket->QueueObj->CorrespondAddress || RT->Config->Get('CorrespondAddress'); } $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) ); $mail->head->set( From => EncodeToMIME( String => $from ) ); my $status = RT->Config->Get('ForwardFromUser') # never sign if we forward from User ? SendEmail( %args, Entity => $mail, Sign => 0 ) : SendEmail( %args, Entity => $mail ); return (0, $ticket->loc("Couldn't send email")) unless $status; return (1, $ticket->loc("Send email successfully")); } =head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0 Signs and encrypts message using L, but as well handle errors with users' keys. If a recipient has no key or has other problems with it, then the unction sends a error to him using 'Error: public key' template. Also, notifies RT's owner using template 'Error to RT owner: public key' to inform that there are problems with users' keys. Then we filter all bad recipients and retry. Returns 1 on success, 0 on error and -1 if all recipients are bad and had been filtered out. =cut sub SignEncrypt { my %args = ( Entity => undef, Sign => 0, Encrypt => 0, @_ ); return 1 unless $args{'Sign'} || $args{'Encrypt'}; my $msgid = $args{'Entity'}->head->get('Message-ID') || ''; chomp $msgid; $RT::Logger->debug("$msgid Signing message") if $args{'Sign'}; $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'}; require RT::Crypt::GnuPG; my %res = RT::Crypt::GnuPG::SignEncrypt( %args ); return 1 unless $res{'exit_code'}; my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} ); my @bad_recipients; foreach my $line ( @status ) { # if the passphrase fails, either you have a bad passphrase # or gpg-agent has died. That should get caught in Create and # Update, but at least throw an error here if (($line->{'Operation'}||'') eq 'PassphraseCheck' && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) { $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" ); return 0; } next unless ($line->{'Operation'}||'') eq 'RecipientsCheck'; next if $line->{'Status'} eq 'DONE'; $RT::Logger->error( $line->{'Message'} ); push @bad_recipients, $line; } return 0 unless @bad_recipients; $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0] foreach @bad_recipients; foreach my $recipient ( @bad_recipients ) { my $status = SendEmailUsingTemplate( To => $recipient->{'AddressObj'}->address, Template => 'Error: public key', Arguments => { %$recipient, TicketObj => $args{'Ticket'}, TransactionObj => $args{'Transaction'}, }, ); unless ( $status ) { $RT::Logger->error("Couldn't send 'Error: public key'"); } } my $status = SendEmailUsingTemplate( To => RT->Config->Get('OwnerEmail'), Template => 'Error to RT owner: public key', Arguments => { BadRecipients => \@bad_recipients, TicketObj => $args{'Ticket'}, TransactionObj => $args{'Transaction'}, }, ); unless ( $status ) { $RT::Logger->error("Couldn't send 'Error to RT owner: public key'"); } DeleteRecipientsFromHead( $args{'Entity'}->head, map $_->{'AddressObj'}->address, @bad_recipients ); unless ( $args{'Entity'}->head->get('To') || $args{'Entity'}->head->get('Cc') || $args{'Entity'}->head->get('Bcc') ) { $RT::Logger->debug("$msgid No recipients that have public key, not sending"); return -1; } # redo without broken recipients %res = RT::Crypt::GnuPG::SignEncrypt( %args ); return 0 if $res{'exit_code'}; return 1; } use MIME::Words (); =head2 EncodeToMIME Takes a hash with a String and a Charset. Returns the string encoded according to RFC2047, using B (base64 based) encoding. String must be a perl string, octets are returned. If Charset is not provided then $EmailOutputEncoding config option is used, or "latin-1" if that is not set. =cut sub EncodeToMIME { my %args = ( String => undef, Charset => undef, @_ ); my $value = $args{'String'}; return $value unless $value; # 0 is perfect ascii my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding'); my $encoding = 'B'; # using RFC2047 notation, sec 2. # encoded-word = "=?" charset "?" encoding "?" encoded-text "?=" # An 'encoded-word' may not be more than 75 characters long # # MIME encoding increases 4/3*(number of bytes), and always in multiples # of 4. Thus we have to find the best available value of bytes available # for each chunk. # # First we get the integer max which max*4/3 would fit on space. # Then we find the greater multiple of 3 lower or equal than $max. my $max = int( ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) ) * 3 ) / 4 ); $max = int( $max / 3 ) * 3; chomp $value; if ( $max <= 0 ) { # gives an error... $RT::Logger->crit("Can't encode! Charset or encoding too big."); return ($value); } return ($value) unless $value =~ /[^\x20-\x7e]/; $value =~ s/\s+$//; # we need perl string to split thing char by char Encode::_utf8_on($value) unless Encode::is_utf8($value); my ( $tmp, @chunks ) = ( '', () ); while ( length $value ) { my $char = substr( $value, 0, 1, '' ); my $octets = Encode::encode( $charset, $char ); if ( length($tmp) + length($octets) > $max ) { push @chunks, $tmp; $tmp = ''; } $tmp .= $octets; } push @chunks, $tmp if length $tmp; # encode an join chuncks $value = join "\n ", map MIME::Words::encode_mimeword( $_, $encoding, $charset ), @chunks; return ($value); } sub CreateUser { my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_; my $NewUser = RT::User->new( $RT::SystemUser ); my ( $Val, $Message ) = $NewUser->Create( Name => ( $Username || $Address ), EmailAddress => $Address, RealName => $Name, Password => undef, Privileged => 0, Comments => 'Autocreated on ticket submission', ); unless ($Val) { # Deal with the race condition of two account creations at once if ($Username) { $NewUser->LoadByName($Username); } unless ( $NewUser->Id ) { $NewUser->LoadByEmail($Address); } unless ( $NewUser->Id ) { MailError( To => $ErrorsTo, Subject => "User could not be created", Explanation => "User creation failed in mailgateway: $Message", MIMEObj => $entity, LogLevel => 'crit', ); } } #Load the new user object my $CurrentUser = new RT::CurrentUser; $CurrentUser->LoadByEmail( $Address ); unless ( $CurrentUser->id ) { $RT::Logger->warning( "Couldn't load user '$Address'." . "giving up" ); MailError( To => $ErrorsTo, Subject => "User could not be loaded", Explanation => "User '$Address' could not be loaded in the mail gateway", MIMEObj => $entity, LogLevel => 'crit' ); } return $CurrentUser; } =head2 ParseCcAddressesFromHead HASH Takes a hash containing QueueObj, Head and CurrentUser objects. Returns a list of all email addresses in the To and Cc headers b the current Queue\'s email addresses, the CurrentUser\'s email address and anything that the configuration sub RT::IsRTAddress matches. =cut sub ParseCcAddressesFromHead { my %args = ( Head => undef, QueueObj => undef, CurrentUser => undef, @_ ); my $current_address = lc $args{'CurrentUser'}->EmailAddress; my $user = $args{'CurrentUser'}->UserObj; return grep { $_ ne $current_address && !RT::EmailParser->IsRTAddress( $_ ) && !IgnoreCcAddress( $_ ) } map lc $user->CanonicalizeEmailAddress( $_->address ), map Email::Address->parse( $args{'Head'}->get( $_ ) ), qw(To Cc); } =head2 IgnoreCcAddress ADDRESS Returns true if ADDRESS matches the $IgnoreCcRegexp config variable. =cut sub IgnoreCcAddress { my $address = shift; if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) { return 1 if $address =~ /$address_re/i; } return undef; } =head2 ParseSenderAddressFromHead HEAD Takes a MIME::Header object. Returns a tuple: (user@host, friendly name) of the From (evaluated in order of Reply-To:, From:, Sender) =cut sub ParseSenderAddressFromHead { my $head = shift; #Figure out who's sending this message. foreach my $header ('Reply-To', 'From', 'Sender') { my $addr_line = $head->get($header) || next; my ($addr, $name) = ParseAddressFromHeader( $addr_line ); # only return if the address is not empty return ($addr, $name) if $addr; } return (undef, undef); } =head2 ParseErrorsToAddressFromHead HEAD Takes a MIME::Header object. Return a single value : user@host of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:, From:, Sender) =cut sub ParseErrorsToAddressFromHead { my $head = shift; #Figure out who's sending this message. foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) { # If there's a header of that name my $headerobj = $head->get($header); if ($headerobj) { my ( $addr, $name ) = ParseAddressFromHeader($headerobj); # If it's got actual useful content... return ($addr) if ($addr); } } } =head2 ParseAddressFromHeader ADDRESS Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name =cut sub ParseAddressFromHeader { my $Addr = shift; # Some broken mailers send: ""Vincent, Jesse"" . Hate $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g; my @Addresses = RT::EmailParser->ParseEmailAddress($Addr); my ($AddrObj) = grep ref $_, @Addresses; unless ( $AddrObj ) { return ( undef, undef ); } my $Name = ( $AddrObj->name || $AddrObj->phrase || $AddrObj->comment || $AddrObj->address ); #Lets take the from and load a user object. my $Address = $AddrObj->address; return ( $Address, $Name ); } =head2 DeleteRecipientsFromHead HEAD RECIPIENTS Gets a head object and list of addresses. Deletes addresses from To, Cc or Bcc fields. =cut sub DeleteRecipientsFromHead { my $head = shift; my %skip = map { lc $_ => 1 } @_; foreach my $field ( qw(To Cc Bcc) ) { $head->set( $field => join ', ', map $_->format, grep !$skip{ lc $_->address }, Email::Address->parse( $head->get( $field ) ) ); } } sub GenMessageId { my %args = ( Ticket => undef, Scrip => undef, ScripAction => undef, @_ ); my $org = RT->Config->Get('Organization'); my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0; my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0; my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0; return "" ; } sub SetInReplyTo { my %args = ( Message => undef, InReplyTo => undef, Ticket => undef, @_ ); return unless $args{'Message'} && $args{'InReplyTo'}; my $get_header = sub { my @res; if ( $args{'InReplyTo'}->isa('MIME::Entity') ) { @res = $args{'InReplyTo'}->head->get( shift ); } else { @res = $args{'InReplyTo'}->GetHeader( shift ) || ''; } return grep length, map { split /\s+/m, $_ } grep defined, @res; }; my @id = $get_header->('Message-ID'); #XXX: custom header should begin with X- otherwise is violation of the standard my @rtid = $get_header->('RT-Message-ID'); my @references = $get_header->('References'); unless ( @references ) { @references = $get_header->('In-Reply-To'); } push @references, @id, @rtid; if ( $args{'Ticket'} ) { my $pseudo_ref = 'id .'@'. RT->Config->Get('Organization') .'>'; push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references; } @references = splice @references, 4, -6 if @references > 10; my $mail = $args{'Message'}; $mail->head->set( 'In-Reply-To' => join ' ', @rtid? (@rtid) : (@id) ) if @id || @rtid; $mail->head->set( 'References' => join ' ', @references ); } sub ParseTicketId { my $Subject = shift; my $rtname = RT->Config->Get('rtname'); my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i; my $id; if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) { $id = $1; } else { foreach my $tag ( RT->System->SubjectTag ) { next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i; $id = $1; last; } } return undef unless $id; $RT::Logger->debug("Found a ticket ID. It's $id"); return $id; } sub AddSubjectTag { my $subject = shift; my $ticket = shift; unless ( ref $ticket ) { my $tmp = RT::Ticket->new( $RT::SystemUser ); $tmp->Load( $ticket ); $ticket = $tmp; } my $id = $ticket->id; my $queue_tag = $ticket->QueueObj->SubjectTag; my $tag_re = RT->Config->Get('EmailSubjectTagRegex'); unless ( $tag_re ) { my $tag = $queue_tag || RT->Config->Get('rtname'); $tag_re = qr/\Q$tag\E/; } elsif ( $queue_tag ) { $tag_re = qr/$tag_re|\Q$queue_tag\E/; } return $subject if $subject =~ /\[$tag_re\s+#$id\]/; $subject =~ s/(\r\n|\n|\s)/ /gi; chomp $subject; return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject"; } =head2 Gateway ARGSREF Takes parameters: action queue message This performs all the "guts" of the mail rt-mailgate program, and is designed to be called from the web interface with a message, user object, and so on. Can also take an optional 'ticket' parameter; this ticket id overrides any ticket id found in the subject. Returns: An array of: (status code, message, optional ticket object) status code is a numeric value. for temporary failures, the status code should be -75 for permanent failures which are handled by RT, the status code should be 0 for succces, the status code should be 1 =cut sub _LoadPlugins { my @mail_plugins = @_; my @res; foreach my $plugin (@mail_plugins) { if ( ref($plugin) eq "CODE" ) { push @res, $plugin; } elsif ( !ref $plugin ) { my $Class = $plugin; $Class = "RT::Interface::Email::" . $Class unless $Class =~ /^RT::Interface::Email::/; $Class->require or do { $RT::Logger->error("Couldn't load $Class: $@"); next }; no strict 'refs'; unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) { $RT::Logger->crit( "No GetCurrentUser code found in $Class module"); next; } push @res, $Class; } else { $RT::Logger->crit( "$plugin - is not class name or code reference"); } } return @res; } sub Gateway { my $argsref = shift; my %args = ( action => 'correspond', queue => '1', ticket => undef, message => undef, %$argsref ); my $SystemTicket; my $Right; # Validate the action my ( $status, @actions ) = IsCorrectAction( $args{'action'} ); unless ($status) { return ( -75, "Invalid 'action' parameter " . $actions[0] . " for queue " . $args{'queue'}, undef ); } my $parser = RT::EmailParser->new(); $parser->SmartParseMIMEEntityFromScalar( Message => $args{'message'}, Decode => 0, Exact => 1, ); my $Message = $parser->Entity(); unless ($Message) { MailError( Subject => "RT Bounce: Unparseable message", Explanation => "RT couldn't process the message below", Attach => $args{'message'} ); return ( 0, "Failed to parse this message. Something is likely badly wrong with the message" ); } my @mail_plugins = grep $_, RT->Config->Get('MailPlugins'); push @mail_plugins, "Auth::MailFrom" unless @mail_plugins; @mail_plugins = _LoadPlugins( @mail_plugins ); my %skip_plugin; foreach my $class( grep !ref, @mail_plugins ) { # check if we should apply filter before decoding my $check_cb = do { no strict 'refs'; *{ $class . "::ApplyBeforeDecode" }{CODE}; }; next unless defined $check_cb; next unless $check_cb->( Message => $Message, RawMessageRef => \$args{'message'}, ); $skip_plugin{ $class }++; my $Code = do { no strict 'refs'; *{ $class . "::GetCurrentUser" }{CODE}; }; my ($status, $msg) = $Code->( Message => $Message, RawMessageRef => \$args{'message'}, ); next if $status > 0; if ( $status == -2 ) { return (1, $msg, undef); } elsif ( $status == -1 ) { return (0, $msg, undef); } } @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins; $parser->_DecodeBodies; $parser->_PostProcessNewEntity; my $head = $Message->head; my $ErrorsTo = ParseErrorsToAddressFromHead( $head ); my $MessageId = $head->get('Message-ID') || "Config->Get('Organization') .'>'; #Pull apart the subject line my $Subject = $head->get('Subject') || ''; chomp $Subject; # {{{ Lets check for mail loops of various sorts. my ($should_store_machine_generated_message, $IsALoop, $result); ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) = _HandleMachineGeneratedMail( Message => $Message, ErrorsTo => $ErrorsTo, Subject => $Subject, MessageId => $MessageId ); # Do not pass loop messages to MailPlugins, to make sure the loop # is broken, unless $RT::StoreLoops is set. if ($IsALoop && !$should_store_machine_generated_message) { return ( 0, $result, undef ); } # }}} $args{'ticket'} ||= ParseTicketId( $Subject ); $SystemTicket = RT::Ticket->new( $RT::SystemUser ); $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ; if ( $SystemTicket->id ) { $Right = 'ReplyToTicket'; } else { $Right = 'CreateTicket'; } #Set up a queue object my $SystemQueueObj = RT::Queue->new( $RT::SystemUser ); $SystemQueueObj->Load( $args{'queue'} ); # We can safely have no queue of we have a known-good ticket unless ( $SystemTicket->id || $SystemQueueObj->id ) { return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef ); } my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel( MailPlugins => \@mail_plugins, Actions => \@actions, Message => $Message, RawMessageRef => \$args{message}, SystemTicket => $SystemTicket, SystemQueue => $SystemQueueObj, ); # {{{ If authentication fails and no new user was created, get out. if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) { # If the plugins refused to create one, they lose. unless ( $AuthStat == -1 ) { _NoAuthorizedUserFound( Right => $Right, Message => $Message, Requestor => $ErrorsTo, Queue => $args{'queue'} ); } return ( 0, "Could not load a valid user", undef ); } # If we got a user, but they don't have the right to say things if ( $AuthStat == 0 ) { MailError( To => $ErrorsTo, Subject => "Permission Denied", Explanation => "You do not have permission to communicate with RT", MIMEObj => $Message ); return ( 0, "$ErrorsTo tried to submit a message to " . $args{'Queue'} . " without permission.", undef ); } unless ($should_store_machine_generated_message) { return ( 0, $result, undef ); } # if plugin's updated SystemTicket then update arguments $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id; my $Ticket = RT::Ticket->new($CurrentUser); if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions ) { my @Cc; my @Requestors = ( $CurrentUser->id ); if (RT->Config->Get('ParseNewMessageForTicketCcs')) { @Cc = ParseCcAddressesFromHead( Head => $head, CurrentUser => $CurrentUser, QueueObj => $SystemQueueObj ); } my ( $id, $Transaction, $ErrStr ) = $Ticket->Create( Queue => $SystemQueueObj->Id, Subject => $Subject, Requestor => \@Requestors, Cc => \@Cc, MIMEObj => $Message ); if ( $id == 0 ) { MailError( To => $ErrorsTo, Subject => "Ticket creation failed: $Subject", Explanation => $ErrStr, MIMEObj => $Message ); return ( 0, "Ticket creation failed: $ErrStr", $Ticket ); } # strip comments&corresponds from the actions we don't need # to record them if we've created the ticket just now @actions = grep !/^(comment|correspond)$/, @actions; $args{'ticket'} = $id; } elsif ( $args{'ticket'} ) { $Ticket->Load( $args{'ticket'} ); unless ( $Ticket->Id ) { my $error = "Could not find a ticket with id " . $args{'ticket'}; MailError( To => $ErrorsTo, Subject => "Message not recorded: $Subject", Explanation => $error, MIMEObj => $Message ); return ( 0, $error ); } $args{'ticket'} = $Ticket->id; } else { return ( 1, "Success", $Ticket ); } # }}} my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands'); foreach my $action (@actions) { # If the action is comment, add a comment. if ( $action =~ /^(?:comment|correspond)$/i ) { my $method = ucfirst lc $action; my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message ); unless ($status) { #Warn the sender that we couldn't actually submit the comment. MailError( To => $ErrorsTo, Subject => "Message not recorded: $Subject", Explanation => $msg, MIMEObj => $Message ); return ( 0, "Message not recorded: $msg", $Ticket ); } } elsif ($unsafe_actions) { my ( $status, $msg ) = _RunUnsafeAction( Action => $action, ErrorsTo => $ErrorsTo, Message => $Message, Ticket => $Ticket, CurrentUser => $CurrentUser, ); return ($status, $msg, $Ticket) unless $status == 1; } } return ( 1, "Success", $Ticket ); } =head2 GetAuthenticationLevel # Authentication Level # -1 - Get out. this user has been explicitly declined # 0 - User may not do anything (Not used at the moment) # 1 - Normal user # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate =cut sub GetAuthenticationLevel { my %args = ( MailPlugins => [], Actions => [], Message => undef, RawMessageRef => undef, SystemTicket => undef, SystemQueue => undef, @_, ); my ( $CurrentUser, $AuthStat, $error ); # Initalize AuthStat so comparisons work correctly $AuthStat = -9999999; # if plugin returns AuthStat -2 we skip action # NOTE: this is experimental API and it would be changed my %skip_action = (); # Since this needs loading, no matter what foreach (@{ $args{MailPlugins} }) { my ($Code, $NewAuthStat); if ( ref($_) eq "CODE" ) { $Code = $_; } else { no strict 'refs'; $Code = *{ $_ . "::GetCurrentUser" }{CODE}; } foreach my $action (@{ $args{Actions} }) { ( $CurrentUser, $NewAuthStat ) = $Code->( Message => $args{Message}, RawMessageRef => $args{RawMessageRef}, CurrentUser => $CurrentUser, AuthLevel => $AuthStat, Action => $action, Ticket => $args{SystemTicket}, Queue => $args{SystemQueue}, ); # You get the highest level of authentication you were assigned, unless you get the magic -1 # If a module returns a "-1" then we discard the ticket, so. $AuthStat = $NewAuthStat if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 ); last if $AuthStat == -1; $skip_action{$action}++ if $AuthStat == -2; } # strip actions we should skip @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}} if $AuthStat == -2; last unless @{$args{Actions}}; last if $AuthStat == -1; } return $AuthStat if !wantarray; return ($AuthStat, $CurrentUser, $error); } sub _RunUnsafeAction { my %args = ( Action => undef, ErrorsTo => undef, Message => undef, Ticket => undef, CurrentUser => undef, @_ ); if ( $args{'Action'} =~ /^take$/i ) { my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id ); unless ($status) { MailError( To => $args{'ErrorsTo'}, Subject => "Ticket not taken", Explanation => $msg, MIMEObj => $args{'Message'} ); return ( 0, "Ticket not taken" ); } } elsif ( $args{'Action'} =~ /^resolve$/i ) { my ( $status, $msg ) = $args{'Ticket'}->SetStatus('resolved'); unless ($status) { #Warn the sender that we couldn't actually submit the comment. MailError( To => $args{'ErrorsTo'}, Subject => "Ticket not resolved", Explanation => $msg, MIMEObj => $args{'Message'} ); return ( 0, "Ticket not resolved" ); } } else { return ( 0, "Not supported unsafe action $args{'Action'}", $args{'Ticket'} ); } return ( 1, "Success" ); } =head2 _NoAuthorizedUserFound Emails the RT Owner and the requestor when the auth plugins return "No auth user found" =cut sub _NoAuthorizedUserFound { my %args = ( Right => undef, Message => undef, Requestor => undef, Queue => undef, @_ ); # Notify the RT Admin of the failure. MailError( To => RT->Config->Get('OwnerEmail'), Subject => "Could not load a valid user", Explanation => < $args{'Message'}, LogLevel => 'error' ); # Also notify the requestor that his request has been dropped. if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) { MailError( To => $args{'Requestor'}, Subject => "Could not load a valid user", Explanation => < $args{'Message'}, LogLevel => 'error' ); } } =head2 _HandleMachineGeneratedMail Takes named params: Message ErrorsTo Subject Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc. Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message", "This message appears to be a loop (boolean)" ); =cut sub _HandleMachineGeneratedMail { my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ ); my $head = $args{'Message'}->head; my $ErrorsTo = $args{'ErrorsTo'}; my $IsBounce = CheckForBounce($head); my $IsAutoGenerated = CheckForAutoGenerated($head); my $IsSuspiciousSender = CheckForSuspiciousSender($head); my $IsALoop = CheckForLoops($head); my $SquelchReplies = 0; my $owner_mail = RT->Config->Get('OwnerEmail'); #If the message is autogenerated, we need to know, so we can not # send mail to the sender if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) { $SquelchReplies = 1; $ErrorsTo = $owner_mail; } # Warn someone if it's a loop, before we drop it on the ground if ($IsALoop) { $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself."); #Should we mail it to RTOwner? if ( RT->Config->Get('LoopsToRTOwner') ) { MailError( To => $owner_mail, Subject => "RT Bounce: ".$args{'Subject'}, Explanation => "RT thinks this message may be a bounce", MIMEObj => $args{Message} ); } #Do we actually want to store it? return ( 0, $ErrorsTo, "Message Bounced", $IsALoop ) unless RT->Config->Get('StoreLoops'); } # Squelch replies if necessary # Don't let the user stuff the RT-Squelch-Replies-To header. if ( $head->get('RT-Squelch-Replies-To') ) { $head->add( 'RT-Relocated-Squelch-Replies-To', $head->get('RT-Squelch-Replies-To') ); $head->delete('RT-Squelch-Replies-To'); } if ($SquelchReplies) { # Squelch replies to the sender, and also leave a clue to # allow us to squelch ALL outbound messages. This way we # can punt the logic of "what to do when we get a bounce" # to the scrip. We might want to notify nobody. Or just # the RT Owner. Or maybe all Privileged watchers. my ( $Sender, $junk ) = ParseSenderAddressFromHead($head); $head->add( 'RT-Squelch-Replies-To', $Sender ); $head->add( 'RT-DetectedAutoGenerated', 'true' ); } return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop ); } =head2 IsCorrectAction Returns a list of valid actions we've found for this message =cut sub IsCorrectAction { my $action = shift; my @actions = grep $_, split /-/, $action; return ( 0, '(no value)' ) unless @actions; foreach ( @actions ) { return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/; } return ( 1, @actions ); } sub _RecordSendEmailFailure { my $ticket = shift; if ($ticket) { $ticket->_RecordNote( NoteType => 'SystemError', Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.", ); return 1; } else { $RT::Logger->error( "Can't record send email failure as ticket is missing" ); return; } } RT::Base->_ImportOverlays(); 1;