# # MailScanner - SMTP E-Mail Virus Scanner # Copyright (C) 2002 Julian Field # # $Id: Message.pm 3918 2007-05-27 20:32:11Z sysjkf $ # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # The author, Julian Field, can be contacted by email at # Jules@JulianField.net # or by paper mail at # Julian Field # Dept of Electronics & Computer Science # University of Southampton # Southampton # SO17 1BJ # United Kingdom # package MailScanner::Message; use strict 'vars'; use strict 'refs'; no strict 'subs'; # Allow bare words for parameter %'s use DirHandle; use Time::localtime qw/ctime/; use Time::HiRes qw/time/; use MIME::Parser; use MIME::Decoder::UU; use MIME::Decoder::BinHex; use MIME::WordDecoder; use POSIX qw(:signal_h setsid); use HTML::TokeParser; use HTML::Parser; use Archive::Zip qw( :ERROR_CODES ); use Filesys::Df; #use MailScanner::BinHex; # Install an extra MIME decoder for badly-header uue messages. install MIME::Decoder::UU 'uuencode'; # Install an extra MIME decoder for binhex-encoded attachments. install MIME::Decoder::BinHex 'binhex','binhex40','mac-binhex40','mac-binhex'; use vars qw($VERSION); ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 3918 $, 10; # Attributes are # # $id set by new # $store set by new (is a SMDiskStore for now) # #$hpath set by new # #$dpath set by new # $size set by new (copy of $store->{size}) # #$inhhandle set by new # #$indhandle set by new # $from set by ReadQf # $fromdomain set by new # $fromuser set by new # @to set by new # @todomain set by new # @touser set by new # $subject set by ReadQf # @headers set by ReadQf # just the headers, with /^H/ removed # Note @headers is read-only! # @metadata set by ReadQf # the entire qf file excluding final "." # $returnpathflags set by ReadQf # Only used for sendmail at the moment # $clientip set by ReadQf # $scanme set by NeedsScanning (from MsgBatch constructor) # $workarea set by new # @archiveplaces set by new (addresses and dirs) # @quarantineplaces set by Quarantine.pm # $spamwhitelisted set by IsSpam # $spamblacklisted set by IsSpam # $isspam set by IsSpam # $issaspam set by IsSpam # $isrblspam set by IsSpam # $ishigh set by IsSpam # $sascore set by IsSpam # $spamreport set by IsSpam # $mcpwhitelisted set by IsMCP # $ismcp set by IsMCP # $issamcp set by IsMCP # $ishighmcp set by IsMCP # $mcpsascore set by IsMCP # $mcpreport set by IsMCP # $deleted set by delivery functions # $headerspath set by WriterHeaderFile # file is read-only # $cantparse set by Explode # $toomanyattach set by Explode # $cantdisinfect set by ExplodeArchive # $entity set by Explode # $tnefentity set by Explode (only set if it's a TNEF message) # $badtnef set by Explode # $entity set by Explode # %name2entity set by Explode # %file2parent set by Explode # $virusinfected set by new and ScanBatch # $nameinfected set by new and ScanBatch # $otherinfected set by new and ScanBatch # $sizeinfected set by new and ScanBatch # %virusreports set by TryCommercial (key is filename) # %virustypes set by TryCommercial (key is filename) # %namereports set by filename trap checker # %nametypes set by filename trap checker # %otherreports set by TryOther (key is filename) # %othertypes set by TryOther (key is filename) # %entityreports set by TryOther (key is entity) # %oldviruses set by DisinfectAndDeliver # $infected set by CombineReports # %allreports set by CombineReports # %alltypes set by CombineReports # %entity2parent set by CreateEntitiesHelpers # %entity2file set by CreateEntitiesHelpers # %file2entity set by CreateEntitiesHelpers (maps original evil names) # %file2safefile set by CreateEntitiesHelpers (evil==>safe) # %safefile2file set by CreateEntitiesHelpers (safe==>evil) # $numberparts set by CreateEntitiesHelpers # $signed set by Clean # $bodymodified set by Clean and SignUninfected # $silent set by FindSilentAndNoisyInfections # if infected with a silent virus # $noisy set by FindSilentAndNoisyInfections # if infected with a noisy virus # $needsstripping set by HandleSpam and HandleMCP # $stillwarn set by new # Still send warnings even if deleted # $needsencapsulating set by HandleSpam and HAndleMCP # %postfixrecips set by ReadQf in Postfix support only. Hash of all the # 'R' addresses in the message to aid rebuilding. # %originalrecips set by ReadQf in Postfix support only. Hash of all the # 'O' addresses in the message to aid rebuilding. # %deleteattach set by ScanBatch and CheckFiletypeRules. True if # attachment is to be deleted rather than stored. # $tagstoconvert set by ??? is list of HTML tags to dis-arm # $gonefromdisk set by calls to DeleteUnlock # $subjectwasunsafe set by SweepContent.pm # $safesubject set by SweepContent.pm # $mcpdelivering set by HandleMCP # $salongreport set by SA::Checks (longest version of SA report) # @spamarchive set by HandleHamAndSpam, list of places we have # quarantined spam/mcp message. Used later to # delete infected spam from spam quarantine. # $dontdeliver set by HandleHamAndSpam, true if the message was put # in the spam/mcp archive, but still needs to be # virus-scanned so we can remove it again if # necessary. But it doesn't need repairing, as we # won't be delivering it anyway. # $datenumber set by new # $datestring set by new # $messagedisarmed set by DisarmHTMLTree # @disarmedtags All the HTML tags (incl. phishing) that we found # and disarmed or highlighted. # $quarantinedinfectionsset by QuarantineInfections, has this message already # been quarantined, so doesn't need quarantining # in QuarantineModifiedBodies. # $actions set by HandleHamAndSpam, saves action list. # $ret set by new, true if BarricadeMX RET hash is valid # # Constructor. # Takes id. # Takes options $fake which is just used for making an object for # the command-line testing. # This isn't specific to the MTA at all, so is all done here. sub new { my $type = shift; my($id, $queuedirname, $fake) = @_; my $this = {}; my($mta, $addr, $user, $domain); my($archiveplaces); #print STDERR "Creating message $id\n"; $this->{id} = $id; @{$this->{archiveplaces}} = (); @{$this->{spamarchive}} = (); @{$this->{quarantineplaces}} = (); if ($fake) { bless $this, $type; return $this; } # Create somewhere to store the message $this->{store} = new MailScanner::SMDiskStore($id, $queuedirname); # Try to open and exclusive-lock this message. Return undef if failed. #print STDERR "Trying to lock message " . $this->{id} . "\n"; $this->{store}->Lock() or return undef; #print STDERR "Locked message\n"; # Now try to fill as much of the structure as possible $this->{size} = $this->{store}->size(); $global::MS->{mta}->ReadQf($this) or return 'INVALID'; # Return empty if fails # Work out the user @ domain components ($user, $domain) = address2userdomain($this->{from}); $this->{fromuser} = $user; $this->{fromdomain} = $domain; foreach $addr (@{$this->{to}}) { ($user, $domain) = address2userdomain($addr); push @{$this->{touser}}, $user; push @{$this->{todomain}}, $domain; } # BarricadeMX mods # Automatically detect if BarricadeMX is in use (clientip=127.0.0.1) and # the second Received header contains 'ret-id'. If this is true then: # 1) Override $this->{clientip} with the IP from the 2nd Received header. # 2) If 'ret-id pass' is in the 2nd Received header, set $this->{ret}. # # Example: # # Received: from xxx.xxx.com (localhost.localdomain [127.0.0.1]) # by mail.fsg.com (8.13.1/8.13.1) with SMTP id xxxxxxxxxxxxxx # for ; Sat, 13 Jan 2007 17:02:49 -0500 # Received: from xxxxxxxxxx.net (xxxxxxxx.xxxxxxxxxx.xxx [111.111.11.11]) # by xxxx.xxx.com (xxxx.xxx.com [192.168.111.11]) # id xxxxxxxxxxxxxxxxxx ret-id none; Sat, 13 Jan 2007 17:03:09 -0500 # $this->{ret} = 0; if($this->{clientip} eq '127.0.0.1') { my($header_line, $last_rcvd, $last_rcvd_ip); my($rcvd_count) = 0; foreach $header_line (@{$this->{headers}}) { # print STDERR "DEBUG: Header line: $header_line\n"; if($header_line =~ /ret-id/ && $rcvd_count == 2) { $this->{clientip} = $last_rcvd_ip if ($last_rcvd_ip); # print STDERR "DEBUG: Using received header $rcvd_count - IP: $last_rcvd_ip\n"; $this->{ret} = 1 if($header_line =~ /ret-id pass/i); last; } if($header_line =~ /Received:/) { $rcvd_count++; $last_rcvd = $header_line; my($rcvd_ip) = $last_rcvd =~ /\(.*\[(.+)\]\)/; # print STDERR "DEBUG: $last_rcvd - IP: $rcvd_ip\n"; $last_rcvd_ip = $rcvd_ip; last if $rcvd_count > 2; } } } # Reset the infection counters to 0 $this->{virusinfected} = 0; $this->{nameinfected} = 0; $this->{otherinfected} = 0; $this->{sizeinfected} = 0; $this->{stillwarn} = 0; # Set the date string and number $this->{datestring} = scalar localtime; my($day, $month, $year, $date); ($day, $month, $year) = (localtime)[3,4,5]; $date = sprintf("%04d%02d%02d", $year+1900, $month+1, $day); $this->{datenumber} = $date; # Work out where to archive/copy this message. # Could do all the archiving in a different separate place. $archiveplaces = MailScanner::Config::Value('archivemail', $this); if ($archiveplaces =~ /_DATE_/) { # Only do the work for the date substitution if we really have to $archiveplaces =~ s/_DATE_/$date/g; #print STDERR "Archive location is $archiveplaces\n"; } @{$this->{archiveplaces}} = ((defined $archiveplaces)?split(" ", $archiveplaces):()); # Decide if we want to scan this message at all $this->{scanmail} = MailScanner::Config::Value('scanmail', $this); $this->{scanmail} = 1 if $this->{scanmail} !~ /^[0\s]+$/; bless $this, $type; return $this; } # Take an email address. Return (user, domain). sub address2userdomain { my($addr) = @_; my($user, $domain); $addr = lc($addr); $addr =~ s/^<\s*//; # Delete leading and $addr =~ s/\s*>$//; # trailing <> $user = $addr; $domain = $addr; if ($addr =~ /@/) { $user =~ s/@[^@]*$//; $domain =~ s/^[^@]*@//; } return ($user, $domain); } # Print a message sub print { my $this = shift; print STDERR "Message " . $this->{id} . "\n"; print STDERR " Size = " . $this->{size} . "\n"; print STDERR " From = " . $this->{from} . "\n"; print STDERR " To = " . join(',',@{$this->{to}}) . "\n"; print STDERR " Subj = " . $this->{subject} . "\n"; } # Get/Set "scanme" flag sub NeedsScanning { my($this, $value) = @_; $this->{scanme} = $value if @_ > 1; return $this->{scanme}; } # Write the file containing all the message headers. # Called by the MessageBatch constructor. # Notes: assumes the directories required already exist. sub WriteHeaderFile { my $this = shift; #my @headers; my $header = new FileHandle; my $filename = $global::MS->{work}->{dir} . '/' . $this->{id} . '.header'; $this->{headerspath} = $filename; MailScanner::Lock::openlock($header, ">$filename", "w") or MailScanner::Log::DieLog("Cannot create + lock headers file %s, %s", $filename, $!); #@headers = $global::MS->{mta}->OriginalMsgHeaders($this); #print STDERR "Headers are " . join(', ', @headers) . "\n"; #foreach (@headers) { foreach ($global::MS->{mta}->OriginalMsgHeaders($this)) { tr/\r/\n/; # Work around Outlook [Express] bug allowing viruses in headers print $header "$_\n"; } print $header "\n"; MailScanner::Lock::unlockclose($header); # Set the owner of the header file chown $global::MS->{work}->{uid}, $global::MS->{work}->{gid}, $filename if $global::MS->{work}->{changeowner}; } # Is this message spam? Try to build the spam report and store it in # the message. sub IsSpam { my $this = shift; my($includesaheader, $iswhitelisted, $usegsscanner); my $spamheader = ""; my $rblspamheader = ""; my $gsreport = ""; my $saspamheader = ""; my $RBLsaysspam = 0; my $rblcounter = 0; my $LogSpam = MailScanner::Config::Value('logspam'); my $LogNonSpam = MailScanner::Config::Value('lognonspam'); my $LocalSpamText = MailScanner::Config::LanguageValue($this, 'spam'); my $LocalNotSpamText = MailScanner::Config::LanguageValue($this, 'notspam'); # Construct a pretty list of all the unique domain names for logging my(%todomain, $todomain); foreach $todomain (@{$this->{todomain}}) { $todomain{$todomain} = 1; } $todomain = join(',', keys %todomain); my $recipientcount = @{$this->{to}}; # $spamwhitelisted set by IsSpam # $spamblacklisted set by IsSpam # $isspam set by IsSpam # $ishigh set by IsSpam # $spamreport set by IsSpam $this->{spamwhitelisted} = 0; $this->{spamblacklisted} = 0; $this->{isspam} = 0; $this->{ishigh} = 0; $this->{spamreport} = ""; $this->{sascore} = 0; # Work out if they always want the SA header $includesaheader = MailScanner::Config::Value('includespamheader', $this); # If they want the GS scanner then we must carry on too $usegsscanner = MailScanner::Config::Value('gsscanner', $this); # Do the whitelist check before the blacklist check. # If anyone whitelists it, then everyone gets the message. # If no-one has whitelisted it, then consider the blacklist. $iswhitelisted = 0; my $maxrecips = MailScanner::Config::Value('whitelistmaxrecips'); $maxrecips = 999999 unless $maxrecips; # BarricadeMX mods # Skip SpamAssassin if a valid RET hash is found ($this->{ret} == true) if ($this->{ret}) { MailScanner::Log::InfoLog("Valid RET hash found in Message %s, skipping Spam Checks",$this->{id}); return 0; } if ($recipientcount<=$maxrecips) { if (MailScanner::Config::Value('spamwhitelist', $this)) { # Whitelisted, so get out unless they want SA header #print STDERR "Message is whitelisted\n"; MailScanner::Log::InfoLog("Message %s from %s (%s) is whitelisted", $this->{id}, $this->{clientip}, $this->{from}) if $LogSpam || $LogNonSpam; $iswhitelisted = 1; $this->{spamwhitelisted} = 1; # whitelisted and doesn't want SA header so get out return 0 unless $includesaheader || $usegsscanner; } } else { # Had too many recipients, ignoring the whitelist MailScanner::Log::InfoLog("Message %s from %s (%s) ignored whitelist, " . "had %d recipients (>%d)", $this->{id}, $this->{clientip}, $this->{from}, $recipientcount, $maxrecips) if $LogSpam || $LogNonSpam; } # If it's a blacklisted address, don't bother doing any checks at all if (!$iswhitelisted && MailScanner::Config::Value('spamblacklist', $this)) { $this->{spamblacklisted} = 1; $this->{isspam} = 1; $this->{ishigh} = 1 if MailScanner::Config::Value('blacklistedishigh', $this); $this->{spamreport} = $LocalSpamText . ' (' . MailScanner::Config::LanguageValue($this, 'blacklisted') . ')'; MailScanner::Log::InfoLog("Message %s from %s (%s) to %s" . " is spam (blacklisted)", $this->{id}, $this->{clientip}, $this->{from}, $todomain) if $LogSpam; return 1; } my $whitelistreport = ''; if ($iswhitelisted) { $whitelistreport = ' (' . MailScanner::Config::LanguageValue($this, 'whitelisted') . ')'; } # # Check to see if message is too large to be likely to be spam. # my $maxtestsize = MailScanner::Config::Value('maxspamchecksize',$this); if ($this->{size} > $maxtestsize) { $this->{spamreport} = MailScanner::Config::LanguageValue($this, 'skippedastoobig'); $this->{spamreport} = $this->ReflowHeader( MailScanner::Config::Value('spamheader',$this), $this->{spamreport}); MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is too big for spam checks (%d > %d bytes)", $this->{id}, $this->{clientip}, $this->{from}, $todomain, $this->{size}, $maxtestsize); return 0; } if (!$iswhitelisted) { # Not whitelisted, so do the RBL checks $0 = 'MailScanner: checking with Spam Lists'; ($rblcounter, $rblspamheader) = MailScanner::RBLs::Checks($this); my $rblthreshold = MailScanner::Config::Value('normalrbls', $this); my $highrblthreshold = MailScanner::Config::Value('highrbls', $this); $rblthreshold = 1 if $rblthreshold <= 1; $highrblthreshold = 1 if $highrblthreshold <= 1; $RBLsaysspam = 1 if $rblcounter >= $rblthreshold; # Add leading "spam, " if RBL says it is spam. This will be at the # front of the spam report. $this->{isspam} = 1 if $RBLsaysspam; $this->{isrblspam} = 1 if $RBLsaysspam; $this->{ishigh} = 1 if $rblcounter >= $highrblthreshold; } # rblspamheader is useful start to spamreport if RBLsaysspam. # Do the Custom Spam Checker my($gsscore, $gsreport); #print STDERR "In Message.pm about to look at gsscanner\n"; if ($usegsscanner) { #print STDERR "In Message.pm about to run gsscanner\n"; ($gsscore, $gsreport) = MailScanner::GenericSpam::Checks($this); #print STDERR "In Message.pm we got $gsscore, $gsreport\n"; $this->{gshits} = $gsscore; $this->{gsreport} = $gsreport; $this->{sascore} = $gsscore; # Add the score MailScanner::Log::InfoLog("Custom Spam Scanner for message %s from %s " . "(%s) to %s report is %s %s", $this->{id}, $this->{clientip}, $this->{from}, $todomain, $gsscore, $gsreport) if $LogSpam && ($gsscore!=0 || $gsreport ne ""); } # Don't do the SA checks if they have said no. unless (MailScanner::Config::Value('usespamassassin', $this)) { $this->{spamwhitelisted} = $iswhitelisted; $this->{isspam} = 1 if $gsscore+0.0 >= MailScanner::Config::Value('reqspamassassinscore',$this)+0.0; $this->{ishigh} = 1 if $gsscore+0.0 >= MailScanner::Config::Value('highspamassassinscore',$this)+0.0; MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s", $this->{id}, $this->{clientip}, $this->{from}, $todomain, $rblspamheader) if $RBLsaysspam && $LogSpam; # Replace start of report if it wasn't spam from rbl but now is. $this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText; $this->{spamreport} .= $whitelistreport; $this->{spamreport} .= ', ' if $this->{spamreport}; $this->{spamreport} .= $rblspamheader if $rblspamheader; $this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader; $this->{spamreport} .= $gsscore+0.0 if $gsscore!=0; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0; $this->{spamreport} .= $gsreport if $gsreport ne ""; $this->{spamreport} = $this->ReflowHeader( MailScanner::Config::Value('spamheader',$this), $this->{spamreport}); return $this->{isspam}; } # If it's spam and they dont want to check SA as well if ($this->{isspam} && !MailScanner::Config::Value('checksaifonspamlist', $this)) { $this->{spamwhitelisted} = $iswhitelisted; MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s", $this->{id}, $this->{clientip}, $this->{from}, $todomain, $rblspamheader) if $RBLsaysspam && $LogSpam; # Replace start of report if it wasn't spam from rbl but now is. $this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText; $this->{spamreport} .= $whitelistreport; $this->{spamreport} .= ', ' if $this->{spamreport}; $this->{spamreport} .= $rblspamheader if $rblspamheader; $this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader; $this->{spamreport} .= $gsscore+0.0 if $gsscore!=0; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0; $this->{spamreport} .= $gsreport if $gsreport ne ""; $this->{spamreport} = $this->ReflowHeader( MailScanner::Config::Value('spamheader',$this), $this->{spamreport}); return $RBLsaysspam; } # They must want the SA checks doing. my $SAsaysspam = 0; my $SAHighScoring = 0; my $saheader = ""; my $sascore = 0; my $salongreport = ""; $0 = 'MailScanner: checking with SpamAssassin'; ($SAsaysspam, $SAHighScoring, $saheader, $sascore, $salongreport) = MailScanner::SA::Checks($this); $this->{sascore} += $sascore; # Save the actual figure for use later... # Trim all the leading rubbish off the long SA report and turn it back # into a multi-line string, then store it in the message properties. $salongreport =~ s/^.* pts rule name/ pts rule name/; $salongreport =~ tr/\0/\n/; $this->{salongreport} = $salongreport; #print STDERR $salongreport . "\n"; # Fix the return values $SAsaysspam = 0 unless $saheader; # Solve bug with empty SAreports $saheader =~ s/\s+$//g if $saheader; # Solve bug with trailing space #print STDERR "SA report is \"$saheader\"\n"; #print STDERR "SAsaysspam = $SAsaysspam\n"; $saheader = MailScanner::Config::LanguageValue($this, 'spamassassin') . " ($saheader)" if $saheader; # The message really is spam if SA says so (unless it's been whitelisted) unless ($iswhitelisted) { $this->{isspam} |= $SAsaysspam; $this->{issaspam} = $SAsaysspam; } # If it's spam... if ($this->{isspam}) { #print STDERR "It is spam\nInclude SA = $includesaheader\n"; #print STDERR "SAHeader = $saheader\n"; # If it's SA spam as well, or they always want the SA header if ($SAsaysspam || $includesaheader) { #print STDERR "Spam or Add SA Header\n"; $this->{ishigh} = 1 if $SAHighScoring; $this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText; $this->{spamreport} .= $whitelistreport; $this->{spamreport} .= ', ' if $this->{spamreport}; $this->{spamreport} .= $rblspamheader if $rblspamheader; $this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader; $this->{spamreport} .= $gsscore+0.0 if $gsscore!=0; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0; $this->{spamreport} .= $gsreport if $gsreport ne ""; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsreport; $this->{spamreport} .= $saheader if $saheader ne ""; } } else { # It's not spam... #print STDERR "It's not spam\n"; #print STDERR "SAHeader = $saheader\n"; $this->{spamreport} = ($this->{isspam})?$LocalSpamText:$LocalNotSpamText; $this->{spamreport} .= $whitelistreport; $this->{spamreport} .= ', ' if $this->{spamreport}; $this->{spamreport} .= $rblspamheader if $rblspamheader; $this->{spamreport} .= ', ' if $this->{spamreport} && $rblspamheader; $this->{spamreport} .= $gsscore+0.0 if $gsscore!=0; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsscore!=0; $this->{spamreport} .= $gsreport if $gsreport ne ""; $this->{spamreport} .= ', ' if $this->{spamreport} && $gsreport; $this->{spamreport} .= $saheader if $saheader ne ""; } # Do the spam logging here so we can log high-scoring spam too if (($LogSpam && $this->{isspam}) || ($LogNonSpam && !$this->{isspam})) { my $ReportText = $this->{spamreport}; $ReportText =~ s/\s+/ /sg; MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s", $this->{id}, $this->{clientip}, $this->{from}, $todomain, $ReportText); } # Now just reflow and log the results if ($this->{spamreport} ne "") { $this->{spamreport} = $this->ReflowHeader( MailScanner::Config::Value('spamheader',$this), $this->{spamreport}); } return $this->{isspam}; } # Do whatever is necessary with this message to deal with spam. # We can assume the message passed is indeed spam (isspam==true). # Call it with either 'spam' or 'nonspam'. Don't use 'ham'! sub HandleHamAndSpam { my($this, $HamSpam) = @_; my($actions, $action, @actions, %actions); my(@extraheaders, $actionscopy, $actionkey); # Set default action for DMX/MailWatch reporting $this->{actions} = 'deliver'; # Get a space-separated list of all the actions if ($HamSpam eq 'nonspam') { #print STDERR "Looking up hamactions\n"; $actions = MailScanner::Config::Value('hamactions', $this); # Fast bail-out if it's just the simple "deliver" case that 99% of # people will use return if $actions eq 'deliver'; } else { # It must be spam as it's not ham if ($this->{ishigh}) { #print STDERR "Looking up highscorespamactions\n"; $actions = MailScanner::Config::Value('highscorespamactions', $this); } else { #print STDERR "Looking up spamactions\n"; $actions = MailScanner::Config::Value('spamactions', $this); } } # Find all the bits in quotes, with their spaces $actionscopy = $actions; #print STDERR "Actions = \'$actions\'\n"; while ($actions =~ s/\"([^\"]+)\"//) { $actionkey = $1; #print STDERR "ActionKey = $actionkey and $1\n"; push @extraheaders, $actionkey; MailScanner::Log::WarnLog("Syntax error in \"header\" action in spam " . "actions, missing \":\" in %s", $actionkey) unless $actionkey =~ /:/; } @{$this->{extraspamheaders}} = @extraheaders; $actions = lc($actions); $actions =~ s/^\s*//; $actions =~ s/\s*$//; $actions =~ s/\s+/ /g; #print STDERR "Actions after = \'$actions\'\n"; #print STDERR "Extra headers are \"" . join(',',@extraheaders) . "\"\n"; MailScanner::Log::WarnLog('Syntax error: missing " in spam actions %s', $actionscopy) if $actions =~ /\"/; $actions =~ tr/,//d; # Remove all commas in case they put any in @actions = split(" ", $actions); #print STDERR "Actions are $actions\n"; # The default action if they haven't specified anything is to # deliver spam like normal mail. return unless @actions; # If they have just specified a filename, then something is wrong if ($#actions==0 && $actions[0] =~ /\//) { MailScanner::Log::WarnLog('Your spam actions "%s" looks like a filename.' . ' If this is a ruleset filename, it must end in .rule or .rules', $actions[0]); $actions[0] = 'deliver'; } #print STDERR "Message: HandleHamSpam has actions " . join(',',@actions) . # "\n"; # Save actions for DMX/MailWatch reporting $this->{actions} = join(',', @actions); my %lintoptions; foreach $action (@actions) { $lintoptions{$action} = 1; # If the message is a MCP message then don't do the ham/spam "deliver" # as the MCP actions will have provided a "deliver" if they want one. next if $this->{ismcp} && $action eq 'deliver'; $actions{$action} = 1; #print STDERR "Message: HandleSpam action is $action\n"; if ($action =~ /\@/) { #print STDERR "Message " . $this->{id} . " : HandleSpam() adding " . # "$action to archiveplaces\n"; push @{$this->{archiveplaces}}, $action; $actions{'forward'} = 1; delete $lintoptions{$action}; # Can't syntax-check email addresses } } # Do the syntax check delete $lintoptions{'deliver'}; delete $lintoptions{'delete'}; delete $lintoptions{'store'}; delete $lintoptions{'bounce'}; delete $lintoptions{'forward'}; delete $lintoptions{'striphtml'}; delete $lintoptions{'attachment'}; delete $lintoptions{'notify'}; delete $lintoptions{'header'}; my $lintstring = join(' ',keys %lintoptions); if ($lintstring ne '') { my $lints = ($lintstring =~ / /)?'s':''; my $linttype; if ($HamSpam eq 'nonspam') { $linttype = 'Non-Spam'; } else { if ($this->{ishigh}) { $linttype = 'High-Scoring Spam'; } else { $linttype = 'Spam'; } } MailScanner::Log::WarnLog("Message %s produced illegal %s Action%s " . "\"%s\", so message is being delivered", $this->{id}, $linttype, $lints, $lintstring); #print STDERR sprintf("Message %s produced illegal %s Action%s " . # "\"%s\", so message is being delivered\n", # $this->{id}, $linttype, $lints, $lintstring); # We found an error so fail-safe by delivering the message $actions{'deliver'} = 1; } # Now we are left with deliver, bounce, delete, store and striphtml. #print STDERR "Archive places are " . join(',', keys %actions) . "\n"; # Split this job into 2. # 1) The message is being delivered to at least 1 address, # 2) The message is not being delivered to anyone. # The extra addresses for forward it to have already been added. if ($actions{'deliver'} || $actions{'forward'} || $this->{mcpdelivering}) { # # Message is going to original recipient and/or extra recipients # MailScanner::Log::NoticeLog("Spam Actions: message %s actions are %s", $this->{id}, join(',', keys %actions)) if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam'); # Delete the original recipient if they are only forwarding it $global::MS->{mta}->DeleteRecipients($this) if !$actions{'deliver'}; # Delete action is over-ridden as we are sending it somewhere delete $actions{'delete'}; # Message still exists, so it will be delivered to its new recipients } else { # # Message is not going to be delivered anywhere # MailScanner::Log::NoticeLog("Spam Actions: message %s actions are %s", $this->{id}, join(',', keys %actions)) if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam'); # Mark the message so it won't get cleaned up or delivered, but just dropped #print STDERR "Setting DontDeliver for " . $this->{id} . "\n"; $this->{dontdeliver} = 1; # Optimisation courtesy of Yavor.Trapkov@wipo.int $this->{deleted} = 1 if (keys %actions) == 1 && $actions{'delete'}; ## Mark the message as deleted, so it won't get delivered #$this->{deleted} = 1; } # All delivery will now happen correctly. # Bounce a message back to the sender if they want that if ($actions{'bounce'}) { if ($HamSpam eq 'nonspam') { MailScanner::Log::WarnLog("Does not make sense to bounce non-spam"); } else { #MailScanner::Log::WarnLog('The "bounce" Spam Action no longer exists'); if ($this->{ishigh}) { MailScanner::Log::NoticeLog("Will not bounce high-scoring spam") } else { $this->HandleSpamBounce() if MailScanner::Config::Value('enablespambounce', $this); } } } # Notify the recipient if they want that if ($actions{'notify'}) { if ($HamSpam eq 'nonspam') { MailScanner::Log::WarnLog("Does not make sense to notify recipient about non-spam"); } else { $this->HandleSpamNotify(); } } # Store it if they want that if ($actions{'store'}) { my($dir, $dir2, $spamdir, $uid, $gid, $changeowner); $uid = $global::MS->{quar}->{uid}; $gid = $global::MS->{quar}->{gid}; $changeowner = $global::MS->{quar}->{changeowner}; $dir = MailScanner::Config::Value('quarantinedir', $this); #$dir2 = $dir . '/' . MailScanner::Quarantine::TodayDir(); $dir2 = $dir . '/' . $this->{datenumber}; $spamdir = $dir2 . '/' . $HamSpam; #print STDERR "dir = $dir\ndir2 = $dir2\nspamdir = $spamdir\n"; umask $global::MS->{quar}->{dirumask}; unless (-d $dir) { mkdir $dir, 0777; chown $uid, $gid, $dir if $changeowner; } unless (-d $dir2) { mkdir $dir2, 0777; chown $uid, $gid, $dir2 if $changeowner; } unless (-d $spamdir) { mkdir $spamdir, 0777; chown $uid, $gid, $spamdir if $changeowner; } #print STDERR "Storing spam to $spamdir/" . $this->{id} . "\n"; #print STDERR "uid=$uid gid=$gid changeowner=$changeowner\n"; umask $global::MS->{quar}->{fileumask}; my @paths = $this->{store}->CopyEntireMessage($this, $spamdir, $this->{id}, $uid, $gid, $changeowner); # Remember where we have stored the spam in an archive, so we never # archive infected messages #print STDERR "Added " . join(',', @paths) . " to spamarchive\n"; push @{$this->{spamarchive}}, @paths; chown $uid, $gid, "$spamdir/" . $this->{id}; # Harmless if this fails } umask 0077; # Safety net # If they want to strip the HTML tags out of it, # then just tag it as we can only do this later. $this->{needsstripping} = 1 if $actions{'striphtml'}; # If they want to encapsulate the message in an RFC822 part, # then tag it so we can do this later. $this->{needsencapsulating} = 1 if $actions{'attachment'}; } # We want to send a message back to the sender saying that their junk # email has been rejected by our site. # Send a message back to the sender which has the local postmaster as # the header sender, but <> as the envelope sender. This means it # cannot bounce. # Now have 3 different message file settings: # 1. Is spam according to RBL's # 2. Is spam according to SpamAssassin # 3. Is spam according to both sub HandleSpamBounce { my $this = shift; my($from,$to,$subject,$date,$spamreport,$longspamreport,$hostname); my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id); my($postmastername); $from = $this->{from}; # Don't ever send a message to "" or "<>" return if $from eq "" || $from eq "<>"; # Do we want to send the sender a warning at all? # If nosenderprecedence is set to non-blank and contains this # message precedence header, then just return. my(@preclist, $prec, $precedence, $header); @preclist = split(" ", lc(MailScanner::Config::Value('nosenderprecedence', $this))); $precedence = ""; foreach $header (@{$this->{headers}}) { $precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i; } if (@preclist && $precedence ne "") { foreach $prec (@preclist) { if ($precedence eq $prec) { MailScanner::Log::InfoLog("Skipping sender of precedence %s", $precedence); return; } } } # Setup other variables they can use in the message template $id = $this->{id}; #$to = join(', ', @{$this->{to}}); $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $hostname = MailScanner::Config::Value('hostname', $this); $subject = $this->{subject}; $date = $this->{datestring}; # scalar localtime; $spamreport = $this->{spamreport}; $longspamreport = $this->{salongreport}; #print STDERR "longspamreport = \"$longspamreport\"\n"; my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); # Delete everything in brackets after the SA report, if it exists $spamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i; # Work out which of the 3 spam reports to send them. $filename = ""; if ($this->{isrblspam} && !$this->{issaspam}) { $filename = MailScanner::Config::Value('senderrblspamreport', $this); MailScanner::Log::NoticeLog("Spam Actions: (RBL) Bounce to %s", $from) if MailScanner::Config::Value('logspam'); } elsif ($this->{issaspam} && !$this->{isrblspam}) { $filename = MailScanner::Config::Value('sendersaspamreport', $this); MailScanner::Log::NoticeLog("Spam Actions: (SpamAssassin) Bounce to %s", $from) if MailScanner::Config::Value('logspam'); } if ($filename eq "") { $filename = MailScanner::Config::Value('senderbothspamreport', $this); MailScanner::Log::NoticeLog("Spam Actions: (RBL,SpamAssassin) Bounce to %s", $from) if MailScanner::Config::Value('logspam'); } $messagefh = new FileHandle; $messagefh->open($filename) or MailScanner::Log::WarnLog("Cannot open message file %s, %s", $filename, $!); $emailmsg = "X-MailScanner-Bounce: yes\n"; while(<$messagefh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; # Bug fix by Martin Hepworth $line = eval "\"$1\""; $emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n"; } $messagefh->close(); if (MailScanner::Config::Value('bouncespamasattachment', $this)) { $this->HandleSpamBounceAttachment($emailmsg); } else { # Send the message to the spam sender, but ensure the envelope # sender address is "<>" so that it can't be bounced. $global::MS->{mta}->SendMessageString($this, $emailmsg, '<>') or MailScanner::Log::WarnLog("Could not send sender spam bounce, %s", $!); } } # Like encapsulating and sending a message to the recipient, take the # passed text as the text and headers of an email message and attach # the original message as an rfc/822 attachment. sub HandleSpamBounceAttachment { my($this, $plaintext) = @_; my $parser = MIME::Parser->new; my $explodeinto = $global::MS->{work}->{dir} . '/' . $this->{id}; #print STDERR "Extracting spam bounce message into $explodeinto\n"; my $filer = MIME::Parser::FileInto->new($explodeinto); $parser->filer($filer); my $bounce = eval { $parser->parse_data(\$plaintext) }; if (!$bounce) { MailScanner::Log::WarnLog("Cannot parse spam bounce report, %s", $!); return; } #print STDERR "Successfully parsed bounce report\n"; # Now make it multipart and push the report into a child $bounce->make_multipart('report'); # Now turn the original message into a string and attach it my(@original); #my $original = $this->{entity}->stringify; @original = $global::MS->{mta}->OriginalMsgHeaders($this, "\n"); push(@original, "\n"); $this->{store}->ReadBody(\@original, MailScanner::Config::Value( 'maxspamassassinsize')); $bounce->add_part(MIME::Entity->build(Type => 'message/rfc822', Disposition => 'attachment', Top => 0, 'X-Mailer' => undef, Data => \@original)); # Prune all the dead branches off the tree PruneEntityTree($bounce); # Stringify the message and send it -- this could be VERY large! my $bouncetext = $bounce->stringify; #print STDERR "Spam bounce message is this:\n$bouncetext"; if ($bouncetext) { $global::MS->{mta}->SendMessageString($this, $bouncetext, '<>') or MailScanner::Log::WarnLog( "Could not send sender spam bounce attachment, %s", $!); } else { MailScanner::Log::WarnLog( "Failed to create sender spam bounce attachment, %s", $!); } } # We want to send a message to the recipient saying that their spam # mail has not been delivered. # Send a message to the recipients which has the local postmaster as # the sender. sub HandleSpamNotify { my $this = shift; my($from,$to,$subject,$date,$spamreport,$hostname,$day,$month,$year); my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id); my($postmastername); $from = $this->{from}; # Don't ever send a message to "" or "<>" return if $from eq "" || $from eq "<>"; # Do we want to send the sender a warning at all? # If nosenderprecedence is set to non-blank and contains this # message precedence header, then just return. my(@preclist, $prec, $precedence, $header); @preclist = split(" ", lc(MailScanner::Config::Value('nosenderprecedence', $this))); $precedence = ""; foreach $header (@{$this->{headers}}) { $precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i; } if (@preclist && $precedence ne "") { foreach $prec (@preclist) { if ($precedence eq $prec) { MailScanner::Log::InfoLog("Skipping sender of precedence %s", $precedence); return; } } } # Setup other variables they can use in the message template $id = $this->{id}; $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $hostname = MailScanner::Config::Value('hostname', $this); $subject = $this->{subject}; $date = $this->{datestring}; # scalar localtime; $spamreport = $this->{spamreport}; # And let them put the date number in there too #($day, $month, $year) = (localtime)[3,4,5]; #$month++; #$year += 1900; #my $datenumber = sprintf("%04d%02d%02d", $year, $month, $day); my $datenumber = $this->{datenumber}; my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); # Delete everything in brackets after the SA report, if it exists $spamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i; # Work out which of the 3 spam reports to send them. $filename = MailScanner::Config::Value('recipientspamreport', $this); MailScanner::Log::NoticeLog("Spam Actions: Notify %s", $to) if MailScanner::Config::Value('logspam'); $messagefh = new FileHandle; $messagefh->open($filename) or MailScanner::Log::WarnLog("Cannot open message file %s, %s", $filename, $!); $emailmsg = ""; while(<$messagefh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; $line = eval "\"$1\""; $emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n"; } $messagefh->close(); # Send the message to the spam sender, but ensure the envelope # sender address is "<>" so that it can't be bounced. $global::MS->{mta}->SendMessageString($this, $emailmsg, $localpostmaster) or MailScanner::Log::WarnLog("Could not send sender spam notify, %s", $!); } sub RejectMessage { my $this = shift; my($from,$to,%tolist,$subject,$date,$hostname); my($emailmsg, $line, $messagefh, $filename, $localpostmaster, $id); my($postmastername); $from = $this->{from}; # Don't ever send a message to "" or "<>" return if $from eq "" || $from eq "<>"; # Setup other variables they can use in the message template $id = $this->{id}; $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $hostname = MailScanner::Config::Value('hostname', $this); $subject = $this->{subject}; $date = $this->{datestring}; # scalar localtime; foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); # Work out which of the 3 spam reports to send them. $filename = MailScanner::Config::Value('rejectionreport', $this); MailScanner::Log::NoticeLog("Reject message %s from %s with report %s", $id, $from, $filename); return if $filename eq ""; #print STDERR "Rejecting message $id with $filename\n"; $messagefh = new FileHandle; $messagefh->open($filename) or MailScanner::Log::WarnLog("Cannot open message file %s, %s", $filename, $!); $emailmsg = "X-MailScanner-Rejected: yes\n"; while(<$messagefh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; $line = eval "\"$1\""; $emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n"; } $messagefh->close(); #print STDERR "Rejection is:\n-----SNIP-----\n$emailmsg-----SNIP-----\n"; # Send the message to the spam sender, but ensure the envelope # sender address is "<>" so that it can't be bounced. $global::MS->{mta}->SendMessageString($this, $emailmsg, '<>') or MailScanner::Log::WarnLog("Could not send rejection report for %s, %s", $id, $!); $this->{deleted} = 1; $this->{dontdeliver} = 1; } # Like encapsulating and sending a message to the recipient, take the # Deliver a message that doesn't want to be touched at all in any way. # Take an out queue dir. sub DeliverUntouched { my $this = shift; my($OutQ) = @_; return if $this->{deleted}; #my $OutQ = MailScanner::Config::Value('outqueuedir', $this); my $store = $this->{store}; # Link the queue data file from in to out $store->LinkData($OutQ); # Add the headers onto the metadata in the message store $global::MS->{mta}->AddHeadersToQf($this); # Add the secret archive recipients my($extra, @extras); foreach $extra (@{$this->{archiveplaces}}) { # Email archive recipients include a '@' next if $extra =~ /^\//; next unless $extra =~ /@/; push @extras, $extra; } $global::MS->{mta}->AddRecipients($this, @extras) if @extras; # Write the new qf file, delete originals and unlock the message $store->WriteHeader($this, $OutQ); unless ($this->{gonefromdisk}) { $store->DeleteUnlock(); $this->{gonefromdisk} = 1; } # Note this does not kick the MTA into life here any more } # Deliver a message that doesn't need scanning at all # Takes an out queue dir. sub DeliverUnscanned { my $this = shift; my($OutQ) = @_; return if $this->{deleted}; #my $OutQ = MailScanner::Config::Value('outqueuedir', $this); my $store = $this->{store}; # Link the queue data file from in to out $store->LinkData($OutQ); # Add the headers onto the metadata in the message store $global::MS->{mta}->AddHeadersToQf($this); # Remove duplicate subject: lines $global::MS->{mta}->UniqHeader($this, 'Subject:'); # Add the information/help X- header my $infoheader = MailScanner::Config::Value('infoheader', $this); if ($infoheader) { my $infovalue = MailScanner::Config::Value('infovalue', $this); $global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue); } # Add the Unscanned X- header if (MailScanner::Config::Value('signunscannedmessages', $this)) { $global::MS->{mta}->AddMultipleHeader($this, 'mailheader', MailScanner::Config::Value('unscannedheader', $this), ', '); } # Remove any headers we don't want in the message my(@removeme, $remove); @removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this)); foreach $remove (@removeme) { # Add a : if there isn't one already, it's needed for DeleteHeader() $remove .= ':' unless $remove =~ /:$/; $global::MS->{mta}->DeleteHeader($this, $remove); } # Leave old content-length: headers as we aren't changing body. # Add the MCP headers if necessary $global::MS->{mta}->AddMultipleHeader($this, 'mcpheader', $this->{mcpreport}, ', ') if $this->{ismcp} || MailScanner::Config::Value('includemcpheader', $this); # Add spam header if it's spam or they asked for it #$global::MS->{mta}->AddHeader($this, # MailScanner::Config::Value('spamheader',$this), # $this->{spamreport}) # JKF 3/10/2005 $global::MS->{mta}->AddMultipleHeader($this, 'spamheader', $this->{spamreport}, ', ') if MailScanner::Config::Value('includespamheader', $this) || ($this->{spamreport} && $this->{isspam}); # Add the spam stars if they want that. Limit it to 60 characters to avoid # a potential denial-of-service attack. my($stars,$starcount,$scoretext,$minstars,$scorefmt); $starcount = int($this->{sascore}) + 0; $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{sascore}+0); $minstars = MailScanner::Config::Value('minstars', $this); $starcount = $minstars if $this->{isrblspam} && $minstars && $starcount<$minstars; if (MailScanner::Config::Value('spamscorenotstars', $this)) { $stars = $scoretext; # int($starcount); } else { $starcount = 60 if $starcount>60; $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount; } if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) { $global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader', $stars, ', '); } # Add the Envelope to and from headers AddFromAndTo($this); # Repair the subject line $global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject}) if $this->{subjectwasunsafe}; # Modify the subject line for Disarming my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this); #if ($this->{messagedisarmed} && # MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); #} if ($this->{messagedisarmed}) { #print STDERR "Message has been disarmed at 1346.\n"; my $where = MailScanner::Config::Value('disarmmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' '); } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); } } # Modify the subject line for spam # if it's spam AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && !$this->{ishigh} && # MailScanner::Config::Value('spamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); #} if ($this->{isspam} && !$this->{ishigh}) { my $where = MailScanner::Config::Value('spammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); } } # If it is high-scoring spam, then add a different bit of text $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && $this->{ishigh} && # MailScanner::Config::Value('highspamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); #} if ($this->{isspam} && $this->{ishigh}) { my $where = MailScanner::Config::Value('highspammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); } } # Modify the subject line for MCP # if it's MCP AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. $starcount = int($this->{mcpsascore}) + 0; $starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{mcpsascore}+0); my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; $mcptag =~ s/_STARS_/$stars/i; #if ($this->{ismcp} && !$this->{ishighmcp} && # MailScanner::Config::Value('mcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); #} if ($this->{ismcp} && !$this->{ishighmcp}) { my $where = MailScanner::Config::Value('mcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); } } # If it is high-scoring MCP, then add a different bit of text $mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; $mcptag =~ s/_STARS_/$stars/i; #if ($this->{ismcp} && $this->{ishighmcp} && # MailScanner::Config::Value('highmcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); #} if ($this->{ismcp} && $this->{ishighmcp}) { my $where = MailScanner::Config::Value('highmcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); } } # Add the extra headers they want for MCP and spam messages my(@extraheaders, $extraheader); my($key, $value); @extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders}; push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders}; foreach $extraheader (@extraheaders) { next unless $extraheader =~ /:/; ($key, $value) = split(/:\s*/, $extraheader, 2); $global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', '); } # Add the secret archive recipients my($extra, @extras); foreach $extra (@{$this->{archiveplaces}}) { # Email archive recipients include a '@' next if $extra =~ /^\//; next unless $extra =~ /@/; push @extras, $extra; } $global::MS->{mta}->AddRecipients($this, @extras) if @extras; # Write the new qf file, delete originals and unlock the message $store->WriteHeader($this, $OutQ); unless ($this->{gonefromdisk}) { $store->DeleteUnlock(); $this->{gonefromdisk} = 1; } # Note this does not kick the MTA into life here any more } # Add the X-Envelope-From and X-Envelope-To headers sub AddFromAndTo { my $this = shift; my($to, %tolist, $from, $envtoheader); # Do they all want the From header if (MailScanner::Config::Value('addenvfrom', $this) !~ /0/) { $from = $this->{from}; $global::MS->{mta}->ReplaceHeader($this, MailScanner::Config::Value('envfromheader', $this), $from); } # Do they all want the To header if (MailScanner::Config::Value('addenvto', $this) =~ /^[1\s]+$/) { # Get the actual text for the header value foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); $envtoheader = MailScanner::Config::Value('envtoheader', $this); # Now reflow the To list in case it is very long $to = $this->ReflowHeader($envtoheader, $to); $global::MS->{mta}->ReplaceHeader($this, $envtoheader, $to); } } # Replace the attachments of the message with a zip archive # containing them all. sub ZipAttachments { my $this = shift; return if $this->{deleted}; return unless MailScanner::Config::Value('zipattachments', $this) =~ /1/; my $workarea = $global::MS->{work}; my $explodeinto = $workarea->{dir} . "/" . $this->{id}; print STDERR "Processing files in $explodeinto\n"; chdir $explodeinto; my $dir = new DirHandle $explodeinto; unless ($dir) { MailScanner::Log::WarnLog("Error: could not open message dir %s", $explodeinto); return; } # Build a list of attachment filenames my($file,@files,$entity); while (defined($file = $dir->read)) { next if $file =~ /^\.+$/; next unless -f "$explodeinto/$file"; print STDERR "Possibly adding file $file\n"; $entity = $this->{file2entity}{$this->{safefile2file}{$file}}; print STDERR "Entity is $entity\n"; next unless $entity; # Don't add the file if it's the winmail.dat file unless ($entity eq $this->{tnefentity} && $this->{tnefentity}) { # Add the file if it is an attachment, not an inline file if ($entity->head->mime_attr("content-disposition") =~ /attachment/i) { unless ($file =~ /\.zip$|\.rar$|\.gz$/i) { push @files, $file; print STDERR "Added $file to attachment list\n"; } } } } # If no files in the archive, don't create it. return unless @files; # Find the name of the new zip file, if there is one my $newzipname = MailScanner::Config::Value('attachzipname', $this); return unless $newzipname; # Create a new zip archive my $zip = Archive::Zip->new(); foreach $file (@files) { $zip->addFile("$explodeinto/$file", $file); } my $safezipname = $this->MakeNameSafe($newzipname, $explodeinto); print STDERR "Writing to zip $safezipname\n"; my $result = $zip->writeToFileNamed($explodeinto . '/' . $safezipname); unless($result == AZ_OK) { print STDERR "Error: Zip file could not be created!\n"; MailScanner::Log::WarnLog("Zip file %s for message %s could not be created", $safezipname, $this->{id}); return; } # Add the new zipfile entity $entity = $this->{entity}; $entity->make_multipart; my $newentity = MIME::Entity->build(Path => "$explodeinto/$safezipname", Type => "application/zip", Encoding => "base64", Filename => $newzipname, Disposition => "attachment"); $entity->add_part($newentity); $this->{bodymodified} = 1; # Create all the Helpers for the new attachment $this->{entity2file}{$newentity} = $newzipname; $this->{entity2parent}{$newentity} = 0; $this->{file2entity}{$newzipname} = $newentity; $this->{name2entity}{scalar($newentity)} = $newentity; $this->{file2safefile}{$newzipname} = $safezipname; $this->{safefile2file}{$safezipname} = $newzipname; # Delete the old attachments' entities my($attachfile, $attachentity); foreach $file (@files) { $attachfile = $this->{safefile2file}{$file}; $attachentity = $this->{file2entity}{$attachfile}; $this->DeleteEntity($entity, $attachentity); # And the files themselves unlink("$explodeinto/$file"); } } # Explode a message into its MIME structure and attachments. # Pass in the workarea where it should go. sub Explode { my $this = shift; # $handle is Sendmail only my($entity, $pipe, $handle, $pid, $workarea, $mailscannername); return if $this->{deleted}; # Get the translation of MailScanner, we use it a lot $mailscannername = MailScanner::Config::LanguageValue($this, 'mailscanner'); # Set up something so that the hash exists $this->{file2parent}{""} = ""; # df file is already locked $workarea = $global::MS->{work}; my $explodeinto = $workarea->{dir} . "/" . $this->{id}; #print STDERR "Going to explode message " . $this->{id} . # " into $explodeinto\n"; # Setup everything for the MIME parser my $parser = MIME::Parser->new; my $filer = MIME::Parser::FileInto->new($explodeinto); # Over-ride the default default character set handler so it does it # much better than the MIME-tools default handling. MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit); #print STDERR "Exploding message " . $this->{id} . " into " . # $explodeinto . "\n"; $parser->filer($filer); $parser->extract_uuencode(1); # uue is off by default $parser->output_to_core('NONE'); # everything into files # The whole parsing thing is totally different for sendmail & Exim for speed. # Many thanks for those who know themselves for this great improvement! if (MailScanner::Config::Value('mta') =~ /sendmail|exim|postfix|zmailer/i) { # # This is for sendmail and Exim systems # $handle = IO::File->new_tmpfile; binmode($handle); $this->{store}->ReadMessageHandle($this, $handle) or return; ## Do the actual parsing my $maxparts = MailScanner::Config::Value('maxparts', $this) || 200; MIME::Entity::ResetMailScannerCounter($maxparts); # Inform MIME::Parser about our maximum $parser->max_parts($maxparts * 3); $entity = eval { $parser->parse($handle) }; # close and delete tmpfile close($handle); if (!$entity && !MIME::Entity::MailScannerCounter()>=$maxparts) { unless ($this->{dpath}) { # It probably ran out of disk space, drop this message from the batch MailScanner::Log::WarnLog("Failed to create message structures for %s" . ", dropping it from the batch", $this->{id}); my @toclear = ( $this->{id} ); $workarea->ClearIds(\@toclear); # Delete attachments we might have made $this->DropFromBatch(); return; } MailScanner::Log::WarnLog("Cannot parse " . $this->{headerspath} . " and " . $this->{dpath} . ", $@"); $this->{entity} = $entity; # In case it failed due to too many attachments $this->{cantparse} = 1; $this->{otherinfected} = 1; return; } # Too many attachments in the message? if ($maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts) { #print STDERR "Found an error!\n"; #Not with sendmail: $pipe->close(); #Not with sendmail: kill 9, $pid; # Make sure we are reaping a dead'un #Not with sendmail: waitpid $pid, 0; MailScanner::Log::WarnLog("Too many attachments (%d) in %s", MIME::Entity::MailScannerCounter(), $this->{id}); $this->{entity} = $entity; # In case it failed due to too many attachments $this->{toomanyattach} = 1; $this->{otherinfected} = 1; return; } # Closing the pipe this way will reap the child, apparently! #Not with sendmail: $pipe->close; #Not with sendmail: kill 9, $pid; # Make sure we are reaping a dead'un $this->{entity} = $entity; } else { # # This is for non-sendmail/Postfix systems # # Create the message stream # NOTE: This still uses the real path of the message body file. ($pipe,$pid) = $this->{store}->ReadMessagePipe($this) or return; # Do the actual parsing my $maxparts = MailScanner::Config::Value('maxparts', $this) || 200; MIME::Entity::ResetMailScannerCounter($maxparts); # Inform MIME::Parser about our maximum $parser->max_parts($maxparts * 3); $entity = eval { $parser->parse($pipe) }; if (!$entity && !MIME::Entity::MailScannerCounter()>=$maxparts) { #print STDERR "Found an error!\n"; $pipe->close() if $pipe; # Don't close a pipe that failed to exist waitpid $pid, 0; unless ($this->{dpath}) { # It probably ran out of disk space, drop this message from the batch MailScanner::Log::WarnLog("Failed to create message structures for %s" . ", dropping it from the batch", $this->{id}); my @toclear = ( $this->{id} ); $workarea->ClearIds(\@toclear); # Delete attachments we might have made $this->DropFromBatch(); return; } MailScanner::Log::WarnLog("Cannot parse " . $this->{headerspath} . " and " . $this->{dpath} . ", $@"); $this->{entity} = $entity;# In case it failed due to too many attachments $this->{cantparse} = 1; $this->{otherinfected} = 1; return; } # Too many attachments in the message? if ($maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts) { #print STDERR "Found an error!\n"; $pipe->close(); kill 9, $pid; # Make sure we are reaping a dead'un waitpid $pid, 0; MailScanner::Log::WarnLog("Too many attachments (%d) in %s", MIME::Entity::MailScannerCounter(), $this->{id}); $this->{entity} = $entity; # In case it failed due to too many attachments $this->{toomanyattach} = 1; $this->{otherinfected} = 1; return; } # Closing the pipe this way will reap the child, apparently! $pipe->close; kill 9, $pid; # Make sure we are reaping a dead'un $this->{entity} = $entity; } # Now handle TNEF files. They should be the only attachment to the message. $this->{tnefentity} = MailScanner::TNEF::FindTNEFFile($entity) if MailScanner::Config::Value('expandtnef'); # Look for winmail.dat files in each attachment directory $path. # When we find one explode it into its files and store the root MIME # entity into $IsTNEF{$id} so we can handle it separately later. # Pattern to match is actually winmail(digits).dat(digits) as that copes # with forwarded or bounced messages from mail packages that download # all attachments into 1 directory, adding numbers to their filenames. # Only delete original tnef if no-one wants to not replace it nor use it my $DeleteTNEF = 0; $DeleteTNEF = 1 if MailScanner::Config::Value('replacetnef', $this) !~ /[01]/; #print STDERR "ReplaceTNEF = " . MailScanner::Config::Value('replacetnef', $this) . "\n"; if (MailScanner::Config::Value('tnefexpander') && $this->{tnefentity}) { my($tneffile, @tneffiles); # Find all the TNEF files called winmail.dat my $outputdir = new DirHandle; $outputdir->open($explodeinto) or MailScanner::Log::WarnLog("Failed to open dir " . $explodeinto . " while scanning for TNEF files, %s", $!); @tneffiles = map { /(winmail\d*\.dat\d*)/i } $outputdir->read(); $outputdir->close(); #print STDERR "TNEF Entity is " . $this->{tnefentity} . "\n"; #print STDERR "TNEF files are " . join(',',@tneffiles) . "\n"; #print STDERR "Tree is \n" . $this->{entity}->dump_skeleton; foreach $tneffile (@tneffiles) { my $result; MailScanner::Log::InfoLog("Expanding TNEF archive at %s/%s", $explodeinto, $tneffile); $result = MailScanner::TNEF::Decoder($explodeinto, $tneffile, $this); if ($result) { # If they want to replace the TNEF rather than add to it, # then delete the original winmail.dat-style attachment # and remove the flag saying it is a TNEF message at all. #print STDERR "***** Found TNEF Attachments = " . $this->{foundtnefattachments} . "\n"; if ($DeleteTNEF && $this->{foundtnefattachments}) { $this->DeleteEntity($this->{entity}, $this->{tnefentity}); unlink "$explodeinto/$tneffile"; delete $this->{tnefentity}; MailScanner::Log::InfoLog("Message %s has had TNEF %s removed", $this->{id}, $tneffile); } } else { MailScanner::Log::WarnLog("Corrupt TNEF %s that cannot be " . "analysed in message %s", $tneffile, $this->{id}); $this->{badtnef} = 1; $this->{otherinfected} = 1; } } } unless(chdir $explodeinto) { MailScanner::Log::WarnLog("Could not chdir to %s just before unpacking " . "extra message parts", $explodeinto); return; } # ------------------------------- # If the MIME boundary exists and is "" then remove the entire message. # The top level must be multipart/mixed if (defined($entity) && $entity->head) { if ($entity->is_multipart || $entity->head->mime_type =~ /^multipart/i) { my $boundary = $entity->head->multipart_boundary; #print STDERR "Boundary is \"$boundary\"\n"; if ($boundary eq "" || $boundary eq "\"\"" || $boundary =~ /^\s/) { my $cantparse = MailScanner::Config::LanguageValue($this, 'cantanalyze'); $this->{allreports}{""} .= "$mailscannername: $cantparse\n"; $this->{alltypes}{""} .= 'c'; $this->{otherinfected}++; #print STDERR "Found error\n"; } } } # ------------------------------- # Now try to extract messages from text files as they might be things # we didn't manage to extract first time around. # And try to expand .tar.gz .tar.z .tgz .zip files. # We will then scan everything from inside them. my($allowpasswords, $couldnotreadmesg, $passwordedmesg, $toodeepmesg); $allowpasswords = MailScanner::Config::Value('allowpasszips', $this); $allowpasswords = ($allowpasswords !~ /0/)?1:0; $couldnotreadmesg = MailScanner::Config::LanguageValue($this, 'unreadablearchive'); $passwordedmesg = MailScanner::Config::LanguageValue($this, 'passwordedarchive'); $toodeepmesg = MailScanner::Config::LanguageValue($this, 'archivetoodeep'); $this->ExplodePartAndArchives($explodeinto, MailScanner::Config::Value('maxzipdepth', $this), $allowpasswords, $couldnotreadmesg, $passwordedmesg, $toodeepmesg, $mailscannername); # Check we haven't filled the disk. Remove this message if we have, so # that we can continue processing the other messages. my $dir = MailScanner::Config::Value("incomingworkdir"); my $df = df($dir, 1024); if ($df) { my $freek = $df->{bavail}; if (defined($freek) && $freek<100 && $freek>=0) { MailScanner::Log::WarnLog("Message %s is too big for available disk space in %s, skipping it", $this->{id}, $dir); my @toclear = ( $this->{id} ); $workarea->ClearIds(\@toclear); # Delete attachments we might have made $this->DropFromBatch(); return; } } # Set the owner and group on all the extracted files chown $workarea->{uid}, $workarea->{gid}, grep { -f } glob "$explodeinto/* $explodeinto/.*" if $workarea->{changeowner}; } # Delete a given entity from the MIME entity tree. # Have to walk the entire tree to do this. # Bail out as soon as we've found it. # Return 0 if DeleteEntity fell off a leaf node. # Return 1 if DeleteEntity hit the TNEF node. # Return 2 if DeleteEntity is just walking back up the tree. sub DeleteEntity { my($message, $entity, $tnef) = @_; my(@parts, $part, @keep); #print STDERR "In DeleteEntity\n"; # If we have a no-body message then replace the TNEF entity with an # empty attachment. Special case. if (scalar($message->{entity}) eq $tnef) { #print STDERR "Found message with no body but a TNEF attachment.\n"; $part = MIME::Entity->build(Type => "text/plain", Encoding => "quoted-printable", Data => ["\n"]); push @keep, $part; $message->{entity}->parts(\@keep); $message->{bodymodified} = 1; #print STDERR "Replaced single part with empty text/plain attachment\n"; return 2; } # Fallen off a leaf node? return 0 unless $entity && defined($entity->head); if ($entity && !$entity->parts) { # FIX FIX FIX !$entity->is_multipart) { # Found the TNEF entity at a leaf node? #(print STDERR "Found TNEF entity at a leaf node $entity\n"),return 1 if scalar($entity) eq $tnef; #(print STDERR "Not found TNEF entity at a leaf node $entity\n"),return 2; return 1 if scalar($entity) eq $tnef; return 2; } @parts = $entity->parts; #print STDERR "Parts are " . join(',',@parts) . "\n"; foreach $part (@parts) { my $foundit = DeleteEntity($message, $part, $tnef); #print STDERR "DeleteEntity = $foundit\n"; push @keep, $part unless $foundit == 1; } # Make sure there is always at least 1 part. #print STDERR "Keep is " . join(',',@keep) . "\n"; unless (@keep) { #print STDERR "Adding an empty text/plain\n"; $part = MIME::Entity->build(Type => "text/plain", Encoding => "quoted-printable", Data => ["\n"]); push @keep, $part; } $entity->parts(\@keep); $message->{bodymodified} = 1; # If there are no parts left, make this entity a singlepart entity $entity->make_singlepart unless scalar(@keep); return 2; } # Quietly drop a message from the batch. Used when we run out of disk # space. sub DropFromBatch { my($message) = @_; $message->{deleted} = 1; $message->{gonefromdisk} = 1; # Don't try to delete the original $message->{store}->Unlock(); # Unlock it so other processes can pick it up } # Try to recursively unpack tar (with or without gzip) files and zip files. # Extracts to a given maximum unpacking depth. sub ExplodePartAndArchives { my($this, $explodeinto, $maxlevels, $allowpasswords, $couldnotreadmesg, $passwordedmesg, $toodeepmesg, $msname) = @_; my($dir, $file, $part, @parts, $buffer); my(%seenbefore, %seenbeforesize, $foundnewfiles); my($size, $level, $ziperror, $tarerror, $silentviruses, $noisyviruses); my($allziperrors, $alltarerrors, $textlevel, $failisokay); my($linenum, $foundheader, $prevline, $line, $position, $prevpos, $nextpos); my($cyclecounter, $rarerror); $dir = new DirHandle; $file = new FileHandle; $level = 0; #-1; $textlevel = 0; $cyclecounter = 0; $ziperror = 0; $tarerror = 0; # Do they only want encryption checking and nothing else? my $onlycheckencryption; $onlycheckencryption = 0; # More robust way of saying maxlevels==0 && allowpasswords==0; $onlycheckencryption = 1 if !$maxlevels && !$allowpasswords; $silentviruses = ' '. MailScanner::Config::Value('silentviruses', $this) .' '; $noisyviruses = ' ' . MailScanner::Config::Value('noisyviruses', $this) .' '; $dir->open($explodeinto); # $cyclecounter is a sanity check to ensure we don't loop forever OUTER: while($cyclecounter<30) { $cyclecounter++; $textlevel++; last if $level>$maxlevels; # && $textlevel>1; $foundnewfiles = 0; $dir->rewind(); @parts = $dir->read(); #print STDERR "Level = $level\n"; foreach $part (@parts) { next if $part eq '.' || $part eq '..'; # Skip the entire loop if it's not what we are looking for # JKF I really haven't the faintest idea why I wrote the next line :-) #next unless $part =~ # /(^msg.*txt$)|(\.(tar\.g?z|taz|tgz|tz|zip|exe|rar)$)/i; $size = -s "$explodeinto/$part"; #print STDERR "Checking $part $size bytes\n"; next if $seenbefore{$part} && $seenbeforesize{$part} == $size; $seenbefore{$part} = 1; $seenbeforesize{$part} = $size; #print STDERR "$level/$maxlevels Found new file $part\n"; #print STDERR "Reading $part\n"; if ($part =~ /^msg.*txt/ && $textlevel<=2) { # Try and find hidden messages in the text files #print STDERR "About to read $explodeinto/$part\n"; $file->open("$explodeinto/$part") or next; # Try reading the first few lines to see if they look like mail headers $linenum = 0; $foundheader = 0; $prevline = ""; $prevpos = 0; $nextpos = 0; $line = undef; for ($linenum=0; $linenum<30; $linenum++) { #$position = $file->getpos(); $line = <$file>; last unless defined $line; $nextpos += length $line; # Must have 2 lines of header # prevline looks like Header: # line looks like setting # or Header: if ($prevline =~ /^[^:\s]+: / && $line =~ /(^\s+\S)|(^[^:\s]+: )/) { #|(^\s+.*=)/) { #print STDERR "Found header start at \"$prevline\"\n and \"$line\"\n"; $foundheader = 1; last; } $prevline = $line; $prevpos = $position; $position = $nextpos; } if ($foundheader) { # Check all lines are header lines up to next blank line my($num, $reallyfoundheader); $reallyfoundheader = 0; # Check for a maximum of 30 lines of headers foreach $num (0..30) { $line = <$file>; last unless defined $line; # Must have a valid header line #print STDERR "Examining: \"$line\"\n"; next if $line =~ /(^\s+\S)|(^[^:\s]+: )/; #print STDERR "Not a header line\n"; # Or a blank line if ($line =~ /^[\r\n]*$/) { $reallyfoundheader = 1; last; } #print STDERR "Not a blank line\n"; # Non-header line, so it isn't a valid message part $reallyfoundheader = 0; last; } #print STDERR "Really found header = $reallyfoundheader\n"; if ($reallyfoundheader) { # Rewind to the start of the header #$file->setpos($prevpos); seek $file, $prevpos, 0; #print STDERR "First line is \"" . <$file> . "\"\n"; # Setup everything for the MIME parser my $parser = MIME::Parser->new; my $filer = MIME::Parser::FileInto->new($explodeinto); # Over-ride the default default character set handler so it does it # much better than the MIME-tools default handling. MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit); #print STDERR "Exploding message " . $this->{id} . " into " . # $explodeinto . "\n"; $parser->filer($filer); $parser->extract_uuencode(1); # uue is off by default $parser->output_to_core('NONE'); # everything into files # Do the actual parsing #print STDERR "About to parse\n"; my $entity = eval { $parser->parse($file) }; #print STDERR "Done the parse\n"; # We might have created new files that need parsing $foundnewfiles = 1; next OUTER; } } $file->close; } # Not got anything to do? next if !$maxlevels && $allowpasswords; #$level++; next if $level > $maxlevels; # Find all the zip files #print STDERR "Looking at $explodeinto/$part\n"; #next if MailScanner::Config::Value('filecommand', $this) eq ""; next unless $file->open("$explodeinto/$part"); #print STDERR "About to read 4 bytes\n"; unless (read($file, $buffer, 4) == 4) { #print STDERR "Very short file $part\n"; $file->close; next; } my $uudfilename = ""; $uudfilename = FindUUEncodedFile($file) if MailScanner::Config::Value('lookforuu', $this) =~ /1/; #$file->close; $failisokay = 0; if ($buffer =~ /^MZ/) { $failisokay = 1; } $file->close, next unless $buffer eq "PK\003\004" || $buffer eq "Rar!" || $part =~ /\.rar$/ || defined($uudfilename) || $failisokay; #print STDERR "Found a zip or rar file\n" ; $file->close, next unless MailScanner::Config::Value('findarchivesbycontent', $this) || $part =~ /\.(tar\.g?z|taz|tgz|tz|zip|exe|rar|uu|uue)$/i; $foundnewfiles = 1; #print STDERR "Unpacking $part at level $level\n"; if ($uudfilename ne "") { # It cannot be a zip or a rar, so skip the checks for them. # Oh yes it can! Do all the checks. # Ignore the return value, don't care if uudecode fails, it was # probably just a false positive on the uuencoded-data locator. #print STDERR "About to unpackuue $part into $uudfilename\n"; $this->UnpackUUE($part, $explodeinto, $file, $uudfilename); } $file->close; # Is it a zip file, in which case unpack the zip $ziperror = ""; #print STDERR "About to unpackzip $part\n"; $ziperror = $this->UnpackZip($part, $explodeinto, $allowpasswords, $onlycheckencryption); #print STDERR "* * * * * * * Unpackzip $part returned $ziperror\n"; # If unpacking as a zip failed, try it as a rar $rarerror = ""; if ($part =~ /\.rar$/i || $buffer eq "Rar!" or $buffer =~ /^MZ[P]?/) { $rarerror = $this->UnpackRar($part, $explodeinto, $allowpasswords, $onlycheckencryption); } $tarerror = ""; $tarerror = 0 # $this->UnpackTar($part, $explodeinto, $allowpasswords) if $ziperror || $part =~ /(tar\.g?z|tgz)$/i; #print STDERR "In inner: \"$part\"\n"; if ($ziperror eq "password" || $rarerror eq "password") { MailScanner::Log::WarnLog("Password-protected archive (%s) in %s", $part, $this->{id}); $this->{allreports}{$part} .= "$msname: $passwordedmesg\n"; $this->{alltypes}{$part} .= 'c'; $this->{passwordprotected} = 1; $this->{otherinfected} = 1; $this->{cantdisinfect} = 1; # Don't even think about disinfecting this! $this->{silent}=1 if $silentviruses =~ / Zip-Password | All-Viruses /i; $this->{noisy} =1 if $noisyviruses =~ / Zip-Password /i; } elsif ($ziperror && $tarerror && $rarerror && !$failisokay) { MailScanner::Log::WarnLog("Unreadable archive (%s) in %s", $part, $this->{id}); $this->{allreports}{$part} .= "$msname: $couldnotreadmesg\n"; $this->{alltypes}{$part} .= 'c'; $this->{otherinfected} = 1; } } #print STDERR "In outer: \"$part\"\n"; last if !$foundnewfiles || $level>$maxlevels; $dir->rewind; #print STDERR "Rewinding, Incrementing level from $level to " . ($level+1) . "\n"; $level++; } #print STDERR "Level=$level($maxlevels)\n"; #print STDERR "Onlycheckencryption=$onlycheckencryption\n"; if ($level>$maxlevels && !$onlycheckencryption && $maxlevels) { MailScanner::Log::WarnLog("Files hidden in very deeply nested archive " . "in %s", $this->{id}); $this->{allreports}{""} .= "$msname: $toodeepmesg\n"; $this->{alltypes}{""} .= 'c'; $this->{otherinfected}++; } } # Search the given filehandle for signs that this could contain uu-encoded data # Return the filename if found, undef otherwise. Also return the open file # handle. sub FindUUEncodedFile { my $fh = shift; my($mode, $file); my $linecounter = 0; seek $fh, 0, 0; # Rewind the file to the start while (<$fh>) { if (/^begin(.*)/) { my $modefile = $1; if ($modefile =~ /^(\s+(\d+))?(\s+(.*?\S))?\s*\Z/) { ($mode, $file) = ($2, $4); } last; } $linecounter++; seek($fh, 0, 0), return undef if $linecounter>50; } return $file; } # We now have a uuencoded file to decode. We have a target filename we have # read from the uuencode header. sub UnpackUUE { my $this = shift; my($uuencoded, $explodeinto, $uuehandle, $uudecoded) = @_; MailScanner::Log::DebugLog("Unpacking UU-encoded file %s", $uuencoded); # Set up all the tree structures for cross-referencing my $safename = $this->MakeNameSafe($uudecoded,$explodeinto); $this->{file2parent}{$uudecoded} = $uuencoded; $this->{file2parent}{$safename} = $uuencoded; $this->{file2safefile}{$uudecoded} = $safename; $this->{safefile2file}{$safename} = $uudecoded; $safename = "$explodeinto/$safename"; my $out = new FileHandle; unless ($out->open("> $safename")) { MailScanner::Log::WarnLog("Unpacking UU-encoded file %s, could not create target file %s", $this->MakeNameSafe($uuencoded,$explodeinto), $safename); return; } while (<$uuehandle>) { last if /^end/; next if /[a-z]/; next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4); $out->print(unpack('u', $_)); } $out->close; } # Unpack a rar file into the named directory. # Return 1 if an error occurred, else 0. # Return 0 on success. # Return "password" if a member was password-protected. # Very much like UnpackZip except it uses the external "unrar" command. sub UnpackRar { my($this, $zipname, $explodeinto, $allowpasswords, $onlycheckencryption) = @_; my($zip, @members, $member, $name, $fh, $safename, $memb, $check, $junk, $unrar,$IsEncrypted, $PipeTimeOut, $PipeReturn,$NameTwo, $HasErrors, $member2, $Stuff, $BeginInfo, $EndInfo, $ParseLine, $what); # Timeout value for unrar is currently the same as that of the file # command + 20. Julian, when you add the filetimeout to the config file # perhaps you should think about adding a maxcommandexecutetime setting # as well $PipeTimeOut = MailScanner::Config::Value('unrartimeout'); $unrar = MailScanner::Config::Value('unrarcommand'); return 1 unless $unrar && -x $unrar; #MailScanner::Log::WarnLog("UnPackRar Testing : %s", $zipname); # This part lists the archive contents and makes the list of # file names within. "This is a list verbose option" $memb = SafePipe("$unrar v -p- '$explodeinto/$zipname' 2>&1", $PipeTimeOut); $junk = ""; $Stuff = ""; $BeginInfo = 0; $EndInfo = 0; $ParseLine = 1; $memb =~ s/\r//gs; my @test = split /\n/, $memb; $memb = ''; # Have to parse the output from the 'v' command and parse the information # between the ----------------------------- lines foreach $what (@test) { #print STDERR "Processing \"$what\"\n"; # If we haven't hit any ------- lines at all, and we are prompted for # a password, then the whole archive is password-protected. unless ($BeginInfo || $EndInfo) { if ($what =~ /^Encrypted file:/i && !$allowpasswords) { MailScanner::Log::WarnLog("Password Protected RAR Found"); return "password"; } } # Have we already hit the beginng and now find another ------ string? # If so then we are at the end $EndInfo = 1 if $what =~ /-{40,}$/ && $BeginInfo; # if we are after the begning but haven't reached the end, # then process this line if ($BeginInfo && !$EndInfo) { # If we are on line one then it's the file name with full path # otherwise we are on the info line containing the attributes if ($ParseLine eq 1) { $junk = $what; $junk =~ s/^\s+|\s+$//g; chomp($junk); $ParseLine = 2; } else { $Stuff = $what; $Stuff =~ s/^\s+|\s+$//g; # Need to remove redundant spaces from our info line and # split it into it's components chomp($Stuff); $Stuff =~ s/\s{2,}/ /g; my ($RSize,$RPacked,$RRatio,$RDate,$RTime,$RAttrib,$RCrc,$RMeth,$RVer) = split /\s/, $Stuff; # If RAttrib doesn't begin with d then it's a file and we # add it to our $memb string, otherwise we ignore the directory # only entries #MailScanner::Log::WarnLog("UnPackRar InfoLine :%s:", $Stuff); #MailScanner::Log::WarnLog("UnPackRar Looking at ATTRIB :->%s<-:", # $RAttrib); $memb .= "$junk\n" if $RAttrib !~ /^d|^.D/; $junk = ''; $Stuff = ''; $ParseLine = 1; } } # If we have a line full of ---- and $BeginInfo is not set then # we are at the first and we need to set $BeginInfo so next pass # begins processing file information if ($what =~ /-{40,}$/ && ! $BeginInfo) { $BeginInfo = 1; } } # Remove returns from the output string, exit if the archive is empty # or the output is empty $memb =~ s/\r//gs; return 1 if $memb ne '' && $memb =~ /(No files to extract|^COMMAND_TIMED_OUT$)/si; return 0 if $memb eq ''; # JKF If no members it probably wasn't a Rar self-ext #MailScanner::Log::DebugLog("Unrar : Archive Testing Completed On : %s", # $memb); @members = split /\n/, $memb; $fh = new FileHandle; foreach $member2 (@members) { $IsEncrypted = 0; $HasErrors = 0; #MailScanner::Log::InfoLog("Checking member %s",$member2); # Test the current file name to see if it's password protected # and capture the output. If the command times out, then return next if $member2 eq ""; $member = quotemeta $member2; #print STDERR "Member is ***$member***\n"; $check = SafePipe( "$unrar t -p- -idp '$explodeinto/$zipname' $member 2>&1", $PipeTimeOut); #print STDERR "Point 1\n"; return 1 if $check =~ /^COMMAND_TIMED_OUT$/; # Check for any error with this file. Format is FileName - Error string if ($check =~ /$member\s+-\s/i){ MailScanner::Log::WarnLog("Unrar: Error in file: %s -> %s", $zipname,$member); $HasErrors = 1; } $check =~ s/\n/:/gsi; #MailScanner::Log::WarnLog("Got : %s", $check); # If we get the string Encrypted then we have found a password # protected archive and we handle it the same as zips are handled if ($check =~ /\bEncrypted file:\s.+\(password incorrect/si) { $IsEncrypted = 1; MailScanner::Log::WarnLog("Password Protected RAR Found"); #print STDERR "Checking member " . $member . "\n"; #print STDERR "******** Encryption = " . $IsEncrypted . "\n"; return "password" if !$allowpasswords && $IsEncrypted; } # If they don't want to extract, but only check for encryption, # then skip the rest of this as we don't actually want the files # checked against the file name/type rules next if $onlycheckencryption; $name = $member2; #print STDERR "UnPackRar : Making Safe Name from $name\n"; # There is no facility to change the output name for a rar file # but we can rename rename the files inside the archive # prefer to use $NameTwo because there is no path attached # $safename is guaranteed not to exist, but NameTwo gives us the # filename without any directory information, which we use later. $safename = $this->MakeNameSafe($name,$explodeinto); $NameTwo = $safename; $NameTwo = $1 if $NameTwo =~ /([^\/]+)$/; #MailScanner::Log::InfoLog("UnPackRar: Member : %s", $member); #print STDERR "UnPackRar : Safe Name is $safename\n"; #MailScanner::Log::InfoLog("UnPackRar: SafeName : %s", $safename); $this->{file2parent}{$name} = $zipname; $this->{file2parent}{$safename} = $zipname; $this->{file2safefile}{$name} = $safename; $this->{safefile2file}{$safename} = $name; #print STDERR "Archive member \"$name\" is now \"$safename\"\n"; #$this->{file2entity}{$name} = $this->{entity}; $this->{file2safefile}{$name} = $zipname; #$this->{safefile2file}{$safename} = $zipname; $safename = "$explodeinto/$safename"; $PipeReturn = ''; $? = 0; if (!$IsEncrypted && !$HasErrors) { #print STDERR "Expanding ***$member***\ninto ***$NameTwo***\n"; $PipeReturn = SafePipe( "$unrar p -y -inul -p- -idp '$explodeinto/$zipname' $member > \"$NameTwo\"", $PipeTimeOut); unless ("$?" == 0 && $PipeReturn ne 'COMMAND_TIMED_OUT'){ # The rename operation failed!, so skip the extraction of a # potentially bad file name. # JKF Temporary testing code #MailScanner::Log::WarnLog("UnPackRar: RC: %s PipeReturn : ",$?,$PipeReturn); MailScanner::Log::WarnLog("UnPackRar: Could not rename or use " . "safe name in Extract, NOT Unpacking file %s", $safename); next; } #MailScanner::Log::InfoLog("UnPackRar: Done...., got %d and %s", $?, $PipeReturn); } #MailScanner::Log::WarnLog("RC = %s : Encrypt = %s : PipeReturn = %s", # $?,$IsEncrypted,$PipeReturn ); unless ("$?" == 0 && !$HasErrors && !$IsEncrypted && $PipeReturn ne 'COMMAND_TIMED_OUT') { # If we got an error, or this file is encrypted create a zero-length # file so the filename tests will still work. MailScanner::Log::WarnLog("Unrar : Encrypted Or Extract Error Creating" . " 0 length %s",$NameTwo); $fh->open(">$safename") && $fh->close(); } } return 0; } # Modified Julian's code from SweepOther.pm # Changed to allow execution of any given command line with a time # control. This could replace any call to system or use of backticks # # $Cmd = command line to execute # $timeout = max time in seconds to allow execution # sub SafePipe { my ($Cmd, $TimeOut) = @_; my($Kid, $pid, $TimedOut, $Str); $Kid = new FileHandle; $TimedOut = 0; #print STDERR "SafePipe : Command : $Cmd\n"; #print STDERR "SafePipe : TimeOut : $TimeOut\n"; $? = 0; # Make sure there's no junk left in here eval { die "Can't fork: $!" unless defined($pid = open($Kid, '-|')); if ($pid) { # In the parent # Set up a signal handler and set the alarm time to the timeout # value passed to the function local $SIG{ALRM} = sub { $TimedOut = 1; die "Command Timed Out" }; alarm $TimeOut; # while the command is running we will collect it's output # in the $Str variable. We don't process it in any way here so # whatever called us will get back exactly what they would have # gotten with a system() or backtick call #MailScanner::Log::DebugLog("SafePipe : Processing %s", $Cmd); while(<$Kid>) { $Str .= $_; #print STDERR "SafePipe : Processing line \"$_\"\n"; } #MailScanner::Log::DebugLog("SafePipe : Completed $Cmd"); #print STDERR "SafePipe : Returned $PipeReturnCode\n"; $pid = 0; # 2.54 alarm 0; # Workaround for bug in perl shipped with Solaris 9, # it doesn't unblock the SIGALRM after handling it. eval { my $unblockset = POSIX::SigSet->new(SIGALRM); sigprocmask(SIG_UNBLOCK, $unblockset) or die "Could not unblock alarm: $!\n"; }; } else { # In the child POSIX::setsid(); # Execute the command via an exec call, bear in mind this will only # capture STDIN so if you need STDERR, or both you have to handle, for # example, 2>&1 as part of the command line just as you would with # system() or backticks # #the line following the # call should *never* be reached unless the call it's self fails #print STDERR "SafePipe in child exec $Cmd\n"; my @args = ( "$Cmd" ); #exec $Cmd or print STDERR "SafePipe : failed to execute $Cmd\n"; open STDIN, "< /dev/null"; exec @args or MailScanner::Log::WarnLog("SafePipe : failed to execute %s", $Cmd); #MailScanner::Log::DebugLog("SafePipe in Message.pm : exec failed " . # "for $Cmd"); exit 1; } }; alarm 0; # 2.53 #MailScanner::Log::DebugLog("SafePipe in Message.pm : Completed $Cmd"); #MailScanner::Log::WarnLog("Returned Code : %d", $?); # Catch failures other than the alarm MailScanner::Log::WarnLog("SafePipe in Message.pm : $Cmd failed with real error: $@") if $@ and $@ !~ /Command Timed Out/; #print STDERR "SafePipe : pid = $pid and \@ = $@\n"; # In which case any failures must be the alarm if ($@ or $pid>0) { # Kill the running child process my($i); kill -15, $pid; # Wait for up to 5 seconds for it to die for ($i=0; $i<5; $i++) { sleep 1; waitpid($pid, &POSIX::WNOHANG); ($pid=0),last unless kill(0, $pid); kill -15, $pid; } # And if it didn't respond to 11 nice kills, we kill -9 it if ($pid) { kill -9, $pid; waitpid $pid, 0; # 2.53 } } # If the command timed out return the string below, otherwise # return the command output in $Str return $Str unless $TimedOut; MailScanner::Log::WarnLog("Safepipe in Message.pm : %s timed out!", $Cmd); return "COMMAND_TIMED_OUT"; } # Unpack a zip file into the named directory. # Return 1 if an error occurred, else 0. # Return 0 on success. # Return "password" if a member was password-protected. sub UnpackZip { my($this, $zipname, $explodeinto, $allowpasswords, $onlycheckencryption) = @_; my($zip, @members, $member, $name, $fh, $safename); #print STDERR "Unpacking $zipname\n"; return 1 if -s "$explodeinto/$zipname" == 4_237_4; # zip of death? return 1 unless $zip = Archive::Zip->new("$explodeinto/$zipname"); return 1 unless @members = $zip->members(); $fh = new FileHandle; foreach $member (@members) { #print STDERR "Checking member " . $member->fileName() . "\n"; #print STDERR "******** Encryption = " . $member->isEncrypted() . "\n"; return "password" if !$allowpasswords && $member->isEncrypted(); # If they don't want to extract, but only check for encryption, # then skip the rest of this as we don't actually want the files. next if $onlycheckencryption; $name = $member->fileName(); $safename = $this->MakeNameSafe($name, $explodeinto); $this->{file2parent}{$name} = $zipname; $this->{file2parent}{$safename} = $zipname; $this->{file2safefile}{$name} = $safename; $this->{safefile2file}{$safename} = $name; #print STDERR "Archive member \"$name\" is now \"$safename\"\n"; #$this->{file2entity}{$name} = $this->{entity}; $this->{file2safefile}{$name} = $zipname; #$this->{safefile2file}{$safename} = $zipname; $safename = "$explodeinto/$safename"; #print STDERR "About to extract $member to $safename\n"; unless ($zip->extractMemberWithoutPaths($member, $safename) == AZ_OK) { # Create a zero-length file if extraction failed # so the filename tests will still work. #print STDERR "Done passworded extraction of $member to $safename\n"; $fh->open(">$safename") && $fh->close(); } #print STDERR "Done extraction of $member to $safename\n"; } return 0; } # Is this filename evil? sub IsNameEvil { my($this, $name, $dir) = @_; #print STDERR "Testing \"$name\" to see if it is evil\n"; return 1 if (!defined($name) or ($name eq '')); ### empty return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace return 1 if ($name =~ m{^\.+\Z}); ### dots return 1 if ($name =~ tr{ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF}{}c); return 1 if (length($name) > 50); return 'exists' if (-e "$dir/$name"); #print STDERR "It is okay\n"; #$self->debug("it's ok"); 0; } # Make this filename safe and return the safe version sub MakeNameSafe { my($self, $fname, $dir) = @_; ### Isolate to last path element: my $last = $fname; $last =~ s{^.*[/\\\[\]:]}{}; if ($last and !$self->IsNameEvil($last, $dir)) { #$self->debug("looks like I can use the last path element"); #print STDERR "MakeNameSafe: 1 $fname,$last\n"; return $last; } # Try removing leading whitespace, trailing whitespace and all # dangerous characters to start with. $last =~ s/^\s+//; $last =~ s/\s+\Z//; $last =~ tr/ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF//cd; #print STDERR "MakeNameSafe: 2 $fname,$last\n"; return $last unless $self->IsNameEvil($last, $dir); ### Break last element into root and extension, and truncate: my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/) ? ($1, $2) : ($last, '')); # JKF Delete leading and trailing whitespace $root =~ s/^\s+//; $ext =~ s/\s+$//; $root = substr($root, 0, ($self->{MPF_TrimRoot} || 14)); $ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3)); $ext =~ /^\w+$|^$/ or $ext = "dat"; my $trunc = $root . ($ext ? ".$ext" : ''); if (!$self->IsNameEvil($trunc, $dir)) { #$self->debug("looks like I can use the truncated last path element"); #print STDERR "MakeNameSafe: 3 $fname,$trunc\n"; return $trunc; } # It is still evil, but probably just because it exists if ($self->IsNameEvil($trunc, $dir) eq 'exists') { my $counter = 0; $trunc = $trunc . '0'; do { $counter++; $trunc = $root . $counter . ($ext ? ".$ext" : ''); } while $self->IsNameEvil($trunc, $dir) eq 'exists'; return $trunc; } ### Hope that works: #print STDERR "MakeNameSafe: 4 $fname,:-(\n"; undef; } # Unpack a tar file into the named directory. # Return 1 if an error occurred, else 0. sub UnpackTar { my($this, $tarname, $explodeinto) = @_; return 1; # Not yet implemented } # Try to parse all the text bits of each message, looking to see if they # can be parsed into files which might be infected. # I then throw these sections back to the MIME parser. sub ExplodePart { my($this, $explodeinto) = @_; my($dir, $file, $part, @parts); $dir = new DirHandle; $file = new FileHandle; $dir->open($explodeinto); @parts = $dir->read(); $dir->close(); my($linenum, $foundheader, $prevline, $line, $position, $prevpos, $nextpos); foreach $part (@parts) { #print STDERR "Reading $part\n"; next unless $part =~ /^msg.*txt/; # Try and find hidden messages in the text files #print STDERR "About to read $explodeinto/$part\n"; $file->open("$explodeinto/$part") or next; # Try reading the first few lines to see if they look like mail headers $linenum = 0; $foundheader = 0; $prevline = ""; $prevpos = 0; $nextpos = 0; $line = undef; for ($linenum=0; $linenum<30; $linenum++) { #$position = $file->getpos(); $line = <$file>; last unless defined $line; $nextpos += length $line; # Must have 2 lines of header if ($prevline =~ /^[^:\s]+: / && $line =~ /(^\s+)|(^[^:]+ )|(^\s+.*=)/) { #print STDERR "Found header start at \"$prevline\"\n and \"$line\"\n"; $foundheader = 1; last; } $prevline = $line; $prevpos = $position; $position = $nextpos; } unless ($foundheader) { $file->close(); next; } # Rewind to the start of the header #$file->setpos($prevpos); seek $file, $prevpos, 0; #print STDERR "First line is \"" . <$file> . "\"\n"; # Setup everything for the MIME parser my $parser = MIME::Parser->new; #my $filer = MIME::Parser::FileInto::MailScanner->new($explodeinto); my $filer = MIME::Parser::FileInto->new($explodeinto); # Over-ride the default default character set handler so it does it # much better than the MIME-tools default handling. MIME::WordDecoder->default->handler('*' => \&WordDecoderKeep7Bit); #print STDERR "Exploding message " . $this->{id} . " into " . # $explodeinto . "\n"; $parser->filer($filer); $parser->extract_uuencode(1); # uue is off by default $parser->output_to_core('NONE'); # everything into files # Do the actual parsing my $entity = eval { $parser->parse($file) }; $file->close; } } # Print the infection reports for this message sub PrintInfections { my $this = shift; my($filename, $report, $type); print STDERR "Virus reports for " . $this->{id} . ":\n"; foreach $filename (keys %{$this->{virusreports}}) { print STDERR " "; print STDERR $filename . "\t" . $this->{virusreports}{$filename} . "\n"; print STDERR " " . $this->{virustypes}{$filename} . "\n"; } print STDERR "Name reports for " . $this->{id} . ":\n"; foreach $filename (keys %{$this->{namereports}}) { print STDERR " "; print STDERR $filename . "\t" . $this->{namereports}{$filename} . "\n"; print STDERR " " . $this->{nametypes}{$filename} . "\n"; } print STDERR "Other reports for " . $this->{id} . ":\n"; foreach $filename (keys %{$this->{otherreports}}) { print STDERR " "; print STDERR $filename . "\t" . $this->{otherreports}{$filename} . "\n"; print STDERR " " . $this->{othertypes}{$filename} . "\n"; } print STDERR "Entity reports for " . $this->{id} . ":\n"; foreach $filename (keys %{$this->{entityreports}}) { print STDERR " "; print STDERR $filename . "\t" . $this->{entityreports}{$filename} . "\n"; } print STDERR "All reports for " . $this->{id} . ":\n"; foreach $filename (keys %{$this->{allreports}}) { print STDERR " "; print STDERR $filename . "\t" . $this->{allreports}{$filename} . "\n"; } print STDERR "Message is TNEF? " . ($this->{tnefentity}?"Yes":"No") . "\n"; print STDERR "Message is bad TNEF? " . ($this->{badtnef}?"Yes":"No") . "\n"; print STDERR "Message has " . $this->{virusinfected} . " virus infections\n"; print STDERR "Message has " . $this->{sizeinfected} . " size problems\n"; print STDERR "Message has " . $this->{otherinfected} . " other problems\n"; print STDERR "\n"; } # Create the Entity2Parent and Entity2File hashes for a message # $message->CreateEntitiesHelpers($this->{entity2parent}, # $this->{entity2file}); sub CreateEntitiesHelpers { my $this = shift; #my($Entity2Parent, $Entity2File) = @_; return undef unless $this->{entity}; $this->{numberparts} = CountParts($this->{entity}) || 1; # Put something useless in the 2 hashes so that they exist. $this->{entity2file}{""} = 0; $this->{entity2parent}{""} = 0; $this->{file2entity}{""} = $this->{entity}; # Root of this message $this->{name2entity}{""} = 0; $this->{file2safefile}{""} = ""; $this->{safefile2file}{""} = ""; BuildFile2EntityAndEntity2File($this->{entity}, $this->{file2entity}, $this->{file2safefile}, $this->{safefile2file}, $this->{entity2file}, $this->{name2entity}); #print STDERR "In CreateEntitiesHelpers, this = $this\n"; #print STDERR "In CreateEntitiesHelpers, this entity = " . # $this->{entity} . "\n"; #print STDERR "In CreateEntitiesHelpers, parameters are " . # scalar($this->{entity2file}) . " and " . # scalar($this->{entity2parent}) . "\n"; BuildEntity2Parent($this->{entity}, $this->{entity2parent}, undef); } # For the MIME entity given, work out the number of message parts. # Recursive. This is a class function, not a normal method. sub CountParts { my($entity) = @_; my(@parts, $total, $part); return 0 unless $entity; @parts = $entity->parts; $total += int(@parts); foreach $part (@parts) { $total += CountParts($part); } return $total; } # Build the file-->entity and entity-->file mappings for a message. # This will let us replace infected entities later. Key is the filename, # value is the entity. # This is recursive. This is a class function, not a normal method. sub BuildFile2EntityAndEntity2File { my($entity, $file2entity, $file2safefile, $safefile2file, $entity2file, $name2entity) = @_; # Build the conversion hash from scalar(entity) --> real entity object # Need to do this as objects cannot be hash keys. $name2entity->{scalar($entity)} = $entity; my(@parts, $body, $headfile, $part, $path); # Find the body for this entity $body = $entity->bodyhandle; if (defined($body) && defined($body->path)) { # data is on disk: $path = $body->path; $path =~ s#^.*/([^/]*)$#$1#; $file2entity->{$path} = $entity; $entity2file->{$entity} = $path; #print STDERR "Path is $path\n"; } # And the head, which is where the recommended filename is stored # This is so we can report infections in the filenames which are # recommended, even if they are evil and we hence haven't used them. $headfile = $entity->head->recommended_filename || $path; #print STDERR "rec filename for \"$headfile\" is \"" . $entity->head->recommended_filename . "\"\n"; #print STDERR "headfile is $headfile\n"; if ($headfile) { $file2entity->{$headfile} = $entity if !$file2entity->{$headfile}; $file2safefile->{$headfile} = $path; $safefile2file->{$path} = $headfile; #print STDERR "File2SafeFile (\"$headfile\") = \"$path\"\n"; } # And for all its children @parts = $entity->parts; foreach $part (@parts) { BuildFile2EntityAndEntity2File($part, $file2entity, $file2safefile, $safefile2file, $entity2file, $name2entity); } } # Build a hash that gives the parent of any entity # (except for root ones which will be undef). # This is recursive. sub BuildEntity2Parent { my($entity, $Entity2Parent, $parent) = @_; my(@parts, $part); $Entity2Parent->{$entity} = $parent; @parts = $entity->parts; foreach $part (@parts) { #print STDERR "BuildEntity2Parent: Doing part $part\n"; $Entity2Parent->{$part} = $entity; BuildEntity2Parent($part, $Entity2Parent, $entity); } } # Combine the virus reports and the other reports, as otherwise the # cleaning code is really messy. I might combine them when I create # them some time later, but I wanted to keep them separate if possible # in case anyone wanted a feature in the future which would be easier # with separate reports. # If safefile2file does not map for a filename, ban the whole message # to be on the safe side. sub CombineReports { my $this = shift; my($file, $text, $Name); my(%reports, %types); #print STDERR "Combining reports for " . $this->{id} . "\n"; # If they want to include the scanner name in the reports, then also # include the translation of "MailScanner" in the filename/type/content # reports. # If they set "MailScanner = " in languages.conf then this string will # *not* be inserted at the start of the reports. $Name = MailScanner::Config::LanguageValue($this, 'mailscanner') if MailScanner::Config::Value('showscanner', $this); $Name .= ': ' if $Name ne "" && $Name !~ /:/; # Or the flags together $this->{infected} = $this->{virusinfected} | $this->{nameinfected} | $this->{sizeinfected} | $this->{otherinfected} ; # Combine all the reports and report-types while (($file, $text) = each %{$this->{virusreports}}) { #print STDERR "Adding file $file report $text\n"; $this->{allreports}{$file} .= $text; $reports{$file} .= $text; } while (($file, $text) = each %{$this->{virustypes}}) { #print STDERR "Adding file $file type $text\n"; $this->{alltypes}{$file} .= $text; $types{$file} .= $text; } while (($file, $text) = each %{$this->{namereports}}) { #print STDERR "Adding file \"$file\" report \"$text\"\n"; # Next line not needed as we prepend the $Name anyway #$text =~ s/\n(.)/\n$Name: NEWSTABLE $1/g if $Name; # Make sure name is at the front of this #print STDERR "report is now \"$text\"\n"; $this->{allreports}{$file} .= $Name . $text; $reports{$file} .= $Name . $text; } while (($file, $text) = each %{$this->{nametypes}}) { #print STDERR "Adding file $file type $text\n"; $this->{alltypes}{$file} .= $text; $types{$file} .= $text; } while (($file, $text) = each %{$this->{otherreports}}) { #print STDERR "Adding file $file report $text\n"; $this->{allreports}{$file} .= $Name . $text; $reports{$file} .= $Name . $text; } while (($file, $text) = each %{$this->{othertypes}}) { #print STDERR "Adding file $file type $text\n"; $this->{alltypes}{$file} .= $text; $types{$file} .= $text; } # Now try to map all the reports onto their parents as far as possible #print STDERR "About to combine reports\n"; my($key, $value, $parent, %foundparent); while(($key, $value) = each %reports) { $parent = $this->{file2parent}{$key}; #print STDERR "Looking at report for $key (son of $parent)\n"; #if (defined $parent && exists($this->{safefile2file}{$parent})) { # #print STDERR "Found parent of $key is $parent\n"; # $foundparent{$key} = 1; # $this->{allreports}{$parent} .= $value; # $this->{alltypes}{$parent} .= $types{$key}; #} else { # #print STDERR "Promoting report for $key\n"; # delete $this->{allreports}{$key}; # delete $this->{alltypes}{$key}; # $this->{allreports}{""} .= $value; # $this->{alltypes}{""} .= $types{$key}; #} if (defined $parent && exists($this->{safefile2file}{$parent}) && $parent ne "") { #print STDERR "Found parent of $key is $parent\n"; $foundparent{$key} = 1; $this->{allreports}{$parent} .= $value; $this->{alltypes}{$parent} .= $types{$key}; } else { #print STDERR "Promoting report for $key\n"; if($parent eq "" and exists($this->{safefile2file}{$key})) { $foundparent{$key} = 1; delete $this->{allreports}{$key}; delete $this->{alltypes}{$key}; $this->{allreports}{$key} .= $value; $this->{alltypes}{$key} .= $types{$key}; } else { delete $this->{allreports}{$key}; delete $this->{alltypes}{$key}; $this->{allreports}{""} .= $value; $this->{alltypes}{""} .= $types{$key}; } } } # And delete the records for members we have found. #foreach $key (keys %foundparent) { # print STDERR "Deleting report for $key\n"; # delete $this->{allreports}{$key}; # delete $this->{alltypes}{$key}; #} # Now look for the reports we can't match anywhere and make them # map to the entire message. #while(($key, $value) = each %reports) { # if (!defined $foundparent{$key} || !exists($this->{safefile2file}{$key})) { # #print STDERR "Promoting report for $key\n"; # delete $this->{allreports}{$key}; # delete $this->{alltypes}{$key}; # $this->{allreports}{""} .= $value; # $this->{alltypes}{""} .= $types{$key}; # } #} #print STDERR "Finished combining reports\n"; #$this->PrintInfections(); } # Clean the message. This involves removing all the infected or # troublesome sections of the message and replacing them with # nice little text files explaining what happened. # We do not do true macro-virus disinfection here. # Also mark the message as having had its body modified. sub Clean { my $this = shift; #print STDERR "\n\n\nStart Of Clean\n\n"; #$this->PrintInfections(); # Get out if nothing to do #print STDERR "Have we got anything to do?\n"; return unless ($this->{allreports} && %{$this->{allreports}}) || ($this->{entityreports} && %{$this->{entityreports}}); #print STDERR "Yes we have\n"; my($file, $text, $entity, $parent, $filename, $everyreport, %AlreadyCleaned); # Work out whether infected bits of this message should be stored my $storeme = 0; $storeme = 1 if MailScanner::Config::Value('quarantineinfections', $this) =~ /1/; # Cancel the storage if it is silent and no-one wants it quarantined $storeme = 0 if $this->{silent} && !$this->{noisy} && MailScanner::Config::Value('quarantinesilent', $this) !~ /1/; # Construct a string of all the reports, which is used if there is # cleaning needing doing on the whole message $everyreport = join("\n", values %{$this->{allreports}}); # Construct a hash of all the entities we will clean, # so we clean parents in preference to their children. my(%EntitiesWeClean); $EntitiesWeClean{scalar($this->{tnefentity})} = 1 if $this->{tnefentity}; while(($file, $text) = each %{$this->{allreports}}) { $entity = $this->{file2entity}{"$file"}; # If we are a child, push the parent on the list $entity = $this->{file2entity}{$this->{file2parent}{$file}} if !$entity; # If there isn't a parent either, push the whole message on the list $entity = $this->{entity} if !$entity; $EntitiesWeClean{scalar $entity} = 1; } # Work through each filename-based report in turn, 1 per attachment while(($file, $text) = each %{$this->{allreports}}) { #print STDERR "Cleaning $file which had a report of $text\n"; $this->{bodymodified} = 1; # This message body has been changed in memory # If it's a TNEF message, then use the entity of the winmail.dat # file, else use the entity of the infected file. my $tnefentity = $this->{tnefentity}; #print STDERR "It's a TNEF message\n" if $tnefentity; if ($file eq "") { #print STDERR "It's a whole body infection, entity = ".$this->{entity}."\n"; $entity = $this->{entity}; } else { #print STDERR "It's just 1 file, which is $file\n"; if ($tnefentity) { $entity = $tnefentity; } else { $entity = $this->{file2entity}{"$file"}; # Skip this report if we are reporting this entity's parent $parent = scalar($this->{file2entity}{$this->{file2parent}{$file}}); next if !$entity && $parent && $EntitiesWeClean{$parent}; #print STDERR "Cleaning $file which is entity $entity\n"; # Try to find a matching entity, may involve querying the parent if (!$entity) { $entity = $parent; #$this->{file2entity}{$this->{file2parent}{$file}}; #print STDERR "Parent of $file is " . $this->{file2parent}{$file} . "\n"; #print STDERR "Entity was blank, cleaning $entity\n"; } # Could not find parent, give up and zap whole message if (!$entity) { $entity = $this->{entity}; #print STDERR "Could not find entity, doing whole message\n"; } } } # Avoid cleaning the same entity twice as it will clean the wrong thing! next if $AlreadyCleaned{$entity}; $AlreadyCleaned{$entity} = 1; # Work out which message to replace the attachment with. # As there may be multiple types for 1 file, find them in # in decreasing order of importance. my $ModificationOnly = 0; # Is this just an "m" modification? my $type = $this->{alltypes}{"$file"}; #print STDERR "In Clean message, type = $type and quar? = $storeme\n"; if ($type =~ /v/i) { # It's a virus. Either delete or store it. if ($storeme) { $filename = MailScanner::Config::Value('storedvirusmessage', $this); } else { $filename = MailScanner::Config::Value('deletedvirusmessage', $this); } } elsif ($type =~ /f/i) { # It's a filename trap. Either delete or store it. if ($storeme) { $filename = MailScanner::Config::Value('storedfilenamemessage', $this); } else { $filename = MailScanner::Config::Value('deletedfilenamemessage', $this); } } elsif ($type =~ /c/i) { # It's dangerous content, either delete or store it. if ($storeme) { $filename = MailScanner::Config::Value('storedcontentmessage', $this); } else { $filename = MailScanner::Config::Value('deletedcontentmessage', $this); } } elsif ($type =~ /s/i) { # It's dangerous content, either delete or store it. if ($storeme) { $filename = MailScanner::Config::Value('storedsizemessage', $this); } else { $filename = MailScanner::Config::Value('deletedsizemessage', $this); } } elsif ($type eq 'm') { # The only thing wrong here is that the MIME structure has been # modified, so the message must be re-built. Nothing needs to # be removed from the message. $ModificationOnly = 1; } else { # Treat it like a virus anyway, to be on the safe side. if ($storeme) { $filename = MailScanner::Config::Value('storedvirusmessage', $this); } else { $filename = MailScanner::Config::Value('deletedvirusmessage', $this); } } # If entity is null then there was a parsing problem with the message, # so don't try to walk its tree as it will fail. next unless $entity; # MIME structure has been modified, so the message must be rebuilt. # Nothing needs to be cleaned though. next if $ModificationOnly; # If it's a silent virus, then only generate the report if anyone # wants a copy of it in the quarantine. Or else it won't be quarantined # but they will still get a copy of the report. #print STDERR "\n\nSilent = " . $this->{silent} . " and Noisy = " . $this->{noisy} . "\n"; $filename = "" if $this->{silent} && !$this->{noisy} && !MailScanner::Config::Value('deliversilent', $this); # && # MailScanner::Config::Value('quarantinesilent', $this) !~ /1/; # Do the actual attachment replacement #print STDERR "File = \"$file\"\nthis = \"$this\"\n"; #print STDERR "Entity to clean is $entity\n" . # "root entity is " . $this->{entity} . "\n"; if ($file eq "") { # It's a report on the whole message, so use all the reports # This is a virus disinfection on the *whole* message, so the # cleaner needs to know not to generate any mime parts. #print STDERR "Calling CleanEntity for whole message\n"; $this->CleanEntity($entity, $everyreport, $filename); } else { # It's a report on 1 section, so just use the report for that #print STDERR "About to call CleanEntity of $filename, $text\n"; $this->CleanEntity($entity, $text, $filename); } } # Now do the entity reports. These are for things like unparsable tnef # files, partial messages, external-body messages, things like that # which are always just errors. # Work through each report in turn, 1 per attachment #print STDERR "Entity reports are " . $this->{entityreports} . "\n"; while(($entity, $text) = each %{$this->{entityreports}}) { #print STDERR "Cleaning $entity which had a report of $text\n"; # Find rogue entity reports that should point to tnefentity but don't $entity = $this->{tnefentity} if $this->{badtnef} && !$entity; next unless $entity; # Skip rubbish in the reports # Turn the text name of the entity into the object itself $entity = $this->{name2entity}{scalar($entity)}; $this->{bodymodified} = 1; # This message body has been changed in memory #print STDERR "In Clean message, quar? = $storeme and entity = $entity\n"; # It's always an error, so handle it like a virus. # Either delete or store it. if ($storeme) { $filename = MailScanner::Config::Value('storedvirusmessage', $this); } else { $filename = MailScanner::Config::Value('deletedvirusmessage', $this); } # Do the actual attachment replacement #print STDERR "About to try to clean $entity, $text, $filename\n"; $this->CleanEntity($entity, $text, $filename); } # Sign the top of the message body with a text/html warning if they want. if (MailScanner::Config::Value('markinfectedmessages',$this) =~ /1/ && !$this->{signed}) { #print STDERR "In Clean message, about to sign message " . $this->{id} . # "\n"; $this->SignWarningMessage($this->{entity}); $this->{signed} = 1; } #print STDERR "\n\n\nAfter Clean()\n"; #$this->PrintInfections(); } # Do the actual attachment replacing sub CleanEntity { my $this = shift; my($entity, $report, $reportname) = @_; my(@parts, $Warning, $Disposition, $warningfile, $charset, $i); # Find the parent as that's what you have to change #print STDERR "CleanEntity: In ".$this->{id}." entity is $entity and " . # "its parent is " . $this->{entity2parent}{$entity} . "\n"; my $parent = $this->{entity2parent}{$entity}; $warningfile = MailScanner::Config::Value('attachmentwarningfilename', $this); $charset = MailScanner::Config::Value('attachmentcharset', $this); #print STDERR "Cleaning entity whose report is $report\n"; # Infections applying to the entire message cannot be simply disinfected. # Have to replace the entire message with a text/plain error. unless ($parent) { #print STDERR "Doing the whole message\n"; $Warning = $this->ConstructWarning( MailScanner::Config::LanguageValue($this, 'theentiremessage'), $report, $this->{id}, $reportname); #print STDERR "Warning message is $Warning\n"; #031118 if ($this->{entity} eq $entity) { if ($entity->bodyhandle) { #print STDERR "Really doing the whole message\n"; #print STDERR "Really doing Whole message\n"; # Replacing the whole message as the main body text of the message # contained a virus (e.g. the text of EICAR) without any proper # MIME structure at all. #print STDERR "Entity in CleanEntity is $entity\n"; #print STDERR "Bodyhandle is " . $entity->bodyhandle . "\n"; #031118 $entity->bodyhandle or return undef; # Output message back into body my($io, $filename, $temp); $io = $entity->open("w"); $io->print($Warning . "\n"); $io->close; # Set the MIME type if it was wrong $filename = MailScanner::Config::Value('attachmentwarningfilename', $this); $temp = $entity->head->mime_attr('content-type'); $entity->head->mime_attr('Content-Type', 'text/plain') if $temp && $temp ne 'text/plain'; # Set the charset if there was already a Content-type: header $entity->head->mime_attr('Content-type.charset', $charset) if $temp; $temp = $entity->head->mime_attr('content-type.name'); $entity->head->mime_attr('Content-type.name', $filename) if $temp; $temp = $entity->head->mime_attr('content-disposition'); $entity->head->mime_attr('content-disposition', 'inline') if $temp; $temp = $entity->head->mime_attr('content-disposition.filename'); $entity->head->mime_attr('content-disposition.filename', $filename) if $temp; return; } else { # If the message is multipart but the boundary is "" then it won't # have any parts() which makes it impossible to overwrite without # first forcing it to throw away all the structure by becoming # single-part. $entity->make_singlepart if $entity->is_multipart && $entity->head && $entity->head->multipart_boundary eq ""; $parts[0] = MIME::Entity->build( Type => 'text/plain', Filename => $warningfile, Disposition => 'inline', Data => $Warning, Encoding => 'quoted-printable', Charset => $charset, Top => 0); $entity->make_multipart() if $entity->head && $entity->head->mime_attr('content-type') eq ""; $entity->parts(\@parts); return; } } # Now know that the infection only applies to one part of the message, # so replace that part with an error message. @parts = $parent->parts; # Find the infected part my $tnef = $this->{tnefentity}; #print STDERR "TNEF entity is " . scalar($tnef) . "\n"; my $infectednum = -1; #print STDERR "CleanEntity: Looking for entity $entity\n"; for ($i=0; $i<@parts; $i++) { #print STDERR "CleanEntity: Comparing " . scalar($parts[$i]) . # " with $entity\n"; if (scalar($parts[$i]) eq scalar($entity)) { #print STDERR "Found it in part $i\n"; $infectednum = $i; last; } if ($tnef && (scalar($parts[$i]) eq scalar($tnef))) { #print STDERR "Found winmail.dat in part $i\n"; $infectednum = $i; last; } } #MailScanner::Log::WarnLog( # "Oh bother, missed infected entity in message %s :-(", $this->{id}), return # if $infectednum<0; # Now to actually do something about it... #print STDERR "About to constructwarning from $report\n"; $Warning = $this->ConstructWarning($this->{entity2file}{$entity}, $report, $this->{id}, $reportname); #print STDERR "Reportname is \"$reportname\"\n"; #print STDERR "Warning is \"$Warning\"\n"; # If the warning is now 0 bytes, don't add it, just remove the virus if ($Warning ne "") { $Disposition = MailScanner::Config::Value('warningisattachment',$this) ?'attachment':'inline'; $parts[$infectednum] = build MIME::Entity Type => 'text/plain', Filename => $warningfile, Disposition => $Disposition, Data => $Warning, Encoding => 'quoted-printable', Charset => $charset, Top => 0; } else { # We are just deleting the part, not replacing it # @parts = splice @parts, $infectednum, 1; $parts[$infectednum] = undef; # We prune the tree just during delivery } $parent->parts(\@parts); # And make the parent a multipart/mixed if it's a multipart/alternative # or multipart/related or message/partial $parent->head->mime_attr("Content-type" => "multipart/mixed") if ($parent->is_multipart) && ($parent->head->mime_attr("content-type") =~ /multipart\/(alternative|related)/i); if ($parent->head->mime_attr("content-type") =~ /message\/partial/i) { $parent->head->mime_attr("Content-type" => "multipart/mixed"); # $parent->make_singlepart(); } } # Construct a warning message given an attachment filename, a copy of # what the virus scanner said, the message id and a message filename to parse. # The id is passed in purely for substituting into the warning message file. sub ConstructWarning { my $this = shift; my($attachmententity, $scannersaid, $id, $reportname) = @_; # If there is no report file then we create no warning return "" unless $reportname; my $date = $this->{datestring}; # scalar localtime; my $textfh = new FileHandle; my $dir = $global::MS->{work}{dir}; # Get the working directory my $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); my $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); #print STDERR "ConstructWarning for $attachmententity. Scanner said \"" . # "$scannersaid\", message id $id, file = $reportname\n"; # Reformat the virus scanner report a bit, and optionally remove dirs $scannersaid =~ s/^/ /gm; if (MailScanner::Config::Value('hideworkdir',$this)) { my $pattern = '(' . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/"; #print STDERR "In replacement, regexp is \"$pattern\"\n"; $scannersaid =~ s/$pattern//g; #m # Remove the work dir $scannersaid =~ s/\/?$id\/?//g; # Remove the message id } #print STDERR "After replacement, scanner said \"$scannersaid\"\n"; my $output = ""; my $result = ""; # These are all the variables that are allowed to appear # in the report template. my $filename = ($attachmententity || MailScanner::Config::LanguageValue($this, 'notnamed')); #my $date = scalar localtime; Already defined above my $report = $scannersaid; my $hostname = MailScanner::Config::Value('hostname',$this); my $linkhostname = lc($hostname); $linkhostname =~ tr/a-z0-9_-//dc; my $quarantinedir = MailScanner::Config::Value('quarantinedir', $this); # And let them put the date number in there too my($day, $month, $year); #($day, $month, $year) = (localtime)[3,4,5]; #$month++; #$year += 1900; #my $datenumber = sprintf("%04d%02d%02d", $year, $month, $day); my $datenumber = $this->{datenumber}; # # Do we want to hide the directory and message id from the report path? # if (MailScanner::Config::Value('hideworkdir', $this)) { # my $pattern = "(" . quotemeta($global::MS->{work}->{dir}) . "|\.)/$id/"; # $report =~ s/$pattern//gm; # } open($textfh, $reportname) or MailScanner::Log::WarnLog("Cannot open message file %s, %s", $reportname, $!); my $line; while(defined ($line = <$textfh>)) { chomp $line; #$line =~ s/"/\\"/g; # Escape any " characters #$line =~ s/@/\\@/g; # Escape any @ characters $line =~ s/([\(\)\[\]\.\?\*\+\^"'@])/\\$1/g; # Escape any regex characters # Untainting joy... $line =~ $1 if $line =~ /(.*)/; $result = eval "\"$line\""; $output .= MailScanner::Config::DoPercentVars($result) . "\n"; } $output; } # Sign the body of the message with a text or html warning message # directing users to read the VirusWarning.txt attachment. # Return 0 if nothing was signed, true if it signed something. sub SignWarningMessage { my $this = shift; my $top = shift; #print STDERR "Top is $top\n"; return 0 unless $top; # If multipart, try to sign our first part if ($top->is_multipart) { my $sigcounter = 0; #print STDERR "It's a multipart message\n"; $sigcounter += $this->SignWarningMessage($top->parts(0)); $sigcounter += $this->SignWarningMessage($top->parts(1)) if $top->head and $top->effective_type =~ /multipart\/alternative/i; if ($sigcounter == 0) { # If we haven't signed anything by now, it must be a multipart # message containing only things we can't sign. So add a text/plain # section on the front and sign that. my $text = $this->ReadVirusWarning('inlinetextwarning') . "\n\n"; my $newpart = build MIME::Entity Type => 'text/plain', Disposition => 'inline', Data => $text, Encoding => 'quoted-printable', Top => 0; $top->add_part($newpart, 0); $sigcounter = 1; } return $sigcounter; } my $MimeType = $top->head->mime_type if $top->head; #print STDERR "MimeType is $MimeType\n"; return 0 unless $MimeType =~ m{text/}i; # Won't sign non-text message. # Won't sign attachments. return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i; # Get body data as array of newline-terminated lines #print STDERR "Bodyhandle is " . $top->bodyhandle . "\n"; $top->bodyhandle or return undef; my @body = $top->bodyhandle->as_lines; #print STDERR "Signing message part\n"; # Output message back into body, followed by original data my($line, $io, $warning); $io = $top->open("w"); if ($MimeType =~ /text\/html/i) { $warning = $this->ReadVirusWarning('inlinehtmlwarning'); #$warning = quotemeta $warning; # Must leave HTML tags alone! foreach $line (@body) { $line =~ s/\/$&$warning/i; $io->print($line); } } else { $warning = $this->ReadVirusWarning('inlinetextwarning'); $io->print($warning . "\n"); foreach $line (@body) { $io->print($line) }; # Original body data } (($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline $io->close; # We signed something return 1; } # Read the appropriate warning message to sign the top of cleaned messages. # Passed in the name of the config variable that points to the filename. # This is also used to read the inline signature added to the bottom of # clean messages. # Substitutions allowed in the message are # $viruswarningfilename -- by default VirusWarning.txt # $from # $subject # and $filename -- comma-separated list of infected attachments sub ReadVirusWarning { my $this = shift; my($option) = @_; my $file = MailScanner::Config::Value($option, $this); my $viruswarningname = MailScanner::Config::Value('attachmentwarningfilename', $this); my($line); #print STDERR "Reading virus warning message from $filename\n"; my $fh = new FileHandle; $fh->open($file) or (MailScanner::Log::WarnLog("Could not open inline file %s, %s", $file, $!), return undef); # Work out the list of all the infected attachments, including # reports applying to the whole message my($attach, $text, %infected, $filename, $from, $subject, $id); while (($attach, $text) = each %{$this->{allreports}}) { # It affects the entire message if the entity of this file matches # the entity of the entire message. my $entity = $this->{file2entity}{"$attach"}; #if ($attach eq "") { if ($this->{entity} eq $entity) { $infected{MailScanner::Config::LanguageValue($this, "theentiremessage")} = 1; } else { $infected{"$attach"} = 1; } } # And don't forget the external bodies which are just entity reports while (($attach, $text) = each %{$this->{entityreports}}) { $infected{MailScanner::Config::LanguageValue($this, 'notnamed')} = 1; } $filename = join(', ', keys %infected); $id = $this->{id}; $from = $this->{from}; $subject = $this->{subject}; my $result = ""; while (<$fh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; $line = eval "\"$1\""; $result .= MailScanner::Config::DoPercentVars($line) . "\n"; } $fh->close(); $result; } # Sign the bottom of the message with a tag-line saying it is clean # and MailScanner is wonderful :-) # Have already checked that message is not infected, and that they want # clean signatures adding to messages. sub SignUninfected { my $this = shift; return if $this->{infected}; # Double-check! my($entity, $scannerheader); # Use the presence of an X-MailScanner: header to decide if the # message will have already been signed by another MailScanner server. $scannerheader = MailScanner::Config::Value('mailheader', $this); $scannerheader =~ tr/://d; #print STDERR "Signing uninfected message " . $this->{id} . "\n"; # Want to sign the bottom of the highest-level MIME entity $entity = $this->{entity}; if (MailScanner::Config::Value('signalreadyscanned', $this) || (defined($entity) && !$entity->head->count($scannerheader))) { $this->AppendSignCleanEntity($entity); #$this->PrependSignCleanEntity($entity) # if MailScanner::Config::Value('signtopaswell', $this); $entity->head->add('MIME-Version', '1.0') unless $entity->head->get('mime-version'); $this->{bodymodified} = 1; } } # Sign the end of a message (which is an entity) with the given tag-line sub PrependSignCleanEntity { my $this = shift; my($top) = @_; my($MimeType, $signature, @signature); return unless $top; #print STDERR "In PrependSignCleanEntity, signing $top\n"; # If multipart, try to sign our first part if ($top->is_multipart) { my $sigcounter = 0; # JKF Signed and encrypted multiparts must not be touched. # JKF Instead put the sig in the epilogue. Breaks the RFC # JKF but in a harmless way. if ($top->effective_type =~ /multipart\/(signed|encrypted)/i) { # Read the sig and put it in the epilogue, which may be ignored $signature = $this->ReadVirusWarning('inlinetextpresig'); @signature = map { "$_\n" } split(/\n/, $signature); unshift @signature, "\n"; $top->preamble(\@signature); return 1; } $sigcounter += $this->PrependSignCleanEntity($top->parts(0)); $sigcounter += $this->PrependSignCleanEntity($top->parts(1)) if $top->head and $top->effective_type =~ /multipart\/alternative/i; if ($sigcounter == 0) { # If we haven't signed anything by now, it must be a multipart # message containing only things we can't sign. So add a text/plain # section on the front and sign that. my $text = $this->ReadVirusWarning('inlinetextpresig') . "\n\n"; my $newpart = build MIME::Entity Type => 'text/plain', Charset => MailScanner::Config::Value('attachmentcharset', $this), Disposition => 'inline', Data => $text, Encoding => 'quoted-printable', Top => 0; $top->add_part($newpart, 0); $sigcounter = 1; } return $sigcounter; } $MimeType = $top->head->mime_type if $top->head; return 0 unless $MimeType =~ m{text/}i; # Won't sign non-text message. # Won't sign attachments. return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i; # Get body data as array of newline-terminated lines $top->bodyhandle or return undef; my @body = $top->bodyhandle->as_lines; # Output original data back into body, followed by message my($line, $io); $io = $top->open("w"); if ($MimeType =~ /text\/html/i) { $signature = $this->ReadVirusWarning('inlinehtmlpresig'); foreach $line (@body) { $line =~ s/\/$&$signature/i; $io->print($line); } #(($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline } else { $signature = $this->ReadVirusWarning('inlinetextpresig'); $io->print("$signature\n"); foreach $line (@body) { $io->print($line) }; # Original body data } $io->close; # We signed something return 1; } # Sign the end of a message (which is an entity) with the given tag-line sub AppendSignCleanEntity { my $this = shift; my($top) = @_; my($MimeType, $signature, @signature); return unless $top; #print STDERR "In AppendSignCleanEntity, signing $top\n"; # If multipart, try to sign our first part if ($top->is_multipart) { my $sigcounter = 0; # JKF Signed and encrypted multiparts must not be touched. # JKF Instead put the sig in the epilogue. Breaks the RFC # JKF but in a harmless way. if ($top->effective_type =~ /multipart\/(signed|encrypted)/i) { # Read the sig and put it in the epilogue, which may be ignored $signature = $this->ReadVirusWarning('inlinetextsig'); @signature = map { "$_\n" } split(/\n/, $signature); unshift @signature, "\n"; $top->epilogue(\@signature); return 1; } $sigcounter += $this->AppendSignCleanEntity($top->parts(0)); $sigcounter += $this->AppendSignCleanEntity($top->parts(1)) if $top->head and $top->effective_type =~ /multipart\/alternative/i; if ($sigcounter == 0) { # If we haven't signed anything by now, it must be a multipart # message containing only things we can't sign. So add a text/plain # section on the front and sign that. my $text = $this->ReadVirusWarning('inlinetextsig') . "\n\n"; my $newpart = build MIME::Entity Type => 'text/plain', Charset => MailScanner::Config::Value('attachmentcharset', $this), Disposition => 'inline', Data => $text, Encoding => 'quoted-printable', Top => 0; $top->add_part($newpart, 0); $sigcounter = 1; } return $sigcounter; } $MimeType = $top->head->mime_type if $top->head; return 0 unless $MimeType =~ m{text/(html|plain)}i; # Won't sign non-text message. # Won't sign attachments. return 0 if $top->head->mime_attr('content-disposition') =~ /attachment/i; # Get body data as array of newline-terminated lines $top->bodyhandle or return undef; my @body = $top->bodyhandle->as_lines; # Output original data back into body, followed by message my($line, $io, $FoundHTMLEnd); $FoundHTMLEnd = 0; # If there is no tag, still append the signature $io = $top->open("w"); if ($MimeType =~ /text\/html/i) { $signature = $this->ReadVirusWarning('inlinehtmlsig'); foreach $line (@body) { $FoundHTMLEnd = 1 if $line =~ s/\<\/x?html\>/$signature$&/i; $io->print($line); } $io->print($signature . "\n") unless $FoundHTMLEnd; (($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); # Ensure final newline } else { foreach $line (@body) { $io->print($line) }; # Original body data $signature = $this->ReadVirusWarning('inlinetextsig'); $io->print("\n$signature\n"); } $io->close; # We signed something return 1; } # Deliver an uninfected message. It is already signed as necessary. # If the body has been modified then we need to reconstruct it from # the MIME structure. If not modified, then just link it across to # the outgoing queue. sub DeliverUninfected { my $this = shift; if ($this->{bodymodified}) { # The body of this message has been modified, so reconstruct # it from the MIME structure and deliver that. #print STDERR "Body modified\n"; $this->DeliverModifiedBody('cleanheader'); } else { #print STDERR "Body not modified\n"; if (MailScanner::Config::Value('virusscan', $this) =~ /1/) { #print STDERR "Message is scanned and clean\n"; $this->DeliverUnmodifiedBody('cleanheader'); } else { #print STDERR "Message is unscanned\n"; $this->DeliverUnmodifiedBody('unscannedheader'); } } } my($DisarmFormTag, $DisarmScriptTag, $DisarmCodebaseTag, $DisarmIframeTag, $DisarmWebBug, $DisarmPhishing, $DisarmNumbers, $DisarmHTMLChangedMessage, $DisarmWebBugFound, $DisarmPhishingFound, $PhishingSubjectTag, $PhishingHighlight, $StrictPhishing, $WebBugWhitelist, $WebBugReplacement); # Deliver a message which has not had its body modified in any way. # This is a lot faster as it doesn't involve reconstructing the message # body at all, it is just copied from the inqueue to the outqueue. sub DeliverUnmodifiedBody { my $this = shift; my($headervalue) = @_; #print STDERR "DisarmPhishingFound = " . $DisarmPhishingFound . " for message " . $this->{id} . "\n"; return if $this->{deleted}; # This should never happen # Prune the entity tree to remove all undef values PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity}); #print STDERR "Delivering Unmodified Body message\n"; my $OutQ = MailScanner::Config::Value('outqueuedir', $this); my $store = $this->{store}; # Link the queue data file from in to out $store->LinkData($OutQ); # Set up the output envelope with its (possibly modified) headers # Used to do next line but it breaks text-only messages with no MIME # structure as the MIME explosion will have created a MIME structure. #$global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header); $global::MS->{mta}->AddHeadersToQf($this); # Remove duplicate subject: lines $global::MS->{mta}->UniqHeader($this, 'Subject:'); # Add the information/help X- header my $infoheader = MailScanner::Config::Value('infoheader', $this); if ($infoheader) { my $infovalue = MailScanner::Config::Value('infovalue', $this); $global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue); } $global::MS->{mta}->AddMultipleHeader($this, 'mailheader', MailScanner::Config::Value($headervalue, $this), ', '); # Delete all content length headers anyway. They are unsafe. # No, leave them if nothing in the body has been modified. #$global::MS->{mta}->DeleteHeader($this, 'Content-length:'); # Add the MCP header if necessary $global::MS->{mta}->AddMultipleHeader($this, 'mcpheader', $this->{mcpreport}, ', ') if $this->{ismcp} || MailScanner::Config::Value('includemcpheader', $this); # Add the spam header if they want that #$global::MS->{mta}->AddHeader($this, # MailScanner::Config::Value('spamheader',$this), # $this->{spamreport}) # JKF 3/10/2005 $global::MS->{mta}->AddMultipleHeader($this, 'spamheader', $this->{spamreport}, ', ') if MailScanner::Config::Value('includespamheader', $this) || ($this->{spamreport} && $this->{isspam}); # Add the spam stars if they want that. Limit it to 60 characters to avoid # a potential denial-of-service attack. my($stars,$starcount,$scoretext,$minstars,$scorefmt); $starcount = int($this->{sascore}) + 0; $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{sascore}+0); $minstars = MailScanner::Config::Value('minstars', $this); $starcount = $minstars if $this->{isrblspam} && $minstars && $starcount<$minstars; if (MailScanner::Config::Value('spamscorenotstars', $this)) { $stars = $scoretext; # int($starcount); } else { $starcount = 60 if $starcount>60; $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount; } if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) { $global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader', $stars, ', '); } # Add the Envelope to and from headers AddFromAndTo($this); # Repair the subject line $global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject}) if $this->{subjectwasunsafe}; # Modify the subject line for Disarming my $subjectchanged = 0; my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this); my $phishingtag = MailScanner::Config::Value('phishingsubjecttag', $this); #if ($this->{messagedisarmed}) { # #print STDERR "Found messagedisarmed = " . join(',',@{$this->{disarmedtags}}) . "\n"; # if(MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); # $subjectchanged = 1; # } # if (grep /phishing/i, @{$this->{disarmedtags}}) { # #print STDERR "Found a phishing disarmedtags\n"; # # We found it had a phishing link in it. Are we tagging phishing Subject? # if (MailScanner::Config::Value('tagphishingsubject',$this) =~ /1/ && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag) #) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' '); # $subjectchanged = 1; # } # } #} if ($this->{messagedisarmed}) { #print STDERR "MessageDisarmed is set at 3878\n"; my $where = MailScanner::Config::Value('disarmmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' '); $subjectchanged = 1; #print STDERR "MessageDisarmed is set (end)\n"; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); $subjectchanged = 1; #print STDERR "MessageDisarmed is set (start)\n"; } #print STDERR "disarmedtags = " . join(',',@{$this->{disarmedtags}}) . "\n"; } #print STDERR "Hello from 3840\n"; if ($this->{disarmphishingfound}) { # grep /phishing/i, @{$this->{disarmedtags}}) { # We found it had a phishing link in it. Are we tagging phishing Subject? #print STDERR "DisarmPhishingFound at 3896!\n"; #print STDERR "ID = " . $this->{id} . "\n"; my $where = MailScanner::Config::Value('tagphishingsubject', $this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $phishingtag)) { #print STDERR "end\n"; $global::MS->{mta}->AppendHeader($this, 'Subject:', $phishingtag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { #print STDERR "start\n"; $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); $subjectchanged = 1; } #} } # Modify the subject line for spam # if it's spam AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && !$this->{ishigh} && # MailScanner::Config::Value('spamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); # $subjectchanged = 1; #} if ($this->{isspam} && !$this->{ishigh}) { my $where = MailScanner::Config::Value('spammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } } # If it is high-scoring spam, then add a different bit of text $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && $this->{ishigh} && # MailScanner::Config::Value('highspamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); # $subjectchanged = 1; #} if ($this->{isspam} && $this->{ishigh}) { my $where = MailScanner::Config::Value('highspammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } } # Modify the subject line for MCP # if it's MCP AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. $starcount = int($this->{mcpsascore}) + 0; $starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{mcpsascore}+0); my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; #if ($this->{ismcp} && !$this->{ishighmcp} && # MailScanner::Config::Value('mcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); # $subjectchanged = 1; #} if ($this->{ismcp} && !$this->{ishighmcp}) { my $where = MailScanner::Config::Value('mcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } } # If it is high-scoring MCP, then add a different bit of text $mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; #if ($this->{ismcp} && $this->{ishighmcp} && # MailScanner::Config::Value('highmcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); # $subjectchanged = 1; #} if ($this->{ismcp} && $this->{ishighmcp}) { my $where = MailScanner::Config::Value('highmcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } } # Modify the subject line for scanning -- but only do it if the # subject hasn't already been modified by MailScanner for another reason. my $modifscan = MailScanner::Config::Value('scannedmodifysubject', $this); my $scantag = MailScanner::Config::Value('scannedsubjecttext', $this); if ($modifscan =~ /start/ && !$subjectchanged && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' '); $subjectchanged = 1; } elsif ($modifscan =~ /end|1/ && !$subjectchanged && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' '); $subjectchanged = 1; } # Remove any headers we don't want in the message my(@removeme, $remove); @removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this)); foreach $remove (@removeme) { # Add a : if there isn't one already, it's needed for DeleteHeader() $remove .= ':' unless $remove =~ /:$/; $global::MS->{mta}->DeleteHeader($this, $remove); } # Add the extra headers they want for MCP and spam messages my(@extraheaders, $extraheader); my($key, $value); @extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders}; push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders}; foreach $extraheader (@extraheaders) { #print STDERR "Unmod Adding extra header $extraheader\n"; next unless $extraheader =~ /:/; ($key, $value) = split(/:\s*/, $extraheader, 2); $global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', '); } # Add the secret archive recipients my($extra, @extras); foreach $extra (@{$this->{archiveplaces}}) { next if $extra =~ /^\//; next unless $extra =~ /@/; push @extras, $extra; } $global::MS->{mta}->AddRecipients($this, @extras) if @extras; # Write the new qf file, delete originals and unlock the message $store->WriteHeader($this, $OutQ); unless ($this->{gonefromdisk}) { $store->DeleteUnlock(); $this->{gonefromdisk} = 1; } # Note this does not kick the MTA into life here any more } # Deliver a message which has had its body modified. # This is slower as the message has to be reconstructed from all its # MIME entities. sub DeliverModifiedBody { my $this = shift; my($headervalue) = @_; return if $this->{deleted}; # This should never happen #print STDERR "Delivering Modified Body message with header \"$headervalue\"\n"; my $store = $this->{store}; # If there is no data structure at all for this message, then we # can't sensibly deliver anything, so just delete it. # The parsing must have failed completely. my $entity = $this->{entity}; unless ($entity) { #print STDERR "Deleting duff message\n"; unless ($this->{gonefromdisk}) { $store->DeleteUnlock(); $this->{gonefromdisk} = 1; } return; } # Prune the entity tree to remove all undef values #PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity}); PruneEntityTree($entity,$this->{entity2file},$this->{file2entity}); my $OutQ = MailScanner::Config::Value('outqueuedir', $this); # Write the new body file #print STDERR "Writing the MIME body of $this, " . $this->{id} . "\n"; $store->WriteMIMEBody($this->{id}, $entity, $OutQ); #print STDERR "Written the MIME body\n"; # Set up the output envelope with its (possibly modified) headers $global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header); # Remove duplicate subject: lines $global::MS->{mta}->UniqHeader($this, 'Subject:'); # Add the information/help X- header my $infoheader = MailScanner::Config::Value('infoheader', $this); if ($infoheader) { my $infovalue = MailScanner::Config::Value('infovalue', $this); $global::MS->{mta}->ReplaceHeader($this, $infoheader, $infovalue); } # Add the clean/dirty header #print STDERR "Adding clean/dirty header $headervalue\n"; $global::MS->{mta}->AddMultipleHeader($this, 'mailheader', MailScanner::Config::Value($headervalue, $this), ', '); # Delete all content length headers as the body has been modified. $global::MS->{mta}->DeleteHeader($this, 'Content-length:'); # Add the MCP header if necessary $global::MS->{mta}->AddMultipleHeader($this, 'mcpheader', $this->{mcpreport}, ', ') if $this->{ismcp} || MailScanner::Config::Value('includemcpheader', $this); # Add the spam header if they want that #$global::MS->{mta}->AddHeader($this, # MailScanner::Config::Value('spamheader',$this), # $this->{spamreport}) # JKF 3/10/2005 $global::MS->{mta}->AddMultipleHeader($this, 'spamheader', $this->{spamreport}, ', ') if MailScanner::Config::Value('includespamheader', $this) || ($this->{spamreport} && $this->{isspam}); # Add the spam stars if they want that. Limit it to 60 characters to avoid # a potential denial-of-service attack. my($stars,$starcount,$scoretext,$minstars,$scorefmt); $starcount = int($this->{sascore}) + 0; $starcount = 0 if $this->{spamwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{sascore}+0); $minstars = MailScanner::Config::Value('minstars', $this); $starcount = $minstars if $this->{isrblspam} && $minstars && $starcount<$minstars; if (MailScanner::Config::Value('spamscorenotstars', $this)) { $stars = $scoretext; # int($starcount); } else { $starcount = 60 if $starcount>60; $stars = MailScanner::Config::Value('spamstarscharacter') x $starcount; } if (MailScanner::Config::Value('spamstars', $this) =~ /1/ && $starcount>0) { $global::MS->{mta}->AddMultipleHeader($this, 'spamstarsheader', $stars, ', '); } # Add the Envelope to and from headers AddFromAndTo($this); # Repair the subject line #print STDERR "Metadata is " . join("\n", @{$this->{metadata}}) . "\n"; $global::MS->{mta}->ReplaceHeader($this, 'Subject:', $this->{safesubject}) if $this->{subjectwasunsafe}; my $subjectchanged = 0; # Modify the subject line for viruses or filename traps. # Only use the filename trap test if it isn't infected by anything else. my $nametag = MailScanner::Config::Value('namesubjecttext', $this); my $contenttag = MailScanner::Config::Value('contentsubjecttext', $this); my $sizetag = MailScanner::Config::Value('sizesubjecttext', $this); #print STDERR "I have triggered a size trap\n" if $this->{sizeinfected}; if ($this->{nameinfected} && # Triggered a filename trap !$this->{virusinfected} && # No other reports about it !$this->{otherinfected} && # They want the tagging & not already tagged !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $nametag)) { #if (MailScanner::Config::Value('nameprependsubject',$this)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $nametag, ' '); # $subjectchanged = 1; #} my $where = MailScanner::Config::Value('namemodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $nametag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $nametag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $nametag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $nametag, ' '); $subjectchanged = 1; } } elsif ($this->{sizeinfected} && # Triggered a size trap !$this->{virusinfected} && !$this->{nameinfected}) { # && #!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $sizetag)) { #if (MailScanner::Config::Value('sizeprependsubject',$this)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $sizetag, ' '); # $subjectchanged = 1; #} my $where = MailScanner::Config::Value('sizemodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $sizetag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $sizetag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $sizetag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $sizetag, ' '); $subjectchanged = 1; } } elsif ($this->{otherinfected} && # Triggered a content trap !$this->{virusinfected} && # No other reports about it !$this->{nameinfected}) { #&& # They want the tagging & not already tagged #!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $contenttag)) { #if (MailScanner::Config::Value('contentprependsubject',$this)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $contenttag, ' '); # $subjectchanged = 1; #} my $where = MailScanner::Config::Value('contentmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $contenttag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $contenttag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $contenttag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $contenttag, ' '); $subjectchanged = 1; } } else { # It may be really virus infected. # Modify the subject line for viruses # if it's infected AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. my $virustag = MailScanner::Config::Value('virussubjecttext', $this); #print STDERR "I am infected\n" if $this->{infected}; #if ($this->{infected} && # MailScanner::Config::Value('virusprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $virustag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $virustag, ' '); # $subjectchanged = 1; #} if ($this->{infected}) { my $where = MailScanner::Config::Value('virusmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $virustag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $virustag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $virustag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $virustag, ' '); $subjectchanged = 1; } } } # Modify the subject line for Disarming my $disarmtag = MailScanner::Config::Value('disarmsubjecttext',$this); my $phishingtag = MailScanner::Config::Value('phishingsubjecttag', $this); #print STDERR "phishingtag = $phishingtag\n"; if ($this->{messagedisarmed}) { #print STDERR "DisarmPhishingFound is set at 4200\n"; #print STDERR "Message id = " . $this->{id} . "\n"; #print STDERR "Found messagedisarmed = " . join(',',@{$this->{disarmedtags}}) . "\n"; #if(MailScanner::Config::Value('disarmprependsubject',$this) =~ /1/ && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); # $subjectchanged = 1; #} my $where = MailScanner::Config::Value('disarmmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $disarmtag, ' '); $subjectchanged = 1; #print STDERR "MessageDisarmed is set (end)\n"; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $disarmtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $disarmtag, ' '); $subjectchanged = 1; #print STDERR "MessageDisarmed is set (start)\n"; } } if ($this->{disarmphishingfound}) { #print STDERR "disarmedtags = " . join(',',@{$this->{disarmedtags}}) . "\n"; #if (grep /phishing/i, @{$this->{disarmedtags}}) { #print STDERR "Found phishing disarmedtags2\n"; # We found it had a phishing link in it. Are we tagging phishing Subject? #if (MailScanner::Config::Value('tagphishingsubject',$this) =~ /1/ && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' '); # $subjectchanged = 1; #} # We found it had a phishing link in it. Are we tagging phishing Subject? my $where = MailScanner::Config::Value('tagphishingsubject', $this); #print STDERR "Where is $where\n"; #print STDERR "Subject tag check = " . $global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag) . "***\n"; if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $phishingtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $phishingtag, ' '); $subjectchanged = 1; #print STDERR "end\n"; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $phishingtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $phishingtag, ' '); $subjectchanged = 1; #print STDERR "start\n"; } #} } # Modify the subject line for spam # if it's spam AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && !$this->{ishigh} && # MailScanner::Config::Value('spamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); # $subjectchanged = 1; #} if ($this->{isspam} && !$this->{ishigh}) { my $where = MailScanner::Config::Value('spammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } } # If it is high-scoring spam, then add a different bit of text $spamtag = MailScanner::Config::Value('highspamsubjecttext', $this); $spamtag =~ s/_SCORE_/$scoretext/; $spamtag =~ s/_STARS_/$stars/i; #if ($this->{isspam} && $this->{ishigh} && # MailScanner::Config::Value('highspamprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); # $subjectchanged = 1; #} if ($this->{isspam} && $this->{ishigh}) { my $where = MailScanner::Config::Value('highspammodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $spamtag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $spamtag, ' '); $subjectchanged = 1; } } # Modify the subject line for MCP # if it's MCP AND they want to modify the subject line AND it's not # already been modified by another of your MailScanners. $starcount = int($this->{mcpsascore}) + 0; $starcount = 0 if $this->{mcpwhitelisted}; # 0 stars if white-listed $scorefmt = MailScanner::Config::Value('scoreformat', $this); $scorefmt = '%d' if $scorefmt eq ''; $scoretext = sprintf($scorefmt, $this->{mcpsascore}+0); my $mcptag = MailScanner::Config::Value('mcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; #if ($this->{ismcp} && !$this->{ishighmcp} && # MailScanner::Config::Value('mcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); # $subjectchanged = 1; #} if ($this->{ismcp} && !$this->{ishighmcp}) { my $where = MailScanner::Config::Value('mcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } } # If it is high-scoring MCP, then add a different bit of text $mcptag = MailScanner::Config::Value('highmcpsubjecttext', $this); $mcptag =~ s/_SCORE_/$scoretext/; #if ($this->{ismcp} && $this->{ishighmcp} && # MailScanner::Config::Value('highmcpprependsubject',$this) && # !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { # $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); # $subjectchanged = 1; #} if ($this->{ismcp} && $this->{ishighmcp}) { my $where = MailScanner::Config::Value('highmcpmodifysubject',$this); if ($where =~ /end/ && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } elsif ($where =~ /start|1/ && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $mcptag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $mcptag, ' '); $subjectchanged = 1; } } # Modify the subject line for scanning -- but only do it if the # subject hasn't already been modified by MailScanner for another reason. my $modifscan = MailScanner::Config::Value('scannedmodifysubject', $this); my $scantag = MailScanner::Config::Value('scannedsubjecttext', $this); if ($modifscan =~ /start/ && !$subjectchanged && !$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) { $global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' '); } elsif ($modifscan =~ /end|1/ && !$subjectchanged && !$global::MS->{mta}->TextEndsHeader($this, 'Subject:', $scantag)) { $global::MS->{mta}->AppendHeader($this, 'Subject:', $scantag, ' '); } # Remove any headers we don't want in the message my(@removeme, $remove); @removeme = split(/[,\s]+/, MailScanner::Config::Value('removeheaders', $this)); foreach $remove (@removeme) { # Add a : if there isn't one already, it's needed for DeleteHeader() $remove .= ':' unless $remove =~ /:$/; $global::MS->{mta}->DeleteHeader($this, $remove); } # Add the extra headers they want for MCP and spam messages my(@extraheaders, $extraheader); my($key, $value); @extraheaders = @{$this->{extramcpheaders}} if $this->{extramcpheaders}; push @extraheaders, @{$this->{extraspamheaders}} if $this->{extraspamheaders}; foreach $extraheader (@extraheaders) { #print STDERR "Mod Adding extra header $extraheader\n"; next unless $extraheader =~ /:/; ($key, $value) = split(/:\s*/, $extraheader, 2); $global::MS->{mta}->AddMultipleHeaderName($this, $key . ':', $value, ', '); } # Add the secret archive recipients my($extra, @extras); foreach $extra (@{$this->{archiveplaces}}) { next if $extra =~ /^\//; next unless $extra =~ /@/; push @extras, $extra; } $global::MS->{mta}->AddRecipients($this, @extras) if @extras; # Write the new qf file, delete originals and unlock the message #print STDERR "Writing the new qf file\n"; $store->WriteHeader($this, $OutQ); unless ($this->{gonefromdisk}) { $store->DeleteUnlock(); $this->{gonefromdisk} = 1; } # Note this does not kick the MTA into life here any more } # Prune all the undef branches out of an entity tree sub PruneEntityTree { my ($entity,$entity2file,$file2entity) = @_; #print STDERR "Pruning $entity\n"; return undef unless $entity; return $entity unless $entity->parts; my(@newparts, $part, $newpart, $counter); # Do a pre-traversal depth-first search of the tree #print STDERR "Looking at $entity\n"; foreach $part ($entity->parts) { #$counter++; #print STDERR "$counter Going down to $part\n"; next unless $part; #print STDERR "Non null $part\n"; $newpart = PruneEntityTree($part,$entity2file,$file2entity); #$newpart = $newpart?PruneEntityTree($part,$entity2file,$file2entity):$part; #print STDERR "Replacement is $newpart\n"; if ($newpart) { #print STDERR "Adding replacement $newpart\n"; push @newparts, $newpart; #print STDERR "Newparts = " . join(',',@newparts) . "\n"; #} else { # my $file = $entity2file->{$newpart} if $entity2file; # delete $entity2file->{$newpart} if $entity2file && $file; # delete $file2entity->{$file} if $file2entity && $file; } #print STDERR "Coming up, added $newpart\n"; } #print STDERR "About to return\n"; # Keep all the parts we found, prune as much as we can if (@newparts) { #print STDERR "Returning entity $entity with " . join(',',@newparts) . "\n"; $entity->parts(\@newparts); return $entity; } else { #print STDERR "Returning undef\n"; return undef; } } # Delete a message from the incoming queue sub DeleteMessage { my $this = shift; #print STDERR "DeletingMessage " . $this->{id} . "\n"; unless ($this->{gonefromdisk}) { $this->{store}->DeleteUnlock(); $this->{gonefromdisk} = 1; } $this->{deleted} = 1; } ## Is this message from a local domain? #sub IsFromLocalDomain { # my $this = shift; # # #print STDERR "Deleting cleaned message " . $this->{id} . "\n"; # $this->{store}->Delete(); # $this->{store}->Unlock(); # $this->{deleted} = 1; #} # Work out if the message is infected with a "silent" virus such as Klez. # Set the "silent" flag on all such messages. # At the same time, find the "noisy" non-spoofing infections such as # document macro viruses. sub FindSilentAndNoisyInfections { my $this = shift; my(@silentin) = split(" ",MailScanner::Config::Value('silentviruses', $this)); my($silent, $silentin, @silent, $regexp, $allreports, $logstring, $allsilent); my($virusreports); my(@noisyin) = split(" ",MailScanner::Config::Value('noisyviruses', $this)); my($noisy, $noisyin, @noisy, $nregexp); #print "-1 Silentin = \"" . join(',',@silentin) . "\"\n"; #print "-1 Noisy in = \"" . join(',',@noisyin) . "\"\n"; # Get out quickly if there's nothing to do return unless @silentin || @noisyin; # Turn each silent and noisy report into a regexp $allsilent = 0; foreach $silent (@silentin) { if (lc($silent) eq 'all-viruses') { $allsilent = 1; next; } $silentin = quotemeta $silent; push @silent, $silentin; } foreach $noisy (@noisyin) { next if lc($noisy) eq 'all-viruses'; $noisyin = quotemeta $noisy; push @noisy, $noisyin; } # Make 2 big regexps from them all $regexp = ""; $nregexp = ""; $regexp = '(' . join(')|(', @silent) . ')' if @silent; $nregexp = '(' . join(')|(', @noisy) . ')' if @noisy; # Make 1 big string from all the reports $allreports = join('', values %{$this->{allreports}}); $virusreports = join(' ', values %{$this->{virusreports}}); #print STDERR "FindSilentInfection: Looking for \"$regexp\" in \"" . # $allreports . "\"\n"; #print STDERR "FindNoisyInfection: Looking for \"$nregexp\" in \"" . # $allreports . "\"\n"; #$this->{silent} = 1 if @silentin && $allreports =~ /$regexp/i; #$this->{noisy} = 1 if @noisyin && $allreports =~ /$nregexp/i; # Do this with grep so I can extract the matching line. $this->{silent} = 1 if $regexp && grep {$logstring .= "$_ " if /$regexp/i;} values %{$this->{allreports}}; if ($allsilent && $virusreports) { $this->{silent} = 1; $logstring .= $virusreports; } $this->{noisy} = 1 if $nregexp && grep /$nregexp/i, values %{$this->{allreports}}; #print STDERR "0 regexp = $nregexp and search = \"" . join('","',values %{$this->{allreports}}) . "\"\n"; #print STDERR "1 FindSilentInfection: Found it!\n" if $this->{silent}; #print STDERR "1 FindNoisyInfection: Found it!\n" if $this->{noisy}; return unless MailScanner::Config::Value('logsilentviruses', $this); $logstring = join(',', values %{$this->{allreports}}) if !$logstring && $allsilent && $this->{silent} == 1; $logstring =~ s/[\n,]+(.)/,$1/g; MailScanner::Log::NoticeLog("Viruses marked as silent: %s", $logstring) if $logstring; #print STDERR "2 FindSilentInfection: Found it!\n" if $this->{silent}; #print STDERR "2 FindNoisyInfection: Found it!\n" if $this->{noisy}; } # Deliver a cleaned message and remove it from the incoming queue sub DeliverCleaned { my $this = shift; # The body of this message has been modified, so reconstruct # it from the MIME structure and deliver that. #print STDERR "Delivering cleaned up message " . $this->{id} . "\n"; $this->DeliverModifiedBody('dirtyheader'); } # Send a warning message to the person who sent this message. # Need to create variables for from, to, subject, date and report # for use within the message. sub WarnSender { my $this = shift; my($from,$to,$subject,$date,$allreports,$alltypes,$report,$type); my($entityreports, @everyreportin, $entitytypes, @everytype); my($emailmsg, $line, $messagefh, $msgname, $localpostmaster, $id); my($hostname, $postmastername); # Do we want to send the sender a warning at all? # If nosenderprecedence is set to non-blank and contains this # message precedence header, then just return. my(@preclist, $prec, $precedence, $header); @preclist = split(" ", lc(MailScanner::Config::Value('nosenderprecedence', $this))); $precedence = ""; foreach $header (@{$this->{headers}}) { $precedence = lc($1) if $header =~ /^precedence:\s+(\S+)/i; } if (@preclist && $precedence ne "") { foreach $prec (@preclist) { if ($precedence eq $prec) { MailScanner::Log::InfoLog("Skipping sender of precedence %s", $precedence); return; } } } # Now we know we want to send the message, it's not a bulk mail $from = $this->{from}; # Don't ever send a message to "" or "<>" return if $from eq "" || $from eq "<>"; # Setup other variables they can use in the message template $id = $this->{id}; #$to = join(', ', @{$this->{to}}); $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $hostname = MailScanner::Config::Value('hostname', $this); $subject = $this->{subject}; $date = $this->{datestring}; # scalar localtime; my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); $allreports = $this->{allreports}; $entityreports = $this->{entityreports}; push @everyreportin, values %$allreports; push @everyreportin, values %$entityreports; my $reportword = MailScanner::Config::LanguageValue($this, "report"); my($reportline, @everyreport); foreach $reportline (@everyreportin) { push @everyreport, map { ((/^$reportword: /m)?$_:"$reportword: $_") . "\n" } split(/\n/, $reportline); } #print STDERR "Reports are \"" . join('", "', @everyreport) . "\"\n"; #$report = join('', @everyreport); my %seen = (); $report = join('', grep { ! $seen{$_} ++ } @everyreport); #print STDERR "***Report to sender is***\n$report***END***\n"; $alltypes = $this->{alltypes}; $entitytypes = $this->{entitytypes}; push @everytype, values %$alltypes; push @everytype, values %$entitytypes; $type = join('', @everytype); # Do we want to hide the directory and message id from the report path? if (MailScanner::Config::Value('hideworkdir', $this)) { my $pattern = "(" . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/"; $report =~ s/$pattern//g; # m # Remove the work dir $report =~ s/\/?$id\/?//g; # Remove the message id } # Set the report filename dependent on what triggered MailScanner, be it # a virus, a filename trap, a Denial Of Service attack, or an parsing error. if ($type =~ /v/i) { $msgname = MailScanner::Config::Value('sendervirusreport', $this); } elsif ($type =~ /f/i) { $msgname = MailScanner::Config::Value('senderfilenamereport', $this); } elsif ($type =~ /e/i) { $msgname = MailScanner::Config::Value('sendererrorreport', $this); } elsif ($type =~ /c/i) { $msgname = MailScanner::Config::Value('sendercontentreport', $this); } elsif ($type =~ /s/i) { $msgname = MailScanner::Config::Value('sendersizereport', $this); } else { $msgname = MailScanner::Config::Value('sendervirusreport', $this); } #print STDERR "Report is $msgname\n"; # Work out the list of all the infected attachments, including # reports applying to the whole message my($attach, $text, %infected, $filename); while (($attach, $text) = each %$allreports) { if ($attach eq "") { $infected{MailScanner::Config::LanguageValue($this, "theentiremessage")} = 1; } else { $infected{"$attach"} = 1; } } # And don't forget the external bodies which are just entity reports while (($attach, $text) = each %$entityreports) { $infected{MailScanner::Config::LanguageValue($this, 'notnamed')} = 1; } $filename = join(', ', keys %infected); $messagefh = new FileHandle; $messagefh->open($msgname) or MailScanner::Log::WarnLog("Cannot open message file %s, %s", $msgname, $!); $emailmsg = ""; while(<$messagefh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; $line = eval "\"$1\""; $emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n"; } $messagefh->close(); # This did say $localpostmaster in the last parameter, but I changed # it to '<>' so that the sender warnings couldn't bounce. $global::MS->{mta}->SendMessageString($this, $emailmsg, '<>') or MailScanner::Log::WarnLog("Could not send sender warning, %s", $!); } # Create the headers for a postmaster notification message. # This is expensive so don't do it much! sub CreatePostmasterHeaders { my $this = shift; my($to) = @_; my($result, $charset); # Make sure the Postmaster notice is in the right character set $charset = MailScanner::Config::Value('attachmentcharset',$this); $result = "From: \"" . MailScanner::Config::Value('noticesfrom', $this) . "\" <" . MailScanner::Config::Value('localpostmaster',$this) . ">\nTo: "; #$to = MailScanner::Config::Value('noticerecipient',$this); #$to =~ s/ +/, /g; $result .= $to . "\nSubject: " . MailScanner::Config::LanguageValue($this, 'noticesubject') . "\n"; $result .= "Content-type: text/plain; charset=$charset\n" if $charset; return $result; } # Create the notification text for 1 email message. sub CreatePostmasterNotice { my $this = shift; my(@everyrept); push @everyrept, values %{$this->{allreports}}; push @everyrept, values %{$this->{entityreports}}; foreach (@everyrept) { chomp; s/\n/\n /g; $_ .= "\n"; } my $reportword = MailScanner::Config::LanguageValue($this, "report"); my $id = $this->{id}; my $from = $this->{from}; #my $to = join(', ', @{$this->{to}}); my $subj = $this->{subject}; my $ip = $this->{clientip}; my $rept = join(" $reportword: ", @everyrept); #print STDERR "Rept is\n$rept\n"; # Build list of unique archive and quarantine storage locations my @quarantines = grep /\//, @{$this->{archiveplaces}}; push @quarantines, grep /\//, @{$this->{quarantineplaces}}; my($quarantine, %quarantinelist); foreach $quarantine (@quarantines) { $quarantinelist{$quarantine} = 1; } $quarantine = join(', ', sort keys %quarantinelist); # Build unique list of recipients. Avoids Postfix problem which has # separate lists of real recipients and original recipients. my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); my($result, $headers); if (MailScanner::Config::Value('hideworkdirinnotice',$this)) { my $pattern = '(' . quotemeta($global::MS->{work}->{dir}) . "|\\\.)/"; #print STDERR "In replacement, regexp is \"$pattern\"\n"; $rept =~ s/$pattern//g; #m # Remove the work dir $rept =~ s/\/?$id\/?//g; # Remove the message id } my $reportspaces = 10 - length($reportword); $reportword = ' ' x $reportspaces . $reportword if $reportspaces>0; $result = "\n" . " Sender: $from\n" . "IP Address: $ip\n" . " Recipient: $to\n" . " Subject: $subj\n" . " MessageID: $id\n" . "Quarantine: $quarantine\n" . "$reportword: $rept\n"; if (MailScanner::Config::Value('noticefullheaders', $this)) { $headers = join("\n ", $global::MS->{mta}->OriginalMsgHeaders($this)); $result .= MailScanner::Config::LanguageValue($this, 'fullheadersare') . ":\n\n $headers\n\n"; } $result; } # Find the attachments that have been disinfected and deliver them all # in a new MIME message. sub DeliverDisinfectedAttachments { my $this = shift; my(@list, $reports, $attachment); $reports = $this->{oldviruses}; # Loop through every attachment in the original list foreach $attachment (keys %$reports) { #print STDERR "Looking to see if \"$attachment\" has been disinfected\n"; # Never attempt "whole body" disinfections next if $attachment eq ""; # Skip messages that are in the new report list next if defined $this->{virusreports}{"$attachment"}; # Don't disinfect files the disinfector renamed if (!$global::MS->{work}->FileExists($this, $attachment)) { #print STDERR "Skipping deleted/renamed attachment $attachment\n"; next; } # Add it to the list #print STDERR "Adding $attachment to list of disinfected files\n"; push @list, $attachment; } # Is there nothing to do? return unless @list; #print STDERR "Have disinfected attachments " . join(',',@list) . "\n"; # Deliver a message to the original recipients containing the # disinfected attachments. This is really a Sendmail-specific thing. $global::MS->{work}->ChangeToMessage($this); $this->DeliverFiles(@list); } # Create and deliver a new message from MailScanner about the # disinfected files passed in @list. sub DeliverFiles { my $this = shift; my(@files) = @_; my($MaxSubjectLength, $from, $to, $subject, $newsubject, $top); my($localpostmaster, $postmastername); $MaxSubjectLength = 25; $from = $this->{from}; #$to = join(', ', @{$this->{to}}); my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); $subject = $this->{subject}; $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $newsubject = MailScanner::Config::LanguageValue($this, 'disinfected') . ": " . substr($subject, 0, $MaxSubjectLength); $newsubject .= '...' if length($subject)>$MaxSubjectLength; #print STDERR "About to deliver " . join(',',@files) . " to original " . # "recipients after disinfection\n"; # Create the top-level MIME entity, just the headers $top = MIME::Entity->build(Type => 'multipart/mixed', From => "$postmastername <$localpostmaster>", To => $to, Subject => $newsubject, 'X-Mailer' => 'MailScanner', MailScanner::Config::Value('mailheader', $this) => MailScanner::Config::Value('disinfectedheader', $this)); # Construct the text of the message body my($textfh, $textfile, $output, $result, $attachment); $textfh = new FileHandle; $textfile = MailScanner::Config::Value('disinfectedreporttext', $this); $textfh->open($textfile) or MailScanner::Log::WarnLog("Cannot open disinfected report message " . "file %s, %s", $textfile, $!); $output = ""; my $line; my $ea = qr/([\(\)\[\]\.\?\*\+\^"'@<>:])/; while(<$textfh>) { $line = chomp; #s#"#\\"#g; # Escape any " characters #s#@#\\@#g; # Escape any @ characters $line =~ s/$ea/\\$1/g; # Escape any regex characters # Untainting joy... $line =~ /(.*)/; $result = eval "\"$1\""; $output .= MailScanner::Config::DoPercentVars($result) . "\n"; } $textfh->close(); $top->attach(Data => $output); # Construct all the attachments foreach $attachment (@files) { # Added "./" to start of next line to avoid potential DoS attack $top->attach(Path => "./$attachment", Type => "application/octet-stream", Encoding => "base64", Disposition => "attachment"); } # Now send the message $global::MS->{mta}->SendMessageEntity($this, $top, $localpostmaster) or MailScanner::Log::WarnLog("Could not send disinfected message, %s",$!); } # Archive this message to any directories in its archiveplaces attribute sub ArchiveToFilesystem { my $this = shift; my($dir, $todaydir, $target, $didanything); $didanything = 0; $todaydir = $this->{datenumber}; #MailScanner::Quarantine::TodayDir(); foreach $dir (@{$this->{archiveplaces}}) { #print STDERR "Archive to $dir\n"; next unless $dir =~ /^\//; # Must be a pathname # If it exists, and it's a file, then append the message to it # in mbox format. if (-f $dir) { #print STDERR "It is a file\n"; $this->AppendToMbox($dir); $didanything = 1; next; } $target = "$dir/$todaydir"; unless (-d "$target") { umask $global::MS->{quar}->{dirumask}; mkdir "$target",0777 or MailScanner::Log::WarnLog("Cannot create directory %s", $target); umask 0077; } #print STDERR "It is a dir\n"; umask $global::MS->{quar}->{fileumask}; $this->{store}->CopyToDir($target, $this->{id}); #print STDERR "Stored " . $this->{id} . " to $target\n"; umask 0077; $didanything = 1; } return $didanything; } # Append a message to an mbox file sub AppendToMbox { my($this, $mbox) = @_; my $fh = new IO::File "$mbox", "a"; if ($fh) { # Print the mbox message header starting with a blank line and "From" # From $from `date "+%a %b %d %T %Y"` my($now, $recip); $now = ctime(); $now =~ s/ (\d)/ 0$1/g; # Insert leading zeros where needed print $fh "From " . $this->{from} . ' ' . $now . "\n"; foreach $recip (@{$this->{to}}) { print $fh "X-MailScanner-Recipient: $recip\n"; } $fh->flush; # Write the entire message to this handle, then close. $this->{store}->WriteEntireMessage($this, $fh); print $fh "\n"; # Blank line at end of message to separate messages $fh->close; MailScanner::Log::InfoLog("Archived message %s to mbox file %s", $this->{id}, $mbox); } else { MailScanner::Log::WarnLog("Failed to append message to pre-existing " . "mbox file %s", $mbox); } } sub ReflowHeader { my($this, $key, $input) = @_; my($output, $pos, $len, $firstline, @words, $word); $output = ""; $pos = 0; $firstline = 1; @words = split(/,\s*/, $input); foreach $word (@words) { $len = length($word); if ($firstline) { $output = "$word"; $pos = $len + length($key)+1; # 1 = space between key and input $firstline = 0; next; } # Wrap at column 75 (pretty arbitrary number just less than 80) if ($pos+$len < 75) { $output .= ", $word"; $pos += 2 + $len; } else { $output .= ",\n\t$word"; $pos = 8 + $len; } } return $output; } # Strip the HTML out of this message. All the checks have already # been done, so just get on with it. sub StripHTML { my $this = shift; #print STDERR "Stripping HTML from message " . $this->{id} . "\n"; $this->HTMLToText($this->{entity}); } # Disarm some of the HTML tags in this message. sub DisarmHTML { my $this = shift; #print STDERR "Tags to convert are " . $this->{tagstoconvert} . " on message " . $this->{id} . "\n"; # Set the disarm booleans for this message $DisarmFormTag = 0; $DisarmScriptTag = 0; $DisarmCodebaseTag = 0; $DisarmCodebaseTag = 0; $DisarmIframeTag = 0; $DisarmWebBug = 0; $DisarmPhishing = 0; $DisarmNumbers = 0; $StrictPhishing = 0; $DisarmWebBugFound = 0; $PhishingSubjectTag= 0; $PhishingHighlight = 0; $DisarmFormTag = 1 if $this->{tagstoconvert} =~ /form/i; $DisarmScriptTag = 1 if $this->{tagstoconvert} =~ /script/i; $DisarmCodebaseTag = 1 if $this->{tagstoconvert} =~ /codebase/i; $DisarmCodebaseTag = 1 if $this->{tagstoconvert} =~ /data/i; $DisarmIframeTag = 1 if $this->{tagstoconvert} =~ /iframe/i; $DisarmWebBug = 1 if $this->{tagstoconvert} =~ /webbug/i; $PhishingSubjectTag= 1 if MailScanner::Config::Value('tagphishingsubject', $this) =~ /1/; #print STDERR "PhishingSubjectTag = $PhishingSubjectTag\n"; $PhishingHighlight = 1 if MailScanner::Config::Value('phishinghighlight', $this) =~ /1/; #print STDERR "PhishingHighlight = $PhishingHighlight\n"; $DisarmPhishingFound = 0; $this->{disarmphishingfound} = 0; $DisarmHTMLChangedMessage = 0; if (MailScanner::Config::Value('findphishing', $this) =~ /1/) { $DisarmPhishing = 1; $DisarmNumbers = 1 if MailScanner::Config::Value('phishingnumbers', $this) =~ /1/; $StrictPhishing = 1 if MailScanner::Config::Value('strictphishing', $this) =~ /1/; } # Construct the WebBugWhitelist - space and comma-separated list of words $WebBugWhitelist = MailScanner::Config::Value('webbugwhitelist', $this); $WebBugWhitelist =~ s/^\s+//; $WebBugWhitelist =~ s/\s+$//; $WebBugWhitelist =~ s/[\s,]+/|/g; $WebBugReplacement = MailScanner::Config::Value('webbugurl', $this); my($counter, @disarmedtags); ($counter, @disarmedtags) = $this->DisarmHTMLTree($this->{entity}); #print STDERR "disarmedtags = ". join(', ', @disarmedtags) . "\n"; # If the HTML checks found a real problem or there really was a phishing # attack, only then should we log anything. #print "DisarmPhishingFound = $DisarmPhishingFound on message " . $this->{id} . "\n"; $this->{disarmphishingfound} = 1 if $DisarmPhishingFound; @disarmedtags = ('phishing') if $DisarmPhishingFound && $PhishingHighlight && !@disarmedtags; #JKF1 && $PhishingHighlight && !@disarmedtags; #print STDERR "Found DisarmPhishingFound\n" if $DisarmPhishingFound; MailScanner::Log::InfoLog('Content Checks: Detected and have disarmed ' . join(', ', @disarmedtags) . ' tags in ' . 'HTML message in %s from %s', $this->{id}, $this->{from}) if $DisarmHTMLChangedMessage || $DisarmPhishingFound; # And save the results from the phishing trip if ($DisarmPhishingFound) { # Do we want this or not? I say no. $this->{otherinfected} = 1; $this->{bodymodified} = 1; #print STDERR "DisarmPhishingFound = $DisarmPhishingFound\n"; } if ($DisarmHTMLChangedMessage) { #print STDERR "Disarm Changed the message at 5132.\n"; $this->{bodymodified} = 1; $this->{messagedisarmed} = 1; } else { $this->{messagedisarmed} = 0; } # Store all the tags we disarmed #print STDERR "Storing " . join(',', @disarmedtags) . "\n"; @{$this->{disarmedtags}} = @disarmedtags; } # Search for a multipart/alternative. # If found, change it to multipart/mixed and make all its members into # suitable named attachments. sub EncapsulateAttachments { my($message, $searchtype, $entity, $filename) = @_; # Reached a leaf node? return 0 unless $entity && defined($entity->head); my(@parts, $part, $type, $extension, $newname); my $counter = 0; $type = $entity->head->mime_attr('content-type'); if (!$searchtype || ($type && $type =~ /$searchtype/i)) { #print STDERR "Found alternative message at entity $entity\n"; # Turn it into a multipart/mixed $entity->head->mime_attr('content-type' => 'multipart/mixed') if $searchtype; # Change the parts into attachments @parts = $entity->parts; foreach $part (@parts) { my $head = $part->head; $type = $head->mime_attr('content-type') || 'text/plain'; $extension = '.dat'; $type =~ /\/([a-z0-9-]+)$/i and $extension = '.' . lc($1); $extension = '.txt' if $type =~ /text\/plain/i; $extension = '.html' if $type =~ /text\/html/i; $newname = $filename . $extension; $head->mime_attr('Content-Type' => $type); $head->mime_attr('Content-Disposition' => 'attachment'); $head->mime_attr('Content-Disposition.filename' => $newname) unless $head->mime_attr('Content-Disposition.filename'); $head->mime_attr('Content-Type.name' => $newname) unless $head->mime_attr('Content-Type.name'); $counter++; } } else { # Now try the same on all the parts foreach $part (@parts) { $counter += $message->EncapsulateAttachments($searchtype, $part, $filename); } } return $counter; } sub EncapsulateMessageHTML { my $this = shift; my($entity, $filename, $newpart); $entity = $this->{entity}; $filename = MailScanner::Config::Value('originalmessage', $this); $entity->make_multipart('mixed'); $this->EncapsulateAttachments('multipart/alternative', $entity, $filename) or $this->EncapsulateAttachments(undef, $entity, $filename); # Insert the new message part $newpart = MIME::Entity->build(Type => "text/plain", Disposition => undef, Data => [ "Hello\n","There\n","Last line\n" ], Filename => undef, Top => 0, 'X-Mailer' => undef ); $entity->add_part($newpart, 0); # Insert at the start of the message # Clean up the message so spammers can't pollute me $this->{entity}->preamble(undef); $this->{entity}->epilogue(undef); $this->{entity}->head->add('MIME-Version', '1.0') unless $this->{entity}->head->get('mime-version'); $this->{bodymodified} = 1; return; } # Encapsulate the message in an RFC822 structure so that it becomes a # single atachment of the message. Need to build the spam report to put # in as the text/plain body of the main message. sub EncapsulateMessage { my $this = shift; my($entity, $rfc822, $mimeversion, $mimeboundary, @newparts); my($messagefh, $filename, $emailmsg, $line, $charset); my($id, $to, $from, $localpostmaster, $hostname, $subject, $date); my($fullspamreport, $briefspamreport, $longspamreport, $sascore); my($postmastername); # For now, if there is no entity structure at all then just return, # we cannot encapsulate a message without it. # Unfortunately that means we can't encapsulate messages that are # Virus Scanning = no ("yes" but also having "Virus Scanners=none" is # fine, and works). The encapsulation will merely fail to do anything. # Hopefully this will only be used by corporates who are virus scanning # everything anyway. # Workaround: Instead of using "Virus Scanning = no", use # "Virus Scanners = none" and a set of filename rules that pass all files. return unless $this->{entity}; # Construct the RFC822 attachment $mimeversion = $this->{entity}->head->get('mime-version'); # Prune all the dead branches off the tree PruneEntityTree($this->{entity},$this->{entity2file},$this->{file2entity}); $entity = $this->{entity}; $rfc822 = $entity->stringify; # Setup variables they can use in the spam report that is inserted at # the top of the message. $id = $this->{id}; #$to = join(', ', @{$this->{to}}); my($to, %tolist); foreach $to (@{$this->{to}}) { $tolist{$to} = 1; } $to = join(', ', sort keys %tolist); $from = $this->{from}; $localpostmaster = MailScanner::Config::Value('localpostmaster', $this); $postmastername = MailScanner::Config::LanguageValue($this, 'mailscanner'); $hostname = MailScanner::Config::Value('hostname', $this); $subject = $this->{subject}; $date = $this->{datestring}; # scalar localtime; $fullspamreport = $this->{spamreport}; $longspamreport = $this->{salongreport}; $sascore = $this->{sascore}; #$this->{salongreport} = ""; # Reset it so we don't ever insert it twice # Delete everything in brackets after the SA report, if it exists $briefspamreport = $fullspamreport; $briefspamreport =~ s/(spamassassin)[^(]*\([^)]*\)/$1/i; $charset = MailScanner::Config::Value('attachmentcharset', $this); # Construct the spam report at the top of the message $messagefh = new FileHandle; $filename = MailScanner::Config::Value('inlinespamwarning', $this); $messagefh->open($filename) or MailScanner::Log::WarnLog("Cannot open inline spam warning file %s, %s", $filename, $!); $emailmsg = ""; while(<$messagefh>) { chomp; s#"#\\"#g; s#@#\\@#g; # Boring untainting again... /(.*)/; $line = eval "\"$1\""; $emailmsg .= MailScanner::Config::DoPercentVars($line) . "\n"; } $messagefh->close(); $newparts[0] = MIME::Entity->build(Type => 'text/plain', Disposition => 'inline', Encoding => 'quoted-printable', Top => 0, 'X-Mailer' => undef, Charset => $charset, Data => $emailmsg); $newparts[1] = MIME::Entity->build(Type => 'message/rfc822', Disposition => 'attachment', Top => 0, 'X-Mailer' => undef, Data => $rfc822); # If there was a multipart boundary, then create a new one so that # the main message has a different boundary from the RFC822 attachment. # Leave the RFC822 one alone, so we don't corrupt the original message, # but make sure we create a new one instead. # Keep generating random boundaries until we have definitely got a new one. my $oldboundary = $entity->head->multipart_boundary; do { $mimeboundary = '======' . $$ . '==' . int(rand(100000)) . '======'; } while $mimeboundary eq $oldboundary; # Put the new parts in place, hopefully it will correct all the multipart # headers for me. Wipe the preamble and epilogue or else someone will use # them to bypass the encapsulation process. # Make it a report if it wasn't multipart already. $entity->make_multipart("report"); # Used to be digest # Try *real* hard to make it a digest. $entity->head->mime_attr("Content-type" => "multipart/report"); # Used to be digest $entity->head->mime_attr("Content-type.boundary" => $mimeboundary); # Delete the "type" subfield which I don't think should be there $entity->head->mime_attr("Content-type.type" => undef); # JKF 09/11/2005 Added after bug report from Georg@hackt.net $entity->head->mime_attr("Content-type.report-type" => 'spam-notification'); $entity->parts(\@newparts); $entity->preamble(undef); $entity->epilogue(undef); $entity->head->add('MIME-Version', '1.0') unless $mimeversion; $this->{bodymodified} = 1; # No infection but we changed the MIIME tree } sub DisarmHTMLTree { my($this, $entity) = @_; my $counter = 0; # Have we modified this message at all? my @disarmed; # List of tags we have disarmed #print STDERR "Disarming HTML Tree\n"; # Reached a leaf node? return 0 unless $entity && defined($entity->head); if ($entity->head->mime_attr('content-disposition') !~ /attachment/i && $entity->head->mime_attr('content-type') =~ /text\/html/i) { #print STDERR "Found text/html message at entity $entity\n"; @disarmed = $this->DisarmHTMLEntity($entity); #print STDERR "Disarmed = " . join(', ',@disarmed) . "\n"; if (@disarmed) { $this->{bodymodified} = 1; $DisarmHTMLChangedMessage = 1; $counter++; } } # Now try the same on all the parts my(@parts, $part, $newcounter, @newtags); @parts = $entity->parts; foreach $part (@parts) { ($newcounter, @newtags) = $this->DisarmHTMLTree($part); $counter += $newcounter; @disarmed = (@disarmed, @newtags); } #print STDERR "Returning " . join(', ', @disarmed) . " from DisarmHTMLTree\n"; return ($counter, @disarmed); } # Walk the MIME tree, looking for text/html entities. Whenever we find # one, create a new filename for a text/plain entity, and replace the # part that pointed to the filename with a replacement that points to # the new txt filename. # Only replace inline sections, don't replace attachments, so that your # users can still mail HTML attachments to each other. # Then tag the message to say it has been modified, so that it is # rebuilt from the MIME tree when it is delivered. sub HTMLToText { my($this, $entity) = @_; my $counter; # Have we modified this message at all? # Reached a leaf node? return 0 unless $entity && defined($entity->head); if ($entity->head->mime_attr('content-disposition') !~ /attachment/i && $entity->head->mime_attr('content-type') =~ /text\/html/i) { #print STDERR "Found text/html message at entity $entity\n"; $this->HTMLEntityToText($entity); MailScanner::Log::InfoLog('Content Checks: Detected and will convert ' . 'HTML message to plain text in %s', $this->{id}); $this->{bodymodified} = 1; # No infection but we changed the MIIME tree #$this->{otherreports}{""} .= "Converted HTML to plain text\n"; #$this->{othertypes}{""} .= "m"; # Modified body, but no infection #$this->{otherinfected}++; $counter++; } # Now try the same on all the parts my(@parts, $part); @parts = $entity->parts; foreach $part (@parts) { $counter += $this->HTMLToText($part); } return $counter; } # HTML::Parset callback function for normal text my(%DisarmDoneSomething, $DisarmLinkText, $DisarmLinkURL, $DisarmAreaURL, $DisarmInsideLink, $DisarmBaseURL); # Convert 1 MIME entity from html to dis-armed HTML using HTML::Parser. sub DisarmHTMLEntity { my($this, $entity) = @_; my($oldname, $newname, $oldfh, $outfh, $htmlparser); #print STDERR "Disarming HTML $entity\n"; # Initialise all the variables we will use in the parsing, so nothing # is inherited from old messages $DisarmLinkText = ""; $DisarmLinkURL = ""; $DisarmInsideLink = 0; $DisarmBaseURL = ""; $DisarmAreaURL = ""; %DisarmDoneSomething = (); # Replace the filename with a new one $oldname = $entity->bodyhandle->path(); #print STDERR "Path is $oldname\n"; $newname = $oldname; $newname =~ s/\..?html?$//i; # Remove .htm .html .shtml $newname .= '2.html'; # This should always pass the filename checks $entity->bodyhandle->path($newname); $outfh = new FileHandle; unless ($outfh->open(">$newname")) { MailScanner::Log::WarnLog('Could not create disarmed HTML file %s', $newname); return keys %DisarmDoneSomething; } # Set default output filehandle so we generate the new HTML $oldfh = select $outfh; # Process the old HTML file into the new one if ($DisarmPhishing) { HTML::Parser->new(api_version => 3, start_h => [\&DisarmTagCallback, "tagname, text, attr, attrseq"], end_h => [\&DisarmEndtagCallback, "tagname, text, '" . $this->{id} . "'"], text_h => [\&DisarmTextCallback, "text"], default_h => [ sub { print @_; }, "text"], ) ->parse_file($oldname) or MailScanner::Log::WarnLog("HTML disarming, can't open file %s: %s", $oldname, $!); } else { HTML::Parser->new(api_version => 3, start_h => [\&DisarmTagCallback, "tagname, text, attr, attrseq"], end_h => [\&DisarmEndtagCallback, "tagname, text, '" . $this->{id} . "'"], default_h => [ sub { print @_; }, "text"], ) ->parse_file($oldname) or MailScanner::Log::WarnLog("HTML disarming, can't open file %s: %s", $oldname, $!); } select $oldfh; $outfh->close(); # Tell the caller if we did anything #print STDERR "Keys are " . join(', ', keys %DisarmDoneSomething) . "\n"; return keys %DisarmDoneSomething; } # HTML::Parser callback for text so we can collect the contents of links sub DisarmTextCallback { my($text) = @_; unless ($DisarmInsideLink) { print $text; #print STDERR "DisarmText just printed \"$text\"\n"; return; } # We are inside a link. # Save the original text, we well might need it. $DisarmLinkText .= $text; #print STDERR "DisarmText just added \"$text\"\n"; } # HTML::Parser callback function for start tags sub DisarmTagCallback { my($tagname, $text, $attr, $attrseq) = @_; #print STDERR "Disarming $tagname\n"; my $output = ""; my $webbugfilename; if ($tagname eq 'form' && $DisarmFormTag) { #print "It's a form\n"; $text = substr $text, 1; $output .= "
{'type'} = "reset"; $output .= '<' . $tagname; foreach (@$attrseq) { next if /^on/; $output .= ' ' . $_ . '="' . $attr->{$_} . '"'; } $output .= '>'; $DisarmDoneSomething{'form input'} = 1; } elsif ($tagname eq 'button' && $DisarmFormTag) { #print "It's a button\n"; $attr->{'type'} = "reset"; $output .= '<' . $tagname; foreach (@$attrseq) { next if /^on/; $output .= ' ' . $_ . '="' . $attr->{$_} . '"'; } $output .= '>'; $DisarmDoneSomething{'form button'} = 1; } elsif ($tagname eq 'object' && $DisarmCodebaseTag) { #print "It's an object\n"; if (exists $attr->{'codebase'}) { $text = substr $text, 1; $output .= "{'data'}) { $text = substr $text, 1; $output .= "{'href'} if exists $attr->{'href'}; $DisarmInsideLink = 1; $DisarmInsideLink = 0 if $DisarmLinkURL eq ''; # JPSB empty A tags. Was: #Old: $DisarmInsideLink = 0 if $text =~ /\/\>$/; # JKF Catch /> empty A tags #print STDERR "DisarmInsideLink = $DisarmInsideLink\n"; } elsif ($tagname eq 'img' && $DisarmWebBug) { #print STDERR "It's an image\n"; #print STDERR "The src is \"" . $attr->{'src'} . "\"\n"; if (exists $attr->{'width'} && $attr->{'width'}<=2 && exists $attr->{'height'} && $attr->{'height'}<=2 && exists $attr->{'src'} && $attr->{'src'} !~ /^cid:|^$WebBugReplacement/i) { # Is the filename in the WebBug whitelist? $webbugfilename = $attr->{'src'}; $webbugfilename = $1 if $webbugfilename =~ /\/([^\/]+)$/; if ($webbugfilename && $WebBugWhitelist && $webbugfilename =~ /$WebBugWhitelist/i) { # It's in the whitelist, so ignore it $output .= $text; } else { # It's not in the whitelist, so zap it with insecticide! $output .= ''; $output .= 'Web Bug from ' . $attr->{'src'} if $attr->{'src'}; $output .= ''; $DisarmWebBugFound = 1; $DisarmDoneSomething{'web bug'} = 1; } } else { $output .= $text; } } elsif ($tagname eq 'base') { #print STDERR "It's a Base URL\n"; $output .= $text; #print STDERR "Base URL = " . $attr->{'href'} . "\n"; $DisarmBaseURL = $attr->{'href'} if exists $attr->{'href'}; } elsif ($tagname eq 'area' && $DisarmInsideLink && $DisarmPhishing) { #print STDERR "It's an imagemap area\n"; $output .= $text; #print STDERR "Area URL = " . $attr->{'href'} . "\n"; $DisarmAreaURL = $attr->{'href'}; } else { #print STDERR "The tag was a \"$tagname\"\n"; $output .= $text; #print STDERR "output text is now \"$output\"\n"; } # tagname DisarmPhishing # a 0 0 1 # a 1 0 0 tagname=a && Disarm=1 # b 0 1 1 # b 1 1 0 #if ($DisarmInsideLink && !($tagname eq 'a' && $DisarmPhishing)) { if ($DisarmInsideLink && ($tagname ne 'a' || !$DisarmPhishing)) { $DisarmLinkText .= $output; #print STDERR "StartCallback: DisarmLinkText now equals \"$DisarmLinkText\"\n"; } else { print $output; #print STDERR "StartCallback: Printed2 \"$output\"\n"; } } # HTML::Parser callback function for end tags sub DisarmEndtagCallback { my($tagname, $text, $id) = @_; if ($tagname eq 'iframe' && $DisarmIframeTag) { print ""; $DisarmDoneSomething{'iframe'} = 1; } elsif ($tagname eq 'form' && $DisarmFormTag) { print ""; $DisarmDoneSomething{'form'} = 1; } elsif ($tagname eq 'script' && $DisarmScriptTag) { print ""; $DisarmDoneSomething{'script'} = 1; } elsif ($tagname eq 'map' && $DisarmAreaURL) { # We are inside an imagemap that is part of a phishing imagemap $DisarmLinkText .= ''; } elsif ($tagname eq 'a' && $DisarmPhishing) { #print STDERR "Endtag Callback found link, " . # "disarmlinktext = \"$DisarmLinkText\"\n"; my($squashedtext,$linkurl,$alarm,$numbertrap); $DisarmInsideLink = 0; $squashedtext = lc($DisarmLinkText); if ($DisarmAreaURL) { $squashedtext = $DisarmLinkURL; $DisarmLinkURL = lc($DisarmAreaURL); $DisarmAreaURL = ""; # End of a link, so reset this } else { $squashedtext = lc($DisarmLinkText); } # Try to filter out mentions of Microsoft's .NET system $squashedtext = "" if $squashedtext eq ".net"; $squashedtext = "" if $squashedtext =~ /(^|\b)(ado|asp)\.net($|\b)/; $squashedtext =~ s/\%a0//g; $squashedtext =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape #Moved below tag removal, as required by new 'Remove tags' re. #$squashedtext =~ s/\s+//g; # Remove any whitespace $squashedtext =~ s/\\/\//g; # Change \ to / as many browsers do this $squashedtext =~ s/^\[\d*\]//; # Removing leading [numbers] #$squashedtext =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags $squashedtext =~ s/(\<\/?\w+((\s+\w+(\s*=\s*(?:\".*?\"|\'.*?\'|[^\'\">\s]+))?)+\s*|\s*)\/?\>)*//ig; # Remove tags, better re from snifer_@hotmail.com $squashedtext =~ s/\s+//g; # Remove any whitespace $squashedtext =~ s/^[^\/:]+\@//; # Remove username of email addresses #$squashedtext =~ s/\&\w*\;//g; # Remove things like < and > $squashedtext =~ s/^\<\;//g; # Remove leading < $squashedtext =~ s/\>\;$//g; # Remove trailing > $squashedtext =~ s/\<\;/\/g; # rEmove things like < and > #$squashedtext =~ s/./CharToIntnl("$&")/ge; $squashedtext = StringToIntnl($squashedtext); # s/./CharToIntnl("$&")/ge; #print STDERR "Text = \"$text\"\n"; #print STDERR "1SquashedText = \"$squashedtext\"\n"; #print STDERR "1LinkURL = \"$DisarmLinkURL\"\n"; # If it looks like a link, remove any leading https:// or ftp:// ($linkurl,$alarm) = CleanLinkURL($DisarmLinkURL); #print STDERR "linkurl = $linkurl\nBefore If statement\n"; #print STDERR "squashedtext = $squashedtext\nBefore If statement\n"; # Has it fallen foul of the numeric-ip phishing net? Must treat x # like a digit so it catches 0x41 (= 'A') $numbertrap = ($DisarmNumbers && $linkurl !~ /[<>g-wyz]+/)?1:0; if ($alarm || $squashedtext =~ /^(w+|ft+p|fpt+|ma[il]+to)([.,]|\%2e)/i || $squashedtext =~ /[.,](com|org|net|info|biz|ws)/i || $squashedtext =~ /[.,]com?[.,][a-z][a-z]/i || $squashedtext =~ /^(ht+ps?|ft+p|fpt+|mailto)[:;](\/\/)?(.*(\.|\%2e))/i || $numbertrap) { $squashedtext =~ s/^(ht+ps?|ft+p|fpt+|mailto)[:;](\/\/)?(.*(\.|\%2e))/$3/i; $squashedtext =~ s/\/.*$//; # Only compare the hostnames $squashedtext =~ s/[,.]+$//; # Allow trailing dots and commas $squashedtext = 'www.' . $squashedtext unless $squashedtext =~ /^ww+|ft+p|fpt+|mailto/ || $numbertrap; #print STDERR "2SquashedText = \"$squashedtext\"\n"; # If we have already tagged this link as a phishing attack, spot the # warning text we inserted last time and don't tag it again. my $possiblefraudstart = MailScanner::Config::LanguageValue(0, 'possiblefraudstart'); my $squashedpossible = lc($possiblefraudstart); my $squashedsearch = lc($DisarmLinkText); $squashedpossible =~ s/\s//g; $squashedpossible =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags $squashedsearch =~ s/\s//g; $squashedsearch =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags #$squashedpossible = "www.$squashedpossible\"$linkurl\""; $squashedpossible = quotemeta($squashedpossible); #print STDERR "NEW CODE: SquashedText = $squashedtext\n"; #print STDERR "NEW CODE: DisarmLinkText = $DisarmLinkText\n"; #print STDERR "NEW CODE: Text = $text\n"; #print STDERR "NEW CODE: SquashedPossible = $squashedpossible\n"; #print STDERR "NEW CODE: LinkURL = $linkurl\n"; if ($squashedtext =~ /$squashedpossible/) { #print STDERR "FOUND IT\n"; #print STDERR "$DisarmLinkText$text\n"; print "$DisarmLinkText$text"; $DisarmLinkText = ""; # Reset state of automaton return; } #print STDERR "2LinkURL = \"$linkurl\"\n"; # If it is a phishing catch, or else it's not (numeric or IPv6 numeric) # then notify. #print STDERR "LinkURL is \"$linkurl\"\n"; #print STDERR "Squashe is \"$squashedtext\"\n"; #print STDERR "Phishing by numbers is $DisarmNumbers\n"; # # Less strict phishing net code is here # if (!$StrictPhishing) { my $TheyMatch = 0; unless (InPhishingWhitelist($linkurl)) { #print STDERR "Not strict phishing\n"; # We are just looking at the domain name and country code (more or less) # Find the end of the domain name so we know what to strip my $domain = $linkurl; $domain =~ s/\/*$//; # Take off trailing / $domain =~ s/\.([^.]{2,100})$//; # Take off .TLD my $tld = $1; $domain =~ s/([^.]{2,100})$//; # Take off SLD my $sld = $1; # Now do the same for the squashed text, i.e. where they claim it is my $text = $squashedtext; #print STDERR "Comparing $linkurl and $squashedtext\n"; #print STDERR "tld = $tld and sld = $sld\n"; $text =~ s/\/*$//; # Take off trailing / $text =~ s/\.([^.]{2,100})$//; # Take off .TLD my $ttld = $1; $text =~ s/([^.]{2,100})$//; # Take off SLD my $tsld = $1; #print STDERR "ttld = $ttld and tsld = $tsld\n"; if ($tld && $ttld && $sld && $tsld && $tld eq $ttld && $sld eq $tsld) { #print STDERR "tld/sld test matched\n"; # domain.org or domain.3rd.2nd.india # Last 2 words match (domain.org), should that be enough or do we # need to compare the next word too (domain.org.uk) ? # We need to check the next word too. $domain =~ s/([^.]{2,100})\.$//; # Take off 3LD. my $third = $1; $text =~ s/([^.]{2,100})\.$//; # Take off 3LD. my $tthird = $1; #print STDERR "third = $third and tthird = $tthird\n"; if ($MailScanner::Config::SecondLevelDomainExists{"$sld.$tld"}) { # domain.org.uk $TheyMatch = 1 if $third && $tthird && $third eq $tthird; } else { # Maybe we have a 3rd level domain base? if ($MailScanner::Config::SecondLevelDomainExists{"$third.$sld.$tld"}) { # We need to check the next (4th) word too. $domain =~ /([^.]{2,100})\.$/; # Store 4LD my $fourth = $1; $text =~ /([^.]{2,100})\.$/; # Store 4LD my $tfourth = $1; $TheyMatch = 1 if $fourth && $tfourth && $fourth eq $tfourth && $third && $tthird && $third eq $tthird; } else { # We don't have a 3rd level, and we cannot have got here if # there was a 2nd level, so it must just look like domain.org, # so matches if tld and sld are the same. But we must have that # true or we would never have got here, so they must match. $TheyMatch = 1; } } } # # Put phishing reporting code in here too. # if ($linkurl ne "") { if ($TheyMatch) { # Even though they are the same, still squeal if it's a raw IP if ($numbertrap) { print MailScanner::Config::LanguageValue(0, 'numericlinkwarning') . ' ' if $PhishingHighlight; # && !InPhishingWhitelist($linkurl); $DisarmPhishingFound = 1; $linkurl = substr $linkurl, 0, 80; $squashedtext = substr $squashedtext, 0, 80; $DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag; use bytes; # Don't send UTF16 to syslog, it breaks! MailScanner::Log::NoticeLog('Found ip-based phishing fraud from ' . '%s in %s', $linkurl, $id); } # If it wasn't a raw IP, then everything looks fine } else { # They didn't match so it's definitely an attack print $possiblefraudstart . ' "' . $linkurl . '" ' . MailScanner::Config::LanguageValue(0, 'possiblefraudend') . ' ' if $PhishingHighlight; # && !InPhishingWhitelist($linkurl); $DisarmPhishingFound = 1; $linkurl = substr $linkurl, 0, 80; $squashedtext = substr $squashedtext, 0, 80; $DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag; use bytes; # Don't send UTF16 to syslog, it breaks! MailScanner::Log::NoticeLog('Found phishing fraud from %s ' . 'claiming to be %s in %s', $linkurl, $squashedtext, $id); #$DisarmLinkURL); } # End of less strict reporting code. # But it probably was a phishing attack so print it all out no bytes; print "$DisarmLinkText"; # JKF 20060820 $text"; $DisarmLinkText = ""; # Reset state of automaton } } # End of less strict phishing net. } else { # # Strict Phishing Net Goes Here # if ($alarm || ($linkurl ne "" && $squashedtext !~ /^(w+\.)?\Q$linkurl\E\/?$/) || ($linkurl ne "" && $numbertrap)) { unless (InPhishingWhitelist($linkurl)) { use bytes; # Don't send UTF16 to syslog, it breaks! if ($linkurl ne "" && numbertrap && $linkurl eq $squashedtext) { # It's not a real phishing trap, just a use of numberic IP links print MailScanner::Config::LanguageValue(0, 'numericlinkwarning') . ' ' if $PhishingHighlight; } else { # It's a phishing attack. print $possiblefraudstart . ' "' . $linkurl . '" ' . MailScanner::Config::LanguageValue(0, 'possiblefraudend') . ' ' if $PhishingHighlight; } $DisarmPhishingFound = 1; $linkurl = substr $linkurl, 0, 80; $squashedtext = substr $squashedtext, 0, 80; $DisarmDoneSomething{'phishing'} = 1 if $PhishingHighlight; #JKF1 $PhishingSubjectTag; if ($numbertrap) { MailScanner::Log::InfoLog('Found ip-based phishing fraud from ' . '%s in %s', $linkurl, $id); } else { MailScanner::Log::InfoLog('Found phishing fraud from %s ' . 'claiming to be %s in %s', $linkurl, $squashedtext, $id); #$DisarmLinkURL); } #print STDERR "Fake\n"; no bytes; } } } } #print STDERR "End tag printed \"$DisarmLinkText$text\"\n"; print "$DisarmLinkText$text"; $DisarmLinkText = ""; # Reset state of automaton #print STDERR "Reset disarmlinktext\n"; # # End of all phishing code # } elsif ($DisarmInsideLink) { # If inside a link, add the text to the link text to allow tags in links $DisarmLinkText .= $text; } else { # It is not a tag we worry about, so just print the text and continue. print $text; } } my %CharToInternational = ( 160,'nbsp', 161,'iexcl', 162,'cent', 163,'pound', 164,'curren', 165,'yen', 166,'brvbar', 167,'sect', 168,'uml', 169,'copy', 170,'ordf', 171,'laquo', 172,'not', 173,'shy', 174,'reg', 175,'macr', 176,'deg', 177,'plusmn', 178,'sup2', 179,'sup3', 180,'acute', 181,'micro', 182,'para', 183,'middot', 184,'cedil', 185,'sup1', 186,'ordm', 187,'raquo', 188,'frac14', 189,'frac12', 190,'frac34', 191,'iquest', 192,'Agrave', 193,'Aacute', 194,'Acirc', 195,'Atilde', 196,'Auml', 197,'Aring', 198,'AElig', 199,'Ccedil', 200,'Egrave', 201,'Eacute', 202,'Ecirc', 203,'Euml', 204,'Igrave', 205,'Iacute', 206,'Icirc', 207,'Iuml', 208,'ETH', 209,'Ntilde', 210,'Ograve', 211,'Oacute', 212,'Ocirc', 213,'Otilde', 214,'Ouml', 215,'times', 216,'Oslash', 217,'Ugrave', 218,'Uacute', 219,'Ucirc', 220,'Uuml', 221,'Yacute', 222,'THORN', 223,'szlig', 224,'agrave', 225,'aacute', 226,'acirc', 227,'atilde', 228,'auml', 229,'aring', 230,'aelig', 231,'ccedil', 232,'egrave', 233,'eacute', 234,'ecirc', 235,'euml', 236,'igrave', 237,'iacute', 238,'icirc', 239,'iuml', 240,'eth', 241,'ntilde', 242,'ograve', 243,'oacute', 244,'ocirc', 245,'otilde', 246,'ouml', 247,'divide', 248,'oslash', 249,'ugrave', 250,'uacute', 251,'ucirc', 252,'uuml', 253,'yacute', 254,'thorn', 255,'yuml' ); # Turn any character into an international version of it if it is in the range # 160 to 255. sub CharToIntnl { my $p = shift @_; # Passed in an 8-bit character. #print STDERR "Char in is $p\n"; ($a) = unpack 'C', $p; #print STDERR "Char is $a, $p\n"; # Bash char 160 (space) to nothing return '' if $a == 160; my $char = $CharToInternational{$a}; return '&' . $char . ';' if $char ne ""; return $p; } # Like CharToIntnl but does entire string sub StringToIntnl { my $original = shift; # Much faster char conversion for whole strings my(@newlinkurl, $newlinkurl, $char); @newlinkurl = unpack("C*", $original); # Get an array of characters foreach (@newlinkurl) { next if $_ == 160; $char = $CharToInternational{$_}; if (defined $char) { $newlinkurl .= '&' . $char . ';'; } else { $newlinkurl .= chr($_); } } return $newlinkurl; #$linkurl = $newlinkurl unless $newlinkurl eq ""; #$linkurl =~ s/./CharToIntnl("$&")/ge; -- Old slow version } # Clean up a link URL so it is suitable for phishing detection # Return (clean url, alarm trigger value). An alarm trigger value non-zero # means this is definitely likely to be a phishing trap, no matter what # anything else says. sub CleanLinkURL { my($DisarmLinkURL) = @_; use bytes; my($linkurl,$alarm); $alarm = 0; $linkurl = $DisarmLinkURL; $linkurl = lc($linkurl); #print STDERR "Cleaning up $linkurl\n"; #$linkurl =~ s/\%a0//ig; #$linkurl =~ s/\%e9/é/ig; $linkurl =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape #print STDERR "2Cleaning up $linkurl\n"; $linkurl = StringToIntnl($linkurl); #$linkurl =~ s/./CharToIntnl("$&")/ge; -- Old slow version #print STDERR "Was $linkurl\n"; return ("",0) unless $linkurl =~ /[.\/]/; # Ignore if it is not a website at all #$linkurl = "" unless $linkurl =~ /[.\/]/; # Ignore if it is not a website at all $linkurl =~ s/\s+//g; # Remove any whitespace $linkurl =~ s/\\/\//g; # Change \ to / as many browsers do this #print STDERR "Is $linkurl\n"; return ("",0) if $linkurl =~ /\@/ && $linkurl !~ /\//; # Ignore emails #$linkurl = "" if $linkurl =~ /\@/ && $linkurl !~ /\//; # Ignore emails $linkurl =~ s/[,.]+$//; # Remove trailing dots, but also commas while at it $linkurl =~ s/^\[\d*\]//; # Remove leading [numbers] $linkurl =~ s/^blocked[:\/]+//i; # Remove "blocked::" labels $linkurl =~ s/^outbind:\/\/\d+\//http:\/\//i; # Remove "outbind://22/" type labels $linkurl = $DisarmBaseURL . '/' . $linkurl if $linkurl ne "" && $DisarmBaseURL ne "" && $linkurl !~ /^(https?|ftp|mailto):/i; $linkurl =~ s/^(https?|ftp)[:;]\/\///i; return ("",0) if $linkurl =~ /^ma[il]+to[:;]/i; #$linkurl = "" if $linkurl =~ /^ma[il]+to[:;]/i; $linkurl =~ s/[?\/].*$//; # Only compare up to the first '/' or '?' $linkurl =~ s/(\<\/?(br|p|ul)\>)*$//ig; # Remove trailing br, p, ul tags return ("",0) if $linkurl =~ /^file:/i; # Ignore file: URLs completely #$linkurl = "" if $linkurl =~ /^file:/i; # Ignore file: URLs completely return ("",0) if $linkurl =~ /^#/; # Ignore internal links completely #$linkurl = "" if $linkurl =~ /^#/; # Ignore internal links completely $linkurl =~ s/\/$//; # LinkURL is trimmed -- note $linkurl =~ s/:80$//; # Port 80 is the default anyway $alarm = 1 if $linkurl =~ s/[\x00-\x1f[:^ascii:]]/_BAD_/g; # /\&\#/; $linkurl = 'JavaScript' if $linkurl =~ /^javascript:/i; ($linkurl, $alarm); } # Return 1 if the hostname in $linkurl is in the safe sites file. # Return 0 otherwise. sub InPhishingWhitelist { my($linkurl) = @_; # Quick lookup return 1 if $MailScanner::Config::PhishingWhitelist{$linkurl}; # Trim host. off the front of the hostname while ($linkurl ne "" && $linkurl =~ s/^[^.]+\.//) { # And replace it with *. then look it up #print STDERR "Looking up *.$linkurl\n"; return 1 if $MailScanner::Config::PhishingWhitelist{'*.' . $linkurl}; } return 0; } # Convert 1 MIME entity from html to text using HTML::Parser. sub HTMLEntityToText { my($this, $entity) = @_; my($htmlname, $textname, $textfh, $htmlparser); # Replace the MIME Content-Type $entity->head->mime_attr('Content-type' => 'text/plain'); # Replace the filename with a new one $htmlname = $entity->bodyhandle->path(); $textname = $htmlname; $textname =~ s/\..?html?$//i; # Remove .htm .html .shtml $textname .= '.txt'; # This should always pass the filename checks $entity->bodyhandle->path($textname); # Create the new file with the plain text in it $textfh = new FileHandle; unless ($textfh->open(">$textname")) { MailScanner::Log::WarnLog('Could not create plain text file %s', $textname); return; } $htmlparser = HTML::TokeParser::MailScanner->new($htmlname); # Turn links into text containing the URL $htmlparser->{textify}{a} = 'href'; $htmlparser->{textify}{img} = 'src'; my $inscript = 0; my $instyle = 0; while (my $token = $htmlparser->get_token()) { next if $token->[0] eq 'C'; # Don't output the contents of style or script sections if ($token->[1] =~ /style/i) { $instyle = 1 if $token->[0] eq 'S'; $instyle = 0 if $token->[0] eq 'E'; next if $instyle; } if ($token->[1] =~ /script/i) { $inscript = 1 if $token->[0] eq 'S'; $inscript = 0 if $token->[0] eq 'E'; next if $inscript; } my $text = $htmlparser->get_trimmed_text(); print $textfh $text . "\n" if $text; } $textfh->close(); } # # This is an improvement to the default HTML-Parser routine for getting # the text out of an HTML message. The only difference to their one is # that I join the array of items together with spaces rather than "". # package HTML::TokeParser::MailScanner; use HTML::Entities qw(decode_entities); use vars qw(@ISA); @ISA = qw(HTML::TokeParser); sub get_text { my $self = shift; my $endat = shift; my @text; while (my $token = $self->get_token) { my $type = $token->[0]; if ($type eq "T") { my $text = $token->[1]; decode_entities($text) unless $token->[2]; push(@text, $text); } elsif ($type =~ /^[SE]$/) { my $tag = $token->[1]; if ($type eq "S") { if (exists $self->{textify}{$tag}) { my $alt = $self->{textify}{$tag}; my $text; if (ref($alt)) { $text = &$alt(@$token); } else { $text = $token->[2]{$alt || "alt"}; $text = "[\U$tag]" unless defined $text; } push(@text, $text); next; } } else { $tag = "/$tag"; } if (!defined($endat) || $endat eq $tag) { $self->unget_token($token); last; } } } # JKF join("", @text); join(" ", @text); } # And switch back to the original package we were in package MailScanner::Message; # # This is an improvement to the default MIME character set decoding that # is done on attachment filenames. It decodes all the character sets it # knows about, just as before. But instead of warning about character sets # it doesn't know about (and removing characters in them), it strips # out all the 8-bit characters (rare) and leaves the 7-bit ones (common). # sub WordDecoderKeep7Bit { local $_ = shift; # JKF 19/8/05 Allow characters with the top bit set. # JKF 19/8/05 Still blocks 16-bit characters though, as it should. #tr/\x00-\x7F/#/c; tr/\x00-\xFF/#/c; $_; } # # Create a subclass of MIME::Parser:FileInto so that I can over-ride # the "evil filename" code with a slightly better one that detects # filenames made up solely of whitespace, which breaks the Perl open(). # I have also improved exorcise_filename to detect and remove any leading # or trailing whitespace, which should make life a lot easier for the # virus scanner output parsers. # # For the original version see .../MIME/Parser/Filer.pm #package MIME::Parser::FileInto::MailScanner; # #use vars qw(@ISA); #@ISA = qw(MIME::Parser::FileInto); # ## A filename is evil unless it only contains any of the following: ## \%\(\)\+\,\-\.0-9\=A-Z_a-z\x80-\xFF ## To get the correct pattern match string, do this: ## print '\x00-\x1F\x7F' . quotemeta(' !"£$&') . quotemeta("'") . ## quotemeta('*/:/<>?@[\]^`{|}~') . "\n"; ## print ' ' . quotemeta('%()+,-.') . '0-9' . quotemeta('=') . ## 'A-Z' . quotemeta('_') . 'a-z' . quotemeta('{}') . '\x80-\xFF' . "\n"; ## #sub evil_filename { # my ($self, $name) = @_; # # #$self->debug("is this evil? '$name'"); # # #print STDERR "Testing \"$name\" to see if it is evil\n"; # return 1 if (!defined($name) or ($name eq '')); ### empty # return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace # return 1 if ($name =~ m{^\.+\Z}); ### dots # return 1 if ($name =~ tr{ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF}{}c); # return 1 if ($self->{MPF_MaxName} and # (length($name) > $self->{MPF_MaxName})); # # #print STDERR "It is okay\n"; # #$self->debug("it's ok"); # 0; #} # #sub exorcise_filename { # my ($self, $fname) = @_; # # ### Isolate to last path element: # my $last = $fname; $last =~ s{^.*[/\\\[\]:]}{}; # if ($last and !$self->evil_filename($last)) { # #$self->debug("looks like I can use the last path element"); # return $last; # } # # # Try removing leading whitespace, trailing whitespace and all # # dangerous characters to start with. # $last =~ s/^\s+//; # $last =~ s/\s+\Z//; # $last =~ tr/ \%\(\)\+\,\-\.0-9\=A-Z_a-z\{\}\x80-\xFF//cd; # return $last unless $self->evil_filename($last); # # ### Break last element into root and extension, and truncate: # my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/) # ? ($1, $2) # : ($last, '')); # # JKF Delete leading and trailing whitespace # $root =~ s/^\s+//; # $ext =~ s/\s+$//; # $root = substr($root, 0, ($self->{MPF_TrimRoot} || 14)); # $ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3)); # $ext =~ /^\w+$/ or $ext = "dat"; # my $trunc = $root . ($ext ? ".$ext" : ''); # if (!$self->evil_filename($trunc)) { # #$self->debug("looks like I can use the truncated last path element"); # return $trunc; # } # # ### Hope that works: # undef; #} # # Over-ride a function in MIME::Entity that gets called every time a MIME # part is added to a message. The new version bails out if there were too # many parts in the message. The limit will be read from the config. # It just sets the entity to undef and relies on the supporting code to # actually generate the error. # package MIME::Entity; use vars qw(@ISA $EntityPartCounter $EntityPartCounterMax); @ISA = qw(Mail::Internet); # Reset the counter and the limit sub ResetMailScannerCounter { my($number) = @_; $EntityPartCounter = 0; $EntityPartCounterMax = $number; } # Read the Counter sub MailScannerCounter { return $EntityPartCounter || 0; } # Over-rise their add_part function with my own with counting added sub add_part { my ($self, $part, $index) = @_; defined($index) or $index = -1; # Incrememt the part counter so I can detect messages with too many parts $EntityPartCounter++; #print STDERR "Added a part. Counter = $EntityPartCounter, Max = " . # $EntityPartCounterMax\n"; return undef if $EntityPartCounterMax>0 && $EntityPartCounter > $EntityPartCounterMax; ### Make $index count from the end if negative: $index = $#{$self->{ME_Parts}} + 2 + $index if ($index < 0); splice(@{$self->{ME_Parts}}, $index, 0, $part); $part; } # # Over-ride a function in Mail::Header that parses the block of headers # at the top of each MIME section. My improvement allows the first line # of the header block to be missing, which breaks the original parser # though the filename is still there. # package Mail::Header; sub extract { my $me = shift; my $arr = shift; my $line; $me->empty; # JKF Make this more robust by allowing first line of header to be missing shift @{$arr} while scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o && $arr->[1] =~ /\A$FIELD_NAME/o; # JKF End mod here while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o) { my $tag = $1; $line = shift @{$arr}; $line .= shift @{$arr} while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o); ($tag,$line) = _fmt_line($me,$tag,$line); _insert($me,$tag,$line,-1) if defined $line; } shift @{$arr} if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o); $me; } ## ## Over-ride the MIME boundary extracting code so that we fail to parse ## messages with an empty MIME boundary. Best I can do for now. ## # #package MIME::Parser::Reader; # #sub add_boundary { # my ($self, $bound) = @_; # unshift @{$self->{Bounds}}, $bound; ### now at index 0 # # JKF Fix problem with the Britney virus # $bound = "" if $bound eq '""'; # # JKF End # $self->{BH}{"--$bound"} = "DELIM $bound"; # $self->{BH}{"--$bound--"} = "CLOSE $bound"; # $self; #} # # Over-ride the hunt-for-uuencoded file code as it now needs to hunt for # binhex-encoded text as well. # #package MIME::Parser; # ##------------------------------ ## ## hunt_for_uuencode ENCODED, ENTITY ## ## I ## Try to detect and dispatch embedded uuencode as a fake multipart message. ## Returns new entity or undef. ## #sub hunt_for_uuencode { # my ($self, $ENCODED, $ent) = @_; # my ($good, $jkfis); # local $_; # $self->debug("sniffing around for UUENCODE"); # # ### Heuristic: # $ENCODED->seek(0,0); # while (defined($_ = $ENCODED->getline)) { # if ($good = /^begin [0-7]{3}/) { # $jkfis = 'uu'; # last; # } # if ($good = /^\(This file must be converted with/i) { # $jkfis = 'binhex'; # last; # } # } # $good or do { $self->debug("no one made the cut"); return 0 }; # # ### New entity: # my $top_ent = $ent->dup; ### no data yet # $top_ent->make_multipart; # my @parts; # # ### Made the first cut; on to the real stuff: # $ENCODED->seek(0,0); # my $decoder = MIME::Decoder->new(($jkfis eq 'uu')?'x-uuencode' # :'binhex'); # $self->whine("Found a $jkfis attachment"); # my $pre; # while (1) { # my @bin_data; # # ### Try next part: # my $out = IO::ScalarArray->new(\@bin_data); # eval { $decoder->decode($ENCODED, $out) }; last if $@; # my $preamble = $decoder->last_preamble; # my $filename = $decoder->last_filename; # my $mode = $decoder->last_mode; # # ### Get probable type: # my $type = 'application/octet-stream'; # my ($ext) = $filename =~ /\.(\w+)\Z/; $ext = lc($ext || ''); # if ($ext =~ /^(gif|jpe?g|xbm|xpm|png)\Z/) { $type = "image/$1" } # # ### If we got our first preamble, create the text portion: # if (@$preamble and # (grep /\S/, @$preamble) and # !@parts) { # my $txt_ent = $self->interface('ENTITY_CLASS')->new; # # MIME::Entity->build(Type => "text/plain", # Data => ""); # $txt_ent->bodyhandle($self->new_body_for($txt_ent->head)); # my $io = $txt_ent->bodyhandle->open("w"); # $io->print(@$preamble); # $io->close; # push @parts, $txt_ent; # } # # ### Create the attachment: # ### We use the x-unix-mode convention from "dtmail 1.2.1 SunOS 5.6". # if (1) { # my $bin_ent = MIME::Entity->build(Type=>$type, # Filename=>$filename, # Data=>""); # $bin_ent->head->mime_attr('Content-type.x-unix-mode' => "0$mode"); # $bin_ent->bodyhandle($self->new_body_for($bin_ent->head)); # $bin_ent->bodyhandle->binmode(1); # my $io = $bin_ent->bodyhandle->open("w"); # $io->print(@bin_data); # $io->close; # push @parts, $bin_ent; # } # } # # ### Did we get anything? # @parts or return undef; # # ### Set the parts and a nice preamble: # $top_ent->parts(\@parts); # $top_ent->preamble # (["The following is a multipart MIME message which was extracted\n", # "from a $jkfis-encoded message.\n"]); # $top_ent; #} # # Overload the MIME quoted-printable decoder. # This version will make lines that end in \n now end in \r\n. # This hopefully fixes problems with PDF files as they are now extracted # correctly. # #package MIME::QuotedPrint; # #sub decode_qp ($) #{ # my $res = shift; # $res =~ s/[ \t]+?(\r?\n)/$1/g; # rule #3 (trailing space must be deleted) # $res =~ s/=\r?\n//g; # rule #5 (soft line breaks) # $res =~ s/([^\r])\n\Z/$1\r\n/; # JKF rule to replace trailing \n with \r\n # $res =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; # $res; #} 1;