# # MailScanner - SMTP E-Mail Virus Scanner # Copyright (C) 2002 Julian Field # # OpenProtect - Server Side E-Mail Protection # Copyright (C) 2003 Opencomputing Technologies # # $Id: Qmail.pm,v 1.1.2.4 2004/04/18 20:07:56 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 authors, KM Ganesh, S Karthikeyan can be contacted by email at # email@opencompt.com # or by snail mail at # Opencomputing Technologies # #1, 8th Street, Gopalapuram, # Chennai-86, India. package MailScanner::Sendmail; use strict 'vars'; use strict 'refs'; no strict 'subs'; # Allow bare words for parameter %'s use DirHandle; use vars qw($VERSION); ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = substr q$Revision: 1.1.2.4 $, 10; # Command-line options you need to give to sendmail to sensibly process a # message that is piped to it. Still need to add "-f" for specifying the # envelope sender address. This is usually local postmaster. my $SendmailOptions = "-t -oi -oem -F MailScanner -f"; my $SendmailOptionsNoBounce = "-t -oi -oem -F MailScanner"; my $RunAsUser = 0; my $UnsortedBatchesLeft; # Attributes are # # $HDFileRegexp set by new # $LockType set by new # # If the sendmail and/or sendmail2 config variables aren't set, then # set them to something sensible. This will need to be different # for Exim. sub initialise { $RunAsUser = MailScanner::Config::Value('runasuser'); $RunAsUser = $RunAsUser?getpwnam($RunAsUser):0; MailScanner::Config::Default('sendmail', '/usr/sbin/sendmail'); MailScanner::Config::Default('sendmail2', MailScanner::Config::Value('sendmail')); $MailScanner::SMDiskStore::HashDirDepth = 1; $UnsortedBatchesLeft = 0; # Disable queue-clearing mode } # Constructor. # Takes dir => directory queue resides in sub new { my $type = shift; my $this = {}; # These need to be improved # No change for V4 $this->{HDFileRegexp} = '^([\\d]+)$'; $this->{LockType} = "flock"; bless $this, $type; return $this; } # Required vars are: # # HDFileRegexp: # A regexp that will verify that a filename is a valid # "HDFile" name and leave the queue id in $1 if it is. # # LockType: # The way we should usually do spool file locking for # this MTA ("posix" or "flock") # # HDFileName: # Take a queue ID and return # filename for envelope and data queue file (input) # # TFileName: # Take a queue ID and return # filename for temp queue file # # ReadQf: # Read an envelope queue file (sendmail qf) and build # an array of lines which together form all the mail headers. # # AddHeader: # Given a current set of headers (string), and another header # (key string, value string), return the set of headers with the new one # added. # # DeleteHeader: # Given a current set of headers (string), and another header # (string), return the set of headers with the new one removed. # # ReplaceHeader: # Given a current set of headers (string), and another header # (key string, value string), return the set of headers with the new one # in place of any existing occurence of the header. # # AppendHeader: # Given a current set of headers (string), another header # (key string, value string), and a separator string, # return the set of headers with the new value # appended to any existing occurrence of the header. # # PrependHeader: # Given a current set of headers (string), another header # (key string, value string), and a separator string, # return the set of headers with the new value # prepended to the front of any existing occurrence of the header. # Do the header matching in a case-insensitive way. # # TextStartsHeader: # Given a current set of headers (string), another header (string) # and a search string, # return true if the search string appears at the start of the # text of the header. # Do the matching in a case-insensitive way. # # KickMessage: # Given id, tell MTA to make a delivery attempt. # sub HDFileName { my($this, $id) = @_; return "$id"; } # Give it a temp file name, changes the file name to # a new one for the outgoing queue. sub HDOutFileName { my($file) = @_; #print STDERR "Qmail.pm: HDOutFileName $file\n"; my $dir = $file; $dir =~ s/\/[^\/]+$//; # Bad hash key $file = sprintf("%05X%lX", time % 1000000, (stat($file))[1]); # Add 1 so the number is never zero (defensive programming) $file = sprintf("%d", int(rand 1000000)+1, (stat($file))[1]); #print STDERR "Qmail.pm: New Filename is $file\n"; #print STDERR "\nQmail.pm: QmailHashDirectoryNumber=". MailScanner::Config::Value('qmailhashdirectorynumber'); my $hash = $file%MailScanner::Config::Value('qmailhashdirectorynumber'); return ($dir,$hash,$file); } # No change for V4 sub TFileName { my($this, $id) = @_; return "temp-$$-$id"; } # Change for V4: returns lower-case $from and @to sub ReadQf { my($this, $message) = @_; my($RQf) = $message->{store}{inhdhandle}; my($Rintdf) = $message->{store}{intdhandle}; my($intdline) = readline($Rintdf); my $miobj = new Mail::Internet($RQf); my $mhobj = $miobj->head(); my($from,$to); my($ip); my($Line); my($TOFound, $FROMFound, $IPFound); my($temp,@headers); #print STDERR "Qmail.pm: In ReadQf\n"; #$message->{store}->print(); # Just in case we get a message with no headers at all @{$message->{headers}} = (); @{$message->{metadata}} = $intdline; @headers = @{$mhobj->header()}; chomp @headers; @{$message->{headers}} = @headers; ${$message->{mhobj}} = $mhobj; $from = $intdline; if($from =~ /F(.*?)\0T/) { $message->{from} = $1; $FROMFound = 1; } $to = $intdline; if($to =~ /T/) { # Bug report from Jerome MILLIER-PIERRET $to =~ s/(u.*F.*?\0)//; # Another bug report from him $to =~ s/(u[^@]*F.*?\0)//; $to =~ s/(u.*?F.*?\0)//; do { if($to =~ s/^T((.*?)\0)//) { $TOFound = 1; push @{$message->{to}}, $2; } } while ($to =~ /^T.*?\0/); } $ip = ($mhobj->get(RECEIVED))[1]; if($ip =~ /.*(\d+\.\d+\.\d+\.\d+).*/) { $ip =~ /.*(\d+$1).*/; $ip =~ /.*(\d+$1).*/; #KMG: is this a perl bug or is the earth round ?, Gurus of perl, I call upon thee to purify thy code $message->{clientip} = $1; $IPFound = 1; } elsif (!$IPFound && $ip =~ /.*([\dabcdef.:]+).*/) { $message->{clientip} = $1; $IPFound = 1; } else { $message->{clientip} = '127.0.0.1'; $IPFound = 1; } $message->{subject} = $mhobj->get(SUBJECT); chomp $message->{subject}; return 1 if $TOFound; $message->{store}->DeleteUnlock(); #KMG: three cheers to christophe @ digital network for his persistence and resourcefulness :) #MailScanner::Log::WarnLog("Batch: Deleted queue file with no RCPT TO: address " . # "message %s", $message->{id}); return 0; } # Add all the message headers to the metadata so it's ready to be # mangled and output to disk. Puts the headers at the end. # Can be passed in a string containing all the headers. # This is usually the output of stringify_output (MIME-Tools). # JKF: @headers doesn't include leading "H" header indicator. # @metadata includes leading "H" but no \n characters. # The input to this function can be a "\n"-separated string of # new header lines. This is useful as the SpamCheck header can # be flowed over multiple lines, but still be passed into here # as a single header. #KMG: I Dunno whether this is required for qmail, so it works without it for now #Note to Self: The Future is always BETA ;). #KMG: Case solved, no need for this func as of now :). sub AddHeadersToQf { # my $this = shift; # my($message, $headers) = @_; # my($headertemp, @headersextra); # if($headers) { # add $headers to mhobj # @headersextra = split(/\n/, $headers); # foreach $headertemp (@headersextra) { # ${$message->{mhobj}}->add($headertemp); # } # } } # Add a header. Needs to look for the position of the M record again # so it knows where to insert it. sub AddHeader { my($this, $message, $newkey, $newvalue) = @_; ${$message->{mhobj}}->add($newkey,$newvalue); } # Delete a header. Must be in an N line plus any continuation N lines # that immediately follow it. sub DeleteHeader { my($this, $message, $key) = @_; ${$message->{mhobj}}->delete($key); } sub ReplaceHeader { my($this, $message, $key, $newvalue) = @_; ${$message->{mhobj}}->replace($key,$newvalue); } # Append to the end of a header if it exists. sub AppendHeader { my($this, $message, $key, $newvalue, $sep) = @_; my($temp); $temp = ${$message->{mhobj}}->get($key); $temp = $temp . $newvalue; ${$message->{mhobj}}->replace($key,$temp); } # Insert text at the start of a header if it exists. sub PrependHeader { my($this, $message, $key, $newvalue, $sep) = @_; my($temp); $temp = ${$message->{mhobj}}->get($key); $temp = $newvalue . $temp; ${$message->{mhobj}}->replace($key,$temp); } sub TextStartsHeader { my($this, $message, $key, $text) = @_; my($temp); $temp = ${$message->{mhobj}}->get($key); if($temp =~ m/^$text.*/){ return 1; } return 0; } sub TextEndsHeader { my($this, $message, $key, $text) = @_; my($temp); $temp = ${$message->{mhobj}}->get($key); if($temp =~ m/.*$text$/){ return 1; } return 0; } #KMG: I Dunno whether this is required for qmail, so it works without it for now #Note to Self: The Future is always BETA ;). sub AddRecipients { my $this = shift; my ($message, @recips) = @_; my $tempintd = @{$message->{metadata}}[0]; my $temprecip; foreach $temprecip (@recips) { $tempintd = $tempintd . "T" . $temprecip . "\0"; } @{$message->{metadata}}[0] = $tempintd; } #KMG: I Dunno whether this is required for qmail, so it works without it for now #Note to Self: The Future is always BETA ;). sub DeleteRecipients { my $this = shift; my($message) = @_; my $tempintd = @{$message->{metadata}}[0]; $tempintd =~ s/T.*$//g; @{$message->{metadata}}[0] = $tempintd; } # Send a byte down the trigger FIFO of the Qmail Lock Director, so that it reads # its incoming queue. sub KickMessage { my($empty) = " "; # Using the spool directory with the last element chopped off, # find the public directory wth the trigger. my $lock = MailScanner::Config::Value('outqueuedir'); $lock =~ s/[^\/]+$/lock/; my $fh = new FileHandle; $fh->open(">$lock/trigger") or MailScanner::Log::WarnLog("KickMessage failed as couldn't write to " . "%s, %s", "$lock/trigger", $!); #not doing a SETFL, as it sets qmail-send to 100% cpu busy schedule, not exactly by the bookas in triggerpull.c #fcntl($fh, F_SETFL,fcntl($fh,F_GETFL, 0) | O_NONBLOCK) or # MailScanner::Log::WarnLog("KickMessage FCNTL Fail as couldn't get it" . # "%s", $!); syswrite $fh,$empty, 1; #KMG: This works most of the time $fh->close; return 0; } # Append, add or replace a given header with a given value. sub AddMultipleHeader { my $this = shift; my($message, $headername, $headervalue, $separator) = @_; my($multiple) = MailScanner::Config::Value('multipleheaders', $message); $this->AppendHeader ($message, MailScanner::Config::Value(lc($headername), $message), $headervalue, $separator) if $multiple eq 'append'; $this->AddHeader ($message, MailScanner::Config::Value(lc($headername), $message), $headervalue) if $multiple eq 'add'; $this->ReplaceHeader($message, MailScanner::Config::Value(lc($headername), $message), $headervalue) if $multiple eq 'replace'; } # Send an email message containing all the headers and body in a string. # Also passed in the sender's address. sub SendMessageString { my $this = shift; my($message, $email, $sender) = @_; my($fh); $fh = new FileHandle; if($sender eq '<>') { # print STDERR "\nQmail.pm: Null-Sender is $sender"; # SK: a stray empty -f can confuse the sendmail command of Qmail $fh->open('|' . MailScanner::Config::Value('sendmail', $message) . " $SendmailOptionsNoBounce") or MailScanner::Log::WarnLog("Could not send email message, %s", $!), } else { # print STDERR "\nQmail.pm: Non-null Sender is $sender"; $fh->open('|' . MailScanner::Config::Value('sendmail', $message) . " $SendmailOptions '" . $sender . "'") or MailScanner::Log::WarnLog("Could not send email message, %s", $!), } # print STDERR "\nSending Mail Warning,Sender is:\n$sender:$sender,\nMessage is:\n$email"; #$fh->open('| sendmail -t -oi -oem -F opencomputing -fopen') # or MailScanner::Log::WarnLog("Could not send email message, %s", $!), # return 0; $fh->print($email); # print STDERR "\nemail is :\n $email"; $fh->close(); #return 0; 1; } # Send an email message containing the attached MIME entity. # Also passed in the sender's address. sub SendMessageEntity { my $this = shift; my($message, $entity, $sender) = @_; my($fh); $fh = new FileHandle; if($sender eq '<>') { # print STDERR "\nQmail.pm: Null-Sender is $sender"; # SK: a stray empty -f can confuse the sendmail command of Qmail $fh->open('|' . MailScanner::Config::Value('sendmail', $message) . " $SendmailOptionsNoBounce") or MailScanner::Log::WarnLog("Could not send email message, %s", $!), } else { # print STDERR "\nQmail.pm: Non-null Sender is $sender"; $fh->open('|' . MailScanner::Config::Value('sendmail', $message) . " $SendmailOptions '" . $sender . "'") or MailScanner::Log::WarnLog("Could not send email entity, %s", $!), } $entity->print($fh); # $entity->print(STDERR); # "\nemail is :\n $email"; $fh->close(); #return 0; 1; } # Create a MessageBatch object by reading the queue and filling in # the passed-in batch object. sub CreateBatch { my $this = shift; my($batch) = @_; my($queuedirname, $queuedir, $queue1dir, $queue2dir, $MsgsInQueue); my($DirtyMsgs, $DirtyBytes, $CleanMsgs, $CleanBytes); my($HitLimit1, $HitLimit2, $HitLimit3, $HitLimit4); my($MaxCleanB, $MaxCleanM, $MaxDirtyB, $MaxDirtyM); my(%ModDate, $mta, $file, $file1, $file2, $tmpdate); my(@SortedFiles, $id, $newmessage, @queuedirnames); my($batchempty, $h1, $h2, $delay, $CriticalQueueSize); my($nlinks, $invalidfiles); $queuedir = new DirHandle; $queue1dir = new DirHandle; $queue2dir = new DirHandle; $MsgsInQueue = 0; $delay = MailScanner::Config::Value('queuescaninterval'); #print STDERR "Qmail.pm: Inq = " . %$global::MS->{inq} . "\n"; #print STDERR "Qmail.pm: dir = " . @{$global::MS->{inq}{dir}} . "\n"; @queuedirnames = @{$global::MS->{inq}{dir}}; ($MaxCleanB, $MaxCleanM, $MaxDirtyB, $MaxDirtyM) = MailScanner::MessageBatch::BatchLimits(); # If there are too many messages in the queue, start processing in # directory storage order instead of date order. $CriticalQueueSize = MailScanner::Config::Value('criticalqueuesize'); do { $batch->{messages} = {}; # Statistics logging $batch->{totalbytes} = 0; $batch->{totalmessages} = 0; # # Now do the actual work # $DirtyMsgs = 0; $DirtyBytes = 0; $CleanMsgs = 0; $CleanBytes = 0; $MsgsInQueue = 0; %ModDate = (); @SortedFiles = (); $HitLimit1 = 0; $HitLimit2 = 0; $HitLimit3 = 0; $HitLimit4 = 0; $invalidfiles = ""; my @aux_queuedirnames=@queuedirnames; # Loop through each of the inq directories while( defined($queuedirname=splice(@aux_queuedirnames, ($UnsortedBatchesLeft<=0 ? 0 : int(rand(@aux_queuedirnames))),1))) { #print STDERR "Qmail.pm: Scanning dir $queuedirname\n"; unless (chdir $queuedirname) { MailScanner::Log::WarnLog("Cannot cd to dir %s to read messages, %s", $queuedirname, $!); next; } $mta = $global::MS->{mta}; $MailScanner::SMDiskStore::HashDirDepth = 1; $queuedir->open('.') or MailScanner::Log::DieLog("Cannot open queue dir %s for reading " . "message batch, %s", $queuedirname, $!); #print STDERR "Qmail.pm: Searching " . $queuedirname . " for messages\n"; # Got to read directories and child directories here and find # files in the the child directories. while(defined($file = $queuedir->read())) { next if $file eq '.' || $file eq '..'; next unless -d $file; $queue1dir->open($file) or next; while(defined($file1 = $queue1dir->read())) { next if $file1 eq '.' || $file1 eq '..' || $file1 eq 'core'; if ($MailScanner::SMDiskStore::HashDirDepth==1) { next unless $file1 =~ /$mta->{HDFileRegexp}/; push @SortedFiles, "$queuedirname/$file/$file1"; if ($UnsortedBatchesLeft<=0) { # Running normally ($nlinks, $tmpdate) = (stat("$file/$file1"))[3,9]; # 9 = mtime next if -z _; next unless -f _; next unless -R _; next if $nlinks>1; # Catch files being moved into "deferred" $ModDate{"$queuedirname/$file/$file1"} = $tmpdate; } $MsgsInQueue++; #pri next; } } $queue1dir->close; } $queuedir->close; } # Not sorting the queue will save us considerably more time than # just skipping the sort operation, as it will enable the next bit # of code to just use the files nearest the beginning of the directory. # This should make the directory lookups much faster on filesystems # with slow directory lookups (e.g. anything except xfs). $UnsortedBatchesLeft = 40 if $CriticalQueueSize>0 && $MsgsInQueue>=$CriticalQueueSize; # SortedFiles is array of full pathnames now, not just filenames if ($UnsortedBatchesLeft>0) { $UnsortedBatchesLeft--; } else { @SortedFiles = sort { $ModDate{$a} <=> $ModDate{$b} } keys %ModDate; } $batchempty = 1; # Keep going until end of dir or have reached every imposed limit. This # now processes the files oldest first to make for fairer queue cleanups. #print STDERR "Qmail.pm: Files are " . join(', ', @SortedFiles) . "\n"; while(defined($file = shift @SortedFiles) && $HitLimit1+$HitLimit2+$HitLimit3+$HitLimit4<1) { # In accelerated queue-clearing mode, so we don't know anything yet if ($UnsortedBatchesLeft>0) { $nlinks = (stat $file)[3]; next if -z _; # Skip 0-length queue files next unless -f _; next unless -R _; next if $nlinks>1; # Files being moved into "deferred" } # Yes I know this is a hack but it will help isolate the problem #next if $ModDate{$file} > time-3; # must separate next two lines or $1 gets re-tainted by being part of # same expression as $file [mumble mumble grrr mumble mumble] #print STDERR "Qmail.pm: Reading file $file from list\n"; # Split pathname into dir and file again ($queuedirname, $h1, $file) = ($1,$2,$3) if $file =~ /^(.*)\/([0-9]+)\/([0-9]+)$/; $queuedirname = $queuedirname . '/' . $h1; next unless $file =~ /$mta->{HDFileRegexp}/; $id = $1; #print STDERR "Qmail.pm: Adding $id to batch\n"; # Lock and read the qf file. Skip this message if the lock fails. $newmessage = MailScanner::Message->new($id, $queuedirname); if ($newmessage eq 'INVALID') { $invalidfiles .= "$id "; next; } next unless $newmessage; $batch->{messages}{"$id"} = $newmessage; #print STDERR "Qmail.pm: Added $id to batch\n"; $batchempty = 0; if (MailScanner::Config::Value("virusscan", $newmessage)) { $newmessage->NeedsScanning(1); $DirtyMsgs++; $DirtyBytes += $newmessage->{size}; $HitLimit3 = 1 if $DirtyMsgs>=$MaxDirtyM; $HitLimit4 = 1 if $DirtyBytes>=$MaxDirtyB; $newmessage->WriteHeaderFile(); # Write the file of headers } else { $newmessage->NeedsScanning(0); $CleanMsgs++; $CleanBytes += $newmessage->{size}; $HitLimit1 = 1 if $CleanMsgs>=$MaxCleanM; $HitLimit2 = 1 if $CleanBytes>=$MaxCleanB; # Will have to add a WriteHeaderFile() here to implement # single-file archiving of messages. $newmessage->WriteHeaderFile(); # Write the file of headers } } # Wait a bit until I check the queue again sleep($delay) if $batchempty; } while $batchempty; # Keep trying until we get something # Log the number of invalid messages found MailScanner::Log::InfoLog("New Batch: Found invalid queue files: %s", $invalidfiles) if $invalidfiles; # Log the size of the queue if it is more than 1 batch MailScanner::Log::InfoLog("New Batch: Found %d messages waiting", $MsgsInQueue) if $MsgsInQueue > ($DirtyMsgs+$CleanMsgs); MailScanner::Log::InfoLog("New Batch: Forwarding %d unscanned messages, " . "%d bytes", $CleanMsgs, $CleanBytes) if $CleanMsgs; MailScanner::Log::InfoLog("New Batch: Scanning %d messages, %d bytes", $DirtyMsgs, $DirtyBytes) if $DirtyMsgs; #MailScanner::Log::InfoLog("New Batch: Archived %d $ArchivedMsgs messages", # $ArchivedMsgs) # if $ArchivedMsgs; $batch->{dirtymessages} = $DirtyMsgs; $batch->{dirtybytes} = $DirtyBytes; #print STDERR "Qmail.pm: Dirty stats are $DirtyMsgs msgs, $DirtyBytes bytes\n"; } # Return the array of headers from this message, optionally with a # separator on the end of each one. # This is in Sendmail.pm as the storage of the headers array is specific # to the MTA being used. sub OriginalMsgHeaders { my $this = shift; my($message, $separator) = @_; # No separator so just return the array return @{$message->{headers}}; } sub CheckQueueIsFlat{ return 1; } 1;