#
# MailScanner - SMTP E-Mail Virus Scanner
# Copyright (C) 2002 Julian Field
#
# $Id: SweepOther.pm 3638 2006-06-17 20:28:07Z sysjkf $
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# The author, Julian Field, can be contacted by email at
# Jules@JulianField.net
# or by paper mail at
# Julian Field
# Dept of Electronics & Computer Science
# University of Southampton
# Southampton
# SO17 1BJ
# United Kingdom
#
package MailScanner::SweepOther;
use strict 'vars';
use strict 'refs';
no strict 'subs'; # Allow bare words for parameter %'s
use MIME::Head;
use DirHandle;
use HTML::TokeParser;
use POSIX qw(:signal_h setsid); # For Solaris 9 SIG bug workaround
use vars qw($VERSION);
### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = substr q$Revision: 3638 $, 10;
# Attributes are
#
# Constructor.
sub new {
my $type = shift;
my $this = {};
bless $this, $type;
return $this;
}
# Do all the non-commercial virus checking and rules systems in here
sub ScanBatch {
my $batch = shift;
my $ScanType = shift;
# Insert your own checking here.
$0 = 'MailScanner: scanning for filenames and filetypes';
# In $BaseDir, you will find a directory for each message, which has the
# same name as the message id. Also there is a messageid.header file
# containing all the headers for the message.
# Add entries into %$infections, where they are referenced as
# $infections->{"message id"}{"filename"} but please don't over-write ones
# that are already there.
# If the danger was detected in a header or applies to the whole message
# then append the error report (and a newline) to
# $infections->{"message id"}{""}.
# Return the number of infections/problems you found.
# Can play with the MIME headers of a message using $mime.
my($NumInfections, $BaseDir);
$NumInfections = 0;
$BaseDir = $global::MS->{work}->{dir};
chdir $BaseDir or die "Cannot chdir to $BaseDir for rules checking, $!";
my($id, $attach, $safename, $DirEntry, $message);
my($basefh, $messagefh, $headerfh);
my $counter = 0;
$headerfh = new FileHandle;
$basefh = new DirHandle;
$basefh->open('.')
or MailScanner::Log::DieLog("Could not opendir $BaseDir, %s", $!);
#print STDERR "In SweepOther::ScanBatch, about to read directory $BaseDir\n";
while ($DirEntry = $basefh->read()) {
#print STDERR "In SweepOther::ScanBatch, studying $DirEntry\n";
next if $DirEntry =~ /^\./;
stat $DirEntry; # Do a stat now to save multiple calls later
# Test for presence of dangerous headers
if (-f _ && $DirEntry =~ /\.header$/) {
open($headerfh, $DirEntry) or next;
$id = $DirEntry;
$id =~ s/\.header$//;
$message = $batch->{messages}{$id};
next unless defined $message; # Should be a message for all .header files
next if $message->{deleted}; # Don't do deleted messages!
# Check the message if *any* recipient wants dangerous content scanning
next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;
my @headers = <$headerfh>;
#print STDERR "Checking for Happy virus in $DirEntry ($id)\n";
# X-Spanska: header ==> "Happy" virus
if (grep /^X-Spanska:/i, @headers) {
MailScanner::Log::NoticeLog("Other Checks: Found Happy virus in %s", $id);
$message->{otherreports}{""} .= "\"Happy\" virus\n";
$message->{othertypes}{""} .= "v";
$counter++;
$message->{otherinfected}++;
}
#print STDERR "Checking for long MIME boundary\n";
#print STDERR "Entity = " . $message->{entity} . "\n";
#print STDERR "Boundary = \"" . $message->{entity}->head->multipart_boundary . "\"\n";
# MIME content boundary longer than 138 ==> Eudora exploit
if ($message->{entity} &&
length($message->{entity}->head->multipart_boundary)>=138) {
MailScanner::Log::NoticeLog("Other Checks: Found Eudora " .
"long-MIME-boundary exploit in %s", $id);
$message->{otherreports}{""} .=
MailScanner::Config::LanguageValue($message,'eudoralongmime') . "\n";
$message->{othertypes}{""} .= "v";
$counter++;
# And actually try to replace the MIME boundary with a short one
$message->{entity}->head->mime_attr("Content-type.boundary" =>
"__MailScanner_found_Eudora_long_boundary_attack__");
$message->{otherinfected}++;
}
# No other tests on headers
$headerfh->close();
next;
}
# Test for dangerous attachment filenames specified by filename.rules.conf
# files.
if (-d _) {
$id = $DirEntry;
$messagefh = new DirHandle;
$messagefh->open($id) or next;
$message = $batch->{messages}{$id};
next unless defined $message; # Should be a message for all .header files
next if $message->{deleted}; # Don't do deleted messages!
# Check the message if *any* recipient wants dangerous content scanning
next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;
# Find the name of the TNEF winmail.dat if it exists
my $tnefname = $message->{entity2file}{$message->{tnefentity}};
#print STDERR "TNEF Filename is $tnefname\n";
my $LogNames = MailScanner::Config::Value('logpermittedfilenames',
$message);
# Set up patterns for simple filename real rules files
my($allowpatterns, $denypatterns, $allowexists, $denyexists,
@allowpatterns, @denypatterns, $megaallow, $megadeny);
$allowpatterns = MailScanner::Config::Value('allowfilenames', $message);
$denypatterns = MailScanner::Config::Value('denyfilenames', $message);
$allowpatterns =~ s/^\s+//; # Trim leading space
$denypatterns =~ s/^\s+//;
$allowpatterns =~ s/\s+$//; # Trim trailing space
$denypatterns =~ s/\s+$//;
@allowpatterns = split(" ", $allowpatterns);
@denypatterns = split(" ", $denypatterns);
$allowexists = @allowpatterns; # Don't use them if they are empty!
$denyexists = @denypatterns;
$megaallow = '(' . join(')|(',@allowpatterns) . ')';
$megadeny = '(' . join(')|(',@denypatterns) . ')';
#print STDERR "allowpatterns = $allowpatterns\n";
#print STDERR "deny = $denypatterns\n";
#print STDERR "megaallow = $megaallow\n";
#print STDERR "deny = $megadeny\n";
# Insert new filename rules checking code here
#print STDERR "Searching for dodgy filenames in $id\n";
#print STDERR "SafeFile2File = " . %{$message->{safefile2file}} . "\n";
#while (($attach, $safename) = each %{$message->{file2safefile}}) {
while (defined($safename = $messagefh->read())) {
#print STDERR "Examinin $id/$safename\n";
next unless -f "$id/$safename"; # Skip . and ..
#print STDERR "Real filename of $safename is \"" . $message->{safefile2file}{$safename} . "\"\n";
$attach = $message->{safefile2file}{$safename} || $tnefname;
#print STDERR "Safe filename is $safename\n";
next if $attach eq "" && $safename eq "";
#print STDERR "Searching long name \"$attach\" short name \"$safename\"\n";
# New for V4. The ?= on the end makes the regexp match
# even when the filename is in a foreign character set.
# This replaces '$' at the end of the string with "(\?=)?$"
$attach =~ s/\$$/(\\\?=)\?\$/;
#
# Implement simple all-matches rulesets for allowing and denying files
#
my $MatchFound = 0;
my($logtext, $usertext);
# Ignore if there aren't any patterns
if ($allowexists) {
#print STDERR "Allow exists\n";
if ($attach =~ /$megaallow/i || $safename =~ /$megaallow/i) {
$MatchFound = 1;
#print STDERR "Allowing filename $id\t$safename\n";
MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s",
$id, $safename)
if $LogNames;
}
}
# Ignore if there aren't any patterns
if ($denyexists) {
#print STDERR "Deny exists\n";
if (!$MatchFound && ($attach =~ /$megadeny/i ||
$safename =~ /$megadeny/i)) {
$MatchFound = 1;
# It's a rejection rule, so log the error.
$logtext = MailScanner::Config::LanguageValue($message,
'foundblockedfilename');
$usertext = $logtext;
#print STDERR "Denying filetype $id\t$safename\n";
MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
$logtext, $id, $attach);
$message->{namereports}{$safename} .= "$usertext ($safename)\n";
$message->{nametypes}{$safename} .= "f";
$counter++;
$message->{nameinfected}++;
}
}
# Work through the attachment filename rules,
# using the first rule that matches.
my($i);
my $FilenameRules = MailScanner::Config::FilenameRulesValue($message);
next unless $FilenameRules;
#foreach $i (@$FilenameRules) {
# print STDERR "FilenameRule: $i\n";
#}
my($allowdeny, $regexp);
for ($i=0; !$MatchFound && $i<scalar(@$FilenameRules); $i++) {
($allowdeny, $regexp, $logtext, $usertext)
= split(/\0/, $FilenameRules->[$i]);
#print STDERR "Filename match $i: \"$allowdeny\" \"$regexp\" \"$attach\" \"$safename\" $logtext $usertext\n";
# Skip this rule if the regexp doesn't match
# Check both filenames, the safe and the nasty. This is for
# TNEF messages when the nasty filename is always winmail.dat
next unless $attach =~ /$regexp/i || $safename =~ /$regexp/i;
$MatchFound = 1;
#print STDERR "\"$attach\" matched \"$regexp\" or \"$safename\" did\n";
if ($allowdeny =~ 'deny') {
# It's a rejection rule, so log the error.
MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
$logtext, $id, $attach);
$message->{namereports}{$safename} .= "$usertext ($safename)\n";
$message->{nametypes}{$safename} .= "f";
$counter++;
$message->{nameinfected}++;
# Do we want to delete the attachment or store it?
$message->{deleteattach}{$safename} = 1 if $allowdeny =~ /delete/;
} else {
MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s",
$id, $safename)
if $LogNames;
}
}
MailScanner::Log::InfoLog("Filename Checks: Allowing %s %s " .
"(no rule matched)", $id, $safename)
if $LogNames && !$MatchFound;
}
}
}
$basefh->close();
# Don't do these checks if they haven't specified a filetype rules file
# or they haven't specified a "file" command
return $counter if !MailScanner::Config::Value('filecommand');
return $counter if MailScanner::Config::IsSimpleValue('filetyperules') &&
!MailScanner::Config::Value('filetyperules') &&
MailScanner::Config::IsSimpleValue('allowfiletypes') &&
!MailScanner::Config::Value('allowfiletypes') &&
MailScanner::Config::IsSimpleValue('denyfiletypes') &&
!MailScanner::Config::Value('denyfiletypes');
$counter += CheckFileContentTypes($batch);
return $counter;
}
sub CheckFileContentTypes {
my($batch) = shift;
my $BaseDir = $global::MS->{work}->{dir};
chdir $BaseDir or die "Cannot chdir to $BaseDir for rules checking, $!";
# Fork and execute the file command against a timeout, capturing output
# from it.
# Need "filetimeout" config option
my($Kid, $pid, $TimedOut, $Counter, $PipeReturn, %FileTypes, $filecommand);
my(@filelist);
$Kid = new FileHandle;
$TimedOut = 0;
$filecommand = MailScanner::Config::Value('filecommand');
eval {
die "Can't fork: $!" unless defined($pid = open($Kid, '-|'));
if ($pid) {
# In the parent
local $SIG{ALRM} = sub { $TimedOut = 1; die "Command Timed Out" };
alarm MailScanner::Config::Value('filetimeout');
# Only process the output if we are scanning, not disinfecting
while(<$Kid>) {
chomp;
$FileTypes{$1}{$2} = $3 if /^([^\/]+)\/([^:]+):\s*(.*)$/;
#print STDERR "Processing line \"$_\"\n";
}
close $Kid;
$PipeReturn = $?;
$pid = 0; # 2.54
alarm 0;
# Workaround for bug in perl shipped with Solaris 9,
# it doesn't unblock the SIGALRM after handling it.
eval {
my $unblockset = POSIX::SigSet->new(SIGALRM);
sigprocmask(SIG_UNBLOCK, $unblockset)
or die "Could not unblock alarm: $!\n";
};
} else {
# In the child
POSIX::setsid();
@filelist = <*/*>;
exit 0 unless @filelist;
#exec "$filecommand */*"; # Shouldn't do this like this!
exec(split(/ +/, $filecommand), @filelist);
MailScanner::Log::WarnLog("Can't run file command " .
"(\"$filecommand\"): $!");
exit 1;
}
};
alarm 0; # 2.53
# Note to self: I only close the KID in the parent, not in the child.
MailScanner::Log::DebugLog("Completed checking by $filecommand");
# Catch failures other than the alarm
MailScanner::Log::DieLog("File checker failed with real error: $@")
if $@ and $@ !~ /Command Timed Out/;
#print STDERR "pid = $pid and \@ = $@\n";
# In which case any failures must be the alarm
if ($@ or $pid>0) {
# Kill the running child process
my($i);
kill -15, $pid;
# Wait for up to 5 seconds for it to die
for ($i=0; $i<5; $i++) {
sleep 1;
waitpid($pid, &POSIX::WNOHANG);
($pid=0),last unless kill(0, $pid);
kill -15, $pid;
}
# And if it didn't respond to 11 nice kills, we kill -9 it
if ($pid) {
kill -9, $pid;
waitpid $pid, 0; # 2.53
}
}
# Return failure if the command timed out, otherwise return success
MailScanner::Log::WarnLog("File checker $filecommand timed out!")
if $TimedOut;
# Now check all the %FileTypes we have read in
$Counter = CheckFileTypesRules($batch, \%FileTypes);
return $Counter;
}
sub CheckFileTypesRules {
my($batch, $FileOutput) = @_;
my($id, $attachtypes, $message, $tnefname, $safename, $type, $attach);
my $counter = 0;
while(($id, $attachtypes) = each %$FileOutput) {
next unless $id;
$message = $batch->{messages}{$id};
# Check the message if *any* recipient wants dangerous content scanning
next unless MailScanner::Config::Value('dangerscan', $message) =~ /1/;
$tnefname = $message->{entity2file}{$message->{tnefentity}};
my $LogTypes = MailScanner::Config::Value('logpermittedfiletypes',
$message);
# Set up patterns for simple filename real rules files
my($allowpatterns, $denypatterns, $allowexists, $denyexists,
@allowpatterns, @denypatterns, $megaallow, $megadeny);
$allowpatterns = MailScanner::Config::Value('allowfiletypes', $message);
$denypatterns = MailScanner::Config::Value('denyfiletypes', $message);
$allowpatterns =~ s/^\s+//; # Trim leading space
$denypatterns =~ s/^\s+//;
$allowpatterns =~ s/\s+$//; # Trim trailing space
$denypatterns =~ s/\s+$//;
@allowpatterns = split(" ", $allowpatterns);
@denypatterns = split(" ", $denypatterns);
$allowexists = @allowpatterns; # Don't use them if they are empty!
$denyexists = @denypatterns;
$megaallow = '(' . join(')|(',@allowpatterns) . ')';
$megadeny = '(' . join(')|(',@denypatterns) . ')';
#print STDERR "allowpatterns = $allowpatterns\n";
#print STDERR "deny = $denypatterns\n";
#print STDERR "megaallow = $megaallow\n";
#print STDERR "deny = $megadeny\n";
my($i, $FiletypeRules);
$FiletypeRules = MailScanner::Config::FiletypeRulesValue($message);
while(($safename, $type) = each %$attachtypes) {
$attach = $message->{safefile2file}{$safename} || $tnefname;
next if $attach eq "" && $safename eq "";
#
# Implement simple all-matches rulesets for allowing and denying files
#
my $MatchFound = 0;
my($logtext, $usertext);
# Ignore if there aren't any patterns
if ($allowexists) {
if ($type =~ /$megaallow/i) {
$MatchFound = 1;
MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s",
$id, $safename)
if $LogTypes;
}
}
# Ignore if there aren't any patterns
if ($denyexists) {
if (!$MatchFound && $type =~ /$megadeny/i) {
$MatchFound = 1;
# It's a rejection rule, so log the error.
$logtext = MailScanner::Config::LanguageValue($message,
'foundblockedfiletype');
$usertext = $logtext;
MailScanner::Log::InfoLog("Filename Checks: %s (%s %s)",
$logtext, $id, $attach);
$message->{namereports}{$safename} .= "$usertext ($safename)\n";
$message->{nametypes}{$safename} .= "f";
$counter++;
$message->{nameinfected}++;
}
}
# Work through the attachment filetype rules,
# using the first rule that matches.
next unless $FiletypeRules;
my($allowdeny, $regexp);
for ($i=0; !$MatchFound && $i<@$FiletypeRules; $i++) {
($allowdeny, $regexp, $logtext, $usertext)
= split(/\0/, $FiletypeRules->[$i]);
next unless $type =~/$regexp/i;
#print STDERR "Filetype match: $allowdeny $regexp $logtext $usertext\n";
$MatchFound = 1;
if ($allowdeny =~ /deny/) {
# It's a rejection rule, so log the error.
MailScanner::Log::InfoLog("Filetype Checks: %s (%s %s)",
$logtext, $id, $attach);
$message->{namereports}{$safename} .= "$usertext ($safename)\n";
$message->{nametypes}{$safename} .= "f";
$counter++;
$message->{nameinfected}++;
# Do we want to delete the attachment or store it?
$message->{deleteattach}{$safename} = 1 if $allowdeny =~ /delete/;
} else {
MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s",
$id, $safename)
if $LogTypes;
}
}
# Log it as allowed if it didn't match any rule
MailScanner::Log::InfoLog("Filetype Checks: Allowing %s %s " .
"(no match found)", $id, $safename)
if $LogTypes && !$MatchFound;
}
}
return $counter;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1