Another phishing improvement patch
Julian Field
mailscanner at ecs.soton.ac.uk
Sat Nov 13 21:41:41 GMT 2004
[ The following text is in the "ISO-8859-1" character set. ]
[ Your display is set for the "US-ASCII" character set. ]
[ Some characters may be displayed incorrectly. ]
Sure. Zipped copy attached.
2nd attempt, this time not zipped. The JISCmail service objected to a
file called Message.zip, not quite sure why.
Jeff A. Earickson wrote:
> Julian,
> Can you post the complete latest 4.35.11 Message.pm? The patch
> failed against the original 4.35.11 file, and I've already patched
> this file a couple of times. I could use a fresh copy...
>
> Jeff Earickson
> Colby College
>
> On Sat, 13 Nov 2004, Julian Field wrote:
> Date: Sat, 13 Nov 2004 16:56:33 +0000
>
>> From: Julian Field <mailscanner at ECS.SOTON.AC.UK>
>> Reply-To: MailScanner mailing list <MAILSCANNER at JISCMAIL.AC.UK>
>> To: MAILSCANNER at JISCMAIL.AC.UK
>> Subject: Another phishing improvement patch
>>
>> Another addition to the phishing net. This patch is designed to be
>> applied to the Message.pm file as distributed with 4.35.11.
>>
>> This should help improve the detection rate.
>
--
--
Julian Field
www.MailScanner.info
Buy the MailScanner book at www.MailScanner.info/store
Professional Support Services at www.MailScanner.biz
MailScanner thanks transtec Computers for their support
PGP footprint: EE81 D763 3DB0 0BFD E1DC 7222 11F6 5947 1415 B654
------------------------ MailScanner list ------------------------
To unsubscribe, email jiscmail at jiscmail.ac.uk with the words:
'leave mailscanner' in the body of the email.
Before posting, read the MAQ (http://www.mailscanner.biz/maq/) and
the archives (http://www.jiscmail.ac.uk/lists/mailscanner.html).
Support MailScanner development - buy the book off the website!
[ Part 2: "Attached Text" ]
#
# MailScanner - SMTP E-Mail Virus Scanner
# Copyright (C) 2002 Julian Field
#
# $Id: Message.pm,v 1.126.2.158 2004/10/27 13:50:15 jkf Exp $
#
# 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 at 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 MIME::Parser;
use MIME::Decoder::UU;
use MIME::Decoder::BinHex;
use MIME::WordDecoder;
use POSIX qw(setsid);
use HTML::TokeParser;
use HTML::Parser;
use Archive::Zip qw( :ERROR_CODES );
#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: 1.126.2.158 $, 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)
# $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
# %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)
#
# Constructor.
# Takes id.
# This isn't specific to the MTA at all, so is all done here.
sub new {
my $type = shift;
my($id, $queuedirname) = @_;
my $this = {};
my ($queue, $workarea, $mta, $hpath, $dpath, $addr, $user, $domain);
my ($archiveplaces);
my $hfile = new FileHandle;
#print STDERR "Creating message $id\n";
$this->{id} = $id;
@{$this->{archiveplaces}} = (); # Hope this syntax is right!
# 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;
}
# Reset the infection counters to 0
$this->{virusinfected} = 0;
$this->{nameinfected} = 0;
$this->{otherinfected} = 0;
$this->{stillwarn} = 0;
# Work out where to archive/copy this message.
# Could do all the archiving in a different separate place.
$archiveplaces = MailScanner::Config::Value('archivemail', $this);
@{$this->{archiveplaces}} = ((defined $archiveplaces)?split(" ", $archiveplaces):());
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);
my $spamheader = "";
my $rblspamheader = "";
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');
# 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;
## If it's a blacklisted address, don't bother doing any checks at all
#if (MailScanner::Config::Value('spamblacklist', $this)) {
# $this->{isspam} = 1;
# $this->{spamreport} = 'spam (blacklisted)';
# MailScanner::Log::InfoLog("Message %s from %s (%s) " .
# " is spam (blacklisted)",
# $this->{id}, $this->{clientip},
# $this->{from});
# return 1;
#}
# Work out if they always want the SA header
$includesaheader = MailScanner::Config::Value('includespamheader', $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;
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;
}
} 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 (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;
}
if (!$iswhitelisted) {
# Not whitelisted, so do the RBL checks
#$rblspamheader = MailScanner::RBLs::Checks($this);
($rblcounter, $rblspamheader) = MailScanner::RBLs::Checks($this);
$RBLsaysspam = 1 if $rblcounter;
#$RBLsaysspam = 1 if $rblspamheader;
# Add leading "spam, " if RBL says it is spam. This will be at the
# front of the spam report.
$rblspamheader = $LocalSpamText . ', ' . $rblspamheader if $rblcounter;
$this->{isspam} = 1 if $rblcounter;
$this->{isrblspam} = 1 if $rblcounter;
$this->{ishigh} = 1 if $rblcounter >= MailScanner::Config::Value(
'highrbls', $this);
#print STDERR "RBL report is \"$rblspamheader\"\n";
#print STDERR "RBLCounter = $rblcounter\n";
#print STDERR "HighRBLs = " .
# MailScanner::Config::Value('highrbls', $this) . "\n";
}
# Don't do the SA checks if they have said no.
unless (MailScanner::Config::Value('usespamassassin', $this)) {
$this->{spamwhitelisted} = $iswhitelisted;
$this->{spamreport} = $rblspamheader;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $rblspamheader)
if $RBLsaysspam && $LogSpam;
return $RBLsaysspam;
}
# If it's spam and they dont want to check SA as well
if ($this->{isspam} &&
!MailScanner::Config::Value('checksaifonspamlist', $this)) {
$this->{spamwhitelisted} = $iswhitelisted;
$this->{spamreport} = $rblspamheader;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $rblspamheader)
if $RBLsaysspam && $LogSpam;
return $RBLsaysspam;
}
# They must want the SA checks doing.
my $SAsaysspam = 0;
my $SAHighScoring = 0;
my $saheader = "";
my $sascore = 0;
my $salongreport = "";
($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";
$spamheader = $rblspamheader;
# 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";
$spamheader = $LocalSpamText unless $spamheader;
$spamheader .= ', ' if $spamheader && $saheader;
$spamheader .= $saheader;
$this->{ishigh} = 1 if $SAHighScoring;
}
} else {
# It's not spam...
#print STDERR "It's not spam\n";
#print STDERR "SAHeader = $saheader\n";
$spamheader = MailScanner::Config::LanguageValue($this, 'notspam');
if ($iswhitelisted) {
$spamheader .= ' (' .
MailScanner::Config::LanguageValue($this, 'whitelisted') .
')';
}
# so RBL report must be blank as you can't force inclusion of that.
# So just include SA report.
$spamheader .= ", $saheader";
}
# Now just reflow and log the results
if ($spamheader ne "") {
$spamheader = $this->ReflowHeader(
MailScanner::Config::Value('spamheader',$this), $spamheader);
$this->{spamreport} = $spamheader;
}
# Do the spam logging here so we can log high-scoring spam too
if (($LogSpam && $this->{isspam}) || ($LogNonSpam && !$this->{isspam})) {
my $ReportText = $spamheader;
$ReportText =~ s/\s+/ /sg;
MailScanner::Log::InfoLog("Message %s from %s (%s) to %s is %s",
$this->{id}, $this->{clientip},
$this->{from}, $todomain, $ReportText);
}
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);
# Get a space-separated list of all the actions
if ($HamSpam eq 'nonspam') {
$actions = lc(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}) {
$actions = lc(MailScanner::Config::Value('highscorespamactions', $this));
} else {
$actions = lc(MailScanner::Config::Value('spamactions', $this));
}
}
$actions =~ tr/,//d; # Remove all commas in case they put any in
@actions = split(" ", $actions);
# The default action if they haven't specified anything is to
# deliver spam like normal mail.
return unless @actions;
#print STDERR "Message: HandleHamSpam has actions " . join(',', at actions) .
# "\n";
foreach $action (@actions) {
# 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;
}
}
# 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
#
# Delete action is over-ridden as we are sending it somewhere
delete $actions{'delete'};
MailScanner::Log::InfoLog("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'};
# Message still exists, so it will be delivered to its new recipients
} else {
#
# Message is not going to be delivered anywhere
#
MailScanner::Log::InfoLog("Spam Actions: message %s actions are %s",
$this->{id}, join(',', keys %actions))
if $HamSpam eq 'spam' && MailScanner::Config::Value('logspam');
# 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::InfoLog("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();
$spamdir = $dir2 . '/' . $HamSpam;
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};
$this->{store}->CopyEntireMessage($this, $spamdir, $this->{id},
$uid, $gid, $changeowner);
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);
$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);
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = 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::InfoLog("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::InfoLog("Spam Actions: (SpamAssassin) Bounce to %s",
$from)
if MailScanner::Config::Value('logspam');
}
if ($filename eq "") {
$filename = MailScanner::Config::Value('senderbothspamreport', $this);
MailScanner::Log::InfoLog("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...
/(.*)/;
$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));
# 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);
$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);
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = 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($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::InfoLog("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", $!);
}
# 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);
# 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), ', ');
}
# 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})
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if $this->{isspam} ||
MailScanner::Config::Value('includespamheader', $this);
# 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('spamstars', $this) =~ /1/ && $starcount>0) {
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
$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 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/;
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 it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
if ($this->{isspam} && $this->{ishigh} &&
MailScanner::Config::Value('highspamprependsubject',$this) &&
!$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/;
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 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, ' ');
}
# 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) !~ /0/) {
# 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);
}
}
# Explode a message into its MIME structure and attachments.
# Pass in the workarea where it should go.
sub Explode {
my $this = shift;
my($pipe, $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::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
# 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);
my $entity = eval { $parser->parse($pipe) };
#print STDERR "Done the parse. Counter = " .
# MIME::Entity::MailScannerCounter() . " and max = $maxparts\n";
#$entity = undef
# if $maxparts>0 && MIME::Entity::MailScannerCounter()>=$maxparts;
if (!$entity) {
#print STDERR "Found an error!\n";
$pipe->close();
waitpid $pid, 0;
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 in %s", $this->{id});
$this->{entity} = $entity; # In case it failed due to too many attachments
$this->{toomanyattach} = 1;
$this->{otherinfected} = 1;
return;
}
#close($pipe);
# Closing the pipe this way will reap the child, apparently!
$pipe->close;
kill 9, $pid; # Make sure we are reaping a dead'un
# jjh 2004-03-12 don't waitpid here.
#waitpid $pid, 0;
$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.
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 files are " . join(',', at tneffiles) . "\n";
foreach $tneffile (@tneffiles) {
my $result;
MailScanner::Log::InfoLog("Expanding TNEF archive at %s/%s",
$explodeinto, $tneffile);
$result = MailScanner::TNEF::Decoder($explodeinto, $tneffile, $this);
unless ($result) {
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 ($entity->is_multipart && $entity->head) {
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);
# Set the owner and group on all the extracted files
chown $workarea->{uid}, $workarea->{gid}, glob "$explodeinto/*"
if $workarea->{changeowner};
}
# 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);
$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
next unless $part =~ /(^msg.*txt$)|(\.(tar\.g?z|taz|tgz|tz|zip|exe)$)/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;
}
$file->close;
$failisokay = 0;
if ($buffer =~ /^MZ/) {
$failisokay = 1;
}
next unless $buffer eq "PK\003\004" || $failisokay;
#print STDERR "Found a zip file\n" ;
next unless MailScanner::Config::Value('findarchivesbycontent', $this) ||
$part =~ /\.(tar\.g?z|taz|tgz|tz|zip|exe)$/i;
$foundnewfiles = 1;
#print STDERR "Unpacking $part at level $level\n";
# 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 tar
$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") {
MailScanner::Log::WarnLog("Password-protected archive (%s) in %s",
$part, $this->{id});
$this->{allreports}{$part} .= "$msname: $passwordedmesg\n";
$this->{alltypes}{$part} .= 'c';
$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 && !$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}++;
}
}
# 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->{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->{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: $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};
}
}
# 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/;
# 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 {
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 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;
# 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);
#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 {
## When replacing the whole body of message/partial messages,
## don't forget to fix the root mime header.
#$entity->head->mime_attr("Content-type" => "multipart/mixed")
# if $entity->head->mime_attr("content-type") =~ /message\/partial/i;
#print STDERR "In CleanEntity, replacing entire message\n";
$parts[0] = build MIME::Entity
Type => 'text/plain',
Filename => $warningfile,
Disposition => 'inline',
Data => $Warning,
Encoding => 'quoted-printable',
Charset => $charset,
Top => 0;
#print STDERR "Mime type is " . $entity->mime_type() . "\n";
#my $sss = $entity->is_multipart();
#print STDERR "Currently is " . $sss . "\n";
#print STDERR "Is defined\n" if defined($sss);
#print STDERR "Type now is " . $entity->head->mime_attr('content-type')
# . "\n";
#print STDERR "Status is " . $entity->make_multipart() . "\n"
$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);
$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;
$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) = @_;
my $date = scalar localtime;
my $textfh = new FileHandle;
my $dir = $global::MS->{work}{dir}; # Get the working directory
my $localpostmaster = MailScanner::Config::Value('localpostmaster', $this);
#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 $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);
# # 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 .= $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/\<html\>/$&$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);
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);
$from = $this->{from};
$subject = $this->{subject};
my $result = "";
while (<$fh>) {
chomp;
s#"#\\"#g;
s#@#\\@#g;
# Boring untainting again...
/(.*)/;
$line = eval "\"$1\"";
$result .= $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) ||
!$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/\<x?html\>/$&$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 </html> 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";
$this->DeliverUnmodifiedBody('cleanheader');
}
}
# 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) = @_;
return if $this->{deleted}; # This should never happen
#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);
# 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})
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if $this->{isspam} ||
MailScanner::Config::Value('includespamheader', $this);
# 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('spamstars', $this) =~ /1/ && $starcount>0) {
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
$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 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 $subjectchanged = 0;
my $spamtag = MailScanner::Config::Value('spamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
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 it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
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;
}
# 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, ' ');
}
# 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, ' ');
}
# 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 eq 'start' && !$subjectchanged &&
!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
} elsif ($modifscan eq 'end' && !$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 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;
}
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);
# Set up the output envelope with its (possibly modified) headers
$global::MS->{mta}->AddHeadersToQf($this, $this->{entity}->stringify_header);
# 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})
$global::MS->{mta}->AddMultipleHeader($this, 'spamheader',
$this->{spamreport}, ', ')
if $this->{isspam} ||
MailScanner::Config::Value('includespamheader', $this);
# 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('spamstars', $this) =~ /1/ && $starcount>0) {
if (MailScanner::Config::Value('spamscorenotstars', $this)) {
$stars = $scoretext; # int($starcount);
} else {
$starcount = 60 if $starcount>60;
$stars = MailScanner::Config::Value('spamstarscharacter') x $starcount;
}
$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);
#print STDERR "I have triggered a filename trap\n" if $this->{nameinfected};
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;
}
} 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;
}
} 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;
}
}
# 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/;
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 it is high-scoring spam, then add a different bit of text
$spamtag = MailScanner::Config::Value('highspamsubjecttext', $this);
$spamtag =~ s/_SCORE_/$scoretext/;
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;
}
# 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, ' ');
}
# 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, ' ');
}
# 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 eq 'start' && !$subjectchanged &&
!$global::MS->{mta}->TextStartsHeader($this, 'Subject:', $scantag)) {
$global::MS->{mta}->PrependHeader($this, 'Subject:', $scantag, ' ');
} elsif ($modifscan eq 'end' && !$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 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
}
# 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(@noisyin) = split(" ",MailScanner::Config::Value('noisyviruses', $this));
my($noisy, $noisyin, @noisy, $nregexp);
# 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 = '(' . join(')|(', @silent) . ')';
$nregexp = '(' . join(')|(', @noisy) . ')';
# Make 1 big string from all the reports
$allreports = join('', values %{$this->{allreports}});
#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 @silentin && grep {$logstring .= "$_ " if /$regexp/i;}
values %{$this->{allreports}};
$this->{noisy} = 1 if @noisyin && grep /$nregexp/i,
values %{$this->{allreports}};
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::InfoLog("Viruses marked as silent: %s", $logstring)
if $logstring;
#print STDERR "FindSilentInfection: Found it!\n" if $this->{silent};
#print STDERR "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, @everyreport, $entitytypes, @everytype);
my($emailmsg, $line, $messagefh, $msgname, $localpostmaster, $id);
my($hostname);
# 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);
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = scalar localtime;
my($to, %tolist);
foreach $to (@{$this->{to}}) {
$tolist{$to} = 1;
}
$to = join(', ', sort keys %tolist);
$allreports = $this->{allreports};
$entityreports = $this->{entityreports};
push @everyreport, values %$allreports;
push @everyreport, values %$entityreports;
my $reportword = MailScanner::Config::LanguageValue($this, "report");
$report = join($reportword . ': ', @everyreport);
$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);
} else {
$msgname = MailScanner::Config::Value('sendervirusreport', $this);
}
# 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 $rept = join(" $reportword: ", @everyrept);
my $ip = $this->{clientip};
# 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" .
"$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(',', at 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);
$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);
$newsubject = MailScanner::Config::LanguageValue($this, 'disinfected') .
": " . substr($subject, 0, $MaxSubjectLength);
$newsubject .= '...' if length($subject)>$MaxSubjectLength;
#print STDERR "About to deliver " . join(',', at files) . " to original " .
# "recipients after disinfection\n";
# Create the top-level MIME entity, just the headers
$top = MIME::Entity->build(Type => 'multipart/mixed',
From => "MailScanner <$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 .= $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 = 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);
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.
my($DisarmFormTag, $DisarmScriptTag, $DisarmCodebaseTag, $DisarmIframeTag,
$DisarmWebBug, $DisarmPhishing, $DisarmPhishingFound);
sub DisarmHTML {
my $this = shift;
#print STDERR "Tags to convert are " . $this->{tagstoconvert} . "\n";
# Set the disarm booleans for this message
$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;
if (MailScanner::Config::Value('findphishing', $this) =~ /1/) {
$DisarmPhishing = 1;
$DisarmPhishingFound = 0;
}
$this->DisarmHTMLTree($this->{entity});
# 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;
}
}
# 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);
# 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.
$entity = $this->{entity} or return;
# Construct the RFC822 attachment
$mimeversion = $entity->head->get('mime-version');
$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);
$hostname = MailScanner::Config::Value('hostname', $this);
$subject = $this->{subject};
$date = 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 .= $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);
$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; # Have we modified this message at all?
#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";
$this->DisarmHTMLEntity($entity);
MailScanner::Log::InfoLog('Content Checks: Detected and will disarm ' .
'HTML message 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->DisarmHTMLTree($part);
}
return $counter;
}
# 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;
}
# 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";
# Replace the filename with a new one
$oldname = $entity->bodyhandle->path();
$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;
}
# 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"],
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"],
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();
}
# HTML::Parset callback function for normal text
my($DisarmLinkText, $DisarmLinkURL, $DisarmInsideLink);
# HTML::Parser callback for text so we can collect the contents of links
sub DisarmTextCallback {
my($text) = @_;
unless ($DisarmInsideLink) {
print $text;
return;
}
# We are inside a link.
# Save the original text, we well might need it.
$DisarmLinkText .= $text;
}
# HTML::Parser callback function for start tags
sub DisarmTagCallback {
my($tagname, $text, $attr, $attrseq) = @_;
#print STDERR "Disarming $tagname\n";
my $output = "";
if ($tagname eq 'form' && $DisarmFormTag) {
#print "It's a form\n";
$text = substr $text, 1;
$output .= "<BR><MailScannerForm$$ " . $text;
} elsif ($tagname eq 'input' && $DisarmFormTag) {
#print "It's an input button\n";
$attr->{'type'} = "reset";
$output .= '<' . $tagname;
foreach (@$attrseq) {
next if /^on/;
$output .= ' ' . $_ . '="' . $attr->{$_} . '"';
}
$output .= '>';
} elsif ($tagname eq 'button' && $DisarmFormTag) {
#print "It's a button\n";
$attr->{'type'} = "reset";
$output .= '<' . $tagname;
foreach (@$attrseq) {
next if /^on/;
$output .= ' ' . $_ . '="' . $attr->{$_} . '"';
}
$output .= '>';
} elsif ($tagname eq 'object' && $DisarmCodebaseTag) {
#print "It's an object\n";
if (exists $attr->{'codebase'}) {
$text = substr $text, 1;
$output .= "<MailScannerObject$$ " . $text;
} elsif (exists $attr->{'data'}) {
$text = substr $text, 1;
$output .= "<MailScannerObject$$ " . $text;
} else {
$output .= $text;
}
} elsif ($tagname eq 'iframe' && $DisarmIframeTag) {
#print "It's an iframe\n";
$text = substr $text, 1;
$output .= "<MailScannerIFrame$$ " . $text;
} elsif ($tagname eq 'script' && $DisarmScriptTag) {
#print "It's a script\n";
$text = substr $text, 1;
$output .= "<MailScannerScript$$ " . $text;
} elsif ($tagname eq 'a' && $DisarmPhishing) {
#print STDERR "It's a link\n";
$output .= $text;
$DisarmLinkText = '';
$DisarmLinkURL = $attr->{'href'} if exists $attr->{'href'};
$DisarmInsideLink = 1;
} elsif ($tagname eq 'img' && $DisarmWebBug) {
#print "It's an image\n";
if (exists $attr->{'width'} && $attr->{'width'}<=2 &&
exists $attr->{'height'} && $attr->{'height'}<=2) {
$output .= '<img src="MailScannerWebBug" width="' . $attr->{'width'} .
'" height="' . $attr->{'height'} . '" alt="';
$output .= 'Web Bug from ' . $attr->{'src'} if $attr->{'src'};
$output .= '" />';
} else {
$output .= $text;
}
} else {
#print STDERR "The tag was a \"$tagname\"\n";
$output .= $text;
}
if ($DisarmInsideLink && ($tagname ne 'a' || !$DisarmPhishing)) {
$DisarmLinkText .= $output;
} else {
print $output;
}
}
# HTML::Parser callback function for end tags
sub DisarmEndtagCallback {
my($tagname, $text) = @_;
if ($tagname eq 'iframe' && $DisarmIframeTag) {
print "</MailScannerIFrame$$>";
} elsif ($tagname eq 'form' && $DisarmFormTag) {
print "</MailScannerForm$$>";
} elsif ($tagname eq 'script' && $DisarmScriptTag) {
print "</MailScannerScript$$>";
} elsif ($tagname eq 'a' && $DisarmPhishing) {
my($squashedtext,$linkurl);
$DisarmInsideLink = 0;
$squashedtext = lc($DisarmLinkText);
$squashedtext =~ s/\%a0//g;
$squashedtext =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape
$squashedtext =~ s/\s+//g; # Remove any whitespace
$squashedtext =~ s/\\/\//g;
$squashedtext =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags
#$squashedtext =~ s/^(\<\/?(br|p|ul)\>)*//ig; # Remove leading br, p, ul tags
#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://
if ($squashedtext =~ /^(w+|ft+p|fpt+)([.,]|\%2e)/i ||
$squashedtext =~ /[.,](com|org|net|info|biz|ws)/i ||
$squashedtext =~ /^(ht+ps?|ft+p|fpt+)[:;]\/\/(.*(\.|\%2e))/i) {
$squashedtext =~ s/^(ht+ps?|ft+p|fpt+)[:;]\/\/(.*(\.|\%2e))/$2/i;
$squashedtext =~ s/\/.*$//; # Only compare the hostnames
$squashedtext =~ s/[,.]+$//; # Allow trailing dots and commas
$linkurl = lc($DisarmLinkURL);
$linkurl =~ s/\%a0//ig;
$linkurl =~ s#%([0-9a-f][0-9a-f])#chr(hex('0x' . $1))#gei; # Unescape
$linkurl =~ s/\s+//; # Remove any whitespace
#$linkurl =~ s/(\<\/?[^>]*\>)*//ig; # Remove tags
#$linkurl =~ s/^(\<\/?(br|p|ul)\>)*//ig; # Remove leading br, p, ul tags
$linkurl =~ s/^(https?|ftp):\/\///i;
$linkurl =~ s/\/.*$//; # Only compare up to the first '/' (hostname only)
$linkurl =~ s/(\<\/?(br|p|ul)\>)*$//ig; # Remove trailing br, p, ul tags
$linkurl =~ s/\/$//; # LinkURL is trimmed -- note
#print STDERR "2SquashedText = \"$squashedtext\"\n";
#print STDERR "2LinkURL = \"$linkurl\"\n";
if ($linkurl ne "" && $squashedtext !~ /^\Q$linkurl\E\/?$/) {
print MailScanner::Config::LanguageValue(0, 'possiblefraudstart') .
' "' . $linkurl . '" ' .
MailScanner::Config::LanguageValue(0, 'possiblefraudend') . ' ';
$DisarmPhishingFound = 1;
MailScanner::Log::InfoLog('Found phishing fraud from %s ' .
'claiming to be %s',
$linkurl, $squashedtext);
#$DisarmLinkURL);
}
}
print "$DisarmLinkText$text";
} else {
print $text;
}
}
# 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';
while (my $token = $htmlparser->get_token()) {
next if $token->[0] eq 'C';
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;
tr/\x00-\x7F/#/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<Instance method.>
## 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;
------------------------ MailScanner list ------------------------
To unsubscribe, email jiscmail at jiscmail.ac.uk with the words:
'leave mailscanner' in the body of the email.
Before posting, read the MAQ (http://www.mailscanner.biz/maq/) and
the archives (http://www.jiscmail.ac.uk/lists/mailscanner.html).
Support MailScanner development - buy the book off the website!
More information about the MailScanner
mailing list