X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=rt%2Flib%2FRT%2FEmailParser.pm;h=2954505ff8e622779125f9c34023c9cb33a15a1e;hp=49f3d55183d3e5da7bd328605d8a141621c167f4;hb=9aee669886202be7035e6c6049fc71bc99dd3013;hpb=0ebeec96313dd7edfca340f01f8fbbbac1f4aa1d diff --git a/rt/lib/RT/EmailParser.pm b/rt/lib/RT/EmailParser.pm index 49f3d5518..2954505ff 100644 --- a/rt/lib/RT/EmailParser.pm +++ b/rt/lib/RT/EmailParser.pm @@ -1,33 +1,61 @@ -# BEGIN LICENSE BLOCK -# -# Copyright (c) 1996-2003 Jesse Vincent -# -# (Except where explictly superceded by other copyright notices) -# +# BEGIN BPS TAGGED BLOCK {{{ +# +# COPYRIGHT: +# +# This software is Copyright (c) 1996-2015 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. -# -# Unless otherwise specified, all modifications, corrections or -# extensions to this work which alter its source code become the -# property of Best Practical Solutions, LLC when submitted for -# inclusion in the work. -# -# -# END LICENSE BLOCK +# +# 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::EmailParser; use base qw/RT::Base/; use strict; -use Mail::Address; +use warnings; + + +use Email::Address; use MIME::Entity; use MIME::Head; use MIME::Parser; @@ -35,7 +63,8 @@ use File::Temp qw/tempdir/; =head1 NAME - RT::Interface::CLI - helper functions for creating a commandline RT interface + RT::EmailParser - helper functions for parsing parts from incoming + email messages =head1 SYNOPSIS @@ -43,17 +72,13 @@ use File::Temp qw/tempdir/; =head1 DESCRIPTION -=begin testing - -ok(require RT::EmailParser); - -=end testing =head1 METHODS =head2 new +Returns a new RT::EmailParser object =cut @@ -66,159 +91,172 @@ sub new { } +=head2 SmartParseMIMEEntityFromScalar Message => SCALAR_REF [, Decode => BOOL, Exact => BOOL ] } -# {{{ sub debug +Parse a message stored in a scalar from scalar_ref. -sub debug { - my $val = shift; - my ($debug); - if ($val) { - $RT::Logger->debug( $val . "\n" ); - if ($debug) { - print STDERR "$val\n"; - } - } - if ($debug) { - return (1); - } -} - -# }}} - -# {{{ sub CheckForLoops +=cut -sub CheckForLoops { +sub SmartParseMIMEEntityFromScalar { my $self = shift; + my %args = ( Message => undef, Decode => 1, Exact => 0, @_ ); + + eval { + my ( $fh, $temp_file ); + for ( 1 .. 10 ) { + + # on NFS and NTFS, it is possible that tempfile() conflicts + # with other processes, causing a race condition. we try to + # accommodate this by pausing and retrying. + last + if ( $fh, $temp_file ) = + eval { File::Temp::tempfile( UNLINK => 0 ) }; + sleep 1; + } + if ($fh) { + + #thank you, windows + binmode $fh; + $fh->autoflush(1); + print $fh $args{'Message'}; + close($fh); + if ( -f $temp_file ) { + + my $entity = $self->ParseMIMEEntityFromFile( $temp_file, $args{'Decode'}, $args{'Exact'} ); + unlink($temp_file); + return $entity; + } + } + }; - my $head = $self->Head; - - #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 =~ /^$RT::rtname/ ) { - return (1); + #If for some reason we weren't able to parse the message using a temp file + # try it with a scalar + if ( $@ || !$self->Entity ) { + return $self->ParseMIMEEntityFromScalar( $args{'Message'}, $args{'Decode'}, $args{'Exact'} ); } - # 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); } -# }}} -# {{{ sub CheckForSuspiciousSender +=head2 ParseMIMEEntityFromSTDIN -sub CheckForSuspiciousSender { - my $self = shift; +Parse a message from standard input - #if it's from a postmaster or mailer daemon, it's likely a bounce. +=cut - #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. +sub ParseMIMEEntityFromSTDIN { + my $self = shift; + return $self->ParseMIMEEntityFromFileHandle(\*STDIN, @_); +} - #TODO: search through the whole email and find the right Ticket ID. +=head2 ParseMIMEEntityFromScalar $message - my ( $From, $junk ) = $self->ParseSenderAddressFromHead(); +Takes either a scalar or a reference to a scalar which contains a stringified MIME message. +Parses it. - if ( ( $From =~ /^mailer-daemon/i ) or ( $From =~ /^postmaster/i ) ) { - return (1); +Returns true if it wins. +Returns false if it loses. - } - - return (undef); +=cut +sub ParseMIMEEntityFromScalar { + my $self = shift; + return $self->_ParseMIMEEntity( shift, 'parse_data', @_ ); } -# }}} +=head2 ParseMIMEEntityFromFilehandle *FH -# {{{ sub CheckForAutoGenerated -sub CheckForAutoGenerated { - my $self = shift; - my $head = $self->Head; +Parses a mime entity from a filehandle passed in as an argument - my $Precedence = $head->get("Precedence") || ""; - if ( $Precedence =~ /^(bulk|junk)/i ) { - return (1); - } - else { - return (undef); - } +=cut + +sub ParseMIMEEntityFromFileHandle { + my $self = shift; + return $self->_ParseMIMEEntity( shift, 'parse', @_ ); } -# }}} +=head2 ParseMIMEEntityFromFile -# {{{ sub ParseMIMEEntityFromSTDIN +Parses a mime entity from a filename passed in as an argument -sub ParseMIMEEntityFromSTDIN { +=cut + +sub ParseMIMEEntityFromFile { my $self = shift; - return $self->ParseMIMEEntityFromFileHandle(\*STDIN); + return $self->_ParseMIMEEntity( shift, 'parse_open', @_ ); } -# }}} - -sub ParseMIMEEntityFromScalar { +sub _ParseMIMEEntity { my $self = shift; my $message = shift; + my $method = shift; + my $postprocess = (@_ ? shift : 1); + my $exact = shift; # Create a new parser object: - my $parser = MIME::Parser->new(); $self->_SetupMIMEParser($parser); - + $parser->decode_bodies(0) if $exact; # TODO: XXX 3.0 we really need to wrap this in an eval { } - unless ( $self->{'entity'} = $parser->parse_data($message) ) { + unless ( $self->{'entity'} = $parser->$method($message) ) { + $RT::Logger->crit("Couldn't parse MIME stream and extract the submessages"); # Try again, this time without extracting nested messages $parser->extract_nested_messages(0); - unless ( $self->{'entity'} = $parser->parse_data($message) ) { + unless ( $self->{'entity'} = $parser->$method($message) ) { $RT::Logger->crit("couldn't parse MIME stream"); return ( undef); } } - $self->_PostProcessNewEntity(); - return (1); -} - -# {{{ ParseMIMEEntityFromFilehandle *FH - -=head2 ParseMIMEEntityFromFilehandle *FH -Parses a mime entity from a filehandle passed in as an argument + $self->_PostProcessNewEntity if $postprocess; -=cut + return $self->{'entity'}; +} -sub ParseMIMEEntityFromFileHandle { +sub _DecodeBodies { my $self = shift; - my $filehandle = shift; - - # Create a new parser object: - - my $parser = MIME::Parser->new(); - $self->_SetupMIMEParser($parser); - - - # TODO: XXX 3.0 we really need to wrap this in an eval { } - - unless ( $self->{'entity'} = $parser->parse($filehandle) ) { + return unless $self->{'entity'}; + + my @parts = $self->{'entity'}->parts_DFS; + $self->_DecodeBody($_) foreach @parts; +} - # Try again, this time without extracting nested messages - $parser->extract_nested_messages(0); - unless ( $self->{'entity'} = $parser->parse($filehandle) ) { - $RT::Logger->crit("couldn't parse MIME stream"); - return ( undef); - } +sub _DecodeBody { + my $self = shift; + my $entity = shift; + + my $old = $entity->bodyhandle or return; + return unless $old->is_encoded; + + require MIME::Decoder; + my $encoding = $entity->head->mime_encoding; + my $decoder = MIME::Decoder->new($encoding); + unless ( $decoder ) { + $RT::Logger->error("Couldn't find decoder for '$encoding', switching to binary"); + $old->is_encoded(0); + return; } - $self->_PostProcessNewEntity(); - return (1); -} -# }}} + require MIME::Body; + # XXX: use InCore for now, but later must switch to files + my $new = MIME::Body::InCore->new(); + $new->binmode(1); + $new->is_encoded(0); + + my $source = $old->open('r') or die "couldn't open body: $!"; + my $destination = $new->open('w') or die "couldn't open body: $!"; + { + local $@; + eval { $decoder->decode($source, $destination) }; + $RT::Logger->error($@) if $@; + } + $source->close or die "can't close: $!"; + $destination->close or die "can't close: $!"; -# {{{ _PostProcessNewEntity + $entity->bodyhandle( $new ); +} =head2 _PostProcessNewEntity @@ -231,253 +269,26 @@ sub _PostProcessNewEntity { #Now we've got a parsed mime object. - # try to convert text parts into utf-8 charset - RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8'); - - # Unfold headers that are have embedded newlines + # Better do this before conversion or it will break + # with multiline encoded Subject (RFC2047) (fsck.com #5594) $self->Head->unfold; - -} - -# }}} - -# {{{ sub ParseTicketId - -sub ParseTicketId { - my $self = shift; - - my $Subject = shift; - - if ( $Subject =~ s/\[$RT::rtname \#(\d+)\s*\]//i ) { - my $id = $1; - $RT::Logger->debug("Found a ticket ID. It's $id"); - return ($id); - } - else { - return (undef); - } -} - -# }}} - -# {{{ sub MailError - -=head2 MailError { } - - -# TODO this doesn't belong here. -# TODO doc this - - -=cut - - -sub MailError { - my $self = shift; - - my %args = ( - To => $RT::OwnerEmail, - Bcc => undef, - From => $RT::CorrespondAddress, - Subject => 'There has been an error', - Explanation => 'Unexplained error', - MIMEObj => undef, - LogLevel => 'crit', - @_ - ); - - $RT::Logger->log( - level => $args{'LogLevel'}, - message => $args{'Explanation'} - ); - my $entity = MIME::Entity->build( - Type => "multipart/mixed", - From => $args{'From'}, - Bcc => $args{'Bcc'}, - To => $args{'To'}, - Subject => $args{'Subject'}, - 'X-RT-Loop-Prevention' => $RT::rtname, - ); - - $entity->attach( Data => $args{'Explanation'} . "\n" ); - - my $mimeobj = $args{'MIMEObj'}; - $mimeobj->sync_headers(); - $entity->add_part($mimeobj); - - if ( $RT::MailCommand eq 'sendmailpipe' ) { - open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) || return (0); - print MAIL $entity->as_string; - close(MAIL); - } - else { - $entity->send( $RT::MailCommand, $RT::MailParams ); - } -} - -# }}} - - - -# {{{ sub GetCurrentUser - -sub GetCurrentUser { - my $self = shift; - my $ErrorsTo = shift; - - my %UserInfo = (); - - #Suck the address of the sender out of the header - my ( $Address, $Name ) = $self->ParseSenderAddressFromHead(); - - my $tempuser = RT::User->new($RT::SystemUser); - - #This will apply local address canonicalization rules - $Address = $tempuser->CanonicalizeEmailAddress($Address); - - #If desired, synchronize with an external database - my $UserFoundInExternalDatabase = 0; - - # Username is the 'Name' attribute of the user that RT uses for things - # like authentication - my $Username = undef; - ( $UserFoundInExternalDatabase, %UserInfo ) = - $self->LookupExternalUserInfo( $Address, $Name ); - - $Address = $UserInfo{'EmailAddress'}; - $Username = $UserInfo{'Name'}; - - #Get us a currentuser object to work with. - my $CurrentUser = RT::CurrentUser->new(); - - # First try looking up by a username, if we got one from the external - # db lookup. Next, try looking up by email address. Failing that, - # try looking up by users who have this user's email address as their - # username. - - if ($Username) { - $CurrentUser->LoadByName($Username); - } - - unless ( $CurrentUser->Id ) { - $CurrentUser->LoadByEmail($Address); - } - - #If we can't get it by email address, try by name. - unless ( $CurrentUser->Id ) { - $CurrentUser->LoadByName($Address); - } - - unless ( $CurrentUser->Id ) { - - #If we couldn't load a user, determine whether to create a user - - # {{{ If we require an incoming address to be found in the external - # user database, reject the incoming message appropriately - if ( $RT::SenderMustExistInExternalDatabase - && !$UserFoundInExternalDatabase ) { - - my $Message = - "Sender's email address was not found in the user database."; - - # {{{ This code useful only if you've defined an AutoRejectRequest template - - require RT::Template; - my $template = new RT::Template($RT::Nobody); - $template->Load('AutoRejectRequest'); - $Message = $template->Content || $Message; - - # }}} - - MailError( - To => $ErrorsTo, - Subject => "Ticket Creation failed: user could not be created", - Explanation => $Message, - MIMEObj => $self->Entity, - LogLevel => 'notice' ); - - return ($CurrentUser); - - } - - # }}} - - else { - 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 => $self->Entity, - LogLevel => 'crit' ); - } - } - } - - #Load the new user object - $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 => $self->Entity, - LogLevel => 'crit' ); - - } - } - - return ($CurrentUser); - + # try to convert text parts into utf-8 charset + RT::I18N::SetMIMEEntityToEncoding($self->{'entity'}, 'utf-8'); } -# }}} - - -# {{{ ParseCcAddressesFromHead - =head2 ParseCcAddressesFromHead HASHREF Takes a hashref object 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 $RTAddressRegexp matches. +headers b the current Queue's email addresses, the CurrentUser's +email address and anything that the RT->Config->Get('RTAddressRegexp') matches. =cut sub ParseCcAddressesFromHead { - my $self = shift; - my %args = ( QueueObj => undef, CurrentUser => undef, @@ -486,171 +297,77 @@ sub ParseCcAddressesFromHead { my (@Addresses); - my @ToObjs = Mail::Address->parse( $self->Head->get('To') ); - my @CcObjs = Mail::Address->parse( $self->Head->get('Cc') ); + my @ToObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('To') ) ); + my @CcObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('Cc') ) ); foreach my $AddrObj ( @ToObjs, @CcObjs ) { my $Address = $AddrObj->address; - my $user = RT::User->new($RT::SystemUser); + my $user = RT::User->new(RT->SystemUser); $Address = $user->CanonicalizeEmailAddress($Address); - next if ( $args{'CurrentUser'}->EmailAddress =~ /^$Address$/i ); - next if ( $args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i ); - next if ( $args{'QueueObj'}->CommentAddress =~ /^$Address$/i ); - next if ( IsRTAddress($Address) ); + next if lc $args{'CurrentUser'}->EmailAddress eq lc $Address; + next if $self->IsRTAddress($Address); push ( @Addresses, $Address ); } return (@Addresses); } -# }}} - -# {{{ ParseSenderAdddressFromHead - -=head2 ParseSenderAddressFromHead -Takes a MIME::Header object. Returns a tuple: (user@host, friendly name) -of the From (evaluated in order of Reply-To:, From:, Sender) - -=cut +=head2 IsRTaddress ADDRESS -sub ParseSenderAddressFromHead { - my $self = shift; - - #Figure out who's sending this message. - my $From = $self->Head->get('Reply-To') - || $self->Head->get('From') - || $self->Head->get('Sender'); - return ( $self->ParseAddressFromHeader($From) ); -} - -# }}} - -# {{{ ParseErrorsToAdddressFromHead - -=head2 ParseErrorsToAddressFromHead +Takes a single parameter, an email address. +Returns true if that address matches the C config option. +Returns false, otherwise. -Takes a MIME::Header object. Return a single value : user@host -of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender) =cut -sub ParseErrorsToAddressFromHead { +sub IsRTAddress { my $self = shift; + my $address = 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 = $self->Head->get($header); - if ($headerobj) { - my ( $addr, $name ) = $self->ParseAddressFromHeader($headerobj); + return undef unless defined($address) and $address =~ /\S/; - # If it's got actual useful content... - return ($addr) if ($addr); - } + if ( my $address_re = RT->Config->Get('RTAddressRegexp') ) { + return $address =~ /$address_re/i ? 1 : undef; } -} - -# }}} -# {{{ ParseAddressFromHeader - -=head2 ParseAddressFromHeader ADDRESS - -Takes an address from $self->Head->get('Line') and returns a tuple: user@host, friendly name - -=cut - -sub ParseAddressFromHeader { - my $self = shift; - my $Addr = shift; - - my @Addresses = Mail::Address->parse($Addr); - - my $AddrObj = $Addresses[0]; - - unless ( ref($AddrObj) ) { - return ( undef, undef ); + # we don't warn here, but do in config check + if ( my $correspond_address = RT->Config->Get('CorrespondAddress') ) { + return 1 if lc $correspond_address eq lc $address; + } + if ( my $comment_address = RT->Config->Get('CommentAddress') ) { + return 1 if lc $comment_address eq lc $address; } - my $Name = ( $AddrObj->phrase || $AddrObj->comment || $AddrObj->address ); - - #Lets take the from and load a user object. - my $Address = $AddrObj->address; - - return ( $Address, $Name ); -} - -# }}} - -# {{{ IsRTAddress - -=item IsRTaddress ADDRESS - -Takes a single parameter, an email address. -Returns true if that address matches the $RTAddressRegexp. -Returns false, otherwise. - -=begin testing - -is(RT::EmailParser::IsRTAddress("","rt\@example.com"),1, "Regexp matched rt address" ); -is(RT::EmailParser::IsRTAddress("","frt\@example.com"),undef, "Regexp didn't match non-rt address" ); - -=end testing - -=cut + my $queue = RT::Queue->new( RT->SystemUser ); + $queue->LoadByCols( CorrespondAddress => $address ); + return 1 if $queue->id; -sub IsRTAddress { - my $self = shift; - my $address = shift; + $queue->LoadByCols( CommentAddress => $address ); + return 1 if $queue->id; - # Example: the following rule would tell RT not to Cc - # "tickets@noc.example.com" - if ( defined($RT::RTAddressRegexp) && - $address =~ /$RT::RTAddressRegexp/ ) { - return(1); - } else { - return (undef); - } + return undef; } -# }}} - - -# {{{ CullRTAddresses -=item CullRTAddresses ARRAY +=head2 CullRTAddresses ARRAY Takes a single argument, an array of email addresses. Returns the same array with any IsRTAddress()es weeded out. -=begin testing - -@before = ("rt\@example.com", "frt\@example.com"); -@after = ("frt\@example.com"); -ok(eq_array(RT::EmailParser::CullRTAddresses("",@before),@after), "CullRTAddresses only culls RT addresses"); - -=end testing =cut sub CullRTAddresses { my $self = shift; - my @addresses= (@_); - my @addrlist; + my @addresses = (@_); - foreach my $addr( @addresses ) { - push (@addrlist, $addr) unless IsRTAddress("", $addr); - } - return (@addrlist); + return grep { !$self->IsRTAddress($_) } @addresses; } -# }}} -# {{{ LookupExternalUserInfo # LookupExternalUserInfo is a site-definable method for synchronizing @@ -666,7 +383,7 @@ sub CullRTAddresses { # template for the rejection message. -=item LookupExternalUserInfo +=head2 LookupExternalUserInfo LookupExternalUserInfo is a site-definable method for synchronizing incoming users with an external data source. @@ -679,12 +396,12 @@ sub CullRTAddresses { It returns (FoundInExternalDatabase, ParamHash); - FoundInExternalDatabase must be set to 1 before return if the user was - found in the external database. + FoundInExternalDatabase must be set to 1 before return if the user + was found in the external database. - ParamHash is a Perl parameter hash which can contain at least the following - fields. These fields are used to populate RT's users database when the user - is created + ParamHash is a Perl parameter hash which can contain at least the + following fields. These fields are used to populate RT's users + database when the user is created. EmailAddress is the email address that RT should use for this user. Name is the 'Name' attribute RT should use for this user. @@ -707,15 +424,9 @@ sub LookupExternalUserInfo { $params{'EmailAddress'} = $EmailAddress; $params{'RealName'} = $RealName; - # See RT's contributed code for examples. - # http://www.fsck.com/pub/rt/contrib/ return ($FoundInExternalDatabase, %params); } -# }}} - -# {{{ Accessor methods for parsed email messages - =head2 Head Return the parsed head from this message @@ -738,8 +449,7 @@ sub Entity { return $self->{'entity'}; } -# }}} -# {{{ _SetupMIMEParser + =head2 _SetupMIMEParser $parser @@ -756,29 +466,242 @@ A private instance method which sets up a mime parser to do its job ## Over max size and return them sub _SetupMIMEParser { - my $self = shift; + my $self = shift; my $parser = shift; - my $AttachmentDir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 ); - - # Set up output directory for files: - $parser->output_dir("$AttachmentDir"); + + # Set up output directory for files; we use $RT::VarPath instead + # of File::Spec->tmpdir (e.g., /tmp) beacuse it isn't always + # writable. + my $tmpdir; + if ( -w $RT::VarPath ) { + $tmpdir = File::Temp::tempdir( DIR => $RT::VarPath, CLEANUP => 1 ); + } elsif (-w File::Spec->tmpdir) { + $tmpdir = File::Temp::tempdir( TMPDIR => 1, CLEANUP => 1 ); + } else { + $RT::Logger->crit("Neither the RT var directory ($RT::VarPath) nor the system tmpdir (@{[File::Spec->tmpdir]}) are writable; falling back to in-memory parsing!"); + } - #If someone includes a message, don't extract it + #If someone includes a message, extract it $parser->extract_nested_messages(1); + $parser->extract_uuencode(1); ### default is false + + if ($tmpdir) { + # If we got a writable tmpdir, write to disk + push ( @{ $self->{'AttachmentDirs'} ||= [] }, $tmpdir ); + $parser->output_dir($tmpdir); + $parser->filer->ignore_filename(1); - # Set up the prefix for files with auto-generated names: - $parser->output_prefix("part"); + # Set up the prefix for files with auto-generated names: + $parser->output_prefix("part"); - # If content length is <= 50000 bytes, store each msg as in-core scalar; - # Else, write to a disk file (the default action): + # From the MIME::Parser docs: + # "Normally, tmpfiles are created when needed during parsing, and destroyed automatically when they go out of scope" + # Turns out that the default is to recycle tempfiles + # Temp files should never be recycled, especially when running under perl taint checking - $parser->output_to_core(50000); + $parser->tmp_recycling(0) if $parser->can('tmp_recycling'); + } else { + # Otherwise, fall back to storing it in memory + $parser->output_to_core(1); + $parser->tmp_to_core(1); + $parser->use_inner_files(1); + } + +} + +=head2 ParseEmailAddress string + +Returns a list of Email::Address objects +Works around the bug that Email::Address 1.889 and earlier +doesn't handle local-only email addresses (when users pass +in just usernames on the RT system in fields that expect +Email Addresses) + +We don't handle the case of +bob, fred@bestpractical.com +because we don't want to fail parsing +bob, "Falcone, Fred" +The next release of Email::Address will have a new method +we can use that removes the bandaid + +=cut + +use Email::Address::List; + +sub ParseEmailAddress { + my $self = shift; + my $address_string = shift; + + my @list = Email::Address::List->parse( + $address_string, + skip_comments => 1, + skip_groups => 1, + ); + my $logger = sub { RT->Logger->error( + "Unable to parse an email address from $address_string: ". shift + ) }; + + my @addresses; + foreach my $e ( @list ) { + if ($e->{'type'} eq 'mailbox') { + if ($e->{'not_ascii'}) { + $logger->($e->{'value'} ." contains not ASCII values"); + next; + } + push @addresses, $e->{'value'} + } elsif ( $e->{'value'} =~ /^\s*(\w+)\s*$/ ) { + my $user = RT::User->new( RT->SystemUser ); + $user->Load( $1 ); + if ($user->id) { + push @addresses, Email::Address->new($user->Name, $user->EmailAddress); + } else { + $logger->($e->{'value'} ." is not a valid email address and is not user name"); + } + } else { + $logger->($e->{'value'} ." is not a valid email address"); + } + } + + $self->CleanupAddresses(@addresses); + + return @addresses; +} + +=head2 CleanupAddresses ARRAY + +Massages an array of L objects to make their email addresses +more palatable. + +Currently this strips off surrounding single quotes around C<< ->address >> and +B<< modifies the L objects in-place >>. + +Returns the list of objects for convienence in C/C chains. + +=cut + +sub CleanupAddresses { + my $self = shift; + + for my $addr (@_) { + next unless defined $addr; + # Outlook sometimes sends addresses surrounded by single quotes; + # clean them all up + if ((my $email = $addr->address) =~ s/^'(.+)'$/$1/) { + $addr->address($email); + } + } + return @_; +} + +=head2 RescueOutlook + +Outlook 2007/2010 have a bug when you write an email with the html format. +it will send a 'multipart/alternative' with both 'text/plain' and 'text/html' +in it. it's cool to have a 'text/plain' part, but the problem is the part is +not so right: all the "\n" in your main message will become "\n\n" :/ + +this method will fix this bug, i.e. replaces "\n\n" to "\n". +return 1 if it does find the problem in the entity and get it fixed. + +=cut + + +sub RescueOutlook { + my $self = shift; + my $mime = $self->Entity(); + return unless $mime && $self->LooksLikeMSEmail($mime); + + my $text_part; + if ( $mime->head->get('Content-Type') =~ m{multipart/mixed} ) { + my $first = $mime->parts(0); + if ( $first && $first->head->get('Content-Type') =~ m{multipart/alternative} ) + { + my $inner_first = $first->parts(0); + if ( $inner_first && $inner_first->head->get('Content-Type') =~ m{text/plain} ) + { + $text_part = $inner_first; + } + } + } + elsif ( $mime->head->get('Content-Type') =~ m{multipart/alternative} ) { + my $first = $mime->parts(0); + if ( $first && $first->head->get('Content-Type') =~ m{text/plain} ) { + $text_part = $first; + } + } + + # Add base64 since we've seen examples of double newlines with + # this type too. Need an example of a multi-part base64 to + # handle that permutation if it exists. + elsif ( ($mime->head->get('Content-Transfer-Encoding')||'') =~ m{base64} ) { + $text_part = $mime; # Assuming single part, already decoded. + } + + if ($text_part) { + + # use the unencoded string + my $content = $text_part->bodyhandle->as_string; + if ( $content =~ s/\n\n/\n/g ) { + + # Outlook puts a space on extra newlines, remove it + $content =~ s/\ +$//mg; + + # only write only if we did change the content + if ( my $io = $text_part->open("w") ) { + $io->print($content); + $io->close; + $RT::Logger->debug( + "Removed extra newlines from MS Outlook message."); + return 1; + } + else { + $RT::Logger->error("Can't write to body to fix newlines"); + } + } + } + + return; } -# }}} -eval "require RT::EmailParser_Vendor"; -die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Vendor.pm}); -eval "require RT::EmailParser_Local"; -die $@ if ($@ && $@ !~ qr{^Can't locate RT/EmailParser_Local.pm}); +=head1 LooksLikeMSEmail + +Try to determine if the current email may have +come from MS Outlook or gone through Exchange, and therefore +may have extra newlines added. + +=cut + +sub LooksLikeMSEmail { + my $self = shift; + my $mime = shift; + + my $mailer = $mime->head->get('X-Mailer'); + + # 12.0 is outlook 2007, 14.0 is 2010 + return 1 if ( $mailer && $mailer =~ /Microsoft(?:.*?)Outlook 1[2-4]\./ ); + + if ( RT->Config->Get('CheckMoreMSMailHeaders') ) { + + # Check for additional headers that might + # indicate this came from Outlook or through Exchange. + # A sample we received had the headers X-MS-Has-Attach: and + # X-MS-Tnef-Correlator: and both had no value. + + my @tags = $mime->head->tags(); + return 1 if grep { /^X-MS-/ } @tags; + } + + return 0; # Doesn't look like MS email. +} + +sub DESTROY { + my $self = shift; + File::Path::rmtree([@{$self->{'AttachmentDirs'}}],0,1) + if $self->{'AttachmentDirs'}; +} + + + +RT::Base->_ImportOverlays(); 1;