#
# MailScanner - SMTP E-Mail Virus Scanner
# Copyright (C) 2002 Julian Field
#
# $Id: SMDiskStore.pm 3768 2006-11-07 19:10:54Z 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::SMDiskStore;
use strict 'vars';
use strict 'refs';
no strict 'subs'; # Allow bare words for parameter %'s
use File::Basename;
use File::Copy;
use IO::File;
use IO::Pipe;
use MailScanner::Lock;
use MailScanner::Config;
use vars qw($VERSION @DeletesPending);
### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = substr q$Revision: 3768 $, 10;
# List of pending delete operations so we can clear up properly when killed
@DeletesPending = ();
#################################
#package MailScanner::SMDiskStore;
#
#@MailScanner::SMDiskStore::ISA = qw(MailScanner::DiskStore);
#
#use vars qw($VERSION);
#
#### The package version, both in 1.23 style *and* usable by MakeMaker:
#$VERSION = substr q$Revision: 3768 $, 10;
# Attributes are
#
# $dir set by new (incoming queue dir in case we use it)
# $dname set by new (filename component only)
# $hname set by new (filename component only)
# $tname set by new (filename component only)
# $dpath set by new (full path)
# $hpath set by new (full path)
# $size set by size
# $inhhandle set by lock
# $indhandle set by lock
#
#
# Constructor.
# Takes message id and directory name.
sub new {
my $type = shift;
my($id, $dir) = @_;
my $this = {};
my $mta = $global::MS->{mta};
$this->{dir} = $dir;
#print STDERR "Creating SMDiskStore($id)\n";
# The Sendmail version of these 3 functions take an extra parameter,
# the directory in which the message resides, to allow for nesting.
$this->{dname} = $mta->DFileName($id, $dir);
$this->{hname} = $mta->HFileName($id, $dir);
$this->{tname} = $mta->TFileName($id, $dir);
$this->{dpath} = $dir . '/' . $this->{dname};
$this->{hpath} = $dir . '/' . $this->{hname};
$this->{inhhandle} = new FileHandle;
$this->{indhandle} = new FileHandle;
bless $this, $type;
return $this;
}
# Print the contents of the structure
sub print {
my $this = shift;
print STDERR "dpath = " . $this->{dpath} . "\n" .
"hpath = " . $this->{hpath} . "\n" .
"inhhandle = " . $this->{inhhandle} . "\n" .
"indhandle = " . $this->{indhandle} . "\n" .
"size = " . $this->{size} . "\n";
}
# Open and lock the message
sub Lock {
my $this = shift;
#print STDERR "About to lock " . $this->{hpath} . " and " .
# $this->{dpath} . "\n";
MailScanner::Lock::openlock($this->{inhhandle}, '+<' . $this->{hpath}, 'w', 'quiet')
or return undef;
#print STDERR "Got hlock\n";
# If locking the dfile fails, then must close and unlock the qffile too
# 14/12/2004 Try putting this back in for now.
unless (MailScanner::Lock::openlock($this->{indhandle},
'+<' . $this->{dpath}, 'w', 'quiet')) {
#JKF 14/12/2004 open($this->{indhandle}, '+<' . $this->{dpath})) {
MailScanner::Lock::unlockclose($this->{inhhandle});
return undef;
}
#print STDERR "Got dlock\n";
return undef unless $this->{inhhandle} && $this->{indhandle};
return 1;
}
# Close and unlock the message
sub Unlock {
my $this = shift;
# Now we lock the df file as well, we must unlock it too.
MailScanner::Lock::unlockclose($this->{indhandle});
#close($this->{indhandle});
MailScanner::Lock::unlockclose($this->{inhhandle});
}
# Delete a message (from incoming queue)
sub Delete {
my $this = shift;
# Maintain a list of pending deletes so we can clear up properly
# when killed
@DeletesPending = ($this->{hpath}, $this->{dpath});
unlink($this->{hpath});
# or MailScanner::Log::WarnLog("Unlinking %s failed",
# $this->{hpath});
unlink($this->{dpath});
# or MailScanner::Log::WarnLog("Unlinking %s failed",
# $this->{dpath});
# Clear list of pending deletes
@DeletesPending = ();
}
# Delete and unlock a message (from the incoming queue)
# This will almost certainly be called more than once for each message
sub DeleteUnlock {
my $this = shift;
# Maintain a list of pending deletes so we can clear up properly
# when killed
@DeletesPending = ($this->{hpath}, $this->{dpath});
unlink($this->{hpath})
or MailScanner::Log::WarnLog("Unlinking %s failed: %s",
$this->{hpath}, $!);
MailScanner::Lock::unlockclose($this->{inhhandle});
unlink($this->{dpath})
or MailScanner::Log::WarnLog("Unlinking %s failed: %s",
$this->{dpath}, $!);
MailScanner::Lock::unlockclose($this->{indhandle});
# Clear list of pending deletes
@DeletesPending = ();
}
# Carry out any pending delete operations so we leave the incoming queue
# nice and tidy. We don't do anything except the delete operations as
# the outgoing queue runner will pick up the messages eventually anyway.
sub DoPendingDeletes {
unlink @DeletesPending if @DeletesPending;
@DeletesPending = ();
}
# Link at least the data portion of the message
sub LinkData {
my $this = shift;
my($OutQ) = @_;
my($InDPath, $OutDPath);
$InDPath = $this->{dpath};
# If the incoming queue was nested, the dname will have any of qf,df,xf,tf
# pre-pended to it, so we have to get rid of this before we produce the
# outgoing queue directory name.
$OutDPath = $this->{dname};
$OutDPath =~ s/^[qdxt]f\///;
$OutDPath = $OutQ . '/' . $OutDPath;
#print STDERR "OutQ = $OutQ and OutDPath = $OutDPath\n";
# If the link fails for some reason (usually caused by sendmail calling
# 2 messages the same thing in a very short time), then just skip this
# message and move on to the next one. This one will get delivered when
# the previous one with the same name has been delivered.
unless (link $InDPath, $OutDPath) {
# The link failed, so get the inode numbers of the two files
my($ininode, $outinode);
$ininode = (stat $InDPath)[1];
$outinode = (stat $OutDPath)[1];
# If the files are the same, then just quietly delete the incoming one
if ($ininode == $outinode) {
$this->DeleteUnlock();
} else {
MailScanner::Log::WarnLog("Failed to link message body between queues " .
"($OutDPath --> $InDPath)");
}
return;
}
}
# Write the temporary header data file, before it is made "live" by
# renaming it.
# Passed the parent message object we are working on, and the outqueue dir.
sub WriteHeader {
my $this = shift;
my($message, $Outq) = @_;
my($hfile, $tfile, $Tf);
#print STDERR "Writing header for message " . $message->{id} . "\n";
$tfile = $this->{tname};
$hfile = $this->{hname};
# If the incoming queue was nested, the tname and hname will have
# the qf,df,xf,tf prepended onto it, so we have to get rid of those.
$tfile =~ s/^[qdxt]f\///;
$hfile =~ s/^[qdxt]f\///;
$tfile = $Outq . '/' . $tfile;
$hfile = $Outq . '/' . $hfile;
#print STDERR "tfile = $tfile and hfile = $hfile\n";
umask 0077; # Add this to try to stop 0666 qf files
$Tf = new FileHandle;
MailScanner::Lock::openlock($Tf, ">$tfile", "w")
or MailScanner::Log::DieLog("Cannot create + lock clean tempfile %s, %s",
$tfile, $!);
$Tf->print(MailScanner::Sendmail::CreateQf($message))
or MailScanner::Log::DieLog("Failed to write headers for unscanned " .
"message %s, %s", $message->{id}, $!);
MailScanner::Lock::unlockclose($Tf);
rename "$tfile", "$hfile"
or MailScanner::Log::DieLog("Cannot rename clean %s to %s, %s",
$tfile, $hfile, $!);
}
# Return the size of the message
sub size {
my $this = shift;
my($size, $hpath, $dpath);
# Return previous calculated value if it exists
$size = $this->{size};
return $size if $size;
# Calculate it
$hpath = $this->{hpath};
$dpath = $this->{dpath};
$size = -s $hpath if -e $hpath;
$size += -s $dpath if -e $dpath;
# Store and return
$this->{size} = $size;
return $size;
}
# LEOH 26/03/2003 We do not have dpath in other mailers
sub dsize {
my $this = shift;
return (stat($this->{dpath}))[7];
}
# Read the message body into an array.
# Passed a ref to the array.
# Read up to at least "$max" bytes, if the 2nd parameter is non-zero.
# The 2nd parameter is either
# 1) a number (with possible _ and k or m or g). Copy code from Config.pm
# 2) a number followed by "continue number"
# 3) a number followed by "trackback"
# 2 ==> Continue reading to the end of the encoding block (/^\s*$/) or number
# of bytes whichever is the less
# 3 ==> Delete lines from the end of the encoding block back to the previous
# blank line (/^\s*$/)
#
sub ReadBody {
my $this = shift;
my($body, $max) = @_;
my $dh = $this->{indhandle};
my $lastlineread = undef;
seek($dh, 0, 0); # Rewind the file
# Restraint is disabled, do the whole message.
#print STDERR "max message size is '$max'\n";
unless ($max) {
while(defined($lastlineread = $dh->getline)) {
# End of line characters are already there, so don't add them
#push @{$body}, $lastlineread . "\n";
push @{$body}, $lastlineread;
#print STDERR "Line read is ****" . $_ . "****\n";
}
return;
}
my @configwords = split(" ", $max);
$max = $configwords[0];
$max =~ s/_//g;
$max =~ s/k$/000/ig;
$max =~ s/m$/000000/ig;
$max =~ s/g$/000000000/ig;
#print STDERR "Words are " . join(',',@configwords) . "\n";
# Read the body up to the limit
my($line, $size);
$size = 0;
while(defined($line = <$dh>) && $size<$max) {
push @{$body}, $line;
$size += length($line);
#print STDERR "Line read2 is ****" . $line . "****\n";
}
$lastlineread = $line;
#print STDERR "Initially read $size bytes\n";
# Handle trackback -- This is the tricky one
if ($configwords[1] =~ /tr[au]/i) {
#print STDERR "Trackback:\n";
while (${@{$body}}[scalar(@{$body})-1] !~ /^\s*$/) {
print "Line is ****" . ${@{$body}}[scalar(@{$body})-1] . "****\n";
pop @{$body};
#print STDERR ".";
}
#print STDERR "\n";
return;
}
# Handle continue
if ($configwords[1] =~ /con/i) {
#print STDERR "Continue:\n";
my $maxsizes = 0;
my $maxsize = 0;
# Work out the number they have put in the .conf line after "continue"
$maxsizes = $configwords[2] if $configwords[2] =~ /^[0-9]/;
$maxsizes =~ s/_//g;
if ($maxsizes =~ s/k$//i) {
$maxsize = $maxsizes * 1000;
} elsif ($maxsizes =~ s/m$//i) {
$maxsize = $maxsizes * 1000000;
} elsif ($maxsizes =~ s/g$//i) {
$maxsize = $maxsizes * 1000000000;
} elsif ($maxsizes =~ s/[^0-9]*//g) {
$maxsize = $maxsizes;
}
# Value provided in .conf is the number of extra bytes to read.
$maxsize += $max;
#print STDERR "Maxsize = $maxsize\n";
# Now need to read extra bytes up to $maxsize bytes
while(defined $lastlineread && $lastlineread !~ /^\s*$/) {
#print "Continue added '$lastlineread'\n";
$size += length($lastlineread);
last if $size > $maxsize;
push @{$body}, $lastlineread;
$lastlineread = <$dh>;
#print STDERR "Added $lastlineread";
}
return;
}
## Only use $max if it was set non-zero
#if ($max) {
# my($line, $size);
# $size = 0;
# while(defined($line = <$dh>) && $size<$max) {
# push @{$body}, $line;
# $size += length($line);
# }
# # Continue copying until we hit a blank line, gives SA a complete
# # encoded attachment
# #while(defined $line) {
# # $line = <$dh>;
# # last if $line =~ /^\s+$/;
# # push @{$body}, $line if defined $line;
# #}
#}
}
# Write the message body to a file in the outgoing queue.
# Passed the message id, the root entity of the MIME structure
# and the outgoing queue directory.
sub WriteMIMEBody {
my $this = shift;
my($id, $entity, $outq) = @_;
my($Df, $dfile, $InDPath, $OutDPath);
# If the incoming queue was nested, the dname will have any of qf,df,xf,tf
# pre-pended to it, so we have to get rid of this before we produce the
# outgoing queue directory name.
my $OutDPath = $this->{dname};
$OutDPath =~ s/^[qdxt]f\///;
$dfile = $outq . '/' . $OutDPath;
#print STDERR "Writing MIME body of \"$id\" to $dfile\n";
umask 0077; # Add this to try to stop 0666 df files
$Df = new FileHandle;
MailScanner::Lock::openlock($Df, ">$dfile", "w")
or MailScanner::Log::DieLog("Cannot create + lock clean body %s, %s",
$dfile, $!);
#print STDERR "File handle = $Df\n";
$entity->print_body($Df)
or MailScanner::Log::WarnLog("WriteMIMEBody to %s possibly failed, %s",
$dfile, $!);
MailScanner::Lock::unlockclose($Df);
}
# Copy a dfile and hfile to a directory
# Needs to be done inside a fork so as not to break locks.
# flock may be based on POSIX locks on some OS's (e.g. Solaris).
sub CopyToDir {
my($this,$dir,$file,$uid,$gid,$changeowner) = @_;
my $hpath = $this->{hpath};
my $dpath = $this->{dpath};
my $hfile = basename($hpath);
my $dfile = basename($dpath);
# Need to add this code if sendmail starts using POSIX locks
my $pid = fork;
MailScanner::Log::DieLog("fork: $!") if not defined $pid;
if ($pid) {
waitpid $pid, 0;
return ("$dir/$hfile", "$dir/$dfile");
}
copy($hpath, "$dir/$hfile");
copy($dpath, "$dir/$dfile");
chown $uid, $gid, "$dir/$hfile", "$dir/$dfile" if $changeowner;
exit;
}
# Write a message to a filehandle
sub WriteEntireMessage {
my($this, $message, $handle, $pipe) = @_;
# Uncomment this code if sendmail starts using POSIX locks
# Do this in a subprocess in order to avoid breaking POSIX locks.
# XXX: maybe conditionalize fork on the lock type & $pipe?
my $pid = fork;
MailScanner::Log::DieLog("fork: $!") if not defined $pid;
if ($pid) {
if ($pipe) {
$handle->reader();
} else {
waitpid $pid, 0;
}
return $pid;
}
$handle->writer() if $pipe;
copy($message->{headerspath}, $handle);
copy($this->{dpath}, $handle);
exit;
}
# Copy an entire copy of the message into a named file.
# The target directory name will already exist.
# May be more efficient to do this directly in perl
# rather than by invoking a shell to run cat.
# But it doesn't happen very often anyway.
sub CopyEntireMessage {
my $this = shift;
my($message, $targetdir, $targetfile, $uid, $gid, $changeowner) = @_;
#my $hfile = $message->{headerspath};
#my $dfile = $this->{dpath};
#my $hpath = $this->{hpath};
#
if (MailScanner::Config::Value('storeentireasdfqf')) {
# Don't need cp or cat any more! Yay :-)
#system($global::cp . " \"$hpath\" \"$dfile\" \"$targetdir\"");
return $this->CopyToDir($targetdir, $targetfile, $uid, $gid, $changeowner);
} else {
#system($global::cat . " \"$hfile\" \"$dfile\" > \"$targetdir/$targetfile\"");
my $target = new IO::File "$targetdir/$targetfile", "w";
MailScanner::Log::DieLog("writing to $targetdir/$targetfile: $!")
if not defined $target;
$this->WriteEntireMessage($message, $target);
return ($targetdir . '/' . $targetfile);
}
}
# Produce a pipe that will read the whole message.
# Need to be passed the message to find the headers path
# as it's not part of the DiskStore.
sub ReadMessagePipe {
my $this = shift;
my $message = shift;
#my($hfile, $dfile);
#my $pipe = new FileHandle;
my $pipe = new IO::Pipe;
my $pid;
#$hfile = $message->{headerspath};
#$dfile = $this->{dpath};
#my $cmd = $global::cat . " \"$hfile\" \"$dfile\"";
#
#unless (open($pipe, "$cmd |")) {
# MailScanner::Log::WarnLog("Cannot build message from $hfile " .
# "and $dfile, %s", $!);
#}
#return $pipe;
if (not defined $pipe or not defined ($pid = fork)) {
MailScanner::Log::WarnLog("Cannot build message from $this->{dpath} " .
"and $message->{headerspath}, %s", $!);
} elsif ($pid) { # Parent
$pipe->reader();
# We have to tell the caller what the child's pid is in order to
# reap it. Although IO::Pipe does this for us when it is told to
# fork and exec, it unfortunately doesn't have a neat hook for us
# to tell it the pid when we do the fork. Bah.
return ($pipe,$pid);
} else { # Child
$pipe->writer();
$this->WriteEntireMessage($message, $pipe);
$pipe->close();
exit;
}
#my $pipe = new IO::Pipe;
#
#MailScanner::Log::DieLog("Cannot build message from $this->{dpath} " .
# "and $message->{headerspath}, %s", $!)
# unless defined $pipe;
#
#my $pid = $this->WriteEntireMessage($message, $pipe, 'pipe');
#
## We have to tell the caller what the child's pid is in order to
## reap it. Although IO::Pipe does this for us when it is told to
## fork and exec, it unfortunately doesn't have a neat hook for us
## to tell it the pid when we do the fork. Bah.
#return ($pipe,$pid);
}
# Writes the whole message to a handle.
# Need to be passed the message to find the headers path
# as it's not part of the DiskStore.
sub ReadMessageHandle {
my $this = shift;
my ($message, $handle) = @_;
# we use already opened handles
#my $hhandle = $this->{inhhandle};
#my $dhandle = $this->{indhandle};
my $hhandle = $message->{headerspath};
my $dhandle = $this->{dpath};
# rewind files to read and write with File::Copy
sysseek($handle , 0, 0); # Rewind the file
sysseek($hhandle, 0, 0); # Rewind the file
sysseek($dhandle, 0, 0); # Rewind the file
# File::Copy does not close our handles
# so locks are preserved
copy($hhandle , $handle);
copy($dhandle , $handle);
# rewind tmpfile to read it later
sysseek($handle, 0, 0); # Rewind the file
# rewind source files
sysseek($hhandle, 0, 0); # Rewind the file
sysseek($dhandle, 0, 0); # Rewind the file
return 1;
}
# This is now done much further up
## Copy a dfile and hfile to a directory
#sub CopyToDir {
# my $this = shift;
# my($dir) = @_;
#
# system($global::cp . " \"" . $this->{dpath} . "\" \"" .
# $this->{hpath} . "\" \"$dir\"");
#}
1;
syntax highlighted by Code2HTML, v. 0.9.1