File: /volume1/@appstore/MailPlus-Server/bin/mimedefang.pl
#!/bin/perl
# -*- Perl -*-
#***********************************************************************
#
# mimedefang.pl
#
# Perl scanner which parses MIME messages and filters or removes
# objectionable attachments.
#
# Copyright (C) 2000-2005 Roaring Penguin Software Inc.
#
# This program may be distributed under the terms of the GNU General
# Public License, Version 2, or (at your option) any later version.
#
# This program was derived from the sample program "mimeexplode"
# in the MIME-Tools Perl module distribution.
#
#***********************************************************************
use warnings;
use strict;
# Move site library directory ahead of default library directory in @INC.
# That's so we can sanely package our own version of MIME::Base64 that
# won't conflict with the built-in one on RPM-based platforms.
use lib '/usr/share/perl5/site_perl';
require 5.008;
package main;
# My deepest apologies for this mess of globals...
use vars qw($AddWarningsInline @StatusTags
$Action $Administrator $AdminName $AdminAddress $DoStatusTags
$Changed $CSSHost $DaemonAddress $DaemonName
$DefangCounter $Domain $EntireMessageQuarantined
$MessageID $Rebuild $QuarantineCount
$QuarantineSubdir $QueueID $MsgID $MIMEDefangID
$RelayAddr $WasResent $RelayHostname
$RealRelayAddr $RealRelayHostname
$ReplacementEntity $Sender $ServerMode $Subject $SubjectCount
$ClamdSock $SophieSock $TrophieSock
$SuspiciousCharsInHeaders
$SuspiciousCharsInBody $Helo @ESMTPArgs
@SenderESMTPArgs %RecipientESMTPArgs
$TerminateAndDiscard $URL $VirusName
$CurrentVirusScannerMessage @AddedParts
$VirusScannerMessages $WarningLocation $WasMultiPart
$CWD $FprotdHost $Fprotd6Host
$NotifySenderSubject $NotifyAdministratorSubject
$ValidateIPHeader
$QuarantineSubject $SALocalTestsOnly $NotifyNoPreamble
%Actions %Stupidity @FlatParts @Recipients @Warnings %Features
$SyslogFacility $GraphDefangSyslogFacility
$MaxMIMEParts $InMessageContext $InFilterContext $PrivateMyHostName
$EnumerateRecipients $InFilterEnd $FilterEndReplacementEntity
$AddApparentlyToForSpamAssassin $WarningCounter
@VirusScannerMessageRoutines @VirusScannerEntityRoutines
$VirusScannerRoutinesInitialized
%SendmailMacros %RecipientMailers $CachedTimezone $InFilterWrapUp );
use vars qw($GeneralWarning);
use vars qw($HTMLFoundEndBody $HTMLBoilerplate $SASpamTester);
use Socket;
use IO::Socket;
use IO::Select;
use IO::Handle;
use IO::File;
use MIME::Tools 5.410 ();
use MIME::Words qw(:all);
use Digest::SHA1;
use Time::Local;
use MIME::Parser;
use Sys::Hostname;
use File::Spec qw ();
use MailPlusServer::Log;
# Detect these Perl modules at run-time. Can explicitly prevent
# loading of these modules by setting $Features{"xxx"} = 0;
#
# You can turn off ALL auto-detection by setting
# $Features{"AutoDetectPerlModules"} = 0;
sub detect_and_load_perl_modules {
if (!defined($Features{"AutoDetectPerlModules"}) or
$Features{"AutoDetectPerlModules"}) {
if (!defined($Features{"SpamAssassin"})) {
(eval 'use Mail::SpamAssassin (); $Features{"SpamAssassin"} = 1;')
or $Features{"SpamAssassin"} = 0;
}
if (!defined($Features{"HTML::Parser"})) {
(eval 'use HTML::Parser; $Features{"HTML::Parser"} = 1;')
or $Features{"HTML::Parser"} = 0;
}
if (!defined($Features{"Archive::Zip"})) {
(eval 'use Archive::Zip qw(:ERROR_CODES); $Features{"Archive::Zip"} = 1;')
or $Features{"Archive::Zip"} = 0;
}
if (!defined($Features{"Net::DNS"})) {
(eval 'use Net::DNS; $Features{"Net::DNS"} = 1;')
or $Features{"Net::DNS"} = 0;
}
}
}
undef $SASpamTester;
undef $PrivateMyHostName;
undef @VirusScannerMessageRoutines;
undef @VirusScannerEntityRoutines;
$VirusScannerRoutinesInitialized = 0;
$SALocalTestsOnly = 1;
$DoStatusTags = 0;
$Features{'Virus:AVP'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:AVP5'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:KAVSCANNER'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CLAMAV'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CLAMD'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FPROT'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FPSCAN'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:FSAV'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:HBEDV'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:VEXIRA'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NAI'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:BDC'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NVCC'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SymantecCSS'} = 0; # Ditto
$Features{'Virus:FPROTD'} = 0;
$Features{'Virus:FPROTD6'} = 0;
$Features{'Virus:SOPHIE'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SOPHOS'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:SAVSCAN'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:TREND'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:TROPHIE'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:CSAV'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Virus:NOD32'} = ('/bin/false' ne '/bin/false' ? '/bin/false' : 0);
$Features{'Path:SENDMAIL'} = '/var/packages/MailPlus-Server/target/sbin/sendmail';
$Features{'Path:QUARANTINEDIR'} = '/var/spool/@MailPlus-Server/MD-Quarantine';
$Features{'Path:SPOOLDIR'} = '/var/run/mailplus_server/mimedefang';
$Features{'Path:CONFDIR'} = '/var/packages/MailPlus-Server/target/etc/mimedefang';
# Not in server mode by default
$ServerMode = 0;
# Don't add Apparently-To: header for SpamAssassin
$AddApparentlyToForSpamAssassin = 0;
# Don't add warnings inline (add a MIME part instead)
$AddWarningsInline = 0;
# M$ Exchange or Outlook cannot display multiple Inline: parts
$Stupidity{"NoMultipleInlines"} = 0;
# Warning goes at beginning
$WarningLocation = 0;
# No limit to complexity of MIME messages
$MaxMIMEParts = -1;
# Cache the timzone calculation
$CachedTimezone = "";
# Syslog facility is "mail"
$SyslogFacility = "mail";
undef $GraphDefangSyslogFacility;
$URL = 'http://www.roaringpenguin.com/mimedefang/enduser.php3';
$CSSHost = "127.0.0.1:7777:local";
$FprotdHost = "127.0.0.1:10200";
$Fprotd6Host = "127.0.0.1:10200";
$SophieSock = '/var/run/mailplus_server/mimedefang/sophie';
$ClamdSock = '/var/run/mailplus_server/mimedefang/clamd.sock';
$TrophieSock = '/var/run/mailplus_server/mimedefang/trophie';
#***********************************************************************
# %PROCEDURE: expand_ipv6_address
# %ARGUMENTS:
# addr -- an IPv6 address
# %RETURNS:
# An IPv6 address with all zero fields explicitly expanded, and
# any field shorter than 4 hex digits padded out with zeros.
#***********************************************************************
sub expand_ipv6_address
{
my ($addr) = @_;
return '0000:0000:0000:0000:0000:0000:0000:0000' if ($addr eq '::');
if ($addr =~ /::/) {
# Do nothing if more than one pair of colons
return $addr if ($addr =~ /::.*::/);
# Make sure we don't begin or end with ::
$addr = "0000$addr" if $addr =~ /^::/;
$addr .= '0000' if $addr =~ /::$/;
# Count number of colons
my $colons = ($addr =~ tr/:/:/);
if ($colons < 8) {
my $missing = ':' . ('0000:' x (8 - $colons));
$addr =~ s/::/$missing/;
}
}
# Pad short fields
return join(':', map { (length($_) < 4 ? ('0' x (4-length($_)) . $_) : $_) } (split(/:/, $addr)));
}
#***********************************************************************
# %PROCEDURE: reverse_ip_address_for_rbl
# %ARGUMENTS:
# addr -- an IPv4 or IPv6 address
# %RETURNS:
# The appropriately-reversed address for RBL lookups.
#***********************************************************************
sub reverse_ip_address_for_rbl
{
my ($addr) = @_;
if ($addr =~ /:/) {
$addr = expand_ipv6_address($addr);
$addr =~ s/://g;
return join('.', reverse(split(//, $addr)));
}
return join('.', reverse(split(/\./, $addr)));
}
#***********************************************************************
# %PROCEDURE: in_message_context
# %ARGUMENTS:
# name -- a string to syslog if we are not in a message context
# %RETURNS:
# 1 if we are processing a message; 0 otherwise. Returns 0 if
# we're in filter_relay, filter_sender or filter_recipient
#***********************************************************************
sub in_message_context {
my($name) = @_;
return 1 if ($InMessageContext);
md_syslog('warning', "$name called outside of message context");
return 0;
}
#***********************************************************************
# %PROCEDURE: in_filter_wrapup
# %ARGUMENTS:
# name -- a string to syslog if we are in filter wrapup
# %RETURNS:
# 1 if we are not in filter wrapup; 0 otherwise.
#***********************************************************************
sub in_filter_wrapup {
my($name) = @_;
if ($InFilterWrapUp) {
md_syslog('warning', "$name called inside filter_wrapup context");
return 1;
}
return 0;
}
#***********************************************************************
# %PROCEDURE: in_filter_context
# %ARGUMENTS:
# name -- a string to syslog if we are not in a filter context
# %RETURNS:
# 1 if we are inside filter or filter_multipart, 0 otherwise.
#***********************************************************************
sub in_filter_context {
my($name) = @_;
return 1 if ($InFilterContext);
md_syslog('warning', "$name called outside of filter context");
return 0;
}
#***********************************************************************
# %PROCEDURE: in_filter_end
# %ARGUMENTS:
# name -- a string to syslog if we are not in filter_end
# %RETURNS:
# 1 if we are inside filter_end 0 otherwise.
#***********************************************************************
sub in_filter_end {
my($name) = @_;
return 1 if ($InFilterEnd);
md_syslog('warning', "$name called outside of filter_end");
return 0;
}
#***********************************************************************
# %PROCEDURE: copy_or_link
# %ARGUMENTS:
# src -- source filename
# dest -- destination filename
# %RETURNS:
# 1 on success; 0 on failure.
# %DESCRIPTION:
# Copies a file: First, attempts to make a hard link. If that fails,
# reads the file and copies the data.
#***********************************************************************
sub copy_or_link {
my($src, $dst) = @_;
return 1 if link($src, $dst);
# Link failed; do it the hard way
open(IN, "<$src") or return 0;
if (!open(OUT, ">$dst")) {
close(IN);
return 0;
}
my($n, $string);
while (($n = read(IN, $string, 4096)) > 0) {
print OUT $string;
}
close(IN);
close(OUT);
return 1;
}
#***********************************************************************
# %PROCEDURE: md_copy_orig_msg_to_work_dir
# %ARGUMENTS:
# None
# %DESCRIPTION:
# Copies original INPUTMSG file into work directory for virus-scanning
# %RETURNS:
# 1 on success, 0 on failure.
#***********************************************************************
sub md_copy_orig_msg_to_work_dir {
return if (!in_message_context("md_copy_orig_msg_to_work_dir"));
return copy_or_link("INPUTMSG", "Work/INPUTMSG");
}
#***********************************************************************
# %PROCEDURE: md_copy_orig_msg_to_work_dir_as_mbox_file
# %ARGUMENTS:
# None
# %DESCRIPTION:
# Copies original INPUTMSG file into work directory for virus-scanning
# as a valid mbox file (adds the "From $Sender mumble..." stuff.)
# %RETURNS:
# 1 on success, 0 on failure.
#***********************************************************************
sub md_copy_orig_msg_to_work_dir_as_mbox_file {
return if (!in_message_context("md_copy_orig_msg_to_work_dir_as_mbox_file"));
open(IN, "<INPUTMSG") or return 0;
unless (open(OUT, ">Work/INPUTMBOX")) {
close(IN);
return 0;
}
# Remove angle-brackets for From_ line
my $s = $Sender;
$s =~ s/^<//;
$s =~ s/>$//;
print OUT "From $s " . rfc2822_date() . "\n";
my($n, $string);
while (($n = read(IN, $string, 4096)) > 0) {
print OUT $string;
}
close(IN);
close(OUT);
return 1;
}
#***********************************************************************
# %PROCEDURE: percent_encode
# %ARGUMENTS:
# str -- a string, possibly with newlines and control characters
# %RETURNS:
# A string with unsafe chars encoded as "%XY" where X and Y are hex
# digits. For example:
# "foo\r\nbar\tbl%t" ==> "foo%0D%0Abar%09bl%25t"
#***********************************************************************
sub percent_encode {
my($str) = @_;
$str =~ s/([^\x21-\x7e]|[%\\'"])/sprintf("%%%02X", unpack("C", $1))/ge;
#" Fix emacs highlighting...
return $str;
}
#***********************************************************************
# %PROCEDURE: percent_encode_for_graphdefang
# %ARGUMENTS:
# str -- a string, possibly with newlines and control characters
# %RETURNS:
# A string with unsafe chars encoded as "%XY" where X and Y are hex
# digits. For example:
# "foo\r\nbar\tbl%t" ==> "foo%0D%0Abar%09bl%25t"
# This differs slightly from percent_encode because we don't encode
# quotes or spaces, but we do encode commas.
#***********************************************************************
sub percent_encode_for_graphdefang {
my($str) = @_;
$str =~ s/([^\x20-\x7e]|[%\\,])/sprintf("%%%02X", unpack("C", $1))/ge;
#" Fix emacs highlighting...
return $str;
}
#***********************************************************************
# %PROCEDURE: push_status_tag
# %ARGUMENTS:
# tag -- tag describing current status
# %DESCRIPTION:
# Updates status tag inside multiplexor and pushes onto stack.
# %RETURNS:
# Nothing
#***********************************************************************
sub push_status_tag
{
return unless $DoStatusTags;
my ($tag) = @_;
push(@StatusTags, $tag);
if($tag ne '') {
$tag = "> $tag";
}
set_status_tag(scalar(@StatusTags), $tag);
}
#***********************************************************************
# %PROCEDURE: pop_status_tag
# %ARGUMENTS:
# None
# %DESCRIPTION:
# Pops previous status of stack and sets tag in multiplexor.
# %RETURNS:
# Nothing
#***********************************************************************
sub pop_status_tag
{
return unless $DoStatusTags;
pop @StatusTags;
my $tag = $StatusTags[0] || 'no_tag';
set_status_tag(scalar(@StatusTags), "< $tag");
}
#***********************************************************************
# %PROCEDURE: set_status_tag
# %ARGUMENTS:
# nest_depth -- nesting depth
# tag -- status tag
# %DESCRIPTION:
# Sets the status tag for this worker inside the multiplexor.
# %RETURNS:
# Nothing
#***********************************************************************
sub set_status_tag
{
return unless $DoStatusTags;
my ($depth, $tag) = @_;
$tag ||= '';
if($tag eq '') {
print STATUS_HANDLE "\n";
return;
}
$tag =~ s/[^[:graph:]]/ /g;
if(defined($MsgID) and ($MsgID ne "NOQUEUE")) {
print STATUS_HANDLE percent_encode("$depth: $tag $MsgID") . "\n";
} else {
print STATUS_HANDLE percent_encode("$depth: $tag") . "\n";
}
}
# Try to open the status descriptor
sub init_status_tag
{
return unless $DoStatusTags;
if(open(STATUS_HANDLE, ">&=3")) {
STATUS_HANDLE->autoflush(1);
} else {
$DoStatusTags = 0;
}
}
#***********************************************************************
# %PROCEDURE: percent_decode
# %ARGUMENTS:
# str -- a string encoded by percent_encode
# %RETURNS:
# The decoded string. For example:
# "foo%0D%0Abar%09bl%25t" ==> "foo\r\nbar\tbl%t"
#***********************************************************************
sub percent_decode {
my($str) = @_;
$str =~ s/%([0-9A-Fa-f]{2})/pack("C", hex($1))/ge;
return $str;
}
my $results_fh;
=pod
=head2 write_result_line ( $cmd, @args )
Writes a result line to the RESULTS file.
$cmd should be a one-letter command for the RESULTS file
@args are the arguments for $cmd, if any. They will be percent_encode()'ed
before being written to the file.
Returns nothing.
=cut
sub write_result_line
{
my $cmd = shift;
# Do nothing if we don't yet have a dedicated working directory
if ($CWD eq $Features{'Path:SPOOLDIR'}) {
md_syslog('warning', "write_result_line called before working directory established");
return;
}
my $line = $cmd . join ' ', map { percent_encode($_) } @_;
if (!$results_fh) {
$results_fh = IO::File->new('>>RESULTS');
if (!$results_fh) {
die("Could not open RESULTS file: $!");
}
}
# We have an 8kb limit on the length of lines in RESULTS, including
# trailing newline and null used in the milter. So, we limit $cmd +
# $args to 8190 bytes.
if( length $line > 8190 ) {
md_syslog( 'warning', "Cannot write line over 8190 bytes long to RESULTS file; truncating. Original line began with: " . substr $line, 0, 40);
$line = substr $line, 0, 8190;
}
print $results_fh "$line\n" or die "Could not write RESULTS line: $!";
return;
}
#***********************************************************************
# %PROCEDURE: time_str
# %ARGUMENTS:
# None
# %RETURNS:
# The current time in the form: "YYYY-MM-DD-HH:mm:ss"
# %DESCRIPTION:
# Returns a string representing the current time.
#***********************************************************************
sub time_str {
my($sec, $min, $hour, $mday, $mon, $year, $junk);
($sec, $min, $hour, $mday, $mon, $year, $junk) = localtime(time());
return sprintf("%04d-%02d-%02d-%02d.%02d.%02d",
$year + 1900, $mon+1, $mday, $hour, $min, $sec);
}
sub hour_str {
my($sec, $min, $hour, $mday, $mon, $year, $junk);
($sec, $min, $hour, $mday, $mon, $year, $junk) = localtime(time());
return sprintf('%04d-%02d-%02d-%02d', $year+1900, $mon+1, $mday, $hour);
}
{
# Reworked detection/usage of Sys::Syslog or Unix::Syslog as
# appropriate is mostly borrowed from Log::Syslog::Abstract, to which
# I'd love to convert at some point.
my $_syslogsub = undef;
my $_openlogsub = undef;
my $_fac_map = undef;
#***********************************************************************
# %PROCEDURE: md_openlog
# %ARGUMENTS:
# tag -- syslog tag ("mimedefang.pl")
# facility -- Syslog facility as a string
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Opens a log using either Unix::Syslog or Sys::Syslog
#***********************************************************************
sub md_openlog
{
my ($tag, $facility) = @_;
if( ! defined $_openlogsub ) {
# Try Unix::Syslog first, then Sys::Syslog
eval qq{use Unix::Syslog qw( :macros ); };
if(!$@) {
($_openlogsub, $_syslogsub) = _wrap_for_unix_syslog();
} else {
eval qq{use Sys::Syslog ();};
if(!$@) {
($_openlogsub, $_syslogsub) = _wrap_for_sys_syslog();
} else {
die q{Unable to detect either Unix::Syslog or Sys::Syslog};
}
}
}
return $_openlogsub->($tag, 'pid,ndelay', $facility);
}
#***********************************************************************
# %PROCEDURE: md_syslog
# %ARGUMENTS:
# facility -- Syslog facility as a string
# msg -- message to log
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Calls syslog, either in Sys::Syslog or Unix::Syslog package
#***********************************************************************
sub md_syslog
{
my ($facility, $msg) = @_;
if(!$_syslogsub) {
md_openlog('mimedefang.pl', $SyslogFacility);
}
if (defined $MsgID && $MsgID ne 'NOQUEUE') {
return $_syslogsub->($facility, '%s', $MsgID . ': ' . $msg);
} else {
return $_syslogsub->($facility, '%s', $msg);
}
}
# SYNO: init log module
sub syno_syslog
{
my $facility = shift;
if(!$_syslogsub) {
md_openlog('mimedefang.pl', $SyslogFacility);
}
return $_syslogsub->($facility, @_);
}
MailPlusServer::Log::Configure(\&syno_syslog);
sub _wrap_for_unix_syslog
{
my $openlog = sub {
my ($id, $flags, $facility) = @_;
die q{first argument must be an identifier string} unless defined $id;
die q{second argument must be flag string} unless defined $flags;
die q{third argument must be a facility string} unless defined $facility;
return Unix::Syslog::openlog( $id, _convert_flags( $flags ), _convert_facility( $facility ) );
};
my $syslog = sub {
my $facility = shift;
return Unix::Syslog::syslog( _convert_facility( $facility ), @_);
};
return ($openlog, $syslog);
}
sub _wrap_for_sys_syslog
{
my $openlog = sub {
# Debian Stretch version is 0.33_01...dammit!
my $ver = $Sys::Syslog::VERSION;
$ver =~ s/_.*//;
if( $ver < 0.16 ) {
# Older Sys::Syslog versions still need
# setlogsock(). RHEL5 still ships with 0.13 :(
Sys::Syslog::setlogsock([ 'unix', 'tcp', 'udp' ]);
}
return Sys::Syslog::openlog(@_);
};
my $syslog = sub {
return Sys::Syslog::syslog(@_);
};
return ($openlog, $syslog);
}
sub _convert_flags
{
my($flags) = @_;
my $flag_map = {
pid => Unix::Syslog::LOG_PID(),
ndelay => Unix::Syslog::LOG_NDELAY(),
};
my $num = 0;
foreach my $thing (split(/,/, $flags)) {
next unless exists $flag_map->{$thing};
$num |= $flag_map->{$thing};
}
return $num;
}
sub _convert_facility
{
my($facility) = @_;
my $num = 0;
foreach my $thing (split(/\|/, $facility)) {
if (!defined($_fac_map) ||
!exists($_fac_map->{$thing})) {
$_fac_map->{$thing} = _fac_to_num($thing);
}
next unless defined $_fac_map->{$thing};
$num |= $_fac_map->{$thing};
}
return $num;
}
my %special = (
error => 'err',
panic => 'emerg',
);
# Some of the Unix::Syslog 'macros' tag exports aren't
# constants, so we need to ignore them if found.
my %blacklisted = map { $_ => 1 } qw(mask upto pri makepri fac);
sub _fac_to_num
{
my ($thing) = @_;
return undef if exists $blacklisted{$thing};
$thing = $special{$thing} if exists $special{$thing};
$thing = 'LOG_' . uc($thing);
return undef unless grep { $_ eq $thing } @ {$Unix::Syslog::EXPORT_TAGS{macros} };
return eval "Unix::Syslog::$thing()";
}
}
#***********************************************************************
# %PROCEDURE: fatal
# %ARGUMENTS:
# msg -- message
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Logs an error and (if we are not in server mode) exits.
#***********************************************************************
sub fatal {
my($msg) = @_;
md_syslog('err', "$msg");
if (!$ServerMode) {
die($msg);
} else {
print_and_flush("error: $msg");
}
}
#***********************************************************************
# %PROCEDURE: synthesize_received_header
# %ARGUMENTS:
# None
# %RETURNS:
# A "Received:" header for current message
# %DESCRIPTION:
# Synthesizes a valid Received: header to reflect re-mailing.
#***********************************************************************
sub synthesize_received_header {
my($hdr);
my($hn) = $SendmailMacros{"if_name"};
my $strdate = rfc2822_date();
$hn = get_host_name() unless (defined($hn) and ($hn ne ""));
if ($RealRelayHostname ne "[$RealRelayAddr]") {
$hdr = "Received: from $Helo ($RealRelayHostname [$RealRelayAddr])\n";
} else {
$hdr = "Received: from $Helo ([$RealRelayAddr])\n";
}
$hdr .= "\tby $hn (envelope-sender $Sender) (MIMEDefang) with ESMTP id $MsgID";
if ($#Recipients != 0) {
$hdr .= "; ";
} else {
$hdr .= "\n\tfor " . $Recipients[0] . "; ";
}
$hdr .= $strdate . "\n";
return $hdr;
}
#***********************************************************************
# %PROCEDURE: rebuild_entity
# %ARGUMENTS:
# out -- output entity to hold rebuilt message
# in -- input message
# %RETURNS:
# Nothing useful
# %DESCRIPTION:
# Descends through input entity and rebuilds an output entity. The
# various parts of the input entity may be modified (or even deleted)
#***********************************************************************
sub rebuild_entity {
my($out, $in) = @_;
my @parts = $in->parts;
my($type) = $in->mime_type;
$type =~ tr/A-Z/a-z/;
my($body) = $in->bodyhandle;
my($fname) = takeStabAtFilename($in);
$fname = "" unless defined($fname);
my $extension = "";
$extension = $1 if $fname =~ /(\.[^.]*)$/;
# If no Content-Type: header, add one
if (!$in->head->mime_attr('content-type')) {
$in->head->mime_attr('Content-Type', $type);
}
if (!defined($body)) {
$Action = "accept";
if (defined(&filter_multipart)) {
push_status_tag("In filter_multipart routine");
filter_multipart($in, $fname, $extension, $type);
pop_status_tag();
}
if ($Action eq "drop") {
$Changed = 1;
return 0;
}
if ($Action eq "replace") {
$Changed = 1;
$out->add_part($ReplacementEntity);
return 0;
}
my($subentity);
$subentity = $in->dup;
$subentity->parts([]);
$out->add_part($subentity);
map { rebuild_entity($subentity, $_) } @parts;
} else {
# This is where we call out to the user filter. Get some useful
# info to pass to the filter
# Default action is to accept the part
$Action = "accept";
if (defined(&filter)) {
push_status_tag("In filter routine");
filter($in, $fname, $extension, $type);
pop_status_tag();
}
# If action is "drop", just drop it silently;
if ($Action eq "drop") {
$Changed = 1;
return 0;
}
# If action is "replace", replace it with $ReplacementEntity;
if ($Action eq "replace") {
$Changed = 1;
$out->add_part($ReplacementEntity);
return 0;
}
# Otherwise, accept it
$out->add_part($in);
}
}
#***********************************************************************
# %PROCEDURE: collect_parts
# %ARGUMENTS:
# entity -- root entity to rebuild
# skip_pgp_mime -- If true, skip multipart/signed and multipart/encrypted
# parts
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Adds parts to the array @FlatParts for flattening.
#***********************************************************************
sub collect_parts {
my($entity, $skip_pgp_mime) = @_;
my(@parts) = $entity->parts;
my($part);
if ($#parts >= 0) {
if (! $skip_pgp_mime ||
(lc($entity->head->mime_type) ne "multipart/signed" and
lc($entity->head->mime_type) ne "multipart/encrypted")) {
foreach $part (@parts) {
collect_parts($part, $skip_pgp_mime);
}
}
} else {
push(@FlatParts, $entity);
}
}
#***********************************************************************
# %PROCEDURE: make_defanged_name
# %ARGUMENTS:
# None
# %RETURNS:
# A unique name of the form "defang-$n.binary"
#***********************************************************************
sub make_defanged_name {
$DefangCounter++;
return "defang-$DefangCounter.binary";
}
#***********************************************************************
# %PROCEDURE: action_rebuild
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sets a flag telling MIMEDefang to rebuild message even if it is
# unchanged.
#***********************************************************************
sub action_rebuild {
return undef unless (in_message_context("action_rebuild") && !in_filter_wrapup("action_rebuild"));
$Rebuild = 1;
}
#***********************************************************************
# %PROCEDURE: action_add_entity
# %ARGUMENTS:
# entity -- the mime entity to add (must be pre-built)
# location -- (optional) location at which to add part (default -1 = end)
# %RETURNS:
# The entity object for the new part
# %DESCRIPTION:
# Makes a note to add a part to the message. Parts are *actually* added
# at the end, which lets us correctly handle non-multipart messages or
# multipart/foo where "foo" != "mixed". Sets the rebuild flag.
#***********************************************************************
sub action_add_entity
{
my($entity, $offset) = @_;
return undef unless (in_message_context("action_add_part") && !in_filter_wrapup("action_add_part"));
$offset = -1 unless defined($offset);
push(@AddedParts, [$entity, $offset]);
action_rebuild();
return $entity;
}
#***********************************************************************
# %PROCEDURE: action_add_part
# %ARGUMENTS:
# entity -- the mime entity
# type -- the mime type
# encoding -- see MIME::Entity(8)
# data -- the data for the part
# fname -- file name
# disposition -- content-disposition header
# location -- (optional) location at which to add part (default -1 = end)
# %RETURNS:
# The entity object for the new part
# %DESCRIPTION:
# Makes a note to add a part to the message. Parts are *actually* added
# at the end, which lets us correctly handle non-multipart messages or
# multipart/foo where "foo" != "mixed". Sets the rebuild flag.
#***********************************************************************
sub action_add_part {
my ($entity) = shift;
my ($type) = shift;
my ($encoding) = shift;
my ($data) = shift;
my ($fname) = shift;
my ($disposition) = shift;
my ($offset) = shift;
return undef unless (in_message_context("action_add_part") && !in_filter_wrapup("action_add_part"));
$offset = -1 unless defined($offset);
my ($part);
$part = MIME::Entity->build(Type => $type,
Top => 0,
'X-Mailer' => undef,
Encoding => $encoding,
Data => ["$data"]);
defined ($fname) && $part->head->mime_attr("Content-Type.name" => $fname);
defined ($disposition) && $part->head->mime_attr("Content-Disposition" => $disposition);
defined ($fname) && $part->head->mime_attr("Content-Disposition.filename" => $fname);
return action_add_entity($part, $offset);
}
#***********************************************************************
# %PROCEDURE: process_added_parts
# %ARGUMENTS:
# rebuilt -- rebuilt entity
# %RETURNS:
# A new entity with parts added
# %DESCRIPTION:
# Actually adds requested parts to entity. Ensures that entity is
# of type multipart/mixed
#***********************************************************************
sub process_added_parts {
my($rebuilt) = @_;
my($entity);
# If no parts to add, do nothing
return $rebuilt if ($#AddedParts < 0);
# Make sure we have a multipart/mixed container
if (lc($rebuilt->head->mime_type) ne "multipart/mixed") {
$entity = MIME::Entity->build(Type => "multipart/mixed",
'X-Mailer' => undef);
$entity->add_part($rebuilt);
} else {
$entity = $rebuilt;
}
my $thing;
foreach $thing (@AddedParts) {
$entity->add_part($thing->[0], $thing->[1]);
}
return $entity;
}
#***********************************************************************
# %PROCEDURE: action_insert_header
# %ARGUMENTS:
# header -- header name (eg: X-My-Header)
# value -- header value (eg: any text goes here)
# position -- where to place it (eg: 0 [default] to make it first)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note for milter to insert a header in the message in the
# specified position. May not be supported on all versions of Sendmail;
# on unsupported versions, the C milter falls back to action_add_header.
#***********************************************************************
sub action_insert_header {
my($header, $value, $pos) = @_;
$pos = 0 unless defined($pos);
write_result_line('N', $header, $pos, $value);
}
#***********************************************************************
# %PROCEDURE: action_add_header
# %ARGUMENTS:
# header -- header name (eg: X-My-Header)
# value -- header value (eg: any text goes here)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note for milter to add a header to the message.
#***********************************************************************
sub action_add_header {
my($header, $value) = @_;
write_result_line('H', $header, $value);
}
#***********************************************************************
# %PROCEDURE: action_change_header
# %ARGUMENTS:
# header -- header name (eg: X-My-Header)
# value -- header value (eg: any text goes here)
# index -- index of header to change (default 1)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note for milter to change a header in the message.
#***********************************************************************
sub action_change_header {
my($header, $value, $idx) = @_;
return if (!in_message_context("action_change_header"));
$idx = 1 unless defined($idx);
write_result_line('I', $header, $idx, $value);
}
#***********************************************************************
# %PROCEDURE: action_delete_header
# %ARGUMENTS:
# header -- header name (eg: X-My-Header)
# index -- index of header to delete (default 1)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note for milter to delete a header in the message.
#***********************************************************************
sub action_delete_header {
my($header, $idx) = @_;
return if (!in_message_context("action_delete_header"));
$idx = 1 unless defined($idx);
write_result_line('J', $header, $idx);
}
#***********************************************************************
# %PROCEDURE: action_delete_all_headers
# %ARGUMENTS:
# header -- header name (eg: X-My-Header)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note for milter to delete all instances of header.
#***********************************************************************
sub action_delete_all_headers {
my($header) = @_;
return 0 if (!in_message_context("action_delete_all_headers"));
my($count, $len, $orig_header);
$orig_header = $header;
$len = length($header) + 1;
$header .= ":";
$header = lc($header);
return undef unless(open(HDRS, "<HEADERS"));
$count = 0;
while(<HDRS>) {
if (lc(substr($_, 0, $len)) eq $header) {
$count++;
}
}
close(HDRS);
# Delete in REVERSE order, in case Sendmail updates
# its count as headers are deleted... paranoid but safe.
while ($count > 0) {
action_delete_header($orig_header, $count);
$count--;
}
return 1;
}
#***********************************************************************
# %PROCEDURE: action_accept
# %ARGUMENTS:
# Ignored
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to accept the current part.
#***********************************************************************
sub action_accept {
return 0 if (!in_filter_context("action_accept"));
$Action = "accept";
return 1;
}
#***********************************************************************
# %PROCEDURE: action_accept_with_warning
# %ARGUMENTS:
# msg -- warning message
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to accept the current part, but add a warning to the
# message.
#***********************************************************************
sub action_accept_with_warning {
my($msg) = @_;
return 0 if (!in_filter_context("action_accept_with_warning"));
$Actions{'accept_with_warning'}++;
$Action = "accept";
push(@Warnings, "$msg\n");
return 1;
}
#***********************************************************************
# %PROCEDURE: message_rejected
# %ARGUMENTS:
# None
# %RETURNS:
# True if message has been rejected (with action_bounce or action_tempfail);
# false otherwise.
#***********************************************************************
sub message_rejected {
return 0 if (!in_message_context("message_rejected"));
return (defined($Actions{'tempfail'}) ||
defined($Actions{'bounce'}) ||
defined($Actions{'discard'}));
}
#***********************************************************************
# %PROCEDURE: action_drop
# %ARGUMENTS:
# Ignored
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to drop the current part without any warning.
#***********************************************************************
sub action_drop {
return 0 if (!in_filter_context("action_drop"));
$Actions{'drop'}++;
$Action = "drop";
return 1;
}
#***********************************************************************
# %PROCEDURE: action_drop_with_warning
# %ARGUMENTS:
# msg -- warning message
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to drop the current part and add a warning to the message
#***********************************************************************
sub action_drop_with_warning {
my($msg) = @_;
return 0 if (!in_filter_context("action_drop_with_warning"));
$Actions{'drop_with_warning'}++;
$Action = "drop";
push(@Warnings, "$msg\n");
return 1;
}
#***********************************************************************
# %PROCEDURE: action_replace_with_warning
# %ARGUMENTS:
# msg -- warning message
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to drop the current part and replace it with a warning
#***********************************************************************
sub action_replace_with_warning {
my($msg) = @_;
return 0 if (!in_filter_context("action_replace_with_warning"));
$Actions{'replace_with_warning'}++;
$Action = "replace";
$WarningCounter++;
$ReplacementEntity = MIME::Entity->build(Top => 0,
Type => "text/plain",
Encoding => "-suggest",
Disposition => "inline",
Filename => "warning$WarningCounter.txt",
'X-Mailer' => undef,
Data => [ "$msg\n" ]);
return 1;
}
#***********************************************************************
# %PROCEDURE: action_defang
# %ARGUMENTS:
# entity -- current part
# name -- suggested name for defanged part
# fname -- suggested filename for defanged part
# type -- suggested MIME type for defanged part
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Makes a note to defang the current part by changing its name, filename
# and possibly MIME type.
#***********************************************************************
sub action_defang {
$Changed = 1;
my($entity, $name, $fname, $type) = @_;
return 0 if (!in_filter_context("action_defang"));
$name = "" unless defined($name);
$fname = "" unless defined($fname);
$type = "application/octet-stream" unless defined($type);
$Actions{'defang'}++;
my($head) = $entity->head;
my($oldfname) = takeStabAtFilename($entity);
my($defang);
if ($name eq "" || $fname eq "") {
$defang = make_defanged_name();
}
$name = $defang if ($name eq "");
$fname = $defang if ($fname eq "");
my($warning);
if (defined(&defang_warning)) {
$warning = defang_warning($oldfname, $fname);
} else {
$warning = "An attachment named '$oldfname'";
$warning .= " was converted to '$fname'.\n";
$warning .= "To recover the file, click on the attachment and Save As\n'$oldfname' in order to access it.\n";
}
$entity->effective_type($type);
$head->replace("Content-Type", $type);
$head->mime_attr("Content-Type.name" => $name);
$head->mime_attr("Content-Disposition.filename" => $fname);
$head->mime_attr("Content-Description" => $fname);
action_accept_with_warning("$warning");
return 1;
}
#***********************************************************************
# %PROCEDURE: action_external_filter
# %ARGUMENTS:
# entity -- current part
# cmd -- UNIX command to run
# %RETURNS:
# 1 on success, 0 otherwise.
# %DESCRIPTION:
# Pipes the part through the UNIX command $cmd, and replaces the
# part with the result of running the filter.
#***********************************************************************
sub action_external_filter {
my($entity, $cmd) = @_;
return 0 if (!in_filter_context("action_external_filter"));
# Copy the file
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return 0;
}
if (!defined($body->path)) {
return 0;
}
unless(copy_or_link($body->path, "FILTERINPUT")) {
md_syslog('err', "Could not open FILTERINPUT: $!");
return(0);
}
# Run the filter
my($status) = system($cmd);
# Filter failed if non-zero exit
if ($status % 255) {
md_syslog('err', "External filter exited with non-zero status $status");
return 0;
}
# If filter didn't produce FILTEROUTPUT, do nothing
return 1 if (! -r "FILTEROUTPUT");
# Rename FILTEROUTPUT over original path
unless (rename("FILTEROUTPUT", $body->path)) {
md_syslog('err', "Could not rename FILTEROUTPUT to path: $!");
return(0);
}
$Changed = 1;
$Actions{'external_filter'}++;
return 1;
}
#***********************************************************************
# %PROCEDURE: action_quarantine
# %ARGUMENTS:
# entity -- current part
# msg -- warning message
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Similar to action_drop_with_warning, but e-mails the MIMEDefang
# administrator a notification, and quarantines the part in the
# quarantine directory.
#***********************************************************************
sub action_quarantine {
my($entity, $msg) = @_;
return 0 if (!in_filter_context("action_quarantine"));
$Action = "drop";
push(@Warnings, "$msg\n");
# Can't handle path-less bodies
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return 0;
}
if (!defined($body->path)) {
return 0;
}
get_quarantine_dir();
if ($QuarantineSubdir eq "") {
# Could not create quarantine directory
return 0;
}
$Actions{'quarantine'}++;
$QuarantineCount++;
# Save the part
copy_or_link($body->path, "$QuarantineSubdir/PART.$QuarantineCount.BODY");
# Save the part's headers
if (open(OUT, ">$QuarantineSubdir/PART.$QuarantineCount.HEADERS")) {
$entity->head->print(\*OUT);
close(OUT);
}
# Save the messages
if (open(OUT, ">$QuarantineSubdir/MSG.$QuarantineCount")) {
print OUT "$msg\n";
close(OUT);
}
return 1;
}
#***********************************************************************
# %PROCEDURE: action_sm_quarantine
# %ARGUMENTS:
# reason -- reason for quarantine
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Asks Sendmail to quarantine message in mqueue using Sendmail's
# smfi_quarantine facility.
#***********************************************************************
sub action_sm_quarantine {
my($reason) = @_;
return if (!in_message_context("action_sm_quarantine"));
$Actions{'sm_quarantine'} = 1;
write_result_line("Q", $reason);
}
sub get_quarantine_dir {
# If quarantine dir has already been made, return it.
if ($QuarantineSubdir ne "") {
return $QuarantineSubdir;
}
my($counter) = 0;
my($tries);
my($success) = 0;
my($tm);
$tm = time_str();
my $hour = hour_str();
my $hour_dir = sprintf("%s/%s", $Features{'Path:QUARANTINEDIR'}, $hour);
mkdir($hour_dir, 0750);
if (! -d $hour_dir) {
return "";
}
do {
$counter++;
$QuarantineSubdir = sprintf("%s/%s/qdir-%s-%03d",
$Features{'Path:QUARANTINEDIR'}, $hour, $tm, $counter);
if (mkdir($QuarantineSubdir, 0750)) {
$success = 1;
}
} while(!$success && ($tries++ < 1000));
if (!$success) {
$QuarantineSubdir = "";
return "";
}
# Write the sender and recipient info
if (open(OUT, ">$QuarantineSubdir/SENDER")) {
print OUT "$Sender\n";
close(OUT);
}
if (open(OUT, ">$QuarantineSubdir/SENDMAIL-QID")) {
print OUT "$QueueID\n";
close(OUT);
}
if (open(OUT, ">$QuarantineSubdir/RECIPIENTS")) {
my($s);
foreach $s (@Recipients) {
print OUT "$s\n";
}
close(OUT);
}
# Copy message headers
if (open(OUT, ">$QuarantineSubdir/HEADERS")) {
if (open(IN, "<HEADERS")) {
while(<IN>) {
print OUT;
}
close(IN);
}
close(OUT);
}
return $QuarantineSubdir;
}
#***********************************************************************
# %PROCEDURE: action_quarantine_entire_message
# %ARGUMENTS:
# msg -- quarantine message (optional)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Puts a copy of the entire message in the quarantine directory.
#***********************************************************************
sub action_quarantine_entire_message {
my($msg) = @_;
return 0 if (!in_message_context("action_quarantine_entire_message"));
# If no parts have yet been quarantined, create the quarantine subdirectory
# and write useful info there
get_quarantine_dir();
if ($QuarantineSubdir eq "") {
# Could not create quarantine directory
return 0;
}
# Don't copy message twice
if ($EntireMessageQuarantined) {
return 1;
}
$Actions{'quarantine_entire_message'}++;
if (defined($msg) && ($msg ne "")) {
if (open(OUT, ">$QuarantineSubdir/MSG.0")) {
print OUT "$msg\n";
close(OUT);
}
}
$EntireMessageQuarantined = 1;
copy_or_link("INPUTMSG", "$QuarantineSubdir/ENTIRE_MESSAGE");
return 1;
}
#***********************************************************************
# %PROCEDURE: action_bounce
# %ARGUMENTS:
# reply -- SMTP reply text (eg: "Not allowed, sorry")
# code -- SMTP reply code (eg: 554)
# DSN -- DSN code (eg: 5.7.1)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Causes the SMTP transaction to fail with an SMTP 554 failure code and the
# specified reply text. If code or DSN are omitted or invalid,
# use 554 and 5.7.1.
#***********************************************************************
sub action_bounce {
my($reply, $code, $dsn) = @_;
return 0 if (!in_message_context("action_bounce"));
$reply = "Forbidden for policy reasons" unless (defined($reply) and ($reply ne ""));
$code = 554 unless (defined($code) and $code =~ /^5\d\d$/);
$dsn = "5.7.1" unless (defined($dsn) and $dsn =~ /^5\.\d{1,3}\.\d{1,3}$/);
write_result_line('B', $code, $dsn, $reply);
$Actions{'bounce'}++;
return 1;
}
#***********************************************************************
# %PROCEDURE: action_discard
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Causes the entire message to be silently discarded without without
# notifying anyone.
#***********************************************************************
sub action_discard {
return 0 if (!in_message_context("action_discard"));
write_result_line("D", "");
$Actions{'discard'}++;
return 1;
}
#***********************************************************************
# %PROCEDURE: action_notify_sender
# %ARGUMENTS:
# msg -- a message to send
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Causes an e-mail to be sent to the sender containing $msg
#***********************************************************************
sub action_notify_sender {
my($msg) = @_;
return 0 if (!in_message_context("action_notify_sender"));
if ($Sender eq '<>') {
md_syslog('err', "Skipped action_notify_sender: Sender = <>");
return 0;
}
if ($VirusName ne "") {
md_syslog('err', "action_notify_sender disabled when virus is detected");
return 0;
}
if (open(FILE, ">>NOTIFICATION")) {
print FILE $msg;
close(FILE);
$Actions{'notify_sender'}++;
return 1;
}
md_syslog('err', "Could not create NOTIFICATION file: $!");
return 0;
}
#***********************************************************************
# %PROCEDURE: action_notify_administrator
# %ARGUMENTS:
# msg -- a message to send
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Causes an e-mail to be sent to the MIMEDefang administrator
# containing $msg
#***********************************************************************
sub action_notify_administrator {
my($msg) = @_;
if (!$InMessageContext) {
send_admin_mail($NotifyAdministratorSubject, $msg);
return 1;
}
if (open(FILE, ">>ADMIN_NOTIFICATION")) {
print FILE $msg;
close(FILE);
$Actions{'notify_administrator'}++;
return 1;
}
md_syslog('err', "Could not create ADMIN_NOTIFICATION file: $!");
return 0;
}
#***********************************************************************
# %PROCEDURE: relay_is_blacklisted
# %ARGUMENTS:
# addr -- IP address of relay host.
# domain -- domain of blacklist server (eg: inputs.orbz.org)
# %RETURNS:
# The result of the lookup (eg 127.0.0.2)
#***********************************************************************
sub relay_is_blacklisted {
my($addr, $domain) = @_;
$addr = reverse_ip_address_for_rbl($addr) . ".$domain";
my $hn;
$hn = gethostbyname($addr);
return 0 unless defined($hn);
return $hn if ($hn);
# Hostname is defined, but false -- return 1 instead.
return 1;
}
#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi
# %ARGUMENTS:
# addr -- IP address of relay host.
# timeout -- number of seconds after which to time out
# answers_wanted -- if positive, return as soon as this many positive answers
# have been received.
# domains -- an array of domains to check
# res (optional) -- A Net::DNS::Resolver object. If you don't pass
# one in, we'll generate one and use it.
# %RETURNS:
# A hash table with one entry per original domain. Entries in hash
# will be:
# { $domain => $return }, where $return is one of SERVFAIL, NXDOMAIN or
# a list of IP addresses as a dotted-quad.
#***********************************************************************
sub relay_is_blacklisted_multi {
my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
my($domain, $sock);
my $ans = {};
my $positive_answers = 0;
foreach $domain (@{$domains}) {
$ans->{$domain} = 'SERVFAIL';
}
unless ($Features{"Net::DNS"}) {
md_syslog('err', "Attempted to call relay_is_blacklisted_multi, but Perl module Net::DNS is not installed");
return $ans;
}
push_status_tag("Doing RBL Lookup");
my %sock_to_domain;
# Reverse the address
$addr = reverse_ip_address_for_rbl($addr);
# If user did not pass in a Net::DNS::Resolver object, generate one.
unless (defined($res and (UNIVERSAL::isa($res, "Net::DNS::Resolver")))) {
$res = Net::DNS::Resolver->new;
$res->defnames(0);
}
my $sel = IO::Select->new();
# Send out the queries
foreach $domain (@{$domains}) {
$sock = $res->bgsend("$addr.$domain", 'A');
$sock_to_domain{$sock} = $domain;
$sel->add($sock);
}
# Now wait for them to come back.
my $terminate = time() + $timeout;
while (time() <= $terminate) {
my $expire = $terminate - time();
# Avoid fractional wait for select which gets truncated.
# So we may end up timing out after 1 extra second... no big deal
$expire = 1 if ($expire < 1);
my @ready;
@ready = $sel->can_read($expire);
foreach $sock (@ready) {
my $pack = $res->bgread($sock);
$sel->remove($sock);
$domain = $sock_to_domain{$sock};
undef($sock);
my($rr, $rcode);
$rcode = $pack->header->rcode;
if ($rcode eq "SERVFAIL" or $rcode eq "NXDOMAIN") {
$ans->{$domain} = $rcode;
next;
}
my $got_one = 0;
foreach $rr ($pack->answer) {
if ($rr->type eq 'A') {
$got_one = 1;
if ($ans->{$domain} eq "SERVFAIL") {
$ans->{$domain} = ();
}
push(@{$ans->{$domain}}, $rr->address);
}
}
$positive_answers++ if ($got_one);
}
last if ($sel->count() == 0 or
($answers_wanted > 0 and $positive_answers >= $answers_wanted));
}
pop_status_tag();
return $ans;
}
#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi_count
# %ARGUMENTS:
# addr -- IP address of relay host.
# timeout -- number of seconds after which to time out
# answers_wanted -- if positive, return as soon as this many positive answers
# have been received.
# domains -- an array of domains to check
# res (optional) -- A Net::DNS::Resolver object. If you don't pass
# one in, we'll generate one and use it.
# %RETURNS:
# A number indicating how many RBLs the host was blacklisted in.
#***********************************************************************
sub relay_is_blacklisted_multi_count {
my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
my $ans = relay_is_blacklisted_multi($addr,
$timeout,
$answers_wanted,
$domains,
$res);
my $count = 0;
my $domain;
foreach $domain (keys(%$ans)) {
my $r = $ans->{$domain};
if (ref($r) eq "ARRAY" and $#{$r} >= 0) {
$count++;
}
}
return $count;
}
#***********************************************************************
# %PROCEDURE: relay_is_blacklisted_multi_list
# %ARGUMENTS:
# addr -- IP address of relay host.
# timeout -- number of seconds after which to time out
# answers_wanted -- if positive, return as soon as this many positive answers
# have been received.
# domains -- an array of domains to check
# res (optional) -- A Net::DNS::Resolver object. If you don't pass
# one in, we'll generate one and use it.
# %RETURNS:
# An array indicating the domains in which the relay is blacklisted.
#***********************************************************************
sub relay_is_blacklisted_multi_list {
my($addr, $timeout, $answers_wanted, $domains, $res) = @_;
my $ans = relay_is_blacklisted_multi($addr,
$timeout,
$answers_wanted,
$domains,
$res);
my $result = [];
my $domain;
foreach $domain (keys(%$ans)) {
my $r = $ans->{$domain};
if (ref($r) eq "ARRAY" and $#{$r} >= 0) {
push @$result, $domain;
}
}
# If in list context, return the array. Otherwise, return
# array reference.
return (wantarray ? @$result : $result);
}
#***********************************************************************
# %PROCEDURE: signal_unchanged
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Tells mimedefang C program message has not been altered (does nothing...)
#***********************************************************************
sub signal_unchanged {
}
#***********************************************************************
# %PROCEDURE: signal_changed
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Tells mimedefang C program message has been altered.
#***********************************************************************
sub signal_changed {
write_result_line("C", "");
}
#***********************************************************************
# %PROCEDURE: get_host_name
# %ARGUMENTS:
# None
# %RETURNS:
# Local host name, if it could be determined.
#***********************************************************************
sub get_host_name {
# Use cached value if we have it
return $PrivateMyHostName if defined($PrivateMyHostName);
# Otherwise execute "hostname"
$PrivateMyHostName = hostname;
$PrivateMyHostName = "localhost" unless defined($PrivateMyHostName);
# Now make it FQDN
my($fqdn) = gethostbyname($PrivateMyHostName);
$PrivateMyHostName = $fqdn if (defined $fqdn) and length($fqdn) > length($PrivateMyHostName);
return $PrivateMyHostName;
}
#***********************************************************************
# %PROCEDURE: gen_date_msgid_headers
# %ARGUMENTS:
# None
# %RETURNS:
# A string like this: "Date: <rfc2822-date>\nMessage-ID: <message@id.com>\n"
# %DESCRIPTION:
# Generates RFC2822-compliant Date and Message-ID headers.
#***********************************************************************
sub gen_date_msgid_headers {
return "Date: " . rfc2822_date() . "\n" . gen_msgid_header();
}
sub rfc2822_date
{
my $now = time();
my ($ss, $mm, $hh, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($now);
return sprintf("%s, %02d %s %04d %02d:%02d:%02d %s",
(qw( Sun Mon Tue Wed Thu Fri Sat ))[$wday],
$mday,
(qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec ))[$mon],
$year + 1900,
$hh,
$mm,
$ss,
header_timezone($now)
);
}
sub header_timezone
{
return $CachedTimezone if ($CachedTimezone ne "");
my($now) = @_;
my($sec, $min, $hr, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($now);
my $a = timelocal($sec, $min, $hr, $mday, $mon, $year);
my $b = timegm($sec, $min, $hr, $mday, $mon, $year);
my $c = ($b - $a) / 60;
$hr = int(abs($c) / 60);
$min = abs($c) - 60 * $hr;
if ($c >= 0) {
$CachedTimezone = sprintf("+%02d%02d", $hr, $min);
} else {
$CachedTimezone = sprintf("-%02d%02d", $hr, $min);
}
return $CachedTimezone;
}
#***********************************************************************
# %PROCEDURE: gen_msgid_header
# %ARGUMENTS:
# None
# %RETURNS:
# A string like this: "Message-ID: <message@id.com>\n"
# %DESCRIPTION:
# Generates RFC2822-compliant Message-ID headers.
#***********************************************************************
sub gen_msgid_header {
my ($ss, $mm, $hh, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
# Generate a "random" message ID that looks
# similiar to sendmail's for SpamAssassin comparing
# Received / MessageID QueueID
return sprintf("Message-ID: <%04d%02d%02d%02d%02d.%s\@%s>\n",
$year + 1900,
$mon + 1,
$mday,
$hh,
$mm,
($QueueID eq 'NOQUEUE' ? rand() : $QueueID),
get_host_name()
);
}
#***********************************************************************
# %PROCEDURE: send_quarantine_notifications
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sends quarantine notification message, if anything was quarantined
#***********************************************************************
sub send_quarantine_notifications {
# If there are quarantined parts, e-mail a report
if ($QuarantineCount > 0 || $EntireMessageQuarantined) {
my($body);
$body = "From: $DaemonName <$DaemonAddress>\n";
$body .= "To: \"$AdminName\" <$AdminAddress>\n";
$body .= gen_date_msgid_headers();
$body .= "Auto-Submitted: auto-generated\n";
$body .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
$body .= "Precedence: bulk\n";
$body .= "Subject: $QuarantineSubject\n\n";
if ($QuarantineCount >= 1) {
$body .= "An e-mail had $QuarantineCount part";
$body .= "s" if ($QuarantineCount != 1);
} else {
$body .= "An e-mail message was";
}
$body .= " quarantined in the directory\n";
$body .= "$QuarantineSubdir on " . get_host_name() . ".\n\n";
$body .= "The sender was '$Sender'.\n\n" if defined($Sender);
$body .= "The Sendmail queue identifier was $QueueID.\n\n" if ($QueueID ne "NOQUEUE");
$body .= "The relay machine was $RelayHostname ($RelayAddr).\n\n";
if ($EntireMessageQuarantined) {
$body .= "The entire message was quarantined in $QuarantineSubdir/ENTIRE_MESSAGE\n\n";
}
my($recip);
foreach $recip (@Recipients) {
$body .= "Recipient: $recip\n";
}
my $donemsg = 0;
my $i;
for ($i=0; $i<=$QuarantineCount; $i++) {
if (open(IN, "<$QuarantineSubdir/MSG.$i")) {
if (!$donemsg) {
$body .= "Quarantine Messages:\n";
$donemsg = 1;
}
while(<IN>) {
$body .= $_;
}
close(IN);
}
}
if ($donemsg) {
$body .= "\n";
}
if (open(IN, "<$QuarantineSubdir/HEADERS")) {
$body .= "\n----------\nHere are the message headers:\n";
while(<IN>) {
$body .= $_;
}
close(IN);
}
for ($i=1; $i<=$QuarantineCount; $i++) {
if (open(IN, "<$QuarantineSubdir/PART.$i.HEADERS")) {
$body .= "\n----------\nHere are the headers for quarantined part $i:\n";
while(<IN>) {
$body .= $_;
}
close(IN);
}
}
if ($#Warnings >= 0) {
$body .= "\n----------\nHere are the warning details:\n\n";
$body .= "@Warnings";
}
send_mail($DaemonAddress, $DaemonName, $AdminAddress, $body);
}
}
#***********************************************************************
# %PROCEDURE: signal_complete
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Tells mimedefang C program Perl filter has finished successfully.
# Also mails any quarantine notifications and sender notifications.
#***********************************************************************
sub signal_complete {
# Send notification to sender, if required
if ($Sender ne '<>' && -r "NOTIFICATION") {
my($body);
$body = "From: $DaemonName <$DaemonAddress>\n";
$body .= "To: $Sender\n";
$body .= gen_date_msgid_headers();
$body .= "Auto-Submitted: auto-generated\n";
$body .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
$body .= "Precedence: bulk\n";
$body .= "Subject: $NotifySenderSubject\n\n";
unless($NotifyNoPreamble) {
$body .= "An e-mail you sent with message-id $MessageID\n";
$body .= "was modified by our mail scanning software.\n\n";
$body .= "The recipients were:";
my($recip);
foreach $recip (@Recipients) {
$body .= " $recip";
}
$body .= "\n\n";
}
if (open(FILE, "<NOTIFICATION")) {
unless($NotifyNoPreamble) {
$body .= "Here are the details of the modification:\n\n";
}
while(<FILE>) {
$body .= $_;
}
close(FILE);
}
send_mail($DaemonAddress, $DaemonName, $Sender, $body);
}
# Send notification to administrator, if required
if (-r "ADMIN_NOTIFICATION") {
my $body = "";
if (open(FILE, "<ADMIN_NOTIFICATION")) {
$body .= join('', <FILE>);
close(FILE);
send_admin_mail($NotifyAdministratorSubject, $body);
}
}
# Syslog some info if any actions were taken
my($msg) = "";
my($key, $num);
foreach $key (sort keys(%Actions)) {
$num = $Actions{$key};
$msg .= " $key=$num";
}
if ($msg ne "") {
md_syslog('debug', "filter: $msg");
}
write_result_line("F", "");
if ($results_fh) {
$results_fh->close() or die("Could not close RESULTS file: $!");
undef $results_fh;
}
if ($ServerMode) {
print_and_flush('ok');
}
}
#***********************************************************************
# %PROCEDURE: send_mail
# %ARGUMENTS:
# fromAddr -- address of sender
# fromFull -- full name of sender
# recipient -- address of recipient
# body -- mail message (including headers) newline-terminated
# deliverymode -- optional sendmail delivery mode arg (default "-odd")
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sends a mail message using Sendmail. Invokes Sendmail without involving
# the shell, so that shell metacharacters won't cause security problems.
#***********************************************************************
sub send_mail {
my($fromAddr, $fromFull, $recipient, $body, $deliverymode) = @_;
$deliverymode = "-odd" unless defined($deliverymode);
if ($deliverymode ne "-odb" &&
$deliverymode ne "-odq" &&
$deliverymode ne "-odd" &&
$deliverymode ne "-odi") {
$deliverymode = "-odd";
}
my($pid);
# Fork and exec for safety instead of involving shell
$pid = open(CHILD, "|-");
if (!defined($pid)) {
md_syslog('err', "Cannot fork to run sendmail");
return;
}
if ($pid) { # In the parent -- pipe mail message to the child
print CHILD $body;
close(CHILD);
return;
}
# In the child -- invoke Sendmail
# Direct stdout to stderr, or we will screw up communication with
# the multiplexor..
open(STDOUT, ">&STDERR");
my(@cmd);
if ($fromAddr ne "") {
push(@cmd, "-f$fromAddr");
} else {
push(@cmd, "-f<>");
}
if ($fromFull ne "") {
push(@cmd, "-F$fromFull");
}
push(@cmd, $deliverymode);
push(@cmd, "-Ac");
push(@cmd, "-oi");
push(@cmd, "--");
push(@cmd, $recipient);
# In curlies to silence Perl warning...
my $sm;
$sm = $Features{'Path:SENDMAIL'};
{ exec($sm, @cmd); }
# exec failed!
md_syslog('err', "Could not exec $sm: $!");
exit(1);
# NOTREACHED
}
#***********************************************************************
# %PROCEDURE: resend_message_one_recipient
# %ARGUMENTS:
# recip -- a single recipient
# deliverymode -- optional sendmail delivery mode arg (default "-odd")
# %RETURNS:
# True on success; false on failure.
# %DESCRIPTION:
# Re-sends the message (as if it came from original sender) to
# a single recipient.
#***********************************************************************
sub resend_message_one_recipient {
my($recip, $deliverymode, $extra_headers) = @_;
return resend_message_specifying_mode($deliverymode, [ $recip ], $extra_headers);
}
#***********************************************************************
# %PROCEDURE: send_admin_mail
# %ARGUMENTS:
# subject -- mail subject
# body -- mail message (without headers) newline-terminated
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sends a mail message to the administrator
#***********************************************************************
sub send_admin_mail {
my ($subject, $body) = @_;
my $mail;
$mail = "From: $DaemonName <$DaemonAddress>\n";
$mail .= "To: \"$AdminName\" <$AdminAddress>\n";
$mail .= gen_date_msgid_headers();
$mail .= "Auto-Submitted: auto-generated\n";
$mail .= "MIME-Version: 1.0\nContent-Type: text/plain\n";
$mail .= "Precedence: bulk\n";
$mail .= "Subject: $subject\n\n";
$mail .= $body;
send_mail($DaemonAddress, $DaemonName, $AdminAddress, $mail);
}
#***********************************************************************
# %PROCEDURE: resend_message_specifying_mode
# %ARGUMENTS:
# deliverymode -- delivery mode
# recipients -- reference to list of recipients to resend message to.
# %RETURNS:
# True on success; false on failure.
# %DESCRIPTION:
# Re-sends the message (as if it came from original sender) to
# a list of recipients.
#***********************************************************************
sub resend_message_specifying_mode {
my($deliverymode, $recips, $extra_headers) = @_;
return 0 if (!in_message_context("resend_message_specifying_mode"));
$deliverymode = "-odd" unless defined($deliverymode);
if ($deliverymode ne "-odb" &&
$deliverymode ne "-odq" &&
$deliverymode ne "-odd" &&
$deliverymode ne "-odi") {
$deliverymode = "-odd";
}
# Fork and exec for safety instead of involving shell
my $pid = open(CHILD, "|-");
if (!defined($pid)) {
md_syslog('err', "Cannot fork to resend message");
return 0;
}
if ($pid) { # In the parent -- pipe mail message to the child
unless (open(IN, "<INPUTMSG")) {
md_syslog('err', "Could not open INPUTMSG in resend_message: $!");
return 0;
}
# Preserve relay's IP address if possible...
if ($ValidateIPHeader =~ /^X-MIMEDefang-Relay/) {
print CHILD "$ValidateIPHeader: $RelayAddr\n"
}
if ($extra_headers ne '') {
print CHILD "$extra_headers\n";
}
# Synthesize a Received: header
print CHILD synthesize_received_header();
# Copy message over
while(<IN>) {
print CHILD;
}
close(IN);
if (!close(CHILD)) {
if ($!) {
md_syslog('err', "sendmail failure in resend_message: $!");
} else {
md_syslog('err', "sendmail non-zero exit status in resend_message: $?");
}
return 0;
}
return 1;
}
# In the child -- invoke Sendmail
# Direct stdout to stderr, or we will screw up communication with
# the multiplexor..
open(STDOUT, ">&STDERR");
my(@cmd);
if ($Sender eq "") {
push(@cmd, "-f<>");
} else {
push(@cmd, "-f$Sender");
}
push(@cmd, $deliverymode);
push(@cmd, "-Ac");
push(@cmd, "-oi");
push(@cmd, "--");
push @cmd, @$recips;
# In curlies to silence Perl warning...
my $sm;
$sm = $Features{'Path:SENDMAIL'};
{ exec($sm, @cmd); }
# exec failed!
md_syslog('err', "Could not exec $sm: $!");
exit(1);
# NOTREACHED
}
#***********************************************************************
# %PROCEDURE: resend_message
# %ARGUMENTS:
# recipients -- list of recipients to resend message to.
# %RETURNS:
# True on success; false on failure.
# %DESCRIPTION:
# Re-sends the message (as if it came from original sender) to
# a list of recipients.
#***********************************************************************
sub resend_message {
return 0 if (!in_message_context("resend_message"));
my(@recips);
@recips = @_;
return resend_message_specifying_mode("-odd", \@recips);
}
#***********************************************************************
# %PROCEDURE: stream_by_recipient
# %ARGUMENTS:
# None
# %RETURNS:
# True if message was resent; false if it was for only a single user
# %DESCRIPTION:
# If there is more than one recipient, re-send the message once per
# recipient.
# MAKE SURE your sendmail is set up to use
# /etc/mail/submit.cf.
#
# Use this
# ONLY from filter_begin() and ONLY if you have Sendmail 8.12 or newer,
# and ONLY if locally-submitted mail goes via SMTP.
#***********************************************************************
sub stream_by_recipient {
return 0 if (!in_message_context("stream_by_recipient"));
if ($#Recipients <= 0) {
# Only one recipient (or none??)
return 0;
}
my($recip);
foreach $recip (@Recipients) {
if (!resend_message_one_recipient($recip)) {
md_syslog('crit', 'stream_by_recipient: COULD NOT RESEND MESSAGE - PLEASE INVESTIGATE');
action_bounce("Unable to stream message");
# We return 1 to avoid rest of filter
return 1;
}
}
$TerminateAndDiscard = 1;
return 1;
}
#***********************************************************************
# %PROCEDURE: stream_by_domain
# %ARGUMENTS:
# None
# %RETURNS:
# True if message was resent; false if it was for only a single domain.
# %DESCRIPTION:
# Checks each recipient. If recipients are in more than one domain
# (foo@abc.com, foo@xyz.com), the message is re-sent (once per domain),
# action_discard() is called, and scanning terminates. Use this
# ONLY from filter_begin() and ONLY if you have Sendmail 8.12 or newer,
# and ONLY if locally-submitted mail goes via SMTP.
#***********************************************************************
sub stream_by_domain {
my(%Domains, $recip, $dom, $nkeys, $key);
return 0 if (!in_message_context("stream_by_domain"));
# Grab list of domains of recipients
foreach $recip (@Recipients) {
$dom = $recip;
# Remove angle brackets
$dom =~ s/[<>]//g;
# Get domain
$dom =~ s/.*\@//;
if (!defined($Domains{$dom})) {
$Domains{$dom} = [ $recip ];
} else {
push( @{ $Domains{$dom} }, $recip);
}
$Domain = $dom;
}
$nkeys = keys(%Domains);
if ($nkeys > 1) {
# More than one domain. Cancel and resend
foreach $key (keys %Domains) {
if (!resend_message(@{$Domains{$key}})) {
md_syslog('crit', 'stream_by_domain: COULD NOT RESEND MESSAGE - PLEASE INVESTIGATE');
action_bounce("Unable to stream message");
# We return 1 to avoid rest of filter
return 1;
}
}
$TerminateAndDiscard = 1;
return 1;
}
return 0;
}
=pod
=head2 takeStabAtFilename ( $entity )
Makes a guess at a filename for the attachment. Calls MIME::Head's
recommended_filename() method, which tries 'Content-Disposition.filename'and if
not found, 'Content-Type.name'.
Returns a MIME-decoded filename, or a blank string if none found.
=cut
sub takeStabAtFilename
{
my ($entity) = @_;
my $guess = $entity->head->recommended_filename();
if( defined $guess ) {
return scalar( decode_mimewords( $guess ) );
}
return '';
}
#***********************************************************************
# %PROCEDURE: re_match
# %ARGUMENTS:
# entity -- a MIME entity
# regexp -- a regular expression
# %RETURNS:
# 1 if either of Content-Disposition.filename or Content-Type.name
# matches regexp; 0 otherwise. Matching is
# case-insensitive
# %DESCRIPTION:
# A helper function for filter.
#***********************************************************************
sub re_match {
my($entity, $regexp) = @_;
my($head) = $entity->head;
my($guess) = $head->mime_attr("Content-Disposition.filename");
if (defined($guess)) {
$guess = decode_mimewords($guess);
return 1 if $guess =~ /$regexp/i;
}
$guess = $head->mime_attr("Content-Type.name");
if (defined($guess)) {
$guess = decode_mimewords($guess);
return 1 if $guess =~ /$regexp/i;
}
return 0;
}
#***********************************************************************
# %PROCEDURE: re_match_ext
# %ARGUMENTS:
# entity -- a MIME entity
# regexp -- a regular expression
# %RETURNS:
# 1 if the EXTENSION part of either of Content-Disposition.filename or
# Content-Type.name matches regexp; 0 otherwise.
# Matching is case-insensitive.
# %DESCRIPTION:
# A helper function for filter.
#***********************************************************************
sub re_match_ext {
my($entity, $regexp) = @_;
my($ext);
my($head) = $entity->head;
my($guess) = $head->mime_attr("Content-Disposition.filename");
if (defined($guess)) {
$guess = decode_mimewords($guess);
return 1 if (($guess =~ /(\.[^.]*)$/) && ($1 =~ /$regexp/i));
}
$guess = $head->mime_attr("Content-Type.name");
if (defined($guess)) {
$guess = decode_mimewords($guess);
return 1 if (($guess =~ /(\.[^.]*)$/) && ($1 =~ /$regexp/i));
}
return 0;
}
#***********************************************************************
# %PROCEDURE: re_match_in_zip_directory
# %ARGUMENTS:
# fname -- name of ZIP file
# regexp -- a regular expression
# %RETURNS:
# 1 if the EXTENSION part of any file in the zip archive matches regexp
# Matching is case-insensitive.
# %DESCRIPTION:
# A helper function for filter.
#***********************************************************************
no strict 'subs';
sub dummy_zip_error_handler {} ;
sub re_match_in_zip_directory {
my($zipname, $regexp) = @_;
unless ($Features{"Archive::Zip"}) {
md_syslog('err', "Attempted to use re_match_in_zip_directory, but Perl module Archive::Zip is not installed.");
return 0;
}
my $zip = Archive::Zip->new();
# Prevent carping about errors
Archive::Zip::setErrorHandler(\&dummy_zip_error_handler);
if ($zip->read($zipname) == AZ_OK()) {
foreach my $member ($zip->members()) {
my $file = $member->fileName();
return 1 if ($file =~ /$regexp/i);
}
}
return 0;
}
use strict 'subs';
#***********************************************************************
# %PROCEDURE: entity_contains_virus_nai
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by NAI uvscan; 0 otherwise.
# %DESCRIPTION:
# Runs the NAI Virus Scan program on the entity. (http://www.nai.com)
#***********************************************************************
sub entity_contains_virus_nai {
unless ($Features{'Virus:NAI'}) {
md_syslog('err', "NAI Virus Scan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run uvscan
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:NAI'} . " --mime --noboot --secure --allole $path 2>&1", "Found");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# UVScan return codes
return (wantarray ? interpret_nai_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_nai
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the NAI Virus Scan program on the working directory
#***********************************************************************
sub message_contains_virus_nai {
unless ($Features{'Virus:NAI'}) {
md_syslog('err', "NAI Virus Scan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run uvscan
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:NAI'} . " --noboot --secure --mime --allole ./Work 2>&1", "Found");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# UVScan return codes
return (wantarray ? interpret_nai_code($code) : $code);
}
sub interpret_nai_code {
# Info from Anthony Giggins
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Driver integrity check failed
return ($code, 'swerr', 'tempfail') if ($code == 2);
# "A general problem occurred" -- idiot Windoze programmers...
return ($code, 'swerr', 'tempfail') if ($code == 6);
# Could not find a driver
return ($code, 'swerr', 'tempfail') if ($code == 8);
# Scanner tried to clean a file, but it failed
return ($code, 'swerr', 'tempfail') if ($code == 12);
# Virus found
if ($code == 13) {
# Sigh... stupid NAI can't have a standard message. Go through
# hoops to get virus name.
my $cm = $CurrentVirusScannerMessage;
$cm =~ s/ !+//;
$cm =~ s/!+//;
if ($VirusName eq "") {
$VirusName = "EICAR-Test"
if ($cm =~ m/Found: EICAR test file/i);
}
if ($VirusName eq "") {
$VirusName = $1
if ($cm =~ m/^\s+Found the (\S+) .*virus/i);
}
if ($VirusName eq "") {
$VirusName = $1
if ($cm =~ m/Found the (.*) trojan/i);
}
if ($VirusName eq "") {
$VirusName = $1
if ($cm =~ m/Found .* or variant (.*)/i);
}
$VirusName = "unknown-NAI-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Self-check failed
return ($code, 'swerr', 'tempfail') if ($code == 19);
# User quit using --exit-on-error
return ($code, 'interrupted', 'tempfail') if ($code == 102);
# Unknown exit code
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_bdc
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Bitdefender; 0 otherwise.
# %DESCRIPTION:
# Runs the Bitdefender program on the entity. (http://www.bitdefender.com)
#***********************************************************************
sub entity_contains_virus_bdc {
unless($Features{'Virus:BDC'}) {
md_syslog('err', "Bitdefender not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
# Run bdc
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:BDC'} . " $path --mail 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_bdc_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_bdc
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Bitdefender program on the working directory
#***********************************************************************
sub message_contains_virus_bdc {
unless($Features{'Virus:BDC'}) {
md_syslog('err', "Bitdefender not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run bdc
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:BDC'} . " $CWD/Work --mail --arc 2>&1");
return (wantarray ? interpret_bdc_code($code) : $code);
}
sub interpret_bdc_code {
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# If code is not 0 or 1, it's an internal error
return ($code, 'swerr', 'tempfail') if ($code != 1);
# Code is 1 -- virus found.
$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/(?:suspected|infected)\: (\S+)/);
$VirusName = "unknown-BDC-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_csav
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Command Anti-Virus
# %DESCRIPTION:
# Runs the Command Anti-Virus program. (http://www.commandsoftware.com)
#***********************************************************************
sub entity_contains_virus_csav {
unless($Features{'Virus:CSAV'}) {
md_syslog('err', "Command Anti-Virus not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run csav
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:CSAV'} . " $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# csav return codes
return (wantarray ? interpret_csav_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_csav
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Command Anti-Virus program on the working directory
#***********************************************************************
sub message_contains_virus_csav {
unless($Features{'Virus:CSAV'}) {
md_syslog('err', "Command Anti-Virus not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run csav
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:CSAV'} . " ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# csav return codes
return (wantarray ? interpret_csav_code($code) : $code);
}
sub interpret_csav_code {
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 50);
# Interrupted
return ($code, 'interrupted', 'tempfail') if ($code == 5);
# Out of memory
return ($code, 'swerr', 'tempfail') if ($code == 101);
# Suspicious files found
if ($code == 52) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Found a virus
if ($code == 51) {
$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/infec.*\: (\S+)/i);
$VirusName = "unknown-CSAV-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Found a virus and disinfected
if ($code == 53) {
$VirusName = "unknown-CSAV-virus disinfected";
return ($code, 'virus', 'quarantine');
}
# Unknown exit code
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_fsav
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by F-Secure Anti-Virus
# %DESCRIPTION:
# Runs the F-Secure Anti-Virus program. (http://www.f-secure.com)
#***********************************************************************
sub entity_contains_virus_fsav {
unless($Features{'Virus:FSAV'}) {
md_syslog('err', "F-Secure Anti-Virus not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run fsav
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FSAV'} . " --dumb --mime $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# fsav return codes
return (wantarray ? interpret_fsav_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_fsav
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the F-Secure Anti-Virus program on the working directory
#***********************************************************************
sub message_contains_virus_fsav {
unless($Features{'Virus:FSAV'}) {
md_syslog('err', "F-Secure Anti-Virus not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run fsav
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FSAV'} . " --dumb --mime ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# fsav return codes
return (wantarray ? interpret_fsav_code($code) : $code);
}
sub interpret_fsav_code {
# Info from David Green
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Abnormal termination
return ($code, 'swerr', 'tempfail') if ($code == 1);
# Self-test failed
return ($code, 'swerr', 'tempfail') if ($code == 2);
# Found a virus
if ($code == 3 or $code == 6) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/infec.*\: (\S+)/i);
$VirusName = "unknown-FSAV-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Interrupted
return ($code, 'interrupted', 'tempfail') if ($code == 5);
# Out of memory
return ($code, 'swerr', 'tempfail') if ($code == 7);
# Suspicious files found
if ($code == 8) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Unknown exit code
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: scan_file_using_fprotd_v6
# %ARGUMENTS:
# fname -- name of file to scan
# host -- host and port on which FPROTD version 6 is listening,
# eg 127.0.0.1:7777
# %RETURNS:
# A (code, category, action) triplet. Sets VirusName if virus found.
# %DESCRIPTION:
# Asks FPROTD version 6 to scan a file.
#***********************************************************************
sub scan_file_using_fprotd_v6
{
my($fname, $hname) = @_;
$hname ||= $Fprotd6Host;
my($host, $port) = split(/:/, $hname);
$host ||= '127.0.0.1';
$port ||= 10200;
my $connect_timeout = 10;
my $read_timeout = 60;
# Convert path to absolute
if (! ($fname =~ m+^/+)) {
my($cwd);
chomp($cwd = `pwd`);
$fname = $cwd . "/" . $fname;
}
my $sock = IO::Socket::INET->new(
PeerAddr => $host,
PeerPort => $port,
Timeout => $connect_timeout);
unless (defined $sock) {
md_syslog('warning', "Could not connect to FPROTD6 on $host: $!");
return (999, 'cannot-execute', 'tempfail');
}
if (!$sock->print("SCAN --scanlevel=2 --archive=2 --heurlevel=2 --adware --applications FILE $fname\n") || !$sock->flush()) {
md_syslog('warning', "Error writing to FPROTD6 on $host: $!");
$sock->close();
return (999, 'cannot-execute', 'tempfail');
}
my $s = IO::Select->new($sock);
if (!$s->can_read($read_timeout)) {
$sock->close();
md_syslog('warning', "Timeout reading from FPROTD6 daemon on $host");
return (999, 'cannot-execute', 'tempfail');
}
my $resp = $sock->getline();
$sock->close();
if (!$resp) {
md_syslog('warning', "Did not get response from FPROTD6 on $host while scanning $fname");
return (999, 'cannot-execute', 'tempfail');
}
my ($code, $desc, $name);
unless (($code, $desc, $name) = $resp =~ /\A(\d+)\s<(.*?)>\s(.*)\Z/) {
md_syslog('warning', "Failed to parse response from FPROTD6 for $fname: $resp");
return (999, 'cannot-execute', 'tempfail');
}
# Clean up $desc
$desc =~ s/\A(?:contains infected objects|infected):\s//i;
# Our output should contain:
# 1) A code. The code is a bitmask of:
# bit num Meaning
# 0 1 At least one virus-infected object was found (and remains).
# 1 2 At least one suspicious (heuristic match) object was found (and remains).
# 2 4 Interrupted by user. (SIGINT, SIGBREAK).
# 3 8 Scan restriction caused scan to skip files (maxdepth directories, maxdepth archives, exclusion list, etc).
# 4 16 Platform error (out of memory, real I/O errors, insufficient file permission etc.).
# 5 32 Internal engine error (whatever the engine fails at)
# 6 64 At least one object was not scanned (encrypted file, unsupported/unknown compression method, corrupted or invalid file).
# 7 128 At least one object was disinfected (clean now) (treat same as virus for File::VirusScan)
#
# 2) The description, including virus name
#
# 3) The item name, incl. member of archive etc. We ignore
# this for now.
if($code & (1 | 2 | 128)) {
$VirusName = $desc;
$VirusName ||= 'unknown-FPROTD6-virus';
return ($code, 'virus', 'quarantine');
} elsif($code & 4) {
md_syslog('warning', 'FPROTD6 scanning interrupted by user');
return ($code, 'interrupted', 'tempfail');
} elsif($code & 16) {
md_syslog('warning', 'FPROTD6 platform error');
return ($code, 'swerr', 'tempfail');
} elsif($code & 32) {
md_syslog('warning', 'FPROTD6 internal engine error');
return ($code, 'swerr', 'tempfail');
}
return(0, 'ok', 'ok');
}
#***********************************************************************
# %PROCEDURE: scan_file_using_carrier_scan
# %ARGUMENTS:
# fname -- name of file to scan
# host -- host and port on which Carrier Scan is listening, eg 127.0.0.1:7777
# Can optionally have :local or :nonlocal appended to force
# AVSCANLOCAL or AVSCAN
# %RETURNS:
# A (code, category, action) triplet. Sets VirusName if virus found.
# %DESCRIPTION:
# Asks Symantec CarrierScan Server to scan a file.
#***********************************************************************
sub scan_file_using_carrier_scan {
my($fname, $hname) = @_;
my($host, $port, $local) = split(/:/, $hname);
# If not specified, use local scanning for 127.0.0.1, remote for
# any other.
unless(defined($local)) {
if ($host =~ /^127\.0\.0\.1/) {
$local = 1;
} else {
$local = 0;
}
}
# Convert from strings
if ($local eq "local") {
$local = 1;
}
if ($local eq "nonlocal") {
$local = 0;
}
$port = 7777 unless defined($port);
# Convert path to absolute
if (! ($fname =~ m+^/+)) {
my($cwd);
chomp($cwd = `pwd`);
$fname = $cwd . "/" . $fname;
}
my $sock = IO::Socket::INET->new("$host:$port");
my ($line);
unless (defined $sock) {
md_syslog('warning', "Could not connect to CarrierScan Server on $host: $!");
return (999, 'cannot-execute', 'tempfail');
}
# Read first line of reply from socket
chomp($line = $sock->getline);
$line =~ s/\r//g;
unless ($line =~ /^220/) {
md_syslog('warning', "Unexpected reply $line from CarrierScan Server");
$sock->close;
return (999, 'swerr', 'tempfail');
}
# Next line must be version
chomp($line = $sock->getline);
$line =~ s/\r//g;
unless ($line eq "2") {
md_syslog('warning', "Unexpected version $line from CarrierScan Server");
$sock->close;
return(999, 'swerr', 'tempfail');
}
# Cool; send our stuff!
if ($local) {
if (!$sock->print("Version 2\nAVSCANLOCAL\n$fname\n")) {
$sock->close;
return (999, 'swerr', 'tempfail');
}
} else {
my ($size);
my ($chunk);
my ($chunksize, $nread);
$size = (stat($fname))[7];
unless(defined($size)) {
md_syslog('warning', "Cannot stat $fname: $!");
$sock->close;
return(999, 'swerr', 'tempfail');
}
if (!$sock->print("Version 2\nAVSCAN\n$fname\n$size\n")) {
$sock->close;
return (999, 'swerr', 'tempfail');
}
unless(open(IN, "<$fname")) {
md_syslog('warning', "Cannot open $fname: $!");
$sock->close;
return(999, 'swerr', 'tempfail');
}
while ($size > 0) {
if ($size < 8192) {
$chunksize = $size;
} else {
$chunksize = 8192;
}
$nread = read(IN, $chunk, $chunksize);
unless(defined($nread)) {
md_syslog('warning', "Error reading $fname: $!");
$sock->close;
return(999, 'swerr', 'tempfail');
}
last if ($nread == 0);
if (!$sock->print($chunk)) {
$sock->close;
return (999, 'swerr', 'tempfail');
}
$size -= $nread;
}
if ($size > 0) {
md_syslog('warning', "Error reading $fname: $!");
$sock->close;
return(999, 'swerr', 'tempfail');
}
}
if (!$sock->flush) {
$sock->close;
return (999, 'swerr', 'tempfail');
}
# Get reply from server
chomp($line = $sock->getline);
$line =~ s/\r//g;
unless ($line =~ /^230/) {
md_syslog('warning', "Unexpected response to AVSCAN or AVSCANLOCAL command: $line");
$sock->close;
return(999, 'swerr', 'tempfail');
}
# Get infection status
chomp($line = $sock->getline);
$line =~ s/\r//g;
if ($line == 0) {
$sock->close;
return (0, 'ok', 'ok');
}
# Skip definition date and version, infection count and filename
chomp($line = $sock->getline); # Definition date
chomp($line = $sock->getline); # Definition version
chomp($line = $sock->getline); # Infection count (==1)
chomp($line = $sock->getline); # Filename
# Get virus name
chomp($line = $sock->getline);
$line =~ s/\r//g;
$sock->close;
$VirusName = $line;
return (1, 'virus', 'quarantine');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_carrier_scan
# %ARGUMENTS:
# entity -- a MIME entity
# host (optional) -- Symantec CarrierScan host:port
# %RETURNS:
# Usual virus status
# %DESCRIPTION:
# Scans the entity using Symantec CarrierScan
#***********************************************************************
sub entity_contains_virus_carrier_scan {
my($entity) = shift;
my($host) = $CSSHost;
$host = shift if (@_ > 0);
$host = '127.0.0.1:7777:local' if (!defined($host));
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
return scan_file_using_carrier_scan($entity->bodyhandle->path,
$host);
}
sub entity_contains_virus_fprotd_v6
{
my($entity, $host) = @_;
$host ||= $Fprotd6Host;
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
return scan_file_using_fprotd_v6($entity->bodyhandle->path,
$host);
}
sub message_contains_virus_fprotd_v6
{
my($host) = @_;
$host ||= $Fprotd6Host;
if (!opendir(DIR, "./Work")) {
md_syslog('err', "message_contains_virus_fprotd_v6: Could not open ./Work directory: $!");
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Scan all files in Work
my(@files);
@files = grep { -f "./Work/$_" } readdir(DIR);
closedir(DIR);
my($file, $code, $category, $action);
foreach $file (@files) {
($code, $category, $action) =
scan_file_using_fprotd_v6("Work/$file", $host);
if ($code != 0) {
return (wantarray ? ($code, $category, $action) : $code);
}
}
return (0, 'ok', 'ok');
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_carrier_scan
# %ARGUMENTS:
# host (optional) -- Symantec CarrierScan host:port
# %RETURNS:
# Usual virus status
# %DESCRIPTION:
# Scans the entity using Symantec CarrierScan
#***********************************************************************
sub message_contains_virus_carrier_scan {
my($host) = $CSSHost;
$host = shift if (@_ > 0);
$host = '127.0.0.1:7777:local' if (!defined($host));
if (!opendir(DIR, "./Work")) {
md_syslog('err', "message_contains_virus_carrier_scan: Could not open ./Work directory: $!");
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Scan all files in Work
my(@files);
@files = grep { -f "./Work/$_" } readdir(DIR);
closedir(DIR);
my($file, $code, $category, $action);
foreach $file (@files) {
($code, $category, $action) =
scan_file_using_carrier_scan("Work/$file", $host);
if ($code != 0) {
return (wantarray ? ($code, $category, $action) : $code);
}
}
return (0, 'ok', 'ok');
}
#***********************************************************************
# %PROCEDURE: item_contains_virus_fprotd
# %ARGUMENTS:
# item -- a file or directory
# host (optional) -- Fprotd host and base port.
# %RETURNS:
# Usual virus status
# %DESCRIPTION:
# Scans the entity using Fprotd scanning daemon
#***********************************************************************
sub item_contains_virus_fprotd {
my $item = shift;
my ($host) = $FprotdHost;
$host = shift if (@_ > 0);
$host = '127.0.0.1' if (!defined($host));
my $baseport = 10200;
if($host =~ /(.*):(.*)/ ) {
$host = $1;
$baseport = $2;
}
md_syslog('info', "Scan '$item' via F-Protd \@$host:$baseport");
# The F-Prot demon cannot scan directories, but files only
# hence, we recurse any directories manually
if(-d $item) {
my @result;
$host .= ":$baseport";
foreach my $entry (glob("$item/*")) {
@result = &item_contains_virus_fprotd($entry, $host);
last if $result[0] != 0;
}
return (wantarray ? @result : $result[0]);
}
# Default error message when reaching end of function
my $errmsg = "Could not connect to F-Prot Daemon at $host:$baseport";
# Try 5 ports in order to find an active scanner; they may change the port
# when they find and spawn an updated demon executable
SEARCH_DEMON: foreach my $port ($baseport..($baseport+4)) {
my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port);
if (defined $sock) {
# The arguments (following the '?' sign in the HTTP request)
# are the same as for the command line F-Prot, the additional
# -remote-dtd suppresses the unuseful XML DTD prefix
if (!$sock->print("GET $item?-dumb%20-archive%20-packed%20-remote-dtd HTTP/1.0\n\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
# Fetch HTTP Header
## Maybe dropped, if no validation checks are to be made
while(my $output = $sock->getline) {
if($output =~ /^\s*$/) {
last; # break line for XML content
#### Below here: Validating the protocol
#### If the protocol is not recognized, it's assumed that the
#### endpoint is not an F-Prot demon, hence,
#### the next port is probed.
} elsif($output =~ /^HTTP(.*)/) {
my $h = $1;
next SEARCH_DEMON unless $h =~ m!/1\.0\s+200\s!;
} elsif($output =~ /^Server:\s*(\S*)/) {
next SEARCH_DEMON if $1 !~ /^fprotd/;
}
}
# Parsing XML results
my $xml = HTML::TokeParser->new($sock);
my $t = $xml->get_tag('fprot-results');
unless($t) { # This is an essential tag --> assume a broken demon
$errmsg = 'Demon did not return <fprot-results> tag';
last SEARCH_DEMON;
}
if($t->[1]{'version'} ne '1.0') {
$errmsg = "Incompatible F-Protd results version: "
. $t->[1]{'version'};
last SEARCH_DEMON;
}
my $curText; # temporarily accumulated information
my $virii = ''; # name(s) of virus(es) found
my $code; # overall exit code
my $msg = ''; # accumulated message of virus scanner
while( $t = $xml->get_token ) {
my $tag = $t->[1];
if($t->[0] eq 'S') { # Start tag
# Accumulate the information temporarily
# into $curText until the </detected> tag is found
my $text = $xml->get_trimmed_text;
# $tag 'filename' of no use in MIMEDefang
if($tag eq 'name') {
$virii .= (length $virii ? " " : "" ) . $text;
$curText .= "Found the virus: '$text'\n";
} elsif($tag eq 'accuracy' || $tag eq 'disinfectable' ||
$tag eq 'message') {
$curText .= "\t$tag: $text\n";
} elsif($tag eq 'error') {
$msg .= "\nError: $text\n";
} elsif($tag eq 'summary') {
$code = $t->[2]{'code'}
if defined $t->[2]{'code'};
}
} elsif($t->[0] eq 'E') { # End tag
if($tag eq 'detected') {
# move the cached information to the
# accumulated message
$msg .= "\n$curText" if $curText;
undef $curText;
} elsif($tag eq 'fprot-results') {
last; # security check
}
}
}
$sock->close;
## Check the exit code (man f-protd)
## NOTE: These codes are different from the ones of the command line version!
# 0 Not scanned, unable to handle the object.
# 1 Not scanned due to an I/O error.
# 2 Not scanned, as the scanner ran out of memory.
# 3 X The object is not of a type the scanner knows. This
# may either mean it was misidentified or that it is
# corrupted.
# 4 X The object was valid, but encrypted and could not
# be scanned.
# 5 Scanning of the object was interrupted.
# 7 X The object was identified as an "innocent" object.
# 9 X The object was successfully scanned and nothing was
# found.
# 11 The object is infected.
# 13 The object was disinfected.
unless(defined $code) {
$errmsg = "No summary code found";
last SEARCH_DEMON;
}
if($code < 3 # I/O error, unable to handle, out of mem
# any filesystem error less than zero
|| $code == 5) { # interrupted
## assume this a temporary failure
$errmsg = "Scan error #$code: $msg";
last SEARCH_DEMON;
}
if($code > 10) { # infected; (disinfected: Should never happen!)
# Add the accumulated information
$VirusScannerMessages .= $msg;
if ( length $virii ) {
$VirusName = $virii;
} elsif ( $msg =~ /^\tmessage:\s+(\S.*)/m ) {
$VirusName = $1;
} else {
# no virus name found, log message returned by fprot
$msg =~ s/\s+/ /g;
md_syslog('info',
qq[$MsgID: cannot extract virus name from f-prot: "$msg"]);
$VirusName = "unknown";
}
return (wantarray ? (1, 'virus', 'quarantine') : 1);
}
###### These codes are left to be handled:
# 3 X The object is not of a type the scanner knows. This
# may either mean it was misidentified or that it is
# corrupted.
# 4 X The object was valid, but encrypted and could not
# be scanned.
# 7 X The object was identified as an "innocent" object.
# 9 X The object was successfully scanned and nothing was
# 9 is trival; 7 is probably trival
# 4 & 3 we can't do anything really, because if the attachement
# is some unknown archive format, the scanner wouldn't had known
# this issue anyway, hence, I consider it "clean"
return (wantarray ? (0, 'ok', 'ok') : 0);
}
}
# Could not connect to daemon or some error occured during the
# communication with it
$errmsg =~ s/\s*\.*\s*\n+\s*/\. /g;
md_syslog('err', "$errmsg");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_fprotd
# %ARGUMENTS:
# entity -- a MIME entity
# host (optional) -- F-Prot Demon host:port
# %RETURNS:
# 1 if entity contains a virus as reported by F-Prot Demon
# %DESCRIPTION:
# Invokes the F-Prot daemon (http://www.frisk.org/) on
# the entity.
#***********************************************************************
sub entity_contains_virus_fprotd {
my ($entity) = shift;
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my $path = $entity->bodyhandle->path;
# If path is not absolute, add cwd
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
return item_contains_virus_fprotd($path, $_[0]);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_fprotd
# %ARGUMENTS:
# host (optional) -- F-Prot Demon host:port
# %RETURNS:
# 1 if entity contains a virus as reported by F-Prot Demon
# %DESCRIPTION:
# Invokes the F-Prot daemon (http://www.frisk.org/) on
# the entire message.
#***********************************************************************
sub message_contains_virus_fprotd {
return item_contains_virus_fprotd ("$CWD/Work", $_[0]);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_hbedv
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by H+BEDV Antivir; 0 otherwise.
# %DESCRIPTION:
# Runs the H+BEDV Antivir program on the entity. (http://www.hbedv.com)
#***********************************************************************
sub entity_contains_virus_hbedv {
unless($Features{'Virus:HBEDV'}) {
md_syslog('err', "H+BEDV not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:HBEDV'} . " --allfiles -z -rs $path 2>&1", "!Virus!|>>>|VIRUS:|ALERT:");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_hbedv_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_hbedv
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the H+BEDV Antivir program on the working directory
#***********************************************************************
sub message_contains_virus_hbedv {
unless($Features{'Virus:HBEDV'}) {
md_syslog('err', "H+BEDV not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:HBEDV'} . " --allfiles -z -rs ./Work 2>&1", "!Virus!|>>>|VIRUS:|ALERT:");
return (wantarray ? interpret_hbedv_code($code) : $code);
}
sub interpret_hbedv_code {
# Based on info from Nels Lindquist, updated by
# Thorsten Schlichting
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Virus or virus in memory
if ($code == 1 || $code == 2 || $code == 3) {
$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/ALERT: \[(\S+)/ or
$CurrentVirusScannerMessage =~ /!Virus! \S+ (\S+)/ or
$CurrentVirusScannerMessage =~ m/VIRUS: file contains code of the virus '(\S+)'/);
$VirusName = "unknown-HBEDV-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# All other codes should not happen
md_syslog('err', "Unknown HBEDV Virus scanner return code: $code");
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_vexira
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Vexira; 0 otherwise.
# %DESCRIPTION:
# Runs the Vexira program on the entity. (http://www.centralcommand.com)
#***********************************************************************
sub entity_contains_virus_vexira {
unless($Features{'Virus:VEXIRA'}) {
md_syslog('err', "Vexira not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run vexira
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:VEXIRA'} . " -qqq --log=/dev/null --all-files -as $path 2>&1", ": (virus|iworm|macro|mutant|sequence|trojan) ");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_vexira_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_vexira
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Vexira program on the working directory
#***********************************************************************
sub message_contains_virus_vexira {
unless($Features{'Virus:VEXIRA'}) {
md_syslog('err', "Vexira not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run vexira
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:VEXIRA'} . " -qqq --log=/dev/null --all-files -as ./Work 2>&1", ": (virus|iworm|macro|mutant|sequence|trojan) ");
return (wantarray ? interpret_vexira_code($code) : $code);
}
sub interpret_vexira_code {
# http://www.centralcommand.com/ts/dl/pdf/scanner_en_vexira.pdf
my($code) = @_;
# OK or new file type we don't understand
return ($code, 'ok', 'ok') if ($code == 0 or $code == 9);
# Password-protected ZIP or corrupted file
if ($code == 3 or $code == 5) {
$VirusName = 'vexira-password-protected-zip';
return ($code, 'suspicious', 'quarantine');
}
# Virus
if ($code == 1 or $code == 2) {
$VirusName = $2 if ($CurrentVirusScannerMessage =~ m/: (virus|iworm|macro|mutant|sequence|trojan) (\S+)/);
$VirusName = "unknown-Vexira-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# All other codes should not happen
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_sophos
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Sophos Sweep
# %DESCRIPTION:
# Runs the Sophos Sweep program on the entity.
#***********************************************************************
sub entity_contains_virus_sophos {
unless($Features{'Virus:SOPHOS'}) {
md_syslog('err', "Sophos Sweep not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) = run_virus_scanner($Features{'Virus:SOPHOS'} . " -f -mime -all -archive -ss $path 2>&1", "(>>> Virus)|(Password)|(Could not check)");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_sweep_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_savscan
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Sophos Savscan
# %DESCRIPTION:
# Runs the Sophos Savscan program on the entity.
#***********************************************************************
sub entity_contains_virus_savscan {
unless($Features{'Virus:SAVSCAN'}) {
md_syslog('err', "Sophos Savscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) = run_virus_scanner($Features{'Virus:SAVSCAN'} . " -f -mime -all -cab -oe -tnef -archive -ss $path 2>&1", "(>>> Virus)|(Password)|(Could not check)");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_savscan_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_sophos
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Sophos Sweep program on the working directory
#***********************************************************************
sub message_contains_virus_sophos {
unless($Features{'Virus:SOPHOS'}) {
md_syslog('err', "Sophos Sweep not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) = run_virus_scanner($Features{'Virus:SOPHOS'} . " -f -mime -all -archive -ss ./Work 2>&1", "(>>> Virus)|(Password)|(Could not check)");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_sweep_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_savscan
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Sophos Savscan program on the working directory
#***********************************************************************
sub message_contains_virus_savscan {
unless($Features{'Virus:SAVSCAN'}) {
md_syslog('err', "Sophos Savscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) = run_virus_scanner($Features{'Virus:SAVSCAN'} . " -f -mime -all -cab -oe -tnef -archive -ss ./Work 2>&1", "(>>> Virus)|(Password)|(Could not check)");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_savscan_code($code) : $code);
}
sub interpret_sweep_code {
# Based on info from Nicholas Brealey
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Interrupted
return ($code, 'interrupted', 'tempfail') if ($code == 1);
# This is technically an error code, but Sophos chokes
# on a lot of M$ docs with this code, so we let it through...
return (0, 'ok', 'ok') if ($code == 2);
# Virus
if ($code == 3) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/^\s*>>> Virus '(\S+)'/);
$VirusName = "unknown-Sweep-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Unknown code
return ($code, 'swerr', 'tempfail');
}
sub interpret_savscan_code {
# Based on info from Nicholas Brealey
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Interrupted
return ($code, 'interrupted', 'tempfail') if ($code == 1);
# This is technically an error code, but Sophos chokes
# on a lot of M$ docs with this code, so we let it through...
return (0, 'ok', 'ok') if ($code == 2);
# Virus
if ($code == 3) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/^\s*>>> Virus '(\S+)'/);
$VirusName = "unknown-Savscan-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Unknown code
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_clamav
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by clamav
# %DESCRIPTION:
# Runs the clamav program on the entity.
#***********************************************************************
sub entity_contains_virus_clamav {
unless ($Features{'Virus:CLAMAV'}) {
md_syslog('err', "clamav not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run clamscan
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:CLAMAV'} . " --stdout --no-summary --infected $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_clamav_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_clamav
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the clamscan program on the working directory
#***********************************************************************
sub message_contains_virus_clamav {
unless ($Features{'Virus:CLAMAV'}) {
md_syslog('err', "clamav not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run clamscan
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --stdout --no-summary --infected ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_clamav_code($code) : $code);
}
sub interpret_clamav_code {
my($code) = @_;
# From info obtained from:
# clamscan(1)
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# virus found
if ($code == 1) {
$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/: (.+) FOUND/);
$VirusName = "unknown-Clamav-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# other codes
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_avp5
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Kaspersky 5.x
# %DESCRIPTION:
# Runs the Kaspersky 5.x aveclient program on the entity.
#***********************************************************************
sub entity_contains_virus_avp5 {
unless ($Features{'Virus:AVP5'}) {
md_syslog('err', "Kaspersky aveclient not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run aveclient
my($code, $category, $action) = run_virus_scanner($Features{'Virus:AVP5'} . " -s -p /var/run/aveserver $path 2>&1","INFECTED");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_avp5_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_avp5
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Kaspersky 5.x aveclient program on the working directory
#***********************************************************************
sub message_contains_virus_avp5 {
unless ($Features{'Virus:AVP5'}) {
md_syslog('err', "Kaspersky aveclient not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run aveclient
my($code, $category, $action) = run_virus_scanner($Features{'Virus:AVP5'} . " -s -p /var/run/aveserver $CWD/Work/* 2>&1","INFECTED");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_avp5_code($code) : $code);
}
sub interpret_avp5_code {
my($code) = @_;
# From info obtained from:
# man aveclient (/opt/kav/man/aveclient.8)
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Scan incomplete
return ($code, 'interrupted', 'tempfail') if ($code == 1);
# "modified or damaged virus" = 2; virus = 4
if ($code == 2 or $code == 4) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/INFECTED (\S+)/);
$VirusName = "unknown-AVP5-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# "suspicious" object found
if ($code == 3) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Disinfected ??
return ($code, 'ok', 'ok') if ($code == 5);
# Viruses deleted ??
return ($code, 'ok', 'ok') if ($code == 6);
# AVPLinux corrupt or infected
return ($code, 'swerr', 'tempfail') if ($code == 7);
# Corrupt objects found -- treat as suspicious
if ($code == 8) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Anything else shouldn't happen
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_kavscanner
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Kaspersky kavscanner
# %DESCRIPTION:
# Runs the Kaspersky kavscanner program on the entity.
#***********************************************************************
sub entity_contains_virus_kavscanner {
unless ($Features{'Virus:KAVSCANNER'}) {
md_syslog('err', "Kaspersky kavscanner not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run kavscanner
my($code, $category, $action) = run_virus_scanner($Features{'Virus:KAVSCANNER'} . " -e PASBME -o syslog -i0 $path 2>&1",
"INFECTED");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_kavscanner_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_kavscanner
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Kaspersky 5.x aveclient program on the working directory
#***********************************************************************
sub message_contains_virus_kavscanner {
unless ($Features{'Virus:KAVSCANNER'}) {
md_syslog('err', "Kaspersky aveclient not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run kavscanner
my($code, $category, $action) = run_virus_scanner($Features{'Virus:KAVSCANNER'} . " -e PASBME -o syslog -i0 $CWD/Work/* 2>&1",
"INFECTED");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_kavscanner_code($code) : $code);
}
sub interpret_kavscanner_code {
my($code) = @_;
# From info obtained from:
# man kavscanner (/opt/kav/man/kavscanner.8)
# OK
return ($code, 'ok', 'ok') if ($code == 0 or $code == 5 or $code == 10);
# Password-protected ZIP
if ($code == 9) {
$VirusName = 'kavscanner-password-protected-zip';
return ($code, 'suspicious', 'quarantine');
}
# Virus or suspicious TODO: Set virus name
if ($code == 20 or $code == 21 or $code == 25) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/INFECTED (\S+)/);
$VirusName = 'unknown-kavscanner-virus' if $VirusName eq "";
if ($code == 20) {
return ($code, 'suspicious', 'quarantine');
} else {
return ($code, 'virus', 'quarantine');
}
}
# Something else
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_avp
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by AVP AvpLinux
# %DESCRIPTION:
# Runs the AvpLinux program on the entity.
#***********************************************************************
sub entity_contains_virus_avp {
unless ($Features{'Virus:AVP'}) {
md_syslog('err', "AVP AvpLinux not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($is_daemon);
$is_daemon = ($Features{'Virus:AVP'} =~ /kavdaemon$/);
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action);
if ($is_daemon) {
# If path is not absolute, add cwd
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
($code, $category, $action) =
run_virus_scanner($Features{'Virus:AVP'} . " $CWD -o{$path} -dl -Y -O- -K -I0 -WU=$CWD/DAEMON.RPT 2>&1", "infected");
} else {
($code, $category, $action) =
run_virus_scanner($Features{'Virus:AVP'} . " -Y -O- -K -I0 $path 2>&1", "infected");
}
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_avp_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_avp
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the AVP AvpLinux program on the working directory
#***********************************************************************
sub message_contains_virus_avp {
unless ($Features{'Virus:AVP'}) {
md_syslog('err', "AVP AvpLinux not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($is_daemon);
$is_daemon = ($Features{'Virus:AVP'} =~ /kavdaemon$/);
# Run antivir
my($code, $category, $action);
if ($is_daemon) {
($code, $category, $action) =
run_virus_scanner($Features{'Virus:AVP'} . " $CWD -o{$CWD/Work} -dl -Y -O- -K -I0 -WU=$CWD/DAEMON.RPT 2>&1", "infected");
} else {
($code, $category, $action) =
run_virus_scanner($Features{'Virus:AVP'} . " -Y -O- -K -I0 ./Work 2>&1", "infected");
}
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_avp_code($code) : $code);
}
sub interpret_avp_code {
my($code) = @_;
# From info obtained from:
# http://sm.msk.ru/patches/violet-avp-sendmail-11.4.patch
# and from Steve Ladendorf
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Scan incomplete
return ($code, 'interrupted', 'tempfail') if ($code == 1);
# "modified or damaged virus" = 2; virus = 4
if ($code == 2 or $code == 4) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/infected\: (\S+)/);
$VirusName = "unknown-AVP-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# "suspicious" object found
if ($code == 3) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Disinfected ??
return ($code, 'ok', 'ok') if ($code == 5);
# Viruses deleted ??
return ($code, 'ok', 'ok') if ($code == 6);
# AVPLinux corrupt or infected
return ($code, 'swerr', 'tempfail') if ($code == 7);
# Corrupt objects found -- treat as suspicious
if ($code == 8) {
$VirusName = 'suspicious';
return ($code, 'suspicious', 'quarantine');
}
# Anything else shouldn't happen
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_fprot
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by FRISK F-Prot; 0 otherwise.
# %DESCRIPTION:
# Runs the F-PROT program on the entity. (http://www.f-prot.com)
#***********************************************************************
sub entity_contains_virus_fprot {
unless ($Features{'Virus:FPROT'}) {
md_syslog('err', "F-RISK FPROT not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run f-prot
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FPROT'} . " -DUMB -ARCHIVE -PACKED $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# f-prot return codes
return (wantarray ? interpret_fprot_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_fprot
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the F-RISK f-prot program on the working directory
#***********************************************************************
sub message_contains_virus_fprot {
unless ($Features{'Virus:FPROT'}) {
md_syslog('err', "F-RISK f-prot not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run f-prot
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FPROT'} . " -DUMB -ARCHIVE -PACKED ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# f-prot return codes
return (wantarray ? interpret_fprot_code($code) : $code);
}
sub interpret_fprot_code {
# Info from
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# Unrecoverable error (Missing DAT, etc)
return ($code, 'swerr', 'tempfail') if ($code == 1);
# Driver integrity check failed
return ($code, 'swerr', 'tempfail') if ($code == 2);
# Virus found
if ($code == 3) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/Infection\: (\S+)/);
$VirusName = "unknown-FPROT-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Reserved for now. Treat as an error
return ($code, 'swerr', 'tempfail') if ($code == 4);
# Abnormal termination (scan didn't finish)
return ($code, 'swerr', 'tempfail') if ($code == 5);
# At least one virus removed - Should not happen as we aren't
# requesting disinfection ( at least in this version).
return ($code, 'swerr', 'tempfail') if ($code == 6);
# Memory error
return ($code, 'swerr', 'tempfail') if ($code == 7);
# Something suspicious was found, but not recognized virus
# ( uncomment the one your paranoia dictates :) ).
# return ($code, 'virus', 'quarantine') if ($code == 8);
return ($code, 'ok', 'ok') if ($code == 8);
# Unknown exit code
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_fpscan
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by FRISK F-Prot; 0 otherwise.
# %DESCRIPTION:
# Runs the F-PROT program on the entity. (http://www.f-prot.com)
#***********************************************************************
sub entity_contains_virus_fpscan {
unless ($Features{'Virus:FPSCAN'}) {
md_syslog('err', "F-RISK fpscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run f-prot
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FPSCAN'} . " --report --archive=5 --scanlevel=4 --heurlevel=3 $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# f-prot return codes
return (wantarray ? interpret_fpscan_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_fpscan
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the F-RISK f-prot program on the working directory
#***********************************************************************
sub message_contains_virus_fpscan {
unless ($Features{'Virus:FPSCAN'}) {
md_syslog('err', "F-RISK fpscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run f-prot
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:FPSCAN'} . " --report --archive=5 --scanlevel=4 --heurlevel=3 ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# f-prot return codes
return (wantarray ? interpret_fpscan_code($code) : $code);
}
sub interpret_fpscan_code {
# Info from
my($code) = @_;
# Set to 1 to mark heuristic matches as a virus
my $heuristic_virus = 0;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# bit 1 (1) ==> At least one virus-infected object was found (and
# remains).
if ($code & 0b1) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/^\[Found\s+[^\]]*\]\s+<([^ \t\(>]*)/m);
$VirusName = "unknown-FPSCAN-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
if ($heuristic_virus and $code & 0b10) {
return ($code, 'virus', 'quarantine');
}
# bit 3 (4) ==> Interrupted by user (SIGINT, SIGBREAK).
if ($code & 0b100) {
return ($code, 'swerr', 'tempfail');
}
# bit 4 (8) ==> Scan restriction caused scan to skip files
# (maxdepth directories, maxdepth archives,
# exclusion list, etc).
if ($code & 0b1000) {
return ($code, 'swerr', 'tempfail');
}
# bit 5 (16) ==> Platform error (out of memory, real I/O errors,
# insufficient file permission etc.)
if ($code & 0b10000) {
return ($code, 'swerr', 'tempfail');
}
# bit 6 (32) ==> Internal engine error (whatever the engine fails
# at)
if ($code & 0b100000) {
return ($code, 'swerr', 'tempfail');
}
# bit 7 (64) ==> At least one object was not scanned (encrypted
# file, unsupported/unknown compression method,
# corrupted or invalid file).
if ($code & 0b1000000) {
return ($code, 'swerr', 'tempfail');
}
# bit 8 (128) ==> At least one object was disinfected (clean now).
# Should not happen as we aren't requesting disinfection ( at least
# in this version).
if ($code & 0b10000000) {
return ($code, 'swerr', 'tempfail');
}
# bit 2 (2) ==> At least one suspicious (heuristic match) object
# was found (and remains).
if ($code & 0b10) {
# ( uncomment the one your paranoia dictates :) ).
return ($code, 'ok', 'ok');
}
# Unknown exit code, this should never happen
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_trend
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Trend Micro vscan
# %DESCRIPTION:
# Runs the vscan program on the entity.
#***********************************************************************
sub entity_contains_virus_trend {
unless ($Features{'Virus:TREND'}) {
md_syslog('err', "TREND vscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run antivir
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:TREND'} . " -za -a $path 2>&1", "Found ");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_trend_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_trend
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the Trend vscan program on the working directory
#***********************************************************************
sub message_contains_virus_trend {
unless ($Features{'Virus:TREND'}) {
md_syslog('err', "TREND Filescanner or Interscan not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run vscan
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:TREND'} . " -za -a ./Work/* 2>&1", "Found ");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_trend_code($code) : $code);
}
sub interpret_trend_code {
my($code) = @_;
# From info obtained from:
# http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/amavis/amavis/README.scanners
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# virus found
if ($code >= 1 and $code < 10) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/^\*+ Found virus (\S+)/);
$VirusName = "unknown-Trend-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Anything else shouldn't happen
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_nvcc
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by Norman Virus Control(NVCC)
# %DESCRIPTION:
# Runs the NVCC Anti-Virus program. (http://www.norman.no/)
#***********************************************************************
sub entity_contains_virus_nvcc {
unless($Features{'Virus:NVCC'}) {
md_syslog('err', "Norman Virus Control (NVCC) not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = shift;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run nvcc
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:NVCC'} . " -u -c $path 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# nvcc return codes
return (wantarray ? interpret_nvcc_code($code) : ($code==1 || $code==2));
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_nvcc
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs the NVCC Anti-Virus program on the working directory.
# (http://www.norman.no/)
#***********************************************************************
sub message_contains_virus_nvcc {
unless($Features{'Virus:NVCC'}) {
md_syslog('err', "Norman Virus Control (NVCC) not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run nvcc
my($code, $category, $action) =
run_virus_scanner($Features{'Virus:NVCC'} . " -u -c -s ./Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
# nvcc return codes
return (wantarray ? interpret_nvcc_code($code) : ($code==1 || $code==2));
}
sub interpret_nvcc_code {
my($code) = shift;
# OK
return (0, 'ok', 'ok') if ($code == 0);
# Found a virus
if ($code == 1 or $code == 2 or $code == 14) {
$VirusName = $1
if ($CurrentVirusScannerMessage =~ m/Possible virus[^']*'(\S+)'$/);
#' Emacs highlighting goes nuts with unbalanced single-quote...
$VirusName = "unknown-NVCC-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# Corrupt files/archives found -- treat as suspicious
if ($code == 11) {
$VirusName = 'NVCC-suspicious-code-11';
return ($code, 'suspicious', 'quarantine');
}
# No scan area given or something went wrong
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_sophie
# %ARGUMENTS:
# entity -- a MIME entity
# sophie_sock (optional) -- Sophie socket path
# %RETURNS:
# 1 if entity contains a virus as reported by Sophie
# %DESCRIPTION:
# Invokes the Sophie daemon (http://www.vanja.com/tools/sophie/)
# on the entity.
#***********************************************************************
sub entity_contains_virus_sophie {
my ($entity) = shift;
my ($sophie_sock) = $SophieSock;
$sophie_sock = shift if (@_ > 0);
$sophie_sock = '/var/run/mailplus_server/mimedefang/sophie' if (!defined($sophie_sock));
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my $sock = IO::Socket::UNIX->new(Peer => $sophie_sock);
if (defined $sock) {
my $path = $entity->bodyhandle->path;
# If path is not absolute, add cwd
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
if (!$sock->print("$path\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my($output);
if (!$sock->sysread($output,256)) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (!$sock->close) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if ($output =~ /^0/) { return (wantarray ? (0, 'ok', 'ok') : 0); }
elsif ($output =~ /^1/) {
$VirusName = "Unknown-sophie-virus";
$VirusName = $1 if $output =~ /^1:(.*)$/;
$VirusScannerMessages .= "Sophie found the $VirusName virus.\n";
return (wantarray ? (1, 'virus', 'quarantine') : 1);
}
elsif ($output =~ /^-1/) {
my $errmsg = "unknown status";
$errmsg = "$1" if $output =~ /^-1:(.*)$/;
md_syslog('err', "entity_contains_virus_sophie: $errmsg ($path)");
$VirusScannerMessages .= "Sophie error: $errmsg\n";
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
else {
md_syslog('err', "entity_contains_virus_sophie: unknown response - $output ($path)");
$VirusScannerMessages .= "Sophie error: unknown response - $output\n";
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
}
# Could not connect to daemon
md_syslog('err', "Could not connect to Sophie Daemon at $sophie_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_sophie
# %ARGUMENTS:
# sophie_sock (optional) -- Sophie socket path
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Invokes the Sophie daemon (http://www.vanja.com/tools/sophie/)
# on the entire message.
#***********************************************************************
sub message_contains_virus_sophie {
my ($sophie_sock) = $SophieSock;
$sophie_sock = shift if (@_ > 0);
$sophie_sock = '/var/run/mailplus_server/mimedefang/sophie' if (!defined($sophie_sock));
my $sock = IO::Socket::UNIX->new(Peer => $sophie_sock);
if (defined $sock) {
if (!$sock->print("$CWD/Work\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my($output, $ans);
$ans = $sock->sysread($output, 256);
if (!defined($ans)) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (!$sock->close) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if ($output =~ /^0/) { return (wantarray ? (0, 'ok', 'ok') : 0); }
elsif ($output =~ /^1/) {
$VirusName = "Unknown-sophie-virus";
$VirusName = $1 if $output =~ /^1:(.*)$/;
$VirusScannerMessages .= "Sophie found the $VirusName virus.\n";
return (wantarray ? (1, 'virus', 'quarantine') : 1);
}
elsif ($output =~ /^-1/) {
my $errmsg = "unknown status";
$errmsg = "$1" if $output =~ /^-1:(.*)$/;
md_syslog('err', "message_contains_virus_sophie: $errmsg ($CWD/Work)");
$VirusScannerMessages .= "Sophie error: $errmsg\n";
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
else {
md_syslog('err', "message_contains_virus_sophie: unknown response - $output ($CWD/Work)");
$VirusScannerMessages .= "Sophie error: unknown response - $output\n";
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
}
# Could not connect to daemon
md_syslog('err', "Could not connect to Sophie Daemon at $sophie_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_clamd
# %ARGUMENTS:
# entity -- a MIME entity
# clamd_sock (optional) -- clamd socket path
# %RETURNS:
# 1 if entity contains a virus as reported by clamd
# %DESCRIPTION:
# Invokes the clamd daemon (http://www.clamav.net/)
# on the entity.
#***********************************************************************
sub entity_contains_virus_clamd {
my ($entity) = shift;
my ($clamd_sock) = $ClamdSock;
$clamd_sock = shift if (@_ > 0);
$clamd_sock = '/var/run/mailplus_server/mimedefang/clamd.sock' if (!defined($clamd_sock));
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my $sock = IO::Socket::UNIX->new(Peer => $clamd_sock);
if (defined $sock) {
my $path = $entity->bodyhandle->path;
# If path is not absolute, add cwd
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
if (!$sock->print("SCAN $path\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my($output, $ans);
$ans = $sock->sysread($output,256);
$sock->close;
if (!defined($ans) || !$ans) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
if ($output =~ /: (.+) FOUND/) {
$VirusScannerMessages .= "clamd found the $1 virus.\n";
$VirusName = $1;
return (wantarray ? (1, 'virus', 'quarantine') : 1);
} elsif ($output =~ /: (.+) ERROR/) {
my $err_detail = $1;
md_syslog('err', "Clamd returned error: $err_detail");
# If it's a zip module failure, try falling back on clamscan.
# This is despicable, but it might work
if ($err_detail =~ /(?:zip module failure|not supported data format)/i &&
$Features{'Virus:CLAMAV'}) {
my ($code, $category, $action) =
run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --unzip --unrar --stdout --no-summary --infected $CWD/Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
md_syslog('info', "Falling back on clamscan --unzip --unrar because of Zip module failure in clamd");
return (wantarray ? interpret_clamav_code($code) : $code);
}
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Could not connect to daemon
md_syslog('err', "Could not connect to clamd Daemon at $clamd_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_clamd
# %ARGUMENTS:
# clamd_sock (optional) -- clamd socket path
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Invokes the clamd daemon (http://www.clamav.net/)
# on the entire message.
#***********************************************************************
sub message_contains_virus_clamd {
my ($clamd_sock) = $ClamdSock;
$clamd_sock = shift if (@_ > 0);
$clamd_sock = '/var/run/mailplus_server/mimedefang/clamd.sock' if (!defined($clamd_sock));
my ($output,$sock);
# PING/PONG test to make sure clamd is alive
$sock = IO::Socket::UNIX->new(Peer => $clamd_sock);
if (!defined($sock)) {
md_syslog('err', "Could not connect to clamd daemon at $clamd_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
my $s = IO::Select->new();
$s->add($sock);
if (!$s->can_write(30)) {
$sock->close;
md_syslog('err', "Timeout writing to clamd daemon at $clamd_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
$sock->print("PING");
$sock->flush;
if (!$s->can_read(60)) {
$sock->close;
md_syslog('err', "Timeout reading from clamd daemon at $clamd_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
# Free up memory used by IO::Select object
undef $s;
$sock->sysread($output,256);
$sock->close;
chomp($output);
if (! defined($output) || $output ne "PONG") {
md_syslog('err', "clamd is not responding");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
# open up a socket and scan each file in ./Work
$sock = IO::Socket::UNIX->new(Peer => $clamd_sock);
if (defined $sock) {
if (!$sock->print("SCAN $CWD/Work\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
my $ans;
$ans = $sock->sysread($output,256);
$sock->close;
if (!defined($ans) || !$ans) {
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
if ($output =~ /: (.+) FOUND/) {
$VirusScannerMessages .= "clamd found the $1 virus.\n";
$VirusName = $1;
return (wantarray ? (1, 'virus', 'quarantine') : 1);
} elsif ($output =~ /: (.+) ERROR/) {
my $err_detail = $1;
md_syslog('err', "Clamd returned error: $err_detail");
# If it's a zip module failure, try falling back on clamscan.
# This is despicable, but it might work
if ($err_detail =~ /(?:zip module failure|not supported data format)/i &&
$Features{'Virus:CLAMAV'}) {
my ($code, $category, $action) =
run_virus_scanner($Features{'Virus:CLAMAV'} . " -r --unzip --unrar --stdout --no-summary --infected $CWD/Work 2>&1");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
md_syslog('info', "Falling back on clamscan --unzip --unrar because of Zip module failure in clamd");
return (wantarray ? interpret_clamav_code($code) : $code);
}
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
}
else {
# Could not connect to daemon
md_syslog('err', "Could not connect to clamd daemon at $clamd_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
# No errors, no infected files were found
return (wantarray ? (0, 'ok', 'ok') : 0);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_trophie
# %ARGUMENTS:
# entity -- a MIME entity
# trophie_sock (optional) -- Trophie socket path
# %RETURNS:
# 1 if entity contains a virus as reported by Trophie
# %DESCRIPTION:
# Invokes the Trophie daemon (http://www.vanja.com/tools/trophie/)
# on the entity.
#***********************************************************************
sub entity_contains_virus_trophie {
my ($entity) = shift;
my ($trophie_sock) = $TrophieSock;
$trophie_sock = shift if (@_ > 0);
$trophie_sock = '/var/run/mailplus_server/mimedefang/trophie' if (!defined($trophie_sock));
if (!defined($entity->bodyhandle)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
if (!defined($entity->bodyhandle->path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
my $sock = IO::Socket::UNIX->new(Peer => $trophie_sock);
if (defined $sock) {
my $path = $entity->bodyhandle->path;
# If path is not absolute, add cwd
if (! ($path =~ m+^/+)) {
$path = $CWD . "/" . $path;
}
if (!$sock->print("$path\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
my($output);
$sock->sysread($output, 256);
$sock->close;
if ($output =~ /^1:(.*)$/) {
$VirusScannerMessages .= "Trophie found the $1 virus.\n";
$VirusName = $1;
return (wantarray ? (1, 'virus', 'quarantine') : 1);
}
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Could not connect to daemon
md_syslog('err', "Could not connect to Trophie Daemon at $trophie_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_trophie
# %ARGUMENTS:
# trophie_sock (optional) -- Trophie socket path
# %RETURNS:
# 1 if any file in the working directory contains a virus
# %DESCRIPTION:
# Invokes the Trophie daemon (http://www.vanja.com/tools/trophie/)
# on the entire message.
#***********************************************************************
sub message_contains_virus_trophie {
my ($trophie_sock) = $TrophieSock;
$trophie_sock = shift if (@_ > 0);
$trophie_sock = '/var/run/mailplus_server/mimedefang/trophie' if (!defined($trophie_sock));
my $sock = IO::Socket::UNIX->new(Peer => $trophie_sock);
if (defined $sock) {
if (!$sock->print("$CWD/Work\n")) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
if (!$sock->flush) {
$sock->close;
return (wantarray ? (999, 'swerr', 'tempfail') : 999);
}
my($output);
$sock->sysread($output, 256);
$sock->close;
if ($output =~ /^1:(.*)$/) {
$VirusScannerMessages .= "Trophie found the $1 virus.\n";
$VirusName = $1;
return (wantarray ? (1, 'virus', 'quarantine') : 1);
}
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Could not connect to daemon
md_syslog('err', "Could not connect to Trophie Daemon at $trophie_sock");
return (wantarray ? (999, 'cannot-execute', 'tempfail') : 999);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus_nod32
# %ARGUMENTS:
# entity -- a MIME entity
# %RETURNS:
# 1 if entity contains a virus as reported by NOD32; 0 otherwise.
# %DESCRIPTION:
# Runs Eset NOD32 program on the entity. (http://www.eset.com)
#***********************************************************************
sub entity_contains_virus_nod32 {
unless($Features{'Virus:NOD32'}) {
md_syslog('err', "NOD32 not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
my($entity) = @_;
my($body) = $entity->bodyhandle;
if (!defined($body)) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
# Get filename
my($path) = $body->path;
if (!defined($path)) {
return (wantarray ? (999, 'swerr', 'tempfail') : 1);
}
# Run NOD32
my($code, $category, $action) = run_virus_scanner($Features{'Virus:NOD32'} . " --subdir $path 2>&1", "virus=\"([^\"]+)\"");
if ($action ne 'proceed') {
return (wantarray ? ($code, $category, $action) : $code);
}
return (wantarray ? interpret_nod32_code($code) : $code);
}
#***********************************************************************
# %PROCEDURE: message_contains_virus_nod32
# %ARGUMENTS:
# Nothing
# %RETURNS:
# 1 or 2 if any file in the working directory contains a virus
# %DESCRIPTION:
# Runs Eset NOD32 program on the working directory
#***********************************************************************
sub message_contains_virus_nod32 {
unless($Features{'Virus:NOD32'}) {
md_syslog('err', "NOD32 not installed on this system");
return (wantarray ? (1, 'not-installed', 'tempfail') : 1);
}
# Run NOD32
my($code, $category, $action) = run_virus_scanner($Features{'Virus:NOD32'} . " --subdir ./Work 2>&1", "virus=\"([^\"]+)\"");
return (wantarray ? interpret_nod32_code($code) : $code);
}
sub interpret_nod32_code {
my($code) = @_;
# OK
return ($code, 'ok', 'ok') if ($code == 0);
# 1 or 2 -- virus found
if ($code == 1 || $code == 2) {
$VirusName = $1 if ($CurrentVirusScannerMessage =~ m/virus=\"([^"]*)/);
$VirusName = "unknown-NOD32-virus" if $VirusName eq "";
return ($code, 'virus', 'quarantine');
}
# error
return ($code, 'swerr', 'tempfail');
}
#***********************************************************************
# %PROCEDURE: run_virus_scanner
# %ARGUMENTS:
# cmdline -- command to run
# match -- regular expression to match (default ".*")
# %RETURNS:
# A three-element list: (exitcode, category, recommended_action)
# exitcode is actual exit code from scanner
# category is either "cannot-execute" or "ok"
# recommended_action is either "tempfail" or "proceed"
# %DESCRIPTION:
# Runs a virus scanner, collecting output in $VirusScannerMessages
#***********************************************************************
sub run_virus_scanner {
my($cmd, $match) = @_;
return (999, 'wrong-context', 'tempfail')
if (!in_message_context("run_virus_scanner"));
my($retcode);
my($msg) = "";
$CurrentVirusScannerMessage = "";
$match = ".*" unless defined($match);
unless (open(SCANNER, "$cmd |")) {
$msg = "Unable to execute $cmd: $!";
md_syslog('err', "run_virus_scanner: $msg");
$VirusScannerMessages .= "$msg\n";
$CurrentVirusScannerMessage = $msg;
return (999, 'cannot-execute', 'tempfail');
}
while(<SCANNER>) {
$msg .= $_ if /$match/i;
}
close(SCANNER);
$retcode = $? / 256;
# Some daemons are instructed to save output in a file
if (open(REPORT, "DAEMON.RPT")) {
while(<REPORT>) {
$msg .= $_ if /$match/i;
}
close(REPORT);
unlink("DAEMON.RPT");
}
$VirusScannerMessages .= $msg;
$CurrentVirusScannerMessage = $msg;
return ($retcode, 'ok', 'proceed');
}
#***********************************************************************
# %PROCEDURE: action_tempfail
# %ARGUMENTS:
# reply -- the text reply
# code -- SMTP reply code (eg: 451)
# DSN -- DSN code (eg: 4.3.0)
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Tempfails the message with a 4.x.x SMTP code. If code or DSN are
# omitted or invalid, use 451 and 4.3.0.
#***********************************************************************
sub action_tempfail {
my($reply, $code, $dsn) = @_;
return 0 if (!in_message_context("action_tempfail"));
$reply = "Try again later" unless (defined($reply) and ($reply ne ""));
$code = 451 unless (defined($code) and $code =~ /^4\d\d$/);
$dsn = "4.3.0" unless (defined($dsn) and $dsn =~ /^4\.\d{1,3}\.\d{1,3}$/);
write_result_line('T', $code, $dsn, $reply);
$Actions{'tempfail'}++;
return 1;
}
#***********************************************************************
# %PROCEDURE: pretty_print_mail
# %ARGUMENTS:
# e -- a MIME::Entity object
# size -- maximum size of value to return in characters
# chunk -- optional; used in recursive calls only. Do not supply as arg.
# depth -- used in recursive calls only. Do not supply as arg.
# %RETURNS:
# A "pretty-printed" version of the e-mail body
# %DESCRIPTION:
# Makes a pretty-printed version of the e-mail body no longer than size
# characters. This odd-looking function is used by CanIt...
#***********************************************************************
sub pretty_print_mail {
my($e, $size, $chunk, $depth) = @_;
$chunk = "" unless defined($chunk);
$depth = 0 unless defined($depth);
my(@parts) = $e->parts;
my($type) = $e->mime_type;
my($fname) = takeStabAtFilename($e);
$fname = "; filename=$fname" if ($fname ne "");
my($spaces) = " " x $depth;
$chunk .= "\n$spaces" . "[Part: ${type}${fname}]\n\n";
if ($#parts >= 0) {
my($part);
foreach $part (@parts) {
$chunk = pretty_print_mail($part, $size, $chunk, $depth+1);
last if (length($chunk) >= $size);
}
} else {
return $chunk unless ($type =~ m+^text/+);
my($body) = $e->bodyhandle;
return $chunk unless (defined($body));
my($path) = $body->path;
return $chunk unless (defined($path));
return $chunk unless (open(IN, "<$path"));
while (<IN>) {
$chunk .= $_;
last if (length($chunk) >= $size);
}
close(IN);
}
return $chunk;
}
#***********************************************************************
# %PROCEDURE: md_version
# %ARGUMENTS:
# None
# %RETURNS:
# MIMEDefang version
#***********************************************************************
sub md_version {
return '2.84';
}
#***********************************************************************
# %PROCEDURE: main
# %ARGUMENTS:
# workdir -- directory to "chdir" to and do all work in.
# msg -- file containing MIME message
# %RETURNS:
# 0 if parse went well; non-zero otherwise.
# %DESCRIPTION:
# Main program. Splits the MIME message up and then reconstructs it.
#***********************************************************************
sub main {
my($Filter);
my($workdir);
$Filter = '/var/packages/MailPlus-Server/target/etc/mimedefang/mimedefang-filter';
$DoStatusTags = 0;
my($ip, $name, $sender, $recip, $firstRecip, $helo, $map, $key);
# Check for "-f filter-file" option
if ($#ARGV >= 2) {
if ($ARGV[0] eq "-f") {
$Filter = $ARGV[1];
shift @ARGV;
shift @ARGV;
}
}
if ($#ARGV != 0) {
md_syslog('warning', "Usage: mimedefang.pl [-f filter] workdir | -server | -test | -features | -validate");
print STDERR "Usage: mimedefang.pl [-f filter] workdir | -server | -test | -features | -validate\n";
return 1;
}
$ValidateIPHeader = "";
if (open(IN, '</var/packages/MailPlus-Server/target/etc/mimedefang/mimedefang-ip-key')) {
$ValidateIPHeader = <IN>;
chomp($ValidateIPHeader);
close(IN);
}
# These are set unconditionally; filter() can change them.
$NotifySenderSubject = "MIMEDefang Notification";
$NotifyAdministratorSubject = "MIMEDefang Notification";
$QuarantineSubject = "MIMEDefang Quarantine Report";
$NotifyNoPreamble = 0;
# Load the filter
init_globals();
if ($ValidateIPHeader ne "" and
$ValidateIPHeader !~ /^X-MIMEDefang-Relay/) {
md_syslog('err', "Invalid value for mimedefang-ip-key: $ValidateIPHeader");
$ValidateIPHeader = "";
}
if (! -r $Filter) {
md_syslog('err', "Cannot read filter $Filter: Check permissions. mimedefang.pl will not work.");
}
# Special-case /dev/null so we can invoke without
# a filter for test purposes.
unless ($Filter eq '/dev/null') {
require $Filter;
}
# In case it wasn't done in filter... won't hurt to do it again
detect_and_load_perl_modules();
# Backward-compatibility
if (defined($Administrator)) {
$AdminAddress = $Administrator;
md_syslog('warning', 'Variable $Administrator is deprecated. Use $AdminAddress instead');
}
# Defaults
$AdminName = 'MIMEDefang Administrator' unless defined($AdminName);
$AdminAddress = 'postmaster@localhost' unless defined($AdminAddress);
$DaemonName = 'MIMEDefang' unless defined($DaemonName);
$DaemonAddress = 'mailer-daemon@localhost' unless defined($DaemonAddress);
$SALocalTestsOnly = 1 unless defined($SALocalTestsOnly);
if (!defined($GeneralWarning)) {
$GeneralWarning =
"WARNING: This e-mail has been altered by MIMEDefang. Following this\n" .
"paragraph are indications of the actual changes made. For more\n" .
"information about your site's MIMEDefang policy, contact\n" .
"$AdminName <$AdminAddress>. For more information about MIMEDefang, see:\n\n" .
" $URL\n\n";
}
# check dir
$workdir = $ARGV[0];
if ($workdir eq "-test") {
printf("Filter $Filter seems syntactically correct.\n");
exit(0);
}
if ($workdir eq "-validate") {
if (defined(&filter_validate)) {
exit(filter_validate());
}
print STDERR "ERROR: You must define a function called filter_validate in your filter\nto use the -validate argument.\n";
exit(1);
}
if ($workdir eq "-features") {
# Print available features
my($thing, $ans);
# Print MIMEDefang version
my $ver = md_version();
print("MIMEDefang version $ver\n\n");
# Print the features we have first
foreach $thing (sort keys %Features) {
my($feat);
$feat = $Features{$thing};
$ans = $feat ? "yes" : "no";
if ($ans eq "yes") {
if ($feat ne "1") {
printf("%-30s: %s\n", $thing, "yes ($feat)");
} else {
printf("%-30s: %s\n", $thing, "yes");
}
}
}
# And now print the ones we don't have
foreach $thing (sort keys %Features) {
my($feat);
$feat = $Features{$thing};
$ans = $feat ? "yes" : "no";
if ($ans eq "no") {
printf("%-30s: %s\n", $thing, "no");
}
}
# And print Perl module versions
print("\n");
my($version);
foreach $thing (qw(Archive::Zip Digest::SHA1 HTML::Parser IO::Socket IO::Stringy MIME::Base64 MIME::Tools MIME::Words Mail::Mailer Mail::SpamAssassin Net::DNS Unix::Syslog )) {
unless (eval "require $thing") {
printf("%-30s: missing\n", $thing);
next;
}
$version = $thing->VERSION();
$version = "UNKNOWN" unless defined($version);
printf("%-30s: Version %s\n", $thing, $version);
}
exit(0);
}
my $enter_main_loop;
if ($workdir eq "-server") {
$ServerMode = 1;
$enter_main_loop = 1;
} elsif ($workdir eq "-serveru") {
$ServerMode = 1;
$enter_main_loop = 1;
$DoStatusTags = 1;
} elsif ($workdir eq "-embserver") {
$ServerMode = 1;
$enter_main_loop = 0;
} elsif ($workdir eq "-embserveru") {
$ServerMode = 1;
$DoStatusTags = 1;
$enter_main_loop = 0;
} else {
$ServerMode = 0;
}
if (!$ServerMode) {
chdir($Features{'Path:SPOOLDIR'});
if (defined(&filter_initialize)) {
filter_initialize();
}
init_globals();
do_scan($workdir);
exit(0);
}
do_main_loop() if $enter_main_loop;
}
=item is_public_ip4_address $ip_addr
Returns true if $ip_addr is a publicly-routable IPv4 address, false otherwise
=cut
sub is_public_ip4_address {
my ($addr) = @_;
my @octets = split(/\./, $addr);
# Sanity check: Return false if it's not an IPv4 address
return 0 unless (scalar(@octets) == 4);
foreach my $octet (@octets) {
return 0 if ($octet !~ /^\d+$/);
return 0 if ($octet > 255);
}
# 10.0.0.0 to 10.255.255.255
return 0 if ($octets[0] == 10);
# 172.16.0.0 to 172.31.255.255
return 0 if ($octets[0] == 172 && $octets[1] >= 16 && $octets[1] <= 31);
# 192.168.0.0 to 192.168.255.255
return 0 if ($octets[0] == 192 && $octets[1] == 168);
# Loopback
return 0 if ($octets[0] == 127);
# Local-link for auto-DHCP
return 0 if ($octets[0] == 169 && $octets[1] == 254);
# IPv4 multicast
return 0 if ($octets[0] >= 224 && $octets[0] <= 239);
# Class E ("Don't Use")
return 0 if ($octets[0] >= 240 && $octets[0] <= 247);
# 0.0.0.0 and 255.255.255.255 are bogus
return 0 if ($octets[0] == 0 &&
$octets[1] == 0 &&
$octets[2] == 0 &&
$octets[3] == 0);
return 0 if ($octets[0] == 255 &&
$octets[1] == 255 &&
$octets[2] == 255 &&
$octets[3] == 255);
return 1;
}
=item get_mx_ip_addresses $domain [$resolver_object]
Get IP addresses of all MX hosts for given domain. If there are
no MX hosts, then return A records.
=cut
sub get_mx_ip_addresses {
my($domain, $res) = @_;
my @results;
unless ($Features{"Net::DNS"}) {
md_syslog('err', "Attempted to call get_mx_ip_addresses, but Perl module Net::DNS is not installed");
return @results;
}
if (!defined($res)) {
$res = Net::DNS::Resolver->new;
$res->defnames(0);
}
my $packet = $res->query($domain, 'MX');
if (!defined($packet) ||
$packet->header->rcode eq 'SERVFAIL' ||
$packet->header->rcode eq 'NXDOMAIN' ||
!defined($packet->answer)) {
# No MX records; try A records
$packet = $res->query($domain, 'A');
if (!defined($packet) ||
$packet->header->rcode eq 'SERVFAIL' ||
$packet->header->rcode eq 'NXDOMAIN' ||
!defined($packet->answer)) {
return @results;
}
}
foreach my $item ($packet->answer) {
if ($item->type eq 'MX') {
# Weird MX record of "." or ""
# host -t mx yahoo.com.pk for example
if ($item->exchange eq '' ||
$item->exchange eq '.' ||
$item->exchange eq '0' ||
$item->exchange eq '0 ' ||
$item->exchange eq '0 .' ||
$item->exchange eq '0.') {
push(@results, '0.0.0.0');
next;
}
# If it LOOKS like an IPv4 address, don't do
# an A lookup
if ($item->exchange =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.?$/) {
my ($a, $b, $c, $d) = ($1, $2, $3, $4);
if ($a <= 255 && $b <= 255 && $c <= 255 && $d <= 255) {
push(@results, "$a.$b.$c.$d");
next;
}
}
my $packet2 = $res->query($item->exchange, 'A');
next unless defined($packet2);
next if $packet2->header->rcode eq 'SERVFAIL';
next if $packet2->header->rcode eq 'NXDOMAIN';
next unless defined($packet2->answer);
foreach my $item2 ($packet2->answer) {
if ($item2->type eq 'A') {
push(@results, $item2->address);
}
}
} elsif ($item->type eq 'A') {
push(@results, $item->address);
}
}
return @results;
}
=item md_get_bogus_mx_hosts $domain
Returns a list of "bogus" IP addresses that are in $domain's list of MX
records. A "bogus" IP address is loopback/private/multicast/etc.
=cut
#'
sub md_get_bogus_mx_hosts {
my ($domain) = @_;
my @bogus_hosts = ();
my @mx = get_mx_ip_addresses($domain);
foreach my $mx (@mx) {
if (!is_public_ip4_address($mx)) {
push(@bogus_hosts, $mx);
}
}
return @bogus_hosts;
}
sub do_main_loop
{
init_status_tag();
chdir($Features{'Path:SPOOLDIR'});
if(defined(&filter_initialize)) {
filter_initialize();
}
# Infinite server loop... well, not quite infinite; we stop on EOF
# from STDIN.
while (my $line = <STDIN>) {
chomp $line;
# Clear out vars so they aren't used by filter_begin, etc.
init_globals();
# Change to spool dir -- ignore error
chdir($Features{'Path:SPOOLDIR'});
my ($cmd, @args) = map { percent_decode($_) } split(/\s+/, $line);
$cmd = lc $cmd;
no strict 'refs';
my $cmd_handler = *{"handle_${cmd}"};
use strict 'refs';
if (defined(&{'handle_' . $cmd})) {
no strict 'refs';
&{'handle_' . $cmd}(@args);
use strict 'refs';
} else {
unknown_command_handler( $cmd, @args );
}
}
# EOF on STDIN... time to bye-bye...
if(defined(&filter_cleanup)) {
exit(filter_cleanup());
}
exit(0);
}
# This is the only command handler not named handle_XXXXX for two reasons:
# 1) We don't want someone to pass in a command named 'unknown_command' and
# get this handler.
# 2) This handler takes $cmd as first argument, whereas the others do not get
# their own name passed down as the first arg.
sub unknown_command_handler
{
my ($cmd, @args) = @_;
if(!defined(&filter_unknown_cmd)) {
print_and_flush('error: Unknown command');
return;
}
my ($code, @list) = filter_unknown_cmd($cmd, @args);
$code = "error:" if($code ne "ok" and $code ne "error:");
my $reply = join(' ', map { percent_encode($_) } ($code, @list) );
print_and_flush($reply);
}
sub handle_ping
{
print_and_flush('PONG');
}
sub handle_scan
{
my ($dummyqid, $workdir) = @_;
# EVIL FOLLOWS. AVERT YOUR EYES.
# File::Spec::Unix caches $ENV{'TMPDIR'}.
# We want to force it to cache it BEFORE
# we muck about with the env. variable,
# otherwise code that uses File::Spec->tmpfile
# will fail when our transient $workdir/tmp is
# deleted. Horrible.
# FORCE File::Spec to cache a reasonable tmpfile
File::Spec->tmpdir();
my $old_tmpdir;
mkdir("$workdir/tmp");
if(-d "$workdir/tmp") {
$old_tmpdir = $ENV{'TMPDIR'};
$ENV{'TMPDIR'} = "$workdir/tmp";
} else {
$old_tmpdir = undef;
}
do_scan($workdir);
# If we set TMPDIR to $workdir/tmp, reset it
# here.
if(exists($ENV{'TMPDIR'}) && $ENV{'TMPDIR'} eq "$workdir/tmp")
{
if($old_tmpdir) {
$ENV{'TMPDIR'} = $old_tmpdir;
} else {
delete($ENV{'TMPDIR'});
}
}
chdir($Features{'Path:SPOOLDIR'});
}
sub handle_map
{
my ($map, $key) = @_;
if(!defined(&filter_map)) {
md_syslog('err', "No filter_map function defined");
print_and_flush('PERM No filter_map function defined');
return;
}
my ($code, $val) = filter_map($map, $key);
if( $code ne "OK"
and $code ne "NOTFOUND"
and $code ne "TEMP"
and $code ne "TIMEOUT"
and $code ne "PERM")
{
md_syslog('err', "Invalid code from filter_map: $code");
print_and_flush('PERM Invalid code from filter_map: ' . percent_encode($code));
return;
}
print_and_flush("$code " . percent_encode($val));
}
#***********************************************************************
# %PROCEDURE: handle_tick
# %ARGUMENTS:
# Tick value (integer)
# %DESCRIPTION:
# May be called periodically by multiplexor; runs filter_tick routine
# if it exists.
# %RETURNS:
# Nothing
#***********************************************************************
sub handle_tick
{
my ($tick_no) = @_;
$tick_no ||= 0;
if(defined(&filter_tick)) {
filter_tick($tick_no);
print_and_flush("tock $tick_no");
} else {
print_and_flush("error: tick $tick_no: filter_tick undefined");
}
}
#***********************************************************************
# %PROCEDURE: handle_relayok
# %ARGUMENTS:
# hostip -- IP address of relay host
# hostname -- name of relay host
# port -- client port
# myip -- my IP address
# myport -- my listening port
# %RETURNS:
# Nothing, but prints "ok 1" if we accept connection, "ok 0" if not.
#***********************************************************************
sub handle_relayok
{
my ($hostip, $hostname, $port, $myip, $myport) = @_;
if(!defined(&filter_relay)) {
send_filter_answer('CONTINUE', "ok", "filter_relay", "host $hostip ($hostname)");
return;
}
# Set up globals
$RelayAddr = $hostip;
$RelayHostname = $hostname;
my ($ok, $msg, $code, $dsn, $delay) = filter_relay($hostip, $hostname, $port, $myip, $myport);
send_filter_answer($ok, $msg, "filter_relay", "host $hostip ($hostname)", $code, $dsn, $delay);
}
#***********************************************************************
# %PROCEDURE: handle_helook
# %ARGUMENTS:
# ip -- IP address of relay host
# name -- name of relay host
# helo -- arg to SMTP HELO command
# port -- client port
# myip -- my IP address
# myport -- my listening port
# %RETURNS:
# Nothing, but prints "ok 1" if we accept connections from this host.
# "ok 0" if not.
#***********************************************************************
sub handle_helook
{
my ($ip, $name, $helo, $port, $myip, $myport) = @_;
if(!defined(&filter_helo)) {
send_filter_answer('CONTINUE', "ok", "filter_helo", "helo $helo");
return;
}
# Set up globals
$RelayAddr = $ip;
$RelayHostname = $name;
$Helo = $helo;
my ($ok, $msg, $code, $dsn, $delay) = filter_helo($ip, $name, $helo, $port, $myip, $myport);
send_filter_answer($ok, $msg, "filter_helo", "helo $helo", $code, $dsn, $delay);
}
#***********************************************************************
# %PROCEDURE: handle_senderok
# %ARGUMENTS:
# sender -- e-mail address of sender
# ip -- IP address of relay host
# name -- name of relay host
# helo -- arg to SMTP HELO command
# %RETURNS:
# Nothing, but prints "ok 1" if we accept message from this sender,
# "ok 0" if not.
#***********************************************************************
sub handle_senderok
{
my ($sender, $ip, $name, $helo);
($sender, $ip, $name, $helo, $CWD, $QueueID, @ESMTPArgs) = @_;
if(!defined(&filter_sender)) {
send_filter_answer('CONTINUE', "ok", "filter_sender", "sender $sender");
return;
}
if (!chdir($CWD)) {
send_filter_answer('TEMPFAIL', "could not chdir($CWD): $!", "filter_sender", "sender $sender");
}
# Set up additional globals
$MsgID = $QueueID;
$Sender = $sender;
$RelayAddr = $ip;
$RelayHostname = $name;
$Helo = $helo;
my ($ok, $msg, $code, $dsn, $delay) = filter_sender($sender, $ip, $name, $helo);
send_filter_answer($ok, $msg, "filter_sender", "sender $sender", $code, $dsn, $delay);
chdir($Features{'Path:SPOOLDIR'});
}
#***********************************************************************
# %PROCEDURE: handle_recipok
# %ARGUMENTS:
# recipient -- e-mail address of recipient
# sender -- e-mail address of sender
# ip -- IP address of relay host
# name -- name of relay host
# firstRecip -- first recipient of message
# helo -- arg to SMTP HELO command
# %RETURNS:
# Nothing, but prints "ok 1" if we accept message to this recipient,
# "ok 0" if not.
#***********************************************************************
sub handle_recipok
{
my ($recipient, $sender, $ip, $name, $firstRecip, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr);
($recipient, $sender, $ip, $name, $firstRecip, $helo, $CWD, $QueueID, $rcpt_mailer, $rcpt_host, $rcpt_addr, @ESMTPArgs) = @_;
$MsgID = $QueueID;
if(!defined(&filter_recipient)) {
send_filter_answer('CONTINUE', "ok", "filter_recipient", "recipient $recipient");
return;
}
if (!chdir($CWD)) {
send_filter_answer('TEMPFAIL', "could not chdir($CWD): $!", "filter_recipient", "recipient $recipient");
}
# Set up additional globals
@Recipients = ($recipient);
$Sender = $sender;
$RelayAddr = $ip;
$RelayHostname = $name;
$Helo = $helo;
$RecipientMailers{$recipient} = [ $rcpt_mailer, $rcpt_host, $rcpt_addr ];
my ($ok, $msg, $code, $dsn, $delay) = filter_recipient($recipient, $sender, $ip, $name, $firstRecip, $helo, $rcpt_mailer, $rcpt_host, $rcpt_addr);
send_filter_answer($ok, $msg, "filter_recipient", "recipient $recipient", $code, $dsn, $delay);
chdir($Features{'Path:SPOOLDIR'});
}
sub print_and_flush
{
local $| = 1;
print($_[0], "\n");
}
sub init_globals {
$CWD = $Features{'Path:SPOOLDIR'};
$InMessageContext = 0;
$InFilterEnd = 0;
$InFilterContext = 0;
$InFilterWrapUp = 0;
undef $FilterEndReplacementEntity;
$Action = "";
$Changed = 0;
$DefangCounter = 0;
$Domain = "";
$MIMEDefangID = "";
$MsgID = "NOQUEUE";
$MessageID = "NOQUEUE";
$Helo = "";
$QueueID = "NOQUEUE";
$QuarantineCount = 0;
$Rebuild = 0;
$EntireMessageQuarantined = 0;
$QuarantineSubdir = "";
$RelayAddr = "";
$RealRelayAddr = "";
$WasResent = 0;
$RelayHostname = "";
$RealRelayHostname = "";
$Sender = "";
$Subject = "";
$SubjectCount = 0;
$SuspiciousCharsInHeaders = 0;
$SuspiciousCharsInBody = 0;
$TerminateAndDiscard = 0;
$VirusScannerMessages = "";
$VirusName = "";
$WasMultiPart = 0;
$WarningCounter = 0;
undef %Actions;
undef %SendmailMacros;
undef %RecipientMailers;
undef %RecipientESMTPArgs;
undef @FlatParts;
undef @Recipients;
undef @Warnings;
undef @AddedParts;
undef @StatusTags;
undef @ESMTPArgs;
undef @SenderESMTPArgs;
undef $results_fh;
}
sub builtin_create_parser {
my $parser = MIME::Parser->new();
$parser->extract_nested_messages(1);
$parser->extract_uuencode(1);
$parser->output_to_core(0);
$parser->tmp_to_core(0);
return $parser;
}
#***********************************************************************
# %PROCEDURE: do_scan
# %ARGUMENTS:
# workdir -- working directory to scan
# %RETURNS:
# 0 if parse went well; non-zero otherwise.
# %DESCRIPTION:
# Scan a message in working directory.
#***********************************************************************
sub do_scan {
my($workdir) = @_;
if (!chdir($workdir)) {
fatal("Cannot chdir($workdir): $!");
return -1;
}
$CWD = $workdir;
# Read command file
push_status_tag("Reading COMMANDS");
read_commands_file('need_F') or return -1;
pop_status_tag();
# We're processing a message
$InMessageContext = 1;
# Set message ID
if ($QueueID ne "") {
$MsgID = $QueueID;
} elsif ($MessageID ne "") {
$MsgID = $MessageID;
} else {
$MsgID = "NOQUEUE";
}
if ($QueueID eq "") {
$QueueID = "NOQUEUE";
}
if ($MessageID eq "") {
$MessageID = "NOQUEUE";
}
my($file) = "INPUTMSG";
# Create a subdirectory for storing all the actual message data
my($msgdir) = "Work";
if (!mkdir($msgdir, 0750)) {
fatal("Cannot mkdir($msgdir): $!");
return -1;
}
my $entity;
my $parser;
if (defined(&filter_create_parser)) {
$parser = filter_create_parser();
if (!defined($parser) ||
!$parser->isa('MIME::Parser')) {
$parser = builtin_create_parser();
}
} else {
$parser = builtin_create_parser();
}
my $filer = MIME::Parser::FileInto->new($msgdir);
# Don't trust any filenames from the message.
$filer->ignore_filename(1);
$parser->filer($filer);
# Parse the input stream:
if (!open(FILE, $file)) {
fatal("couldn't open $file: $!");
signal_complete();
return -1;
}
if ($MaxMIMEParts > 0) {
$parser->max_parts($MaxMIMEParts);
}
push_status_tag("Parsing Message");
$entity = $parser->parse(\*FILE);
pop_status_tag();
close FILE;
if (!defined($entity) && $MaxMIMEParts > 0) {
# Message is too complex; bounce it
action_bounce("Message contained too many MIME parts. We do not accept such complicated messages.");
signal_unchanged();
signal_complete();
return;
}
if (!$entity) {
fatal("Couldn't parse MIME in $file: $!");
signal_complete();
return -1;
}
# Make entity multipart
my ($code);
$code = $entity->make_multipart();
$WasMultiPart = ($code eq 'ALREADY');
# If there are multiple Subject: lines, delete all but the first
if ($SubjectCount > 1) {
md_syslog('warning', "Message contains $SubjectCount Subject: headers. Deleting all but the first");
for (my $i=$SubjectCount; $i > 1; $i--) {
action_delete_header("Subject", $i);
}
}
# Call pre-scan filter if defined
if (defined(&filter_begin)) {
push_status_tag("In filter_begin");
filter_begin($entity);
pop_status_tag();
# If stream_by_domain tells us to discard, do so...
if ($TerminateAndDiscard) {
write_result_line("D", "");
signal_unchanged();
md_syslog('debug', "filter_begin set TerminateAndDiscard flag. Don't panic; it's most likely a message being streamed.");
signal_complete();
return;
}
}
# Now rebuild the message!
my($boundary);
my($rebuilt);
my($rebuilt_flat);
# Prepare rebuilt container.
# We don't want a deep copy here, so do some trickery...
my @parts;
# Save parts
@parts = $entity->parts;
# Clear them out prior to deep copy
$entity->parts([]);
# "Deep" copy (ha ha...)
$rebuilt = $entity->dup;
# And restore parts to original
$entity->parts(\@parts);
# Rebuild
$InFilterContext = 1;
push_status_tag("In rebuild loop");
map { rebuild_entity($rebuilt, $_) } $entity->parts;
pop_status_tag();
if ($#Warnings >= 0) {
my $didSomething = 0;
my $html_warning;
$Changed = 1;
if ($AddWarningsInline) {
my $warning = $GeneralWarning . join("\n", @Warnings);
my $ruler = "=" x 75;
$html_warning = $warning;
$html_warning =~ s/&/&/g;
$html_warning =~ s/</</g;
$html_warning =~ s/>/>/g;
$didSomething = 1
if append_text_boilerplate($rebuilt, "$ruler\n$warning", 0);
$didSomething = 1
if append_html_boilerplate($rebuilt, "<hr>\n<pre>\n$html_warning</pre>", 0);
}
if (!$didSomething) {
# HACK for Micro$oft "LookOut!"
if ($WasMultiPart &&
$Stupidity{"NoMultipleInlines"} &&
$WarningLocation == 0) {
# Descend into first leaf
my($msg) = $rebuilt;
my(@parts) = $msg->parts;
while($#parts >= 0) {
$msg = $parts[0];
@parts = $msg->parts;
}
my($head) = $msg->head;
my($type) = $msg->mime_type;
if (lc($head->mime_type) eq "text/plain") {
$head->mime_attr("Content-Type.name" => "MESSAGE.TXT");
$head->mime_attr("Content-Disposition" => "inline");
$head->mime_attr("Content-Disposition.filename" => "MESSAGE.TXT");
$head->mime_attr("Content-Description" => "MESSAGE.TXT");
}
}
my $warns = $GeneralWarning . join("\n", @Warnings);
$WarningCounter++;
action_add_part($rebuilt, "text/plain", "-suggest",
$warns, "warning$WarningCounter.txt", "inline", $WarningLocation);
}
}
$InFilterContext = 0;
# Call post-scan filter if defined
if (defined(&filter_end)) {
$InFilterEnd = 1;
push_status_tag("In filter_end");
filter_end($rebuilt);
pop_status_tag();
$InFilterEnd = 0;
}
if ($Rebuild && defined($FilterEndReplacementEntity)) {
$rebuilt = $FilterEndReplacementEntity;
undef $FilterEndReplacementEntity;
}
if ($Changed || $Rebuild) {
if (!open(OUT, ">NEWBODY")) {
fatal("Can't open NEWBODY: $!");
signal_complete();
return -1;
}
# Add any parts inserted by action_add_part
$rebuilt = process_added_parts($rebuilt);
# Trim out useless multiparts. FIXME: Make this optional?
while ((lc($rebuilt->head->mime_type) eq "multipart/mixed" ||
lc($rebuilt->head->mime_type) eq "multipart/alternative") &&
$rebuilt->parts == 1 && defined($rebuilt->parts(0))) {
$rebuilt->make_singlepart();
}
push_status_tag("Writing new body");
$rebuilt->print_body(\*OUT);
pop_status_tag();
close(OUT);
# Write new content-type header in case we've changed the type.
my $ct = $rebuilt->head->get('Content-Type');
if (!defined($ct)) {
my $type;
$type = $rebuilt->mime_type;
$boundary = $rebuilt->head->multipart_boundary;
if (defined($boundary)) {
$ct = "$type; boundary=\"$boundary\"";
} else {
$ct = "$type";
}
}
if (defined($ct)) {
chomp($ct);
write_result_line("M", $ct);
}
# Write out all the other MIME headers associated with the rebuilt
# entity.
my($tag, $hdr);
foreach $tag (grep {/^content-/i} $rebuilt->head->tags) {
# Already done content-type
next if ($tag =~ /^content-type$/i);
if ($tag =~ /^content-transfer-encoding$/i) {
# If it is now multipart, but wasn't before, we will
# delete any content-transfer-encoding header.
if ($rebuilt->head->mime_type =~ m+^multipart/+i &&
!$WasMultiPart) {
next;
}
}
$hdr = $rebuilt->head->get($tag);
if (defined($hdr) && $hdr ne "") {
chomp($hdr);
action_change_header($tag, $hdr);
}
}
# If it is now multipart, but wasn't before, delete
# content-transfer-encoding header.
if ($rebuilt->head->mime_type =~ m+^multipart/+i &&
!$WasMultiPart) {
action_delete_header("Content-Transfer-Encoding");
}
signal_changed();
} else {
signal_unchanged();
}
# Call filter_wrapup if defined
if (defined(&filter_wrapup)) {
$InFilterWrapUp = 1;
push_status_tag("In filter_wrapup");
filter_wrapup($rebuilt);
pop_status_tag();
$InFilterWrapUp = 0;
}
signal_complete();
return 0;
}
#***********************************************************************
# %PROCEDURE: read_commands_file
# %ARGUMENTS:
# needf - if true, will return an error when no closing "F" was found.
# (optional, default is false). needf should not be set when
# called from within filter_relay, filter_sender, filter_recipient.
# %RETURNS:
# true if parse went well,
# false otherwise
# %DESCRIPTION:
# Parses the COMMANDS file, and sets these global variables based
# upon the contents of that file:
# $Sender
# @Recipients
# %RecipientMailers
# $SuspiciousCharsInHeaders
# $SuspiciousCharsInBody
# $RelayAddr
# $RealRelayAddr
# $WasResent
# $RelayHostname
# $RealRelayHostname
# $QueueID
# $Subject
# $MessageID
# $Helo
# %SendmailMacros
#
#***********************************************************************
sub read_commands_file {
my $needF = shift;
$needF = 0 unless defined($needF);
if (!open(IN, "<COMMANDS")) {
fatal("Cannot open COMMANDS file from mimedefang: $!");
return 0;
}
my($cmd, $arg, $rawcmd, $rawarg, $seenF);
# Save current recipient if called from filter_recipient
my @tmp_recipients = @Recipients;
@Recipients = ();
$seenF = 0;
my $recent_recip = "";
while(<IN>) {
chomp;
$rawcmd = $_;
$cmd = percent_decode($rawcmd);
$arg = substr($cmd, 1);
$cmd = substr($cmd, 0, 1);
$rawarg = substr($rawcmd, 1);
if ($cmd eq "S") {
$Sender = $arg;
} elsif ($cmd eq "s") {
push(@SenderESMTPArgs, $arg);
} elsif ($cmd eq "F") {
$seenF = 1;
last;
} elsif ($cmd eq "R") {
my($recip, $rcpt_mailer, $rcpt_host, $rcpt_addr);
($recip, $rcpt_mailer, $rcpt_host, $rcpt_addr) = split(' ', $rawarg);
$rcpt_mailer = "?" unless (defined($rcpt_mailer) and ($rcpt_mailer ne ""));
$rcpt_host = "?" unless (defined($rcpt_host) and ($rcpt_host ne ""));
$rcpt_addr = "?" unless (defined($rcpt_addr) and ($rcpt_addr ne ""));
$recip = percent_decode($recip);
$rcpt_mailer = percent_decode($rcpt_mailer);
$rcpt_host = percent_decode($rcpt_host);
$rcpt_addr = percent_decode($rcpt_addr);
push(@Recipients, $recip);
$RecipientMailers{$recip} = [$rcpt_mailer, $rcpt_host, $rcpt_addr];
$recent_recip = $recip;
} elsif ($cmd eq "r") {
push (@{$RecipientESMTPArgs{$recent_recip}}, $arg);
} elsif ($cmd eq "!") {
$SuspiciousCharsInHeaders = 1;
} elsif ($cmd eq "?") {
$SuspiciousCharsInBody = 1;
} elsif ($cmd eq "I") {
$RelayAddr = $arg;
$RealRelayAddr = $arg;
} elsif ($cmd eq "J") {
$WasResent = 1;
$RelayAddr = $arg;
my($iaddr, $iname);
$iaddr = inet_aton($RelayAddr);
$iname = gethostbyaddr($iaddr, AF_INET);
if (defined($iname)) {
$RelayHostname = $iname;
} else {
$RelayHostname = "[$RelayAddr]";
}
} elsif ($cmd eq "H") {
$RelayHostname = $arg;
$RealRelayHostname = $arg;
} elsif ($cmd eq "Q") {
$QueueID = $arg;
} elsif ($cmd eq "U") {
$SubjectCount++;
if ($SubjectCount > 1) {
md_syslog('warning', "Message contains more than one Subject: header: $Subject --> $arg");
} else {
$Subject = $arg;
}
} elsif ($cmd eq "X") {
$MessageID = $arg;
} elsif ($cmd eq "E") {
$Helo = $arg;
} elsif ($cmd eq "=") {
my($macro, $value);
($macro, $value) = split(' ', $rawarg);
$value = "" unless defined($value);
$macro = "" unless defined($macro);
if ($macro ne "") {
$macro = percent_decode($macro);
$value = percent_decode($value);
$SendmailMacros{$macro} = $value;
}
} elsif ($cmd eq "i") {
$MIMEDefangID = $arg;
} else {
md_syslog('warning', "Unknown command $cmd from mimedefang");
}
}
close(IN);
if ( $needF && !$seenF ) {
md_syslog('err', "COMMANDS file from mimedefang did not terminate with 'F' -- check disk space in spool directory");
fatal("COMMANDS file did not end with F");
return 0;
}
push @Recipients, @tmp_recipients;
return 1;
}
#***********************************************************************
# %PROCEDURE: replace_entire_message
# %ARGUMENTS:
# e -- a MIME::Entity
# %RETURNS:
# 1 on success; 0 on failure.
# %DESCRIPTION:
# Replaces entire message with $e
# %PRECONDITIONS:
# Can only be called from filter_end
#***********************************************************************
sub replace_entire_message {
my($e) = @_;
return 0 unless in_filter_end("replace_entire_message");
if (!defined($e)) {
md_syslog('err', "Call to replace_entire_message with undefined argument");
return 0;
}
if (ref($e) ne "MIME::Entity") {
md_syslog('err', "Call to replace_entire_message with agument that is not of type MIME::Entity");
return 0;
}
$FilterEndReplacementEntity = $e;
$Rebuild = 1;
return 1;
}
#***********************************************************************
# %PROCEDURE: remove_redundant_html_parts
# %ARGUMENTS:
# e -- entity
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Rebuilds $e without redundant HTML parts. That is, if
# a multipart/alternative entity contains text/plain and text/html
# parts, we nuke the text/html part.
#***********************************************************************
sub remove_redundant_html_parts {
my($e) = @_;
return 0 unless in_filter_end("remove_redundant_html_parts");
my(@parts) = $e->parts;
my($type) = lc($e->mime_type);
# Don't recurse into multipart/signed or multipart/encrypted
return 0 if ($type eq "multipart/signed" or
$type eq "multipart/encrypted");
my(@keep, $part);
my($didsomething);
$didsomething = 0;
my($have_text_plain);
if ($type eq "multipart/alternative" && $#parts >= 0) {
# First look for a text/plain part
$have_text_plain = 0;
foreach $part (@parts) {
$type = lc($part->mime_type);
if ($type eq "text/plain") {
$have_text_plain = 1;
last;
}
}
# If we have a text/plain part, delete any text/html part
if ($have_text_plain) {
foreach $part (@parts) {
$type = lc($part->mime_type);
if ($type ne "text/html") {
push(@keep, $part);
} else {
$didsomething = 1;
}
}
if ($didsomething) {
$e->parts(\@keep);
@parts = @keep;
$Changed = 1;
}
}
}
if ($#parts >= 0) {
foreach $part (@parts) {
$didsomething = 1 if (remove_redundant_html_parts($part));
}
}
return $didsomething;
}
#***********************************************************************
# %PROCEDURE: find_part
# %ARGUMENTS:
# entity -- root MIME part
# content_type -- desired MIME content type
# skip_pgp_mime -- If true, do not descend into multipart/signed or
# multipart/encrypted parts
# %RETURNS:
# First MIME entity of type "$content_type"; undef if none exists.
#***********************************************************************
sub find_part {
my($entity, $content_type, $skip_pgp_mime) = @_;
my(@parts);
my($part);
my($ans);
if (!($entity->is_multipart)) {
if (lc($entity->head->mime_type) eq lc($content_type)) {
return $entity;
} else {
return undef;
}
}
if ($skip_pgp_mime &&
(lc($entity->head->mime_type) eq "multipart/signed" or
lc($entity->head->mime_type) eq "multipart/encrypted")) {
return undef;
}
@parts = $entity->parts;
foreach $part (@parts) {
$ans = find_part($part, $content_type, $skip_pgp_mime);
return $ans if defined($ans);
}
return undef;
}
#***********************************************************************
# %PROCEDURE: append_to_part
# %ARGUMENTS:
# part -- a mime entity
# msg -- text to append to the entity
# %RETURNS:
# 1 on success; 0 on failure.
# %DESCRIPTION:
# Appends text to $part
#***********************************************************************
sub append_to_part {
my($part, $boilerplate) = @_;
return 0 unless defined($part->bodyhandle);
my($path) = $part->bodyhandle->path;
return 0 unless (defined($path));
return 0 unless (open(OUT, ">>$path"));
print OUT "\n$boilerplate\n";
close(OUT);
$Changed = 1;
return 1;
}
# HTML parser callbacks
sub html_echo {
my($text) = @_;
print OUT $text;
}
sub html_end {
my($text) = @_;
if (!$HTMLFoundEndBody) {
if ($text =~ m+<\s*/body+i) {
print OUT "$HTMLBoilerplate\n";
$HTMLFoundEndBody = 1;
}
}
if (!$HTMLFoundEndBody) {
if ($text =~ m+<\s*/html+i) {
print OUT "$HTMLBoilerplate\n";
$HTMLFoundEndBody = 1;
}
}
print OUT $text;
}
#***********************************************************************
# %PROCEDURE: append_to_html_part
# %ARGUMENTS:
# part -- a mime entity (of type text/html)
# msg -- text to append to the entity
# %RETURNS:
# 1 on success; 0 on failure.
# %DESCRIPTION:
# Appends text to $part, but does so by parsing HTML and adding the
# text before </body> or </html>
#***********************************************************************
sub append_to_html_part {
my($part, $boilerplate) = @_;
if (!$Features{"HTML::Parser"}) {
md_syslog('warning', "Attempt to call append_to_html_part, but HTML::Parser Perl module not installed");
return 0;
}
return 0 unless defined($part->bodyhandle);
my($path) = $part->bodyhandle->path;
return 0 unless (defined($path));
return 0 unless (open(IN, "<$path"));
if (!open(OUT, ">$path.tmp")) {
close(IN);
return(0);
}
$HTMLFoundEndBody = 0;
$HTMLBoilerplate = $boilerplate;
my($p);
$p = HTML::Parser->new(api_version => 3,
default_h => [\&html_echo, "text"],
end_h => [\&html_end, "text"]);
$p->unbroken_text(1);
$p->parse_file(*IN);
if (!$HTMLFoundEndBody) {
print OUT "\n$boilerplate\n";
}
close(IN);
close(OUT);
# Rename the path
return 0 unless rename($path, "$path.old");
unless (rename("$path.tmp", $path)) {
rename ("$path.old", $path);
return 0;
}
unlink "$path.old";
$Changed = 1;
return 1;
}
#***********************************************************************
# %PROCEDURE: append_text_boilerplate
# %ARGUMENTS:
# msg -- root MIME entity.
# boilerplate -- boilerplate text to append
# all -- if 1, append to ALL text/plain parts. If 0, append only to
# FIRST text/plain part.
# %RETURNS:
# 1 if text was appended to at least one part; 0 otherwise.
# %DESCRIPTION:
# Appends text to text/plain part or parts.
#***********************************************************************
sub append_text_boilerplate {
my($msg, $boilerplate, $all) = @_;
my($part);
if (!$all) {
$part = find_part($msg, "text/plain", 1);
if (defined($part)) {
if (append_to_part($part, $boilerplate)) {
$Actions{'append_text_boilerplate'}++;
return 1;
}
}
return 0;
}
@FlatParts = ();
my($ok) = 0;
collect_parts($msg, 1);
foreach $part (@FlatParts) {
if (lc($part->head->mime_type) eq "text/plain") {
if (append_to_part($part, $boilerplate)) {
$ok = 1;
$Actions{'append_text_boilerplate'}++;
}
}
}
return $ok;
}
#***********************************************************************
# %PROCEDURE: append_html_boilerplate
# %ARGUMENTS:
# msg -- root MIME entity.
# boilerplate -- boilerplate text to append
# all -- if 1, append to ALL text/html parts. If 0, append only to
# FIRST text/html part.
# %RETURNS:
# 1 if text was appended to at least one part; 0 otherwise.
# %DESCRIPTION:
# Appends text to text/html part or parts. Tries to be clever and
# insert the text before the </body> tag so it has a hope in hell of
# being seen.
#***********************************************************************
sub append_html_boilerplate {
my($msg, $boilerplate, $all) = @_;
my($part);
if (!$all) {
$part = find_part($msg, "text/html", 1);
if (defined($part)) {
if (append_to_html_part($part, $boilerplate)) {
$Actions{'append_html_boilerplate'}++;
return 1;
}
}
return 0;
}
@FlatParts = ();
my($ok) = 0;
collect_parts($msg, 1);
foreach $part (@FlatParts) {
if (lc($part->head->mime_type) eq "text/html") {
if (append_to_html_part($part, $boilerplate)) {
$ok = 1;
$Actions{'append_html_boilerplate'}++;
}
}
}
return $ok;
}
#***********************************************************************
# %PROCEDURE: action_replace_with_url
# %ARGUMENTS:
# entity -- part to replace
# doc_root -- document root in which to place file
# base_url -- base URL for retrieving document
# msg -- message to replace document with. The string "_URL_" is
# replaced with the actual URL of the part.
# cd_data -- optional Content-Disposition filename data to save
# salt -- optional salt to add to SHA1 hash.
# %RETURNS:
# 1 on success, 0 on failure
# %DESCRIPTION:
# Places the part in doc_root/{sha1_of_part}.ext and replaces it with
# a text/plain part giving the URL for pickup.
#***********************************************************************
sub action_replace_with_url {
my($entity, $doc_root, $base_url, $msg, $cd_data, $salt) = @_;
my($ctx);
my($path);
my($fname, $ext, $name, $url);
my $extension = "";
return 0 unless in_filter_context("action_replace_with_url");
return 0 unless defined($entity->bodyhandle);
$path = $entity->bodyhandle->path;
return 0 unless defined($path);
open(IN, "<$path") or return 0;
$ctx = Digest::SHA1->new;
$ctx->addfile(*IN);
$ctx->add($salt) if defined($salt);
close(IN);
$fname = takeStabAtFilename($entity);
$fname = "" unless defined($fname);
$extension = $1 if ($fname =~ /(\.[^.]*)$/);
# Use extension if it is .[alpha,digit,underscore]
$extension = "" unless ($extension =~ /^\.[A-Za-z0-9_]*$/);
# Filename to save
$name = $ctx->hexdigest . $extension;
$fname = $doc_root . "/" . $name;
$url = $base_url . "/" . $name;
if (-r $fname) {
# If file exists, then this is either a duplicate or someone
# has defeated SHA1. Just update the mtime on the file.
my($now);
$now = time;
utime($now, $now, $fname);
} else {
copy_or_link($path, $fname) or return 0;
# In case umask is whacked...
chmod 0644, $fname;
}
# save optional Content-Disposition data
if (defined($cd_data) and ($cd_data ne "")) {
if (open CDF, ">$doc_root/.$name") {
print CDF $cd_data;
close CDF;
chmod 0644, "$doc_root/.$name";
}
}
$msg =~ s/_URL_/$url/g;
action_replace_with_warning($msg);
return 1;
}
#***********************************************************************
# %PROCEDURE: add_recipient
# %ARGUMENTS:
# recip -- recipient to add
# %RETURNS:
# 0 on failure, 1 on success.
# %DESCRIPTION:
# Signals to MIMEDefang to add a recipient to the envelope.
#***********************************************************************
sub add_recipient {
my($recip) = @_;
write_result_line("R", $recip);
return 1;
}
#***********************************************************************
# %PROCEDURE: change_sender
# %ARGUMENTS:
# sender -- new envelope sender
# %RETURNS:
# 0 on failure, 1 on success.
# %DESCRIPTION:
# Signals to MIMEDefang to change the envelope sender. Only works on
# Sendmail 8.14.0 and higher, but no feedback is given to Perl caller!
#***********************************************************************
sub change_sender {
my($sender) = @_;
write_result_line("f", $sender);
return 1;
}
#***********************************************************************
# %PROCEDURE: delete_recipient
# %ARGUMENTS:
# recip -- recipient to delete
# %RETURNS:
# 0 on failure, 1 on success.
# %DESCRIPTION:
# Signals to MIMEDefang to delete a recipient from the envelope.
#***********************************************************************
sub delete_recipient {
my($recip) = @_;
write_result_line("S", $recip);
return 1;
}
#***********************************************************************
# %PROCEDURE: spam_assassin_is_spam
# %ARGUMENTS:
# config -- optional configuration file
# %RETURNS:
# 1 if SpamAssassin thinks current message is SPAM; 0 otherwise
# or if message could not be opened.
# %DESCRIPTION:
# Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_is_spam {
my($hits, $req, $tests, $report) = spam_assassin_check(@_);
return undef if (!defined($hits));
return ($hits >= $req);
}
#***********************************************************************
# %PROCEDURE: spam_assassin_check
# %ARGUMENTS:
# config -- optional spamassassin config file
# %RETURNS:
# An array of four elements,
# Weight of message ('hits')
# Number of hits required before SA conciders a message spam
# Comma separated list of symbolic test names that were triggered
# A 'report' string, detailing tests that failed and their weights
# %DESCRIPTION:
# Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_check {
my($status) = spam_assassin_status(@_);
return undef if (!defined($status));
my $hits = $status->get_hits;
my $req = $status->get_required_hits();
my $tests = $status->get_names_of_tests_hit();
my $report = $status->get_report();
$status->finish();
return ($hits, $req, $tests, $report);
}
#***********************************************************************
# %PROCEDURE: spam_assassin_status
# %ARGUMENTS:
# config -- optional spamassassin config file
# %RETURNS:
# A Mail::SpamAssassin:PerMsgStatus object.
# CALLER IS RESPONSIBLE FOR CALLING finish()
# %DESCRIPTION:
# Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_status {
my $object = spam_assassin_init(@_);
return undef unless $object;
my $mail = spam_assassin_mail();
return undef unless $mail;
my $status;
push_status_tag("Running SpamAssassin");
$status = $object->check($mail);
$mail->finish();
pop_status_tag();
return $status;
}
#***********************************************************************
# %PROCEDURE: spam_assassin_init
# %ARGUMENTS:
# config -- optional spamassassin config file
# %RETURNS:
# A Mail::SpamAssassin object.
# %DESCRIPTION:
# Scans message using SpamAssassin (http://www.spamassassin.org)
#***********************************************************************
sub spam_assassin_init {
my($config) = @_;
my $LOCAL_RULES_DIR = '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin';
my $LOCAL_STATE_DIR = '/var/lib';
unless ($Features{"SpamAssassin"}) {
md_syslog('err', "Attempt to call SpamAssassin function, but SpamAssassin is not installed.");
return undef;
}
if (!defined($SASpamTester)) {
if (!defined($config)) {
if (-r '/var/packages/MailPlus-Server/target/etc/mimedefang/sa-mimedefang.cf') {
$config = '/var/packages/MailPlus-Server/target/etc/mimedefang/sa-mimedefang.cf';
} elsif (-r '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin/sa-mimedefang.cf') {
$config = '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin/sa-mimedefang.cf';
} elsif (-r '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin/local.cf') {
$config = '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin/local.cf';
} else {
$config = '/var/packages/MailPlus-Server/target/etc/mimedefang/spamassassin.cf';
}
}
push_status_tag("Creating SpamAssasin Object");
my $sa_args = {
local_tests_only => $SALocalTestsOnly,
dont_copy_prefs => 1,
userprefs_filename => $config,
user_dir => $Features{'Path:QUARANTINEDIR'},
};
# If SpamAssassin version is older than 3.1.5, we must set
# LOCAL_STATE_DIR or LOCAL_RULES_DIR, because Mail::SpamAssassin
# doesn't provide a default value.
if ($Mail::SpamAssassin::VERSION < 3.001005) {
$sa_args->{LOCAL_STATE_DIR} = $LOCAL_STATE_DIR;
$sa_args->{LOCAL_RULES_DIR} = $LOCAL_RULES_DIR;
}
$SASpamTester = Mail::SpamAssassin->new( $sa_args );
pop_status_tag();
}
return $SASpamTester;
}
#***********************************************************************
# %PROCEDURE: spam_assassin_mail
# %ARGUMENTS:
# none
# %RETURNS:
# A Mail::SpamAssassin::Message object
#***********************************************************************
sub spam_assassin_mail {
unless ($Features{"SpamAssassin"}) {
md_syslog('err', "Attempt to call SpamAssassin function, but SpamAssassin is not installed.");
return undef;
}
open(IN, "<./INPUTMSG") or return undef;
my @msg = <IN>;
close(IN);
# Synthesize a "Return-Path" and "Received:" header
my @sahdrs;
push (@sahdrs, "Return-Path: $Sender\n");
push (@sahdrs, split(/^/m, synthesize_received_header()));
if ($AddApparentlyToForSpamAssassin and
($#Recipients >= 0)) {
push(@sahdrs, "Apparently-To: " .
join(", ", @Recipients) . "\n");
}
unshift (@msg, @sahdrs);
if (!defined($SASpamTester)) {
spam_assassin_init(@_);
return undef unless $SASpamTester;
}
return $SASpamTester->parse(\@msg);
}
#***********************************************************************
# %PROCEDURE: send_filter_answer
# %ARGUMENTS:
# ok -- 1 = accept, 0 = reject, -1 = tmpfail
# msg -- if non-blank, additional message
# who -- one of "filter_sender", "filter_relay" or "filter_recipient"
# what -- the address or host being adjusted
# code -- SMTP reply code
# dsn -- DSN code
# delay -- number of seconds C code should delay before returning
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sends an answer back for filter_relay, filter_sender and filter_recipient
#***********************************************************************
sub send_filter_answer {
my($ok, $msg, $who, $what, $code, $dsn, $delay) = @_;
my($num_ok);
$num_ok = 0;
# Did we get an integer?
$delay = 0 unless (defined($delay) and $delay =~ /^\d+$/);
if ($ok =~ /^-?\d+$/) {
$num_ok = $ok;
}
$msg = "?" if (!defined($msg) or ($msg eq ""));
if ($ok eq 'ACCEPT_AND_NO_MORE_FILTERING') {
md_syslog('debug', "$who said ACCEPT_AND_NO_MORE_FILTERING: No further filtering for this message");
$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
$msg = percent_encode($msg);
$code = percent_encode($code);
$dsn = percent_encode($dsn);
print_and_flush("ok 2 $msg $code $dsn $delay");
} elsif ($ok eq 'DISCARD') {
$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
$msg = percent_encode($msg);
$code = percent_encode($code);
$dsn = percent_encode($dsn);
md_syslog('info', "$who said DISCARD: Discarding this message");
print_and_flush("ok 3 $msg $code $dsn $delay");
} elsif (($ok eq 'CONTINUE') or ($num_ok > 0)) {
$code = 250 unless (defined($code) and $code =~ /^2\d\d$/);
$dsn = "2.1.0" unless (defined($dsn) and $dsn =~ /^2\.\d{1,3}\.\d{1,3}$/);
$msg = percent_encode($msg);
$code = percent_encode($code);
$dsn = percent_encode($dsn);
print_and_flush("ok 1 $msg $code $dsn $delay");
} elsif (($ok eq 'TEMPFAIL') or ($num_ok < 0)) {
md_syslog('debug', "$who tempfailed $what");
$code = 451 unless (defined($code) and $code =~ /^4\d\d$/);
$dsn = "4.3.0" unless (defined($dsn) and $dsn =~ /^4\.\d{1,3}\.\d{1,3}$/);
$msg = percent_encode($msg);
$code = percent_encode($code);
$dsn = percent_encode($dsn);
print_and_flush("ok -1 $msg $code $dsn $delay");
} else {
$code = 554 unless (defined($code) and $code =~ /^5\d\d$/);
$dsn = "5.7.1" unless (defined($dsn) and $dsn =~ /^5\.\d{1,3}\.\d{1,3}$/);
md_syslog('debug', "$who rejected $what");
$msg = percent_encode($msg);
$code = percent_encode($code);
$dsn = percent_encode($dsn);
print_and_flush("ok 0 $msg $code $dsn $delay");
}
}
#***********************************************************************
# %PROCEDURE: md_graphdefang_log_enable
# %ARGUMENTS:
# SyslogFacility -- (optional) The Syslog facility to which mimedefang
# should log messages when md_graphdefang_log() is called. If
# this variable is not passed in, a default value
# of 'mail' will be used.
# EnumerateRecipients -- (optional) Whether or not to output a syslog
# line for each recipient of a spam message or only
# once per incoming message. Disabling this will
# reduce the entries to syslog but will reduce
# statistical granularity on a per user basis.
#
# %RETURNS:
# Nothing
# %DESCRIPTION:
# This is called to enable Mimedefang logging when the md_graphdefang_log()
# subroutine is called. The $SyslogFacility name should be known
# to syslog on the machine on which Mimedefang is running.
#***********************************************************************
sub md_graphdefang_log_enable
{
$GraphDefangSyslogFacility = shift;
$EnumerateRecipients = shift;
# If we don't have a SyslogFacility from the user,
# use the system default
$GraphDefangSyslogFacility = $SyslogFacility
unless defined($GraphDefangSyslogFacility);
# By default, we want md_graphdefang_log to output a syslog line for each
# recipient. This is useful for per user spam statistics.
# i.e. How many spam messages were received by foo@bar.com?
$EnumerateRecipients = 1 unless defined($EnumerateRecipients);
}
#***********************************************************************
# %PROCEDURE: add_ip_validation_header
# %ARGUMENTS:
# None
# %RETURNS:
# 1 if header was added; 0 otherwise
# %DESCRIPTION:
# Adds an IP address validation header to preserve relay info.
#***********************************************************************
sub add_ip_validation_header {
if ($ValidateIPHeader eq "") {
md_syslog('warning', 'add_ip_validation_header called, but no validation header available. Check permissions on /var/packages/MailPlus-Server/target/etc/mimedefang/mimedefang-ip-key');
return 0;
}
action_add_header($ValidateIPHeader, $RelayAddr);
return 1;
}
#***********************************************************************
# %PROCEDURE: delete_ip_validation_header
# %ARGUMENTS:
# None
# %RETURNS:
# 1 if header was deleted; 0 otherwise
# %DESCRIPTION:
# Deletes IP address validation header.
#***********************************************************************
sub delete_ip_validation_header {
if ($ValidateIPHeader eq "") {
md_syslog('warning', 'delete_ip_validation_header called, but no validation header available. Check permissions on /var/packages/MailPlus-Server/target/etc/mimedefang/mimedefang-ip-key');
return 0;
}
action_delete_all_headers($ValidateIPHeader);
return 1;
}
#***********************************************************************
# %PROCEDURE: md_graphdefang_log
# %ARGUMENTS:
# event -- The name of the event that is being logged. Examples
# include virus, spam, mail, etc.
# value1 -- (optional) A value associated with the event being logged.
# value2 -- (optional) A value associated with the event being logged.
# %RETURNS:
# Nothing
# %DESCRIPTION:
# This is called to log events that occur during mimedefang processing.
# It should be called from mimedefang-filter with appropriate
# event names and values. Possible examples:
# md_graphdefang_log('virus',$VirusName,$filename);
# md_graphdefang_log('spam',$hits);
# md_graphdefang_log('bad_filename',$filename,$extension);
#***********************************************************************
sub md_graphdefang_log
{
return unless defined($GraphDefangSyslogFacility);
return if (!in_message_context("md_graphdefang_log"));
my $event = shift;
my $value1 = shift;
my $value2 = shift;
$value1 = "" unless defined($value1);
$value2 = "" unless defined($value2);
my $lcsender = percent_encode_for_graphdefang(lc($Sender));
# Make values safe for graphdefang
my $id = percent_encode_for_graphdefang($MsgID);
my $subj = percent_encode_for_graphdefang($Subject);
$event = percent_encode_for_graphdefang($event);
$value1 = percent_encode_for_graphdefang($value1);
$value2 = percent_encode_for_graphdefang($value2);
if ($EnumerateRecipients || scalar(@Recipients) == 1) {
foreach my $recipient (@Recipients) {
my $lcrecipient = percent_encode_for_graphdefang(lc($recipient));
md_syslog("$GraphDefangSyslogFacility|info","MDLOG,$id," .
"$event,$value1,$value2,$lcsender," .
"$lcrecipient,$subj");
}
} else {
my $lcrecipient = "rcpts=" . scalar(@Recipients);
$lcrecipient = percent_encode_for_graphdefang($lcrecipient);
md_syslog("$GraphDefangSyslogFacility|info","MDLOG,$id," .
"$event,$value1,$value2,$lcsender," .
"$lcrecipient,$subj");
}
}
#***********************************************************************
# %PROCEDURE: message_contains_virus
# %ARGUMENTS:
# None
# %RETURNS:
# ($code, $category, $action) -- standard virus-scanner return values.
# %DESCRIPTION:
# Scans message using *every single* installed virus scanner.
#***********************************************************************
sub message_contains_virus {
my($code, $category, $action);
$code = 0;
$category = 'ok';
$action = 'ok';
initialize_virus_scanner_routines();
if (!@VirusScannerMessageRoutines) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
my ($scanner, $scode, $scat, $sact);
push_status_tag("Running virus scanner");
foreach $scanner (@VirusScannerMessageRoutines) {
($scode, $scat, $sact) = &$scanner();
if ($scat eq "virus") {
return (wantarray ? ($scode, $scat, $sact) : $scode);
}
if ($scat ne "ok") {
$code = $scode;
$category = $scat;
$action = $sact;
}
}
pop_status_tag();
return (wantarray ? ($code, $category, $action) : $code);
}
#***********************************************************************
# %PROCEDURE: entity_contains_virus
# %ARGUMENTS:
# e -- a MIME::Entity
# %RETURNS:
# ($code, $category, $action) -- standard virus-scanner return values.
# %DESCRIPTION:
# Scans entity using *every single* installed virus scanner.
#***********************************************************************
sub entity_contains_virus {
my($e) = @_;
my($code, $category, $action);
$code = 0;
$category = 'ok';
$action = 'ok';
initialize_virus_scanner_routines();
if (!@VirusScannerEntityRoutines) {
return (wantarray ? (0, 'ok', 'ok') : 0);
}
my ($scanner, $scode, $scat, $sact);
push_status_tag("Running virus scanner");
foreach $scanner (@VirusScannerEntityRoutines) {
($scode, $scat, $sact) = &$scanner($e);
if ($scat eq "virus") {
return (wantarray ? ($scode, $scat, $sact) : $scode);
}
if ($scat ne "ok") {
$code = $scode;
$category = $scat;
$action = $sact;
}
}
pop_status_tag();
return (wantarray ? ($code, $category, $action) : $code);
}
#***********************************************************************
# %PROCEDURE: initialize_virus_scanner_routines
# %ARGUMENTS:
# None
# %RETURNS:
# Nothing
# %DESCRIPTION:
# Sets @VirusScannerMessageRoutines and @VirusScannerEntityRoutines
# to arrays of virus-scanner routines to call, based on installed
# scanners.
#***********************************************************************
sub initialize_virus_scanner_routines {
if ($VirusScannerRoutinesInitialized) {
return;
}
$VirusScannerRoutinesInitialized = 1;
# The daemonized scanners first
if ($Features{'Virus:CLAMD'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_clamd;
push @VirusScannerEntityRoutines, \&entity_contains_virus_clamd;
}
if ($Features{'Virus:SOPHIE'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_sophie;
push @VirusScannerEntityRoutines, \&entity_contains_virus_sophie;
}
if ($Features{'Virus:TROPHIE'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_trophie;
push @VirusScannerEntityRoutines, \&entity_contains_virus_trophie;
}
if ($Features{'Virus:SymantecCSS'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_carrier_scan;
push @VirusScannerEntityRoutines, \&entity_contains_virus_carrier_scan;
}
if ($Features{'Virus:FPROTD'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_fprotd;
push @VirusScannerEntityRoutines, \&entity_contains_virus_fprotd;
}
if ($Features{'Virus:FPROTD6'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_fprotd_v6;
push @VirusScannerEntityRoutines, \&entity_contains_virus_fprotd_v6;
}
if ($Features{'Virus:AVP5'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_avp5;
push @VirusScannerEntityRoutines, \&entity_contains_virus_avp5;
}
if ($Features{'Virus:KAVSCANNER'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_kavscanner;
push @VirusScannerEntityRoutines, \&entity_contains_virus_kavscanner;
}
# Finally the command-line scanners
if ($Features{'Virus:CLAMAV'} && ! $Features{'Virus:CLAMD'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_clamav;
push @VirusScannerEntityRoutines, \&entity_contains_virus_clamav;
}
if ($Features{'Virus:AVP'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_avp;
push @VirusScannerEntityRoutines, \&entity_contains_virus_avp;
}
if ($Features{'Virus:NAI'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_nai;
push @VirusScannerEntityRoutines, \&entity_contains_virus_nai;
}
if ($Features{'Virus:FPROT'} && !$Features{'Virus:FPROTD'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_fprot;
push @VirusScannerEntityRoutines, \&entity_contains_virus_fprot;
}
if ($Features{'Virus:FPSCAN'} && !$Features{'Virus:FPROTD6'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_fpscan;
push @VirusScannerEntityRoutines, \&entity_contains_virus_fpscan;
}
if ($Features{'Virus:CSAV'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_csav;
push @VirusScannerEntityRoutines, \&entity_contains_virus_csav;
}
if ($Features{'Virus:FSAV'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_fsav;
push @VirusScannerEntityRoutines, \&entity_contains_virus_fsav;
}
if ($Features{'Virus:HBEDV'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_hbedv;
push @VirusScannerEntityRoutines, \&entity_contains_virus_hbedv;
}
if ($Features{'Virus:BDC'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_bdc;
push @VirusScannerEntityRoutines, \&entity_contains_virus_bdc;
}
if ($Features{'Virus:NVCC'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_nvcc;
push @VirusScannerEntityRoutines, \&entity_contains_virus_nvcc;
}
if ($Features{'Virus:VEXIRA'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_vexira;
push @VirusScannerEntityRoutines, \&entity_contains_virus_vexira;
}
if ($Features{'Virus:SOPHOS'} && ! $Features{'Virus:SOPHIE'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_sophos;
push @VirusScannerEntityRoutines, \&entity_contains_virus_sophos;
}
if ($Features{'Virus:SAVSCAN'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_savscan;
push @VirusScannerEntityRoutines, \&entity_contains_virus_savscan;
}
if ($Features{'Virus:TREND'} && ! $Features{'Virus:TROPHIE'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_trend;
push @VirusScannerEntityRoutines, \&entity_contains_virus_trend;
}
if ($Features{'Virus:NOD32'}) {
push @VirusScannerMessageRoutines, \&message_contains_virus_nod32;
push @VirusScannerEntityRoutines, \&entity_contains_virus_nod32;
}
}
#***********************************************************************
# %PROCEDURE: get_smtp_return_code
# %ARGUMENTS:
# sock -- a socket connected to an SMTP server
# recip -- the recipient we're inquring about
# server -- the server we're querying
# %RETURNS:
# A four-element list:(retval, code, dsn, text),
# where code is a 3-digit SMTP code.
# Retval is 'CONTINUE', 'TEMPFAIL' or 'REJECT'.
# %DESCRIPTION:
# Reads return codes from SMTP server
#***********************************************************************
sub get_smtp_return_code {
my($sock, $recip, $server) = @_;
my($line, $code, $text, $retval, $dsn);
while (defined ($line = $sock->getline())) {
# Chew up all white space, including CR
$line =~ s/\s+$//;
if (($line =~ /^\d\d\d$/) or ($line =~ /^\d\d\d\s/)) {
$line =~ /^(\d\d\d)\s*(.*)$/;
$code = $1;
$text = $2;
# Check for DSN
if ($text =~ /^(\d\.\d{1,3}\.\d{1,3})\s+(.*)$/) {
$dsn = $1;
$text = $2;
} else {
$dsn = "";
}
if ($code =~ /^[123]/) {
$retval = 'CONTINUE';
} elsif ($code =~ /^4/) {
md_syslog('info', "md_check_against_smtp_server for $recip on $server returned $code $dsn $text");
$retval = 'TEMPFAIL';
} elsif ($code =~ /^5/) {
md_syslog('info', "md_check_against_smtp_server for $recip on $server returned $code $dsn $text");
$retval = 'REJECT';
} else {
md_syslog('warning', "Invalid SMTP reply code $code from server $server for $recip");
$retval = 'TEMPFAIL';
}
return ($retval, $code, $dsn, $text);
}
}
my $msg;
if( defined $line ) {
$msg = "Invalid response [$line] from SMTP server";
md_syslog('info', "md_check_against_smtp_server for $recip on $server returned invalid response [$line]");
} else {
$msg = "Empty response from SMTP server";
md_syslog('info', "md_check_against_smtp_server for $recip on $server returned an empty response");
}
return ('TEMPFAIL', "451", "4.3.0", $msg );
}
#***********************************************************************
# %PROCEDURE: md_check_against_smtp_server
# %ARGUMENTS:
# sender -- sender e-mail address
# recip -- recipient e-mail address
# helo -- string to put in "HELO" command
# server -- SMTP server to try.
# port -- optional: Port to connect on (defaults to 25)
# %RETURNS:
# ('CONTINUE', "OK") if recipient is OK
# ('TEMPFAIL', "err") if temporary failure
# ('REJECT', "err") if recipient is not OK.
# %DESCRIPTION:
# Verifies a recipient against another SMTP server by issuing a
# HELO / MAIL FROM: / RCPT TO: / QUIT sequence
#***********************************************************************
sub md_check_against_smtp_server {
my($sender, $recip, $helo, $server, $port) = @_;
my($code, $text, $dsn, $retval);
$port = 'smtp(25)' unless defined($port);
# Add angle-brackets if needed
if (!($sender =~ /^<.*>$/)) {
$sender = "<$sender>";
}
if (!($recip =~ /^<.*>$/)) {
$recip = "<$recip>";
}
my $sock = IO::Socket::INET->new(PeerAddr => $server,
PeerPort => $port,
Proto => 'tcp',
Timeout => 15);
if (!defined($sock)) {
return ('TEMPFAIL', "Could not connect to other SMTP server $server: $!");
}
($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
if ($retval ne 'CONTINUE') {
$sock->print("QUIT\r\n");
$sock->flush();
# Swallow return value
get_smtp_return_code($sock, $recip, $server);
$sock->close();
return ($retval, $text, $code, $dsn);
}
# If the banner contains our host name, there's a loop!
# However, don't check if $server is explicitly 127.0.0.1
# because presumably that indicates the caller knows
# what he or she is doing.
if ($server ne '127.0.0.1' && $server ne '::1') {
my $host_expr = quotemeta(get_host_name());
if ($text =~ /^$host_expr\b/) {
$sock->print("QUIT\r\n");
$sock->flush();
# Swallow return value
get_smtp_return_code($sock, $recip, $server);
$sock->close();
return('REJECT', "Verification server loop! Trying to verify $recip against myself!",
554, '5.4.6');
}
}
$sock->print("HELO $helo\r\n");
$sock->flush();
($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
if ($retval ne 'CONTINUE') {
$sock->print("QUIT\r\n");
$sock->flush();
# Swallow return value
get_smtp_return_code($sock, $recip, $server);
$sock->close();
return ($retval, $text, $code, $dsn);
}
$sock->print("MAIL FROM:$sender\r\n");
$sock->flush();
($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
if ($retval ne 'CONTINUE') {
$sock->print("QUIT\r\n");
$sock->flush();
# Swallow return value
get_smtp_return_code($sock, $recip, $server);
$sock->close();
return ($retval, $text, $code, $dsn);
}
$sock->print("RCPT TO:$recip\r\n");
$sock->flush();
($retval, $code, $dsn, $text) = get_smtp_return_code($sock, $recip, $server);
$sock->print("QUIT\r\n");
$sock->flush();
# Swallow return value
get_smtp_return_code($sock, $recip, $server);
$sock->close();
return ($retval, $text, $code, $dsn);
}
exit(&main) unless caller;
#------------------------------------------------------------
1;