#!/usr/bin/perl -T -w

#############################################################################
package postfwdfilter::Server;

#   This code is Copyright (C) 2001 Morgan Stanley Dean Witter, and
#   is distributed according to the terms of the GNU Public License
#   as found at <URL:http://www.fsf.org/copyleft/gpl.html>.
#
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   Based on MSDW::SMTP::Server --- SMTP server for content-scanning proxy
#   Written by Bennett Todd <bet@rahul.net>

use strict;
use warnings;
use IO::Socket;
use File::Temp qw(mkstemp);

# protocol type hash
my %protos = (
    HE	=> 'SMTP',
    EH	=> 'ESMTP',
    # currently unsupported
    LH	=> 'LMTP',
);

# preload and compile some regexps
my %spatterns = (
    end 	=> qr/[\r\n]*$/,
    data 	=> qr/^data/i,
    helo	=> qr/^(he|[el]h)lo\s+/i,
    rset	=> qr/^rset\s*/i,
    mailfrom	=> qr/^mail\s+from:\s*<?([^>\s]+)>?.*/i,
    rcptto	=> qr/^rcpt\s+to:\s*<?([^>\s]+)>?.*/i,
    xforward	=> qr/^xforward\s*/i,
    xattr	=> qr/^([^=]+)=(.*)$/i,
    tail	=> qr/\s*$/,
    white	=> qr/\s+/,
    dotdot	=> qr/^\.\./,
);

sub new {
    my ($this, @opts) = @_;
    my $class = ref($this) || $this;
    my $self = bless { @opts }, $class;
    $self->{sock} = IO::Socket::INET->new(
	LocalAddr => $self->{interface},
	LocalPort => $self->{port},
	Proto => 'tcp',
	Type => SOCK_STREAM,
	Listen => 65536,
	Reuse => 1,
    );
    die "$0: socket bind failure: $!\n" unless defined $self->{sock};
    $self->{state} = 'just bound',
    $self->{queue} ||= '/var/tmp';
    return $self;
}

sub accept {
    my ($self, @opts) = @_;
    %$self = (%$self, @opts);
    ($self->{"s"}, $self->{peeraddr}) = $self->{sock}->accept or
	die "$0: accept failure: $!\n";
    $self->{state} = ' accepted';
}

sub chat {
    my ($self) = @_;
    local(*_);
    if ($self->{state} !~ /$spatterns{data}/) {
	return 0 unless defined($_ = $self->getline);
	s/$spatterns{end}//;
	$self->{state} = $_;
	if (s/$spatterns{helo}//) {
	    if (defined $protos{my $p = uc($1)}) {
		$self->{proto} = $protos{$p};
	    } else {
		die "$0: unsupported protocol type '".$p."LO'\n";
	    }
	    s/$spatterns{tail}//;
	    s/$spatterns{white}/ /g;
	    $self->{ehelo} = $_;
	} elsif (s/$spatterns{rset}//) {
	    delete $self->{to};
	    delete $self->{recipients};
	} elsif (s/$spatterns{mailfrom}/$1/) {
	    $self->{from} = $_;
	    delete $self->{to};
	    delete $self->{recipients};
	} elsif (s/$spatterns{rcptto}/$1/) {
	    s/$spatterns{tail}//;
	    s/$spatterns{white}/ /g;
	    $self->{to} = $_;
	    push @{$self->{recipients}}, $_;
	} elsif (s/$spatterns{xforward}//) {
	    foreach (split /\s+/) {
		if (m/$spatterns{xattr}/) {
		    $self->{'x'.lc($1)} = $2;
		}
	    }
	} elsif (/$spatterns{data}/) {
	    $self->{to} = $self->{recipients};
	}
    } else {
	$self->reset_queuefile();
	$self->{dirty} = 1;
	while (defined($_ = $self->getline)) {
	    if ($_ eq ".\r\n") {
		return $self->{state} = '.';
	    }
	    s/$spatterns{dotdot}/\./;
	    print { $self->{data} } ("$_") or die "$0: write error saving data: $!\n";
	}
	return(0);
    }
    return $self->{state};
}

sub getline {
    my ($self) = @_;
    local ($/) = "\r\n";
    return $self->{"s"}->getline;
}

sub print {
    my ($self, @msg) = @_;
    $self->{"s"}->print(@msg);
}

sub ok {
    my ($self, @msg) = @_;
    @msg = ("250 2.0.0 Ok.") unless @msg;
    $self->print("@msg\r\n") or
	die "$0: write error acknowledging $self->{state}: $!\n";
}

# create a new spool file
sub new_queuefile {
    my ($self) = @_;
    ($self->{data}, $self->{queuefile}) = mkstemp($self->{queue}."/tXXXXXXXXXX");
    die "$0: error creating temp file $self->{queuefile}: $!\n" unless defined $self->{data};
}

# reset our spool file
sub reset_queuefile {
    my ($self) = @_;
    if (defined $self->{queuefile} and -e $self->{queuefile}) {
	if (defined $self->{dirty}) {
	    seek($self->{data},0,0) or die "$0: can not rewind file: $!\n";
	    truncate($self->{data},0) or die "$0: can not truncate file: $!\n";
	}
    } else {
	$self->new_queuefile();
    }
    delete $self->{dirty};
}

# remove our spool file
sub remove_queuefile {
    my ($self) = @_;
    unlink $self->{queuefile} if defined $self->{queuefile};
}

# put a message into quarantine
sub quarantine {
    my ($self,$dir) = @_;
    my $result = my $qfile = undef;
    if (defined $self->{data}) {
	my $orig = $self->{data};
	seek($orig,0,0) or die "$0: can not rewind file: $!\n";
	($qfile, $result) = mkstemp($dir."/qXXXXXXXXXXXXXXXX");
	if ($qfile and $result) {
	    map { print { $qfile } ("$_") } (<$orig>);
	    $qfile->close();
	}
    }
    return $result;
}

1; # EOF postfwdfilter::Server


#############################################################################
package postfwdfilter::Client;

#   This code is Copyright (C) 2001 Morgan Stanley Dean Witter, and
#   is distributed according to the terms of the GNU Public License
#   as found at <URL:http://www.fsf.org/copyleft/gpl.html>.
#
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   Based on MSDW::SMTP::Server --- SMTP server for content-scanning proxy
#   Written by Bennett Todd <bet@rahul.net>

use strict;
use warnings;
use IO::Socket;

my %cpatterns = (
    end  => qr/\r\n$/,
    dot  => qr/^\./,
    smtp => qr/^\d{3}-/,
);

sub new {
    my ($this, @opts) = @_;
    my $class = ref($this) || $this;
    my $self = bless { timeout => 300, @opts }, $class;
    $self->{sock} = IO::Socket::INET->new(
	PeerAddr => $self->{interface},
	PeerPort => $self->{port},
	Timeout => $self->{timeout},
	Proto => 'tcp',
	Type => SOCK_STREAM,
    );
    die "$0: socket connect failure: $!\n" unless defined $self->{sock};
    return $self;
}

sub hear {
    my ($self) = @_;
    my ($tmp, $reply);
    return undef unless $tmp = $self->{sock}->getline;
    while ($tmp =~ m/$cpatterns{smtp}/) {
	$reply .= $tmp;
	return undef unless $tmp = $self->{sock}->getline;
    }
    $reply .= $tmp;
    $reply =~ s/$cpatterns{end}//;
    return $reply;
}

sub say {
    my ($self, @msg) = @_;
    return unless @msg;
    $self->{sock}->print("@msg", "\r\n") or die "$0: write error: $!\n";
}

# send message content to the upstream server
sub yammer {
    my ($self,$header,$content) = (@_);
    # add our own header
    $self->{sock}->print($header) or die "$0: write error: $!\n";
    # content type...
    my $type = ref($content);
    # ... scalar
    unless ($type) {
	$self->{sock}->print($content) or die "$0: write error: $!\n";
    # ... scalar reference
    } elsif ($type eq 'SCALAR') {
	$self->{sock}->print($$content) or die "$0: write error: $!\n";
    # ... file handle
    } elsif ($type eq 'GLOB') {
	seek ($content,0,0) or die "$0: can not rewind file: $!\n";
	local (*_);
	local ($/) = "\r\n";
	while (<$content>) {
	    s/$cpatterns{dot}/../;
	    $self->{sock}->print($_) or die "$0: write error: $!\n";
	}
    # ... unknown
    } else {
	die "$0: unsupported content type '$type'";
    }
    $self->{sock}->print(".\r\n") or die "$0: write error: $!\n";
}

1; # EOF postfwdfilter::Client


#############################################################################
package postfwdfilter;

#
#   This code is Copyright (C) 2008 Jan P. Kessler, and
#   is distributed according to the terms of the GNU Public License
#   as found at <URL:http://www.fsf.org/copyleft/gpl.html>.
#
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
# Written by Jan P. Kessler <info [at] postfwd [dot] org>


### INIT ###

# modules
use strict;
use warnings;
use IO::Socket qw(SOCK_STREAM);
use Sys::Hostname qw(hostname);
use Sys::Syslog qw(:DEFAULT setlogsock);
use POSIX qw(setsid setlocale strftime LC_ALL);
use Getopt::Long 2.25 qw(:config no_ignore_case bundling);

# optional modules
BEGIN {
    # load Time::HiRes if available
    eval { require Time::HiRes };
    if ($@) {
	warn "$@";
	warn "Failed to include optional module Time::HiRes.";
    } else {
	Time::HiRes->import( qw(time) );
    }
    # include smtp components
    import postfwdfilter::Server;
    import postfwdfilter::Client;
}
# load Mail::SpamAssassin if available
eval { require Mail::SpamAssassin };
my $saversion = ($@) ? '' : Mail::SpamAssassin::Version();
if ($saversion) {
    eval { require Mail::SpamAssassin::Logger };
    if ($@) {
	warn "$@";
	$saversion = '';
	warn "Failed to include optional module Mail::SpamAssassin::Logger. Disabling sascan...";
    }
} else {
    warn "$@";
    warn "Failed to include optional module Mail::SpamAssassin. Disabling sascan...";
}

# program name and version
my $NAME     = 'postfwdfilter';
my $VERSION  = '0.99';
my $HOSTNAME = hostname() || 'localhost';

# default: keep sender address for notifications
# use --adminmail to change
my $ADMIN    = '"<<FROM>>" <<<FROM>>>';

# command line syntax
my $syntax = "syntax: $0 [--verbose] [--daemon] [--throughput] ".
    "[--children=16] [--minperchild=100] [--maxperchild=200] ".
    "[--facility=mail] [--name=".$NAME."] ".
    "[--user=nobody] [--group=nobody] ".
    "[--deny=550 5.7.1 Access denied] [--discard=250 2.0.0 Ok: blackholed] ".
    "listen.addr:port talk.addr:port\n";
# daemon mode user and group
my $user  = 'nobody';
my $group = 'nobody';
# child process limits
my $children    = 16;
my $minperchild = 100;
my $maxperchild = 200;
# default answers
my $denymsg    = "550 5.7.1 Access denied";
my $discardmsg = "250 2.0.0 Ok: blackholed";
# directory for temporary files
my $queuedir   = '/var/tmp/postfwd-queue';
# reset spoolfile after sending
my $queuesafe  = 1;
# quarantine settings
my $quarantine = '/var/tmp/postfwd-quarantine';
my @default_quarantine_actions = qw[ DISCARD DENY NOTIFY ];
# scanner settings
my $SSC_OK  = undef;
my $SSC_BAD = 0;
my $SSC_ERR = 1;
# default SA settings
my $safile     = '/etc/mail/spamassassin';
my $satimeout  = 120;
my $saaction   = 'PASS';
my $samaxscore = 20;
my $samaxsize  = 307200;
# default AV settings
my $virustimeout  = 30;
my $virusaction   = 'NOTIFY';
# scanner definitions:
# set 'cmd' for commandline and 'peer' for socket based scanners. socket type AF_INET
# is recognised by the 'port' setting. others be treated as AF_UNIX domain connections.
my %virusscanners = (
    clamscan => { # CMD - command line scanner
	cmd     => '/usr/bin/clamscan',	# path to binary
	opt     => '--no-summary',	# optional: command line arguments for scan
	version => '--version',		# command line argument to determine version
	good    => qr/\sOK$/m,		# 'no virus' pattern
	evil    => qr/(\S+)\s+FOUND$/m,	# 'virus found' pattern
	stop	=> 1,			# stop further virusscanning if virus found
    },
    clamdunix => { # UNIX - socket based scanner
	peer	=> '/tmp/clamd.socket',	# path to UNIX domain socket
	pre	=> "SCAN ",		# prefix for sendstring
	post	=> "\n",		# suffix for sendstring
	good    => qr/\sOK$/,		# 'no virus' pattern
	evil    => qr/(\S+)\s+FOUND$/,	# 'virus found' pattern
	stop	=> 1,			# stop further virusscanning if virus found
    },
    clamdinet => { # INET - socket based scanner
	peer	=> '127.0.0.1',		# hostname/ip address of scanning host
	port	=> '3310',		# tcp port number
	pre	=> "SCAN ",		# prefix for sendstring
	post	=> "\n",		# suffix for sendstring
	good    => qr/\sOK$/,		# 'no virus' pattern
	evil    => qr/(\S+)\s+FOUND$/,	# 'virus found' pattern
	stop	=> 1,			# stop further virusscanning if virus found
    },
    # further examples...
    clamdscan => {
	cmd     => '/usr/bin/clamdscan',
	opt     => '--no-summary',
	version => '--version',
	good    => qr/\sOK$/m,
	evil    => qr/(\S+)\s+FOUND$/m,
	stop	=> 1,
    },
    trend_old => {
	cmd     => '/opt/trend/ISBASE/IScan.BASE/vscan',
	evil    => qr/^\*{3} Found virus (.*?) in file/,
	stop	=> 1,
    },
);
# aliases
$virusscanners{clamd} = $virusscanners{clamdunix};

# content scanners
my %scanners = (
    virus => {
	init => \&init_virusscanners,
	scan => \&virscan_data,
    },
    spam  => {
	init => \&init_spamassassin,
	scan => \&spamscan_data,
    },
);

# template for virus notification
# do NOT specify From: header here,
# use --adminmail to change
my $virusmail = <<"__EOF__";
To: "<<TO>>" <<<TO>>>
Subject: *****VIRUS***** <<SUBJECT>>
Message-ID: <<<MESSAGEID>>>
Date: <<DATE>>
X-Mailer: $NAME $VERSION
MIME-Version: 1.0
Content-Type: multipart/alternative;
 boundary="------------040006050703060200030301"

This is a multi-part message in MIME format.
--------------040006050703060200030301
Content-Type: text/plain; charset=ISO-8859-15; format=flowed
Content-Transfer-Encoding: 7bit

Hallo,

das System hat in einer an Sie gerichteten E-Mail einen Virus gefunden. Die Zustellung wurde daher verweigert.

Hier einige Kenndaten, falls Sie mit der Erkennung nicht einverstanden sind und sich an Ihren Administrator wenden moechten:

	=========================================================================
	  Datum:	   <<DATE>>
	  Absender:	   <<FROM>>
	  Betreff:	   <<SUBJECT>>
	  Anhang:	   <<ATTACHMENT>>
	  Virus:	   <<VIRUS>>
	  Quelle:	   <<CLIENT>>
	  Message-ID:	   <<<MESSAGEID>>>
	  Quarantaene-ID:  <<<QUARANTINE>>>
	=========================================================================

Mit freundlichen Gruessen
 Ihr Administrator

-- 
$NAME $VERSION auf $HOSTNAME

--------------040006050703060200030301
Content-Type: text/html; charset=ISO-8859-15
Content-Transfer-Encoding: 7bit

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
</head>
<body bgcolor="#ffffff" text="#000000">
<br>
Hallo,<br>
<br>
das System hat in einer an Sie gerichteten E-Mail einen <b>Virus</b> gefunden. Die Zustellung wurde daher verweigert.<br>
<br>
Hier einige Kenndaten, falls Sie mit der Erkennung nicht einverstanden sind und sich an Ihren Administrator wenden m&ouml;chten:<br>
<br>
<pre>
        =========================================================================

          Datum:	<small><<DATE>></small>
          Absender:	<a href=mailto:<<FROM>>><<FROM>></a>
          Betreff:	&#132;<strong><<SUBJECT>></strong>&#148;

          Anhang:	<<ATTACHMENT>>
          Virus:	<<VIRUS>>
          Quelle:	<<CLIENT>>
          Quarant&auml;ne:	<small>qid=&lt;<<QUARANTINE>>&gt;, mid=&lt;<<MESSAGEID>>&gt;</small>

        =========================================================================
</pre>
<br>
Mit freundlichen Gr&uuml;&szlig;en<br>
 Ihr Administrator<br>
<br>
<pre>
-- 
<i><small>$NAME $VERSION auf $HOSTNAME</small></i>

</pre>
<br>
</body>
</html>

--------------040006050703060200030301--

__EOF__
# end of template2

# gather attribute sequence
my %getattr_sequence = (
    helo => [ qw[ xhelo rhelo ehelo ] ],
    name => [ qw[ xname rname ] ],
    addr => [ qw[ xaddr raddr ] ],
);

# preload and compile some regexps
my %patterns = (
    dot 		=> qr/^\./,
    stripdotzero	=> qr/\.0$/,
    empty 		=> qr/^\r?\n$/,
    email 		=> qr/^<?(.*?)>?$/,
    data 		=> qr/^data/i,
    deny 		=> qr/^#deny#/,
    discard 		=> qr/^#discard#/,
    content		=> qr/^content-(type|disposition)/i,
    messageid		=> qr/^message-id:\s*<?(.*?)>?\s*$/i,
    subject		=> qr/^subject:\s*(.*?)\s*$/i,
    received		=> qr/^received:/i,
    attachment		=> qr/(file)?name=["\s]*(.*?)[;"\s]*$/i,
    #received_full	=> qr/^received:\s+from\s+([^\s]+)\s+\(([^\s]+)\s+\[([^\]]+)\]\)/i,
    #tls_line_1		=> qr/^\s+\(using\s+([^\s]+)\s+with\s+cipher\s+([^\s]+)\s+\(([^\)]+)\)\)/i,
    #tls_line_2		=> qr/^\s+\(Client\s+CN\s+\"([^\"]+)\",\s+Issuer\s+\"([^\"]+)\"\s+\(([^\)]+)\)\)/i,
    #tls_fingerprint	=> qr/\bx-tls-client-fingerprint:\s+([0-9A-F:]+)\r?\n/i,
    received_full	=> qr/^received: from ([^\s]+) \(([^\s]+) \[([^\]]+)\]\)\s+/i,
    tls_line_1		=> qr/^\(using ([^\s]+) with cipher ([^\s]+) \(([^\)]+)\)\)\s+/i,
    tls_line_2		=> qr/^\(Client CN "([^"]+)", Issuer "([^"]+)" \(([^\)]+)\)\)/i,
    tls_fingerprint	=> qr/^x-tls-client-fingerprint: ([0-9A-F:]+)/mi,
);

# abbreviate these items for logging
my %abbrev_items = (
    helo => 60, ehelo => 60, xhelo => 60, rhelo => 60,
    tlsccn => 60, tlsissuer => 40, tlsstat => 40,
    reply => 60, attachment => 60, subject => 60,
    virus => 250, messageid => 250, sahits => 500,
);

# do not change this unless you really know why
my $verbose = my $sadebug = 0;
my $OLDARG0 = $0;
my @OLDARGV = @ARGV;

# log items will only be shown if available.
# privacy issues, enable at your own risk. consider using:
#  --logitems=..., --logall, --logtls, --logsubject or --logattachments
#my @default_logitems = qw[
#    client name addr helo ehelo
#    xname xaddr xhelo rname raddr rhelo
#    from to messageid size
#    time sascore sahits
#    tlsproto tlscipher tlskey tlsfingerprinti
#    tlsccn tlsissuer tlsstat
#    virus attachment subject reply
#];
my @default_logitems = qw[ client from to helo messageid size scans virus sascore sahits quarantine reply ];
my $unsafe_charset = qr/[^\x20-\x7E]/;
my $syslog_name = $NAME;
my $syslog_facility = 'mail';
my $syslog_options  = 'pid';
# Sys::Syslog < 0.15 dies when syslog daemon is temporarily not
# present (for example on syslog rotation)
my $syslog_version = (defined $Sys::Syslog::VERSION) ? $Sys::Syslog::VERSION : '';
my $syslog_old = (not($syslog_version) or $syslog_version lt '0.15');

# undef init
use vars qw (
    $server $daemon $ppid $spamtest $throughput
    $logsubject $logattachments $logtls $logall $allow_user_commands
    $syslog_enhanced_charset $sa_opportunistic_expire $taggedmail
    $srcaddr $srcport $dstaddr $dstport $uid $gid $homedir
    $syslog_socktype $syslog_ptr $notification $message
    @scan_sequence @scan_procs @sadomains @sawhitelistfrom
    @quarantine_actions @logitems @virusscanners
    %quarantine_actions
);

# parse command-line
GetOptions(
	"v|verbose+" 					=> \$verbose,
	"d|daemon|daemonize"				=> \$daemon,
	"children=n"					=> \$children,
	"minperchild=n" 				=> \$minperchild,
	"maxperchild=n" 				=> \$maxperchild,
	"u|user=s"					=> \$user,
	"g|group=s"					=> \$group,
	"deny|denymsg=s" 				=> \$denymsg,
	"discard|discardmsg=s" 				=> \$discardmsg,
	"throughput" 					=> \$throughput,
	"hostname|host_name=s"		 		=> \$HOSTNAME,
	"admin|adminmail|admin_mail=s"	 		=> \$ADMIN,
	"allowusercommands|allow_user_commands"		=> \$allow_user_commands,
	"quarantine|quarantine_dir=s"	 		=> \$quarantine,
	"virustimeout|virus_timeout=n"			=> \$virustimeout,
	"virusaction|virus_action=s"			=> \$virusaction,
	"satimeout|sa_timeout=n"			=> \$satimeout,
	"saaction|sa_action=s"				=> \$saaction,
	"sadebug|sa_debug"				=> \$sadebug,
	"safile|sa_file=s"				=> \$safile,
	"samaxscore|sa_max_score=s"			=> \$samaxscore,
	"salevelaction|sa_level_action=s"		=> \$samaxscore, # compatibility
	"samaxsize|sa_max_size=n"			=> \$samaxsize,
	"logall|log_all"				=> \$logall,
	"logtls|log_tls"				=> \$logtls,
	"queue|queuedir|queue_dir=s"			=> \$queuedir,
	"queuesafe|queue_safe|safequeue|safe_queue!"	=> \$queuesafe,
	"logsubject|log_subject"			=> \$logsubject,
	"logattachments|log_attachments"		=> \$logattachments,
	"name|syslogname|syslog_name=s" 		=> \$syslog_name,
	"facility|syslogfacility|syslog_facility=s"	=> \$syslog_facility,
	"syslogoptions|syslog_options=s"		=> \$syslog_options,
	"syslogsocktype|syslog_socktype=s"		=> \$syslog_socktype,
	"syslogold|syslog_old|oldsyslog|old_syslog"	=> \$syslog_old,
	"syslogenhancedcharset|syslog_enhanced_charset"	=> \$syslog_enhanced_charset,
	"saopportunisticexpire|sa_opportunistic_expire"	=> \$sa_opportunistic_expire,
	"opportunisticexpire|opportunistic_expire"	=> \$sa_opportunistic_expire, # shorter
	"vscan|virscan|virusscan=s"			=> sub{ @virusscanners = ( @virusscanners, (split /[,\s]+/, $_[1]) ) },
	"sadomains|sa_domains=s"			=> sub{ @sadomains = ( @sadomains, (split /[,\s]+/, $_[1]) ) },
	"sawhitelistfrom|sa_whitelist_from=s"		=> sub{ @sawhitelistfrom = ( @sawhitelistfrom, (split /[,\s]+/, $_[1]) ) },
	"logitems|log_items=s"				=> sub{ @logitems = ( @logitems, (split /[,\s]+/, $_[1]) ) },
	"quarantineactions|quarantine_actions=s"	=> sub{ @quarantine_actions = ( @quarantine_actions, (split /[,\s]+/, $_[1]) ) },
	"scansequence|scan_sequence|sequence=s"		=> sub{ @scan_sequence = ( @scan_sequence, (split /[,\s]+/, $_[1]) ) },
) or die $syntax;

# basic syntax checks
die $syntax unless @ARGV == 2;
# untaint arguments
if ($ARGV[0] =~ m/^([^:]+):(\d+)$/) {
	($srcaddr, $srcport) = ($1, $2);
}
if ($ARGV[1] =~ m/^([^:]+):(\d+)$/) {
	($dstaddr, $dstport) = ($1, $2);
}
die $syntax unless defined($srcport) and defined($dstport);

# initialize logging
init_log();

# apply security settings
secureme();

# check queue and quarantine directories
check_dirs();

# daemonize and remember parent pid
daemonize() if ($daemon);
my $ppid = $$;

# initialize scanners
foreach my $scanner (@scan_sequence) {
    $scanners{$scanner}{ready} = &{$scanners{$scanner}{init}}()
	if defined $scanners{$scanner}{init};
    push @scan_procs, $scanner
	if $scanners{$scanner}{ready};
}
mylogs ('info', "Scanner sequence: ".(join ', ', @scan_procs)) if ($verbose and @scan_procs);

# initialize smtp server
$server = postfwdfilter::Server->new(interface => $srcaddr, port => $srcport, queue => $queuedir, );
mylogs ('info', "Launched smtp server process: address=$srcaddr, port=$srcport, queue=$queuedir") if $verbose;

# show final initialisation message
mylogs ('info', "$NAME $VERSION ["
	."uid=$user($uid); gid=$group($gid)"
	."; smtp=$srcaddr:$srcport->$dstaddr:$dstport"
	.(($scanners{spam}{ready}) ? "; sa=$saversion" : '')
	.(($scanners{virus}{ready}) ? "; av=".(join ',',@virusscanners) : '')
	."; queue=$queuedir"
	.(($quarantine) ? "; quarantine=$quarantine" : '')
	."] successfully initialized.");


### PARENT ###

# This block is the parent daemon, never does an accept, just herds
# a pool of children who accept and service connections, and
# occasionally kill themselves off
my %children;
my $please_die = 0;
PARENT: while (1) {
    while (scalar(keys %children) >= $children) {
	my $child = wait;
	delete $children{$child} if exists $children{$child};
	if ($please_die) { kill 15, keys %children; exit 0; }
    }
    my $pid = fork;
    die "$0: fork failed: $!\n" unless defined $pid;
    last PARENT if $pid == 0;
    $children{$pid} = 1;
    select(undef, undef, undef, 0.1);
    if ($please_die) { kill 15, keys %children; exit 0; }
}
# ensure that the parent process has not left the main loop accidentally
if ($ppid == $$) {
    mylogs ('crit', "Parent process left main loop. Terminating...");
    kill 15, keys %children;
    exit 0;
} else { $ppid = 0 };


### CHILD ###

# This block is a child service daemon. It inherited the bound
# socket created by SMTP::Server->new, it will service a random
# number of connection requests in [minperchild..maxperchild] then
# exit

# initialize spamassassin. integrating here saves some mb
# for the parent but delays program execution

my $requests = 0;
my $lives = $minperchild + (rand($maxperchild - $minperchild));
my (%opts, %request);
$0 = basename($OLDARG0).'-child';
mylogs ('info', "child ready for input");
while (1) {
    $server->accept(%opts);
    my $client = postfwdfilter::Client->new(interface => $dstaddr, port => $dstport);
    process_request ($server,$client);
    $client = undef;
    delete $server->{"s"};
    $requests++;
    if ($please_die or ($lives-- <= 0)) {
	mylogs ('info', "child finished after $requests requests");
	$server->remove_queuefile() if defined $server;
	exit 0;
    }
}

1; die "should never come here\n";


### SUBROUTINES ###

# takes a list and returns a unified list, keeping given order
sub uniq {
    undef my %uniq;
    return grep(!$uniq{$_}++, @_);
}

# abbreviates a string to a given length and adds '...'
sub abbrev {
    my($len,$str) = @_;
    $str = substr($str,0,($len - 9)).'...'.substr($str,(length($str) - 6),length($str))
	if (length($str) > $len);
    return $str;
}

# returns filename
sub basename {
    my $path = shift;
    $path =~ m@/?([^/]+)$@;
    return $1 || $path;
}

# Sys::Syslog < 0.15
sub mylogs_old {
    my($prio,$msg) = @_;
    eval { local $SIG{'__DIE__'}; syslog ($prio,$msg) };
}

# Sys::Syslog >= 0.15
sub mylogs_new {
    my($prio,$msg) = @_;
    syslog ($prio,$msg);
}

# send log message
sub mylogs {
    my($prio,$msg) = @_;
    # escape unsafe characters
    $msg =~ s/$unsafe_charset/?/g;
    $msg =~ s/\%/%%/g;
    &{$syslog_ptr} ($prio,$msg);
}

# finish program
sub end_program {
    mylogs ('notice', "$NAME $VERSION terminating...") if $ppid;
    $server->remove_queuefile() if defined $server;
}

# init logging
sub init_log {
    # syslog init
    $syslog_socktype = ($syslog_old) ? (($^O eq 'solaris') ? 'inet' : 'unix') : 'native';
    $syslog_ptr = ($syslog_old) ? \&mylogs_old : \&mylogs_new;
    setlogsock $syslog_socktype;
    openlog $syslog_name, $syslog_options, $syslog_facility;
    mylogs ('info', "set up syslogging Sys::Syslog version $syslog_version") if $verbose;
    # check for enhanced syslog charset
    $unsafe_charset = qr/[^\x20-\x7E,\x80-\xFE]/ if $syslog_enhanced_charset;
    # prepare logitems
    @logitems = @default_logitems unless @logitems;
    @logitems = (@logitems, qw[ tlsproto tlscipher tlskey tlsfingerprint tlsccn tlsissuer tlsstat ]) if ($logall or $logtls);
    push @logitems, 'attachment' if ($logall or $logattachments);
    push @logitems, 'subject'    if ($logall or $logsubject);
    # reply should be last item
    if (grep 'reply', @logitems) {
	@logitems = grep {not($_ eq 'reply');} @logitems;
	push @logitems, 'reply';
    }
    # log each item only once
    @logitems = uniq(@logitems);
    mylogs ('info', "logitems: ".(join ',', @logitems)) if $verbose;
}

# security settings
sub secureme {
    # change to root dir, set safe locale and file mode
    setlocale(LC_ALL, 'C'); umask(0077);
    chdir '/' or die "$NAME: can not chdir to /: $!\n";
    # get user- and group-settings
    $uid = getpwnam($user)  or die "$NAME: can not get uid for $user\n";
    $gid = getgrnam($group) or die "$NAME: can not get gid for $group\n";
    $homedir = (getpwnam($user))[7];
    # change user- and group-id
    $) = "$gid $gid"; $( = $gid; $> = $< = $uid;
    # cleanup environment
    $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
    if ($homedir) { $ENV{HOME} = $homedir } else { delete $ENV{HOME} if defined $ENV{HOME} };
    delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
    mylogs ('info', "Successfully applied security settings uid=$user($uid), gid=$group($gid), home=$ENV{HOME}")
	if $verbose;
}

# daemonize
sub daemonize {
    # pretty command line in ps
    $0 = join (' ', $OLDARG0, @OLDARGV);
    # close our streams stdin and stdout
    close STDIN; close STDOUT; close STDERR;
    open STDIN,  "</dev/null" or die "$NAME: can not read from /dev/null: $!\n";
    open STDOUT, ">/dev/null" or die "$NAME: can not write to /dev/null: $!\n";
    # background execution
    my $i=fork();
    if(!defined $i) { die "$NAME: can not fork new master process\n"; }
    if($i>0) { exit(0); }
    setsid() or die "$NAME: can not setsid to background\n";
    # catch signals
    $SIG{__WARN__} = sub { mylogs ('warning', "warning: $_[0]") };
    $SIG{__DIE__}  = sub { mylogs ('crit', "FATAL: $_[0]") unless ($^S or $please_die); $server->remove_queuefile() if defined $server };
    $SIG{TERM} = sub { $please_die = 1; end_program() };
    $SIG{INT} = sub { $please_die = 1; end_program() };
    # now close stderr, too
    open STDERR, '>&STDOUT' or die "$NAME: can not duplicate stderr to stdout: $!\n";
    mylogs ('info', "Successfully daemonized") if $verbose;
}

# check queue and quarantine directories
sub check_dirs {
    # check queue settings
    $queuedir =~ s@/$@@;
    die "Empty value for queue directory!\n" unless $queuedir;
    unless (-d $queuedir) {
	unless (mkdir($queuedir)) {
	    die "$NAME: Can not create queue directory '$queuedir'!\n";
	}
    }
    mylogs ('info', "Using queue directory '$queuedir'") if $verbose;
    # check quarantine settings
    if ($quarantine) {
	@quarantine_actions = @default_quarantine_actions unless (@quarantine_actions);
	# remove trailing '/'
	$quarantine =~ s@/$@@;
	if ($quarantine) {
	    unless (-d $quarantine) {
        	unless (mkdir($quarantine)) {
		    mylogs ('notice', "Can not create quarantine directory '$quarantine'. Disabling quarantine...");
		    undef $quarantine;
		}
	    }
	    if ($quarantine) {
		mylogs ('info', "Using quarantine directory '$quarantine' on actions: ".(join ', ', @quarantine_actions)) if $verbose;
		map { $quarantine_actions{$_} = 1 } @quarantine_actions;
	    }
	}
    }
}

# init virusscanners
sub init_virusscanners {
    return undef unless (@virusscanners);
    my @vhelp = ();
    foreach (@virusscanners) {
	    # check recognition patterns
	    if (!defined $virusscanners{$_}{evil}) {
		mylogs ('notice', "scanner '$_' error: no 'evil' mask");
	    } elsif (!defined $virusscanners{$_}{good}) {
		mylogs ('notice', "scanner '$_' error: no 'good' mask");
	    # command line scanner
	    } elsif (defined $virusscanners{$_}{cmd}) {
		# check executable
		unless (-x $virusscanners{$_}{cmd}) {
		    mylogs ('notice', "scanner '$_' error: no executable '$virusscanners{$_}{cmd}' found");
		} else {
		    mylogs ('info', "Using scanner '$_' -> 'CMD:$virusscanners{$_}{cmd}".((defined $virusscanners{$_}{opt}) ? " $virusscanners{$_}{opt}" : '')."'") if $verbose;
		    # 'scan' function ptr
		    $virusscanners{$_}{scan} = \&cmdscan;
		    # add scanner to list
		    push @vhelp, $_;
		}
	    # socket based scanner
	    } elsif (defined $virusscanners{$_}{peer}) {
		# socket type AF_INET or AF_UNIX
		my $type = (defined $virusscanners{$_}{port}) ? 'INET' : 'UNIX';
		mylogs ('info', "Using scanner '$_' -> '$type:$virusscanners{$_}{peer}".(($type eq 'INET') ? ":$virusscanners{$_}{port}" : '')."'") if $verbose;
		# 'get socket' ptr
		$virusscanners{$_}{scansocket} = ($type eq 'INET') ? \&netscan_socket_inet : \&netscan_socket_unix;
		# 'scan' function ptr
		$virusscanners{$_}{scan} = \&netscan;
		# add scanner to list
		push @vhelp, $_;
	    # unknown scanner type
	    } else {
		mylogs ('notice', "scanner '$_' error: unknown scanner type. please define 'cmd' or 'peer'");
	    }
    }
    if (@virusscanners = @vhelp) {
	# init notification sender
	$virusmail = "From: $ADMIN\r\n".$virusmail;
    }
    return @virusscanners;
}

# init spamassassin
sub init_spamassassin {
    return undef unless $saversion;
    # return code
    my $result = undef;
    # prepare patterns
    @sadomains       = map { $_ = qr/$_/i } @sadomains       if (@sadomains);
    @sawhitelistfrom = map { $_ = qr/$_/i } @sawhitelistfrom if (@sawhitelistfrom);
    # set SA logging level
    $sadebug = ($verbose > 1) ? 'all' : 'info';
    # remove stderr logger when daemonized
    Mail::SpamAssassin::Logger::remove('stderr') if $daemon;
    # create SA object
    if ( $spamtest = Mail::SpamAssassin->new(
	{
	    debug => $sadebug,
	    dont_copy_prefs => 1,
	    site_rules_filename => $safile,
	}
    ) ) {
	# set up SA syslogging
	Mail::SpamAssassin::Logger::add(
	    method => 'syslog',
	    socket => $syslog_socktype,
	    facility => $syslog_facility,
	    ident => $syslog_name );
	Mail::SpamAssassin::Logger::add_facilities($sadebug);
	# notify user switch to SA
	$spamtest->signal_user_changed(
	    {
		username => $user,
		user_dir => $homedir,
		userstate_dir => $homedir,
	    }
	);
	if ($sa_opportunistic_expire) {
	    #$spamtest->init_learner({ learn_to_journal => 1, opportunistic_expire_check_only => 1 });
	    $spamtest->init_learner({ opportunistic_expire_check_only => 1 });
	    $spamtest->finish_learner();
	#} else {
	#    $spamtest->init_learner({ learn_to_journal => 1 });
	#    $spamtest->finish_learner();
	}
	# precompile SA ruleset
	$spamtest->compile_now() if $throughput;
	mylogs ('info', "Successfully initialized ".($throughput ? 'and compiled ' : '')."Mail::SpamAssassin object") if $verbose;
	$result = 1;
    } else {
	# disable SA on failure
	mylogs ('notice', "Can not create Mail::SpamAssassin object. Try to run 'spamassassin -D --lint' on the console. Scan will be skipped.");
    }
    return $result;
}

# check sender for spamassassin whitelist
# for reliable operation own domains should be
# denied for remote senders at mta-level
#
# POSTFIX EXAMPLE
#
# /etc/postfix/main.cf:
# ---------------------
# smtpd_recipient_restrictions =
#   permit_mynetworks,
#   ...<other permit_*>...
#   reject_unauth_destination,
#   check_sender_access hash:/etc/postfix/internal_domains
#
# /etc/postfix/internal_domains:
# ------------------------------
# mydomain1.local	REJECT you are not authorized to send FROM this domain
# mydomain2.local	REJECT you are not authorized to send FROM this domain
#
sub whitelisted_sender {
    my @snds = @_;
    my $result = @sawhitelistfrom;
    if ($result) {
	WHITEFROM: for my $snd (@snds) {
	    $snd =~ s/$patterns{email}/$1/;
	    for my $sasnd (@sawhitelistfrom) {
		last WHITEFROM if ($result = ($snd =~ m/$sasnd/));
	    }
	}
    }
    return $result;
}

# check recipient for spamasassin scan
sub needs_sascan {
    my @recs = @_;
    my $result = not(@sadomains);
    unless ($result) {
	SACHECK: for my $rec (@recs) {
	    $rec =~ s/$patterns{email}/$1/;
	    for my $sarec (@sadomains) {
		last SACHECK if ($result = ($rec =~ m/$sarec/));
	    }
	}
    }
    return $result;
}

# fill in taggedmail template values
sub prepare_taggedmail {
    foreach (keys %request) {
	my $mask = '<<'.uc($_).'>>'; $mask = qr/$mask/;
	my $repl = join ', ', @{$request{$_}} if defined $request{$_};
	$taggedmail =~ s/$mask/$repl/g
	    if ($mask and $repl);
    }
}

# put a message into quarantine
sub quarantine {
    my $qfile = undef;
    if ($qfile = $server->quarantine($quarantine)) {
	mylogs ('info', "Quarantined '$server->{queuefile}' -> '$qfile'") if $verbose;
    } else {
	mylogs ('notice', "Quarantine-error: '$server->{queuefile}' -> '$qfile'");
    }
    return basename($qfile);
}

# cmdscan
sub cmdscan {
    my ($server,$scanner) = @_;
    my $code = $SSC_ERR; my $status = '';
    my $cmdline = $virusscanners{$scanner}{cmd}.((defined $virusscanners{$scanner}{opt}) ? " $virusscanners{$scanner}{opt}" : '' ).' '.$server->{queuefile};
    mylogs ('info', "cmdscan '$scanner' sending: '$cmdline'") if ($verbose > 1);
    my $output = qx($cmdline 2>&1);
    if ($output) {
	map { mylogs ('info', "cmdscan '$scanner' answer: '$_'") } (split /\r?\n/, $output) if ($verbose > 1);
	if ($output =~ /$virusscanners{$scanner}{evil}/) {
	    $status = $1;
	    $code = $SSC_BAD;
	} elsif ($output =~ /$virusscanners{$scanner}{good}/) {
	    $code = $SSC_OK;
	} else {
	    $status = "cmdscan '$scanner' bad answer: '$output'";
	}
    } else {
	$status = "cmdscan '$scanner' empty output for '$cmdline'";
    }
    return ($code,$status);
}

# netscan - get unix socket
sub netscan_socket_unix {
    return new IO::Socket::UNIX (
	Peer => $virusscanners{$_[0]}{peer},
	Type => SOCK_STREAM,
    );
}

# netscan - get inet socket
sub netscan_socket_inet {
    return new IO::Socket::INET (
	PeerAddr => $virusscanners{$_[0]}{peer},
	PeerPort => $virusscanners{$_[0]}{port},
	Timeout  => $virusscanners{$_[0]}{timeout},
	Type     => SOCK_STREAM,
	Proto    => 'tcp',
    );
}

# netscan
sub netscan {
    my ($server,$scanner) = @_;
    my $code = $SSC_ERR; my $status = '';
    my $sendstr = $virusscanners{$scanner}{pre}.$server->{queuefile}.$virusscanners{$scanner}{post};
    my $socket = &{$virusscanners{$scanner}{scansocket}}($scanner);
    if ( $socket ) {
	mylogs ('info',"netscan '$scanner' sending: '$sendstr'") if ($verbose > 1);
	print $socket "$sendstr";
	$sendstr = <$socket>;
	chomp($sendstr);
	mylogs ('info',"netscan '$scanner' answer: '$sendstr'") if ($verbose > 1);
	if ($sendstr =~ /$virusscanners{$scanner}{evil}/) {
	    $status = $1;
	    $code = $SSC_BAD;
	} elsif ($sendstr =~ /$virusscanners{$scanner}{good}/) {
	    $code = $SSC_OK;
	} else {
	    $status = "netscan '$scanner' bad answer: '$sendstr'";
	}
    } else {
	$status = "netscan '$scanner' could not open connection to $virusscanners{$scanner}{peer}:$virusscanners{$scanner}{port}: $@: $!";
    }
    return ($code,$status);
}

# parse message content
sub parse_data {
    my $fh = shift;
    my $received = my $trusted = '';
    my $size = my $rcvd = 0;
    my $getnext = undef;
    my $action = 'PASS';

    # reset filehandle
    seek ($fh,0,0) or die "$0: can not rewind file: $!\n";
    $size = (stat($fh))[7];
    local (*_);
    local ($/) = "\r\n";
    my $inheaders = 1;
    while (<$fh>) {
	mylogs ('info', "[DATA] debug: $_")
	    if ($verbose > 2);
        s/$patterns{dot}/../;

	## inspect message headers
	if (defined $inheaders) {
	    # end of headers
	    if (m/$patterns{empty}/) {
		# parse trusted headers (before first 'Received:')
		if ($trusted =~ m/$patterns{tls_fingerprint}/) {
		    push @{$request{tlsfingerprint}}, $1;
		}
	        # parse own received header
		if ($received =~ s/$patterns{received_full}// ) {
		    my($r_helo,$r_name,$r_addr) = ($1,$2,$3);
		    push @{$request{rhelo}}, $r_helo unless defined $request{rhelo};
		    push @{$request{rname}}, $r_name unless defined $request{rname};
		    push @{$request{raddr}}, $r_addr unless defined $request{raddr};
		    if ($received =~ s/$patterns{tls_line_1}//) {
			my($r_proto,$r_cipher,$r_keylen) = ($1,$2,$3);
			push @{$request{tlsproto}}, $r_proto   unless defined $request{tlsproto};
			push @{$request{tlscipher}}, $r_cipher unless defined $request{tlscipher};
			push @{$request{tlskey}}, $r_keylen    unless defined $request{tlskey};
			if ($received =~ s/$patterns{tls_line_2}//) {
			    my($r_clientcn,$r_issuer,$r_status) = ($1,$2,$3);
			    push @{$request{tlsccn}}, $r_clientcn  unless defined $request{tlsccn};
			    push @{$request{tlsissuer}}, $r_issuer unless defined $request{tlsissuer};
			    push @{$request{tlsstat}}, $r_status   unless defined $request{tlsstat};
			}
		    }
		}
		undef $trusted; undef $received; undef $inheaders;
	    } elsif ($rcvd < 2){
		$rcvd++ if (m/$patterns{received}/);
		unless ($rcvd) {
		    $trusted .= $_;
		} elsif ($rcvd == 1) {
		    $received .= $_;
		}
	    }
	    # get message-id
	    if (not(defined $request{messageid}) and (m/$patterns{messageid}/)) {
		push @{$request{messageid}}, $1;
	    # get subject
	    } elsif (not(defined $request{subject}) and (m/$patterns{subject}/)) {
		my $subject = $1 || '';
		push @{$request{subject}}, $subject;
		if ($allow_user_commands) {
		    $action = 'DENY'    if ($subject =~ m/$patterns{deny}/);
		    $action = 'DISCARD' if ($subject =~ m/$patterns{discard}/);
		}
	    }
	}

	## parse whole message for attachment names
	if (s/$patterns{content}//) {
	    if (m/$patterns{attachment}/) {
		push @{$request{attachment}}, $2;
	    } else {
		$getnext = 1;
	    }
	# or look at next line
	} elsif (defined $getnext) {
	    if (m/$patterns{attachment}/) {
		push @{$request{attachment}}, $2;
	    }
	    undef $getnext;
	}
    } # end of data

    # get some message params
    # save these for later use
    push @{$request{size}}, $size;
    @{$request{attachment}} = uniq(@{$request{attachment}})
	if defined $request{attachment};

    # evaluate result
    foreach my $attr (keys %getattr_sequence) {
	REC: foreach my $rec (@{$getattr_sequence{$attr}}) {
	    if ($rec and (defined $request{$rec})) {
		$request{$attr} = $request{$rec};
		last REC;
	    }
	}
    }
    push @{$request{client}}, ($request{name}[0] || 'unknown').'['.($request{addr}[0] || 'unknown').']';
    return $action;
}

# cycles through virusscanners
sub virscan_data {
    # currently unused
    my $fh = shift;
    my $action = 'PASS';
    my $hasvirus = 0;
    my $header = '';
    # handle timeout
    eval {
	local $SIG{'__DIE__'}; 
	local $SIG{'ALRM'}  = sub { mylogs ('warning',"[TIMEOUT] skipping virusscan after $virustimeout seconds"); die };
	my $prevalert = alarm($virustimeout);
	# cycle through scanners
	SCANNER: foreach my $scanner (@virusscanners) {
	    if (defined $virusscanners{$scanner}{scan}) {
		my ($vcode,$vstatus) = &{$virusscanners{$scanner}{scan}} ($server,$scanner);
		if (defined $vcode) {
		    if ($vcode) {
			mylogs ('warning', "scanner '$scanner' error: $vstatus");
		    } else {
			$hasvirus++;
			push @{$request{virus}}, "$scanner:$vstatus";
			mylogs ('info', "scanner '$scanner' virus: $vstatus overall: $hasvirus") if $verbose;
			last SCANNER if $virusscanners{$scanner}{stop};
		    }
		} else {
			push @{$request{virus}}, "$scanner:none";
			mylogs ('info', "scanner '$scanner' virus: none overall: $hasvirus") if ($verbose > 1);
		}
	    } else {
		    push @{$request{virus}}, "$scanner:error";
		    mylogs ('warning', "scanner '$scanner' error: scan() function undefined");
	    }
	}
	# restore old alarm
	alarm($prevalert);
    };
    if ($hasvirus) {
	$action = $virusaction;
	$taggedmail = $virusmail if ($action eq 'NOTIFY');
    }
    $header = 'virus=<'.(join ',', @{$request{virus}}).'>' if defined $request{virus};
    mylogs ('info', "Virusscan: action=$action, $header") if $verbose;
    return ($action, $header);
}

# scans message with spamassassin
sub spamscan_data {
    my $fh = shift;
    my $action = 'PASS';
    my $header = '';
    if ($request{size}[0] > $samaxsize) {
	push @{$request{sascore}}, 'skipped';
	push @{$request{sahits}}, 'msg('.(sprintf "%.1f",($request{size}[0]/1024)).'k) greater max('.(sprintf "%.1f", ($samaxsize/1024)).'k)';
    } elsif (whitelisted_sender (@{$request{from}})) {
	push @{$request{sascore}}, 'skipped';
	push @{$request{sahits}}, 'sender whitelisted';
    } elsif (!needs_sascan (@{$request{to}})) {
	push @{$request{sascore}}, 'skipped';
	push @{$request{sahits}}, 'recipient whitelisted';
    } else {
	seek ($fh,0,0) or die "$0: can not rewind file: $!\n";
	my $mail = my $status = undef;
	eval {
	    # handle timeout
	    local $SIG{'__DIE__'}; 
	    local $SIG{'ALRM'}  = sub { mylogs ('warning',"[TIMEOUT] skipping spamassassin after $satimeout seconds"); die };
	    my $prevalert = alarm($satimeout);
	    $mail = $spamtest->parse($fh);
	    $status = $spamtest->check($mail);
	    alarm ($prevalert);
	};
	if (defined $mail and defined $status) {
	    my $saspam = $status->is_spam();
	    my $sascore = $status->get_score();
	    my $sahits = $status->get_names_of_tests_hit();
	    my $sareqscore = $status->get_required_score();
	    push @{$request{sascore}}, (sprintf("%.2f",$sascore)).'/'.$sareqscore.'/'.$samaxscore.'/'.$status->get_autolearn_status();
	    push @{$request{sahits}}, $sahits;
	    if ($saspam) {
		    if (not($saaction eq 'PASS') and ($sascore > $samaxscore)) {
			$action = $saaction;
		    } else {
			$taggedmail = $status->rewrite_mail();
			$action='TAG';
		    }
	    }
	    if ($sa_opportunistic_expire and $status->{'bayes_expiry_due'}) {
		    mylogs('info', "bayes expiry was marked as due, running post-check");
		    $spamtest->rebuild_learner_caches();
		    $spamtest->finish_learner();
	    }
	} else {
	    push @{$request{sascore}}, 'skipped';
	    push @{$request{sahits}}, "timeout after $satimeout seconds";
	}
	$status->finish() if defined $status;
	$mail->finish() if defined $mail;
    }
    $header = "sascore=<".(join ',', @{$request{sascore}}).">\r\n\tsahits=<".(join ',', @{$request{sahits}}).">";
    return ($action, $header);
}

# process message content
sub process_data {
    my $fh = shift;
    my $date = strftime("%a, %d %b %Y %T %Z", localtime);
    my @procs = @scan_procs;
    my @scans  = ();
    my $header = '';
    my $action = 'PASS';
    my $t1 = my $t2 = time();

    # date, client and envelope data
    push @{$request{date}}, $date;
    map { @{$request{$_}} = $server->{$_}    if defined $server->{$_} } (qw[ xname xaddr ]);
    map { @{$request{$_}} = $server->{$_}    if defined $server->{$_} } (qw[ ehelo xhelo ]);
    @{$request{from}}     = $server->{from}  if defined $server->{from};
    @{$request{to}}       = @{$server->{to}} if defined $server->{to};

    # parse message content
    my $last = time();
    $action = parse_data($fh);
    my $hdtime = sprintf("%.1f",(time()) - $last); $hdtime =~ s/$patterns{stripdotzero}//;
    ($hdtime > 0) and push @scans, 'header:'.$hdtime.'s';
    mylogs ('info', "hdscan: action=$action") if $verbose;

    # cycle through scanners
    while ($action eq 'PASS' and my $scanner = shift @procs) {
        my $last = time();
        ($action,my $aheader) = &{$scanners{$scanner}{scan}}($fh);
	my $proctime = sprintf("%.1f",(time()) - $last); $proctime =~ s/$patterns{stripdotzero}//;
        push @scans, "$scanner:$proctime".'s';
        mylogs ('info', "$scanner-scan: action=$action, header='$aheader' time=$proctime".'s') if $verbose;
        $header .= "\r\n\t$aheader" if $aheader;
    }

    # note processing information
    push @{$request{scans}}, (join ',', @scans) if @scans;

    # return result
    $action ||= 'PASS';
    $header = "X-Postfwd-Filter: action=$action on $HOSTNAME at $date$header\r\n";
    return ($action, $header);
}

sub process_request {
    my($server,$client) = @_;
    my $datacmd = my $datareply = undef;
    # greetings
    my $banner = $client->hear;
    $server->ok($banner);
    # conversation loop
    while (my $what = $server->chat) {
	mylogs ('info', "[ENV]  debug: $what") if ($verbose > 1);
	if($what =~ m/$patterns{data}/) {
	    $datacmd = $what;
	    $server->ok("354 End data with <CR><LF>.<CR><LF>");
	} elsif ($what eq '.') {
	    # evaluate request whether...
	    my ($action,$header) = process_data($server->{data});
	    # ... to quarantine message and...
	    push @{$request{quarantine}}, quarantine()
		if ($quarantine and defined $quarantine_actions{$action});
	    # ... to reject
	    if ($action eq 'DENY') {
		# deny access to client
		$server->ok($denymsg);
		# drop upstream connection silently
		$client->say("QUIT");
	    # ... to discard
	    } elsif ($action eq 'DISCARD') {
		# deny access to client
		$server->ok($discardmsg);
		# drop upstream connection silently
		$client->say("QUIT");
	    # ... or send it to the upstream server
	    } else {
		# send the original DATA
		$client->say($datacmd);
		# get upstream server's reply
		$client->hear();
		# prepare template
		prepare_taggedmail() if ($action eq 'NOTIFY');
		# send content
		$client->yammer($header,($taggedmail) ? \$taggedmail : $server->{data});
		# get server's reply
		$datareply = $client->hear();
		# and send it to the client
		$server->ok("$datareply\r\n");
		push @{$request{reply}}, $datareply;
	    }
	    # prepare result
	    my $line = "action=<$action>";
	    foreach my $key (@logitems) {
		if (defined $request{$key}) {
		    @{$request{$key}} = map { $_ = abbrev($abbrev_items{$key}, $_) if defined $abbrev_items{$key}; $_ = '<'.$_.'>' } @{$request{$key}};
		    $line .= "; $key=".(join ',', @{$request{$key}});
		}
	    }
	    # log request
	    mylogs ('info', "$line");
	    # cleanup
	    $server->reset_queuefile() if $queuesafe;
	    undef %request; undef $taggedmail;
	} else {
	    # send server's answer to the client
	    $client->say($what);
	    $server->ok($client->hear);
	}
    }
}

## END OF SUBS