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

#
# Author:  Chris Mason <cmason@unixzone.com>
# Current maintainer: Lars Hecking <lhecking@users.sourceforge.net>
#
# Based on work by:
#       Mogens Kjaer, Carlsberg Laboratory, <mk@crc.dk>
#       Juergen Quade, Softing GmbH, <quade@softing.com>
#       Christian Bricart <shiva@aachalon.de>
#
# This script is part of the AMaViS package.  For more information see:
#
# http://amavis.org/
#
# Copyright (C) 2000 - 2002 the people mentioned above
#
#
# This software is licensed under the GNU General Public License (GPL)
# See:  http://www.gnu.org/copyleft/gpl.html
#


use strict;
use MIME::Parser;
use POSIX qw ( strftime geteuid setuid uname setsid
  WEXITSTATUS WIFEXITED WTERMSIG WIFSIGNALED );
use POSIX ":sys_wait_h";
use Fcntl;
use Fcntl ':flock';
use Unix::Syslog qw(:macros :subs);
use IO::File;
use IO::Pipe;
use Convert::TNEF;
use Convert::UUlib ':all';
use Compress::Zlib;
use Archive::Tar;
use Archive::Zip qw ( :CONSTANTS :ERROR_CODES );
use File::Basename;
use File::Copy;
use Socket;


#
# main()
#

package main;

#
# Configurable constants
#

# Config file
my $config_file = "/usr/local/etc/amavisd.conf";

# If $TESTING is yes, no mail is sent at all.  MIME decomposition
# and virus scanning are still performed.  Depending on $DEBUG, you'll
# have to monitor the daemon's log file or stderr to verify correct
# operation.
my $TESTING = "no";

# Create debugging output
# yes: log to stderr; no: log to syslog/file
my $DEBUG = "no";

#
# Non-configurable variables and constants
#

#
# Package related

my $pkg_home_url = "http://amavis.org/";

#
# Logging related

use vars qw ( $DO_SYSLOG $LOGDIR $LOGFILE $myname $log $log_level );

my $SYSLOG_LEVEL = "mail.info";
my ($FACILITY, $PRIORITY);

#
# Virus related

# Av scanners and related vars
use vars qw ( $antivir $avp $avpdc $AVPDIR $csav $fprot $fsav $inocucmd $nod32
  $nod32cli $oav $panda $rav $sophos $sophos_ide_path $cscmdline $scs_host $scs_port $uvscan $vbengcl $vscan
  $vfind $sophie_sockname $trophie_sockname );

use vars qw ( $QUARANTINEDIR $VIRUSFILE $viruslist @virusname
  $warnadmin $warnsender $warnrecip $warn_offsite @local_domains );

use vars qw ( $X_HEADER_TAG $X_HEADER_LINE );

#
# Various external programs
use vars qw ( $arc $bunzip $file $lha $unarj $uncompress $unrar $zoo );

#
# MTA related

use vars qw ( $localhost_ip $localhost_name $smtp_port $enable_relay
  $QMAILDIR $sendmail_cf_orig );

#
# sending email related

use vars qw ( $SENDER @RECIPS $LDA @LDAARGS $sendmail_wrapper
  $sendmail_wrapper_args $mailfrom $mailto );

# Temporary directory
# Moved this above MTA init section because milter init sets TEMPDIR
my $TEMPBASE = "/var/amavis";
use vars '$TEMPDIR';

#
# Client/server/daemon related

my ($socketname, $parentpid, $diedpid, $tmppid) = ("/var/amavis/amavisd.sock", 0, 0, 0);

# flag to indicate compressing file format
my $some_compression = 0;

#
# MTA init section
#

# sendmail

# error codes
my $VIRUSERR = 0;
my $REGERR = 75;   # EX_TEMPFAIL from sendmail sysexits.h

# suid?
#if (setuid(0) == -1) {
#    exit($REGERR)
#}

# set path explicitly
$ENV{PATH} = "/bin:/usr/bin:/usr/local/bin";

# End sendmail
#
# End MTA init section
#

#
# misc internals
use vars qw ( $MAXLEVELS $MAX_ARCHIVE_NESTING $MAXFILES $credits $fh );

# Magic number to detect DoS attacks
my $threshold = 14;

# MIME entity, av scanner output and return status
use vars qw ( $entity $output $errval );

#
# Subroutines
#

#
# Client/server/daemon stuff

# From perlipc(1)
sub daemonize {
    chdir("/")                or die "Can't chdir to /: $!";
    open STDIN, '/dev/null'   or die "Can't read /dev/null: $!";
    open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
    defined(my $pid = fork)   or die "Can't fork: $!";
    exit if $pid;
    setsid                    or die "Can't start a new session: $!";
    open STDERR, '>&STDOUT'   or die "Can't dup stdout: $!";
}

#
# Set up signal handling

# SIGCHLD handler
sub deadbabe {
    do {
	$tmppid = waitpid(-1, &WNOHANG);
    } while ($tmppid > 0);
    $diedpid = 1;
    $SIG{CHLD} = \&deadbabe;
# stupid sys5 resets the signal when called - but only -after- the wait...
}
# Catch any dead child process

# If IGNORE leaves zombies behind on your system,
# switch the comments between the two lines below
# $SIG{CHLD} = \&deadbabe;
$SIG{CHLD} = 'IGNORE';

# may need to do more - eg. if logging changes, close/reopen syslog/log file
# rethink - handler should be simple
sub read_config {
    do "$config_file" || die "Cannot read config file: $!";
    $SIG{HUP} = \&read_config;
}
$SIG{HUP} = \&read_config;
# doesn't work yet!!

# Clean exit
$SIG{INT} = $SIG{TERM} = sub { do_exit(1, __LINE__); };

#
sub setup_socket() {
    my $uaddr = sockaddr_un($socketname);

    socket(Server, PF_UNIX, SOCK_STREAM, 0) || return 0;
    unlink ($socketname);
    do_log(3,"set up socket");

    bind (Server, $uaddr) || return 0;
    do_log(3,"bound socket");

    listen (Server, SOMAXCONN) || return 0;
    do_log(3,"listening");

    return 1;
}

# The heart of the program
sub main_loop() {
    my ($inbuff, $mpid, $a);

    while (($a = accept(Client,Server)) || $diedpid) {

	do_log(3,"enter accept loop");
	# now we start the repeating loop...
	if ($diedpid) {
	    $diedpid = 0;
	    # if the accept returned purely because of a caught sigchld
	    # then continue
	    next unless (defined($a));
	}

	if (!defined($mpid = fork)) {
	    shutdown Server, 2;
	    do_log(0,"shutdown server - cannot fork");
	    do_exit($REGERR, __LINE__);
	}

	# if we're the parent, just go back to the accept loop
	next if ($mpid);

	do_log(3,"forked off -- child running...");

	$SIG{CHLD} = 'DEFAULT';
	# reset sigchild - we don't want to mess up $? for the virus scanner

	#
	# Receive TEMPDIR/SENDER/RCPTS/LDA/LDAARGS from client
	#

	my $ret;
	my $yval = "\1";
	# value to return to the client if AOK

	$ret = recv Client, $inbuff, 8192, 0;
	$TEMPDIR = $inbuff;
	if ($TEMPDIR =~ /^($TEMPBASE\/[-\w\.]+)$/) {
	    $TEMPDIR = $1;
	    # untaint the directory option...
	    $ret = send (Client, $yval, 0);
	} else {
	    do_log(0,"Invalid directory $TEMPDIR");
	    do_exit($REGERR, __LINE__);
	    # invalid directory
	}
	if (!defined($ret)) {
	    do_log(0,"failed to send response to client - $!");
	    do_exit($REGERR, __LINE__);
	}
	$ret = recv Client, $inbuff, 8192, 0;
	$SENDER = $inbuff;
	$ret = send (Client, $yval, 0);
	if (!defined($ret)) {
	    do_log(0,"failed to send response to client - $!");
	    do_exit($REGERR, __LINE__);
	}

	# Simple "protocol"
	# \2 means LDA; \3 means EOT (end of transmission)

	my $outvar = \@RECIPS;
	while (1) {
	    $ret = recv Client, $inbuff, 8192, 0;
	    last if ($inbuff eq "\3");

	    ($inbuff eq "\2") ? $outvar = \@LDAARGS : push(@$outvar, $inbuff);

	    $ret = send (Client, $yval, 0);
	    if (!defined($ret)) {
		do_log(0,"failed to send response to client - $!");
		do_exit($REGERR, __LINE__);
	    }
	}

	# Kiss
	$LDA = shift @LDAARGS;


# command line parsing, sendmail version

if ($enable_relay eq "yes") {
    # relay config

    $LDA = $sendmail_wrapper;
    push(@LDAARGS, "-C$sendmail_cf_orig");
    push(@LDAARGS, "-f<$SENDER>");
    push(@LDAARGS, "@RECIPS");
}

# End sendmail cmd line parsing

	# This is just for debugging purposes
	do_log(1,"$TEMPDIR: from=<$SENDER>, to=<" . join(',',@RECIPS) . ">");
	do_log(1,"LDA is \"$LDA\", LDAARGS is \"" . join(' ',@LDAARGS) . "\"") if ($LDA);

	$SENDER = "<>" if (!$SENDER);

	my($which_section) = "initialization";
	my($sts);
	eval {
	    mkdir("$TEMPDIR/parts", oct('700'))
		or die "Can't create directory $TEMPDIR/parts: $!";
	    chdir($TEMPBASE) or die "Can't chdir to $TEMPDIR: $!";

	    # Mail message was saved by the client; this file is moved
	    # to a quarantine area if a virus was found
	    # Note: to get the qmail config working again, we now read the
	    # actual message (STDIN) before the envelope information (STDOUT)

	    if (!-r "$TEMPDIR/email.txt") {
		die "Can't find mail file $TEMPDIR/email.txt";
	    } else {
		# already created by client, just open it
		$fh = IO::File->new("$TEMPDIR/email.txt")
		    or die "Can't open file $TEMPDIR/email.txt: $!";
	    }
	    $which_section = "decoding";        parse_decode($fh);
	    $which_section = "virus scanning";  virus_scan();
	    $which_section = "mail forwarding"; $sts = forward_mail();

	    $which_section = "finishing";
	};
	if ($@ ne '') {
	    do_log(0,"$which_section failed, retry:\n  " . $@);
	    do_exit($REGERR, __LINE__);
	}

	# forward_mail() returns 0 on success
	do_exit(0, __LINE__) if (!$sts);

	do_exit($REGERR, __LINE__)
    } # accept loop

} # main_loop

#
# Subroutines
#

# Run virus scanner(s)
sub virus_scan {
    # At least one scanner must work!
    my $scanner_errors = 1;

    #
    # Okay, now we scan for viruses
    #
    # If we find one, send mail right away and quit.  No point scanning any
    # more once we've found one.
    #











#
# McAfee
# 

if ($uvscan) {
    do_log(2,"Using $uvscan");
    chop($output = `$uvscan --secure -rv --summary --noboot $TEMPDIR/parts`);
    $errval = retcode($?);
    $scanner_errors &= $errval;
    do_log(2,$output);
    if ($errval) {
	if ($errval == 13) {
	    my $loutput = $output;
	    $loutput =~ s/Found: (.+) NOT a/Found the $1/g;
	    $loutput =~ s/Found the (.+) trojan/Found the $1 virus/g;
	    $loutput =~ s/Found virus or variant (.+) /Found the $1 virus/g;
	    @virusname = ($loutput =~ /Found the (.+) virus/g);
	    do_virus($output);
	} else {
	    do_log(0,"Virus scanner failure: $uvscan (error code: $errval)");
	}
    }
}











    if ($scanner_errors) {
	do_log(0,"All virus scanners failed!");
	do_exit($REGERR, __LINE__);
    }
}

# Forward original message
sub forward_mail {
    my $seen_xheader = ( $X_HEADER_LINE ? 0 : 1 );

    if ($TESTING ne "yes") {
	
    # sending mail, sendmail version
    # For sendmail, we call the "real" local delivery agent

    open(MAIL, "|-") || exec($LDA, @LDAARGS);
    while (<$fh>) {
	next if ($seen_xheader == 0 && m/^$X_HEADER_TAG:/o);
	if ($seen_xheader == 0 && m/\A\r?\n\Z/) {
	    print MAIL "$X_HEADER_TAG: $X_HEADER_LINE\n";
	    $seen_xheader = 1;
	}
	print MAIL $_;
    }

    close(MAIL);

    # Pass up the LDA's error code
    do_exit($? >> 8, __LINE__);
    # End sendmail
    } else {
	do_log(0,"Testing mode - no email sent. $X_HEADER_TAG: $X_HEADER_LINE");
    }
    return 0;
}

# If virus found
sub do_virus(@) {

    # early exit in testing mode
    do_exit(0, __LINE__) if ($TESTING eq "yes");

    $viruslist = join("\n\t",@virusname);

    if ($QUARANTINEDIR) {
	do_quarantine("Virus found");
    } else {
	do_log(0,"Virus found - not quarantined");
    }

    log_msg_id(1);

    # Then we send email
    warn_sender() if ($warnsender eq "yes");

    # warn_recip() is disabled by default because of possible problems
    # with mailing lists. Enable only if you know what you're doing!
    warn_recip() if ($warnrecip eq "yes");

    # Notify admin
    warn_admin() if ($warnadmin eq "yes");

    # Finally, we bounce the message or pretend everything was okay,
    # depending on the MTA
    do_exit($VIRUSERR, __LINE__);
}

#
sub do_quarantine(@) {
    my $reason = shift;
    $VIRUSFILE = "virus-" . strftime("%Y%m%d-%H%M%S", localtime) . "-" . "$$";
    move ("$TEMPDIR/email.txt", "$QUARANTINEDIR/$VIRUSFILE");
    do_log(0,"$reason - quarantined as $VIRUSFILE");
}

# Notify sender
sub warn_sender() {
    return 0 if ($SENDER eq "<>" or $entity->head->get("Precedence") =~ /bulk|list/io);

    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
      do_exit($REGERR, __LINE__);
	my $amavis_url = &amavisCredits();
	print MAIL <<"EOF";
From: $mailfrom
To: $SENDER
Subject: VIRUS IN YOUR MAIL

                           V I R U S  A L E R T

Our viruschecker found the

\t$viruslist

virus(es) in your email to the following recipient(s):

EOF
	foreach (@RECIPS) {
		print MAIL "-> $_\n";
	}
	print MAIL <<"EOF";

Delivery of the email was stopped!

Please check your system for viruses, or ask your system administrator
to do so.
$amavis_url
For your reference, here are the headers from your email:

------------------------- BEGIN HEADERS -----------------------------
EOF
	$entity->print_header(\*MAIL);
	print MAIL <<"EOF";
-------------------------- END HEADERS ------------------------------

EOF
    close(MAIL);
}

# Notify admin
sub warn_admin() {
    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
      do_exit($REGERR, __LINE__);
	$SENDER = "(empty address)" if ($SENDER eq "<>");
	print MAIL <<"EOF";
From: $mailfrom
To: $mailto
Subject: FOUND VIRUS IN MAIL from $SENDER

A virus was found in an email from:

$SENDER

The message was addressed to: 

EOF
	foreach (@RECIPS) {
		print MAIL "-> $_\n";
	}

	if ($QUARANTINEDIR) {
		print MAIL <<"EOF";

The message has been quarantined as:

$QUARANTINEDIR/$VIRUSFILE
EOF
	}
	print MAIL <<"EOF";

Here is the output of the scanner:

$output

Here are the headers:

------------------------- BEGIN HEADERS -----------------------------
EOF
	$entity->print_header(\*MAIL);
	print MAIL <<"EOF";
-------------------------- END HEADERS ------------------------------

EOF
    close(MAIL);
}

# Notify recipient(s)
# if $warn_offsite is "no", recipient addresses where the domain-part
# is not in @local_domains don't get a notification
sub warn_recip() {
    my %local_domains = ();
    for (@local_domains) { $local_domains{$_} = 1 }
    # hashes are faster than arrays
    foreach (@RECIPS) {
	my $rcpt_is_local = undef;
	$rcpt_is_local = 1 if ($local_domains{(split(/>/,(split(/@/))[-1]))[0]});

	# This is a bit inefficient: we open one file per recipient
	if ($rcpt_is_local || $warn_offsite eq "yes") {
	    open(MAIL, "|$sendmail_wrapper $sendmail_wrapper_args -f$mailfrom") ||
	      do_exit($REGERR, __LINE__);
		my $amavis_url = &amavisCredits();
		$SENDER = "(empty address)" if ($SENDER eq "<>");
		print MAIL <<"EOF";
From: $mailfrom
To: $_
Subject: VIRUS IN MAIL FOR YOU FROM $SENDER

                           V I R U S  A L E R T

Our viruschecker found the

\t$viruslist

virus(es) in an email to you from:

$SENDER

Delivery of the email was stopped!

Please contact your system administrator for details.

EOF
		if ($QUARANTINEDIR) {
			print MAIL <<"EOF";
The ID of your quarantined message is:

$VIRUSFILE

EOF
		}
		print MAIL <<"EOF";
$amavis_url
EOF
	    close(MAIL);
	}
    }
}

# amavis credits.
# Called from the notification routines.
sub amavisCredits {
    if ($credits eq "yes" ) {
	return <<EOF;

For further information about this viruschecker see:

$pkg_home_url
AMaViS - A Mail Virus Scanner, licensed GPL

EOF
    }

    return "";
}

# Get ready to break up mime parts
sub parse_decode(@) {
    my $fileh = shift;
    my ($parser, $filer, %atomic, %selfextract);
    my $previous = 0;
    my $warn_files = 0;
    my $warn_compression = 0;

    $parser = new MIME::Parser;
    $filer = MIME::Parser::FileInto->new("$TEMPDIR/parts");
    $filer->ignore_filename(1);
    $parser->filer($filer);
    $parser->extract_nested_messages("NEST");

    do_log(4,"Extracting mime components");

    $entity = $parser->parse($fileh);
    $fileh->seek(0,0);

    # Extract and decode each part to the extent possible

    for (my $i = 1; $i <= $MAXLEVELS; $i++) {
	my $current = 0;

	if ($i == $MAXLEVELS) {
	    do_log(0,"Maximum recursion depth ($MAXLEVELS) exceeded - requeue");
	    do_exit($REGERR,__LINE__);
	}

	opendir(PARTSDIR, "$TEMPDIR/parts")
	    or die "Can't open directory $TEMPDIR/parts: $!";
	my @parts = grep { !/^\.\.?$/ } readdir(PARTSDIR);
	closedir(PARTSDIR);

	# Determine number of parts
	$current = scalar(@parts);

	do_log(4,"Level: $i, parts: $current");
	do_log(4,"Archive nesting depth: $warn_compression");

	# Attempt to prevent DoS attacks with recursive archives
	# If the number of extracted parts is $threshold times greater
	# than the number of parts at the previous level, set $warn_files
	# If this occurs a second time ($warn_files == 2), refer the message
	# back to the mail system and log the deferral
	# We also quit if the maximum archive nesting depth is reached
	# Both measures are probaby not enough in the case of a small
	# number of highly compressed files

	# Triggers at $warn_files == 2
	if ($warn_files > 1 || ($warn_compression >= $MAX_ARCHIVE_NESTING)) {
	    log_msg_id(0);
	    do_log(0,"Possible DoS detected - requeue");
	    do_exit($REGERR,__LINE__);
	}

	# must delay by one level
	if (($previous > 0) && ($current / $previous >= $threshold)) {
	    $warn_files++;
	}
	$previous = $current;

	my $found = 0;
	foreach (@parts) {
	    my $save = $_;
	    unless (defined $atomic{$_} || defined $selfextract{$_}) {
		my $rv = decompose_part($_);

		if ($rv == 1) {
		    $found = 1;
		} elsif ($rv == 2) {
		    do_log(4,"$save is executable");
		    $selfextract{$save} = 1;
		    $found = 1;
		} else {
		    do_log(4,"$save is atomic");
		    $atomic{$save} = 1;
		}
	    }
	}
	last if ($found == 0);

	# must come after calling decompose_part
	if ($some_compression) {
	    $warn_compression++;
	    $some_compression = 0;
	}
    }
}

# Decompose the parts
sub decompose_part(@) {
    my $part = shift;

    # $part should be safe because we generated the filenames ourselves
    # but let's be extra paranoid (and make taint happy)
    if ($part =~ /^([\w\d\-.]+)$/) {
	$part = $1;
    } else {
	do_log(0,"Unsafe partname $part");
	do_exit($REGERR, __LINE__);
    }

    my ($filetype) = qx($file $TEMPDIR/parts/$part) =~ /:\s*(\S.*)$/;

    do_log(4,"File-type of $part: $filetype");

    # possible return values for eval:
    # 0 - unknown or unarchiver failure; consider atomic
    # 1 - some archiver format, successfully unpacked
    # 2 - self-extracting archive, successfully unpacked
    my($sts) = eval { foreach ($filetype) {
	local($_) = $_;  # prevent $filetype (alias $_) from being modified
	/^(ASCII|text|uuencoded|xxencoded|binhex)/io && return do_ascii($part);
	/^gzip compressed/io    && return do_gunzip($part);
	/^compress'd/io         && return do_uncompress($part);
	/^bzip2 compressed/io   && return do_bzip2($part);
	/^(GNU |POSIX )?tar archive/io && return do_tar($part);
	/^Zip archive/io        && return do_unzip($part,0);
	/^RAR archive/io        && return do_unrar($part,0);
	/^LHA.*archive/io       && return do_lha($part,0);
	/^ARC archive/io        && return do_arc($part);
	/^ARJ archive/io        && return do_unarj($part);
	/^Zoo archive/io        && return do_zoo($part);

	# file 3.32+ has an entry for TNEF
	/^(Transport Neutral Encapsulation Format|TNEF)/io && return do_tnef($part);

	# older versions of file report tnef files as data
	/^data$/o               && return do_tnef($part);

	/executable/io          && return do_executable($part);

	# Falling through - no match
	return 0;
    }; };

    if ($@ ne '') {
	do_log(0,"Decoding of $part failed (file-type: $filetype), ".
		 "leaving it unpacked. Report:\n\t" . $@);
    }

    return $sts;
}

# Generate unique filenames
{
    # Persistent and private
    my $filecount = 0;

    sub getfilename(@) {
	if ($filecount > $MAXFILES) {
	    do_log(0,"Maximum number of files ($MAXFILES) exceeded - requeue");
	    do_exit($REGERR,__LINE__);
	}
	return sprintf("part-%05d", ++$filecount);
    }
}

# copy (binary) command output to a file handle
# args: filehandle to print to, command, command args ...
# Code adapted from Camel book, Chapter 3, syswrite
sub fh_copy(@) {
    my $fileh = shift;
    my $blksize = (stat $fileh)[11] || 16384;
    my ($len, $buf, $offset, $written);
    open(DATA, "-|") || exec @_;

    while ($len = sysread DATA, $buf, $blksize) {
	if (!defined $len) {
	    next if $! =~ /^Interrupted/o;
	    do_log(0,"System read error: $!");
	    do_exit($REGERR, __LINE__);
	}
	$offset = 0;
	while ($len) { # Handle partial writes.
	    $written = syswrite $fileh, $buf, $len, $offset;
	    do_log(0,"System write error: $!") unless defined $written;
	    $len -= $written;
	    $offset += $written;
	}
    }
    close(DATA); # or die "fh_copy: close failed: $! $?"
}

# minimal local error handler for Archive-Zip read()
sub myziperr {
    return 5;
}

# minimal local error handler for Archive-Zip extractMember()
sub myzipextracterr {
    # flesh it out later
    return 5;
}

#
# Uncompression/unarchiving routines
# Possible return codes:
# 0 - cannot extract/unpack further (treat as atomic)
# 1 - decoded/extracted from $part  (continue recursive extraction)
# 2 - $part is self-extracting executable (atomic AND continue extraction)

# if ASCII text, try multiple decoding methods as provided by UUlib
# (includes uuencoding, xxencoding, Base64 and BinHex)
sub do_ascii(@) {
    my $part = shift;
    my ($retval, $count) = LoadFile("$TEMPDIR/parts/$part");
    if ($count > 0) {
	do_log(4,"Decoding part $part");

	SetOption (OPT_SAVEPATH, "$TEMPDIR/parts/");
	my $uuerror = 0;
	for (my $i = 0; my $uu = GetFileListItem($i); $i++) {
	    if ($uu->state & FILE_OK) {
		my $newpart = "$TEMPDIR/parts/" . getfilename();
		$uu->decode($newpart);
		$uuerror = 1 if (!$uu->state || !FILE_OK || -z $newpart);
	    }
	}
	return 0 if ($uuerror == 1);

	unlink("$TEMPDIR/parts/$part");
	return 1;
    }
    return 0;
}

# use Archive-Zip
sub do_unzip(@) {
    my $part = shift;
    my $exec = shift;
    my $ziperr;
    my $zip = Archive::Zip->new();

    # Need to set up a temporary minimal error handler
    # because we now test inside do_zip whether the $part
    # in question is a zip archive
    Archive::Zip::setErrorHandler(\&myziperr);
    $ziperr = $zip->read("$TEMPDIR/parts/" . "$part");
    Archive::Zip::setErrorHandler(\&Carp::croak);
    $Carp::CarpLevel++;

    return 0 if ($ziperr != AZ_OK);
    do_log(4,"Unzipping $part");

    $some_compression++;

    my $compmeth = '';
    foreach ($zip->members()) {
	$compmeth = $_->compressionMethod;
	if ($compmeth == COMPRESSION_DEFLATED ||
	    $compmeth == COMPRESSION_STORED) {
	    my $newpart = "$TEMPDIR/parts/" . getfilename();
	    $zip->extractMember($_,$newpart) unless ($_->isDirectory);
	} else {
	    # FIXME note: per member
	    do_log(0,"$part: unsupported compression method: $compmeth");
	}
    }

    unlink("$TEMPDIR/parts/$part") unless $exec;
    return 1;
}

# use external bzip program
# there *is* a perl module for bzip2, but it is not ready for prime time
sub do_bzip2(@) {
    my $part = shift;

    return 0 if (!$bunzip);
    do_log(4,"Expanding bzip2 archive $part");

    $some_compression++;

    my $newpart = "$TEMPDIR/parts/" . getfilename();

    system("$bunzip < $TEMPDIR/parts/$part > $newpart");
    if ($?) {
	unlink("$newpart");
	return 0;
    }

    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# untar any tar archives with Archive-Tar
# extract each file individually
sub do_tar(@) {
    my $part = shift;

    # Work around bug in Archive-Tar
    my $tar = eval { Archive::Tar->new("$TEMPDIR/parts/$part") };

    unless (defined($tar)) {
	do_log(4,"Faulty archive $part");
	return 0;
    }

    do_log(4,"Untarring $part");

    my @list = $tar->list_files();

    foreach (@list) {
	unless (/.*\/$/o) {		# Ignore directories
	    # this is bad (reads whole file into scalar)
	    # need some error handling, too
	    my $data = $tar->get_content($_);
	    my $newpart = "$TEMPDIR/parts/" . getfilename();
	    open(OUTPART, ">$newpart") || do_exit($REGERR, __LINE__);
	    print(OUTPART $data);
	    close(OUTPART);
	}
    }
    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use Zlib to inflate
sub do_gunzip(@) {
    my $part = shift;
    my $buffer;
    my $newpart = "$TEMPDIR/parts/" . getfilename();

    do_log(4,"Inflating gzip archive $part");

    $some_compression++;

    my $gz = gzopen("$TEMPDIR/parts/$part", "rb") || do_exit($REGERR, __LINE__);
    open(OUTPART, ">$newpart") || do_exit($REGERR, __LINE__);

    while ($gz->gzread($buffer) > 0) {
	print(OUTPART $buffer);
    }
    close(OUTPART);

    if ($gzerrno != Z_STREAM_END) {
	unlink("$newpart");
	return 0;
    }
    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use external "uncompress" program
sub do_uncompress(@) {
    my $part = shift;

    return 0 if (!$uncompress);
    do_log(4,"Uncompressing $part");

    $some_compression++;

    my $newpart = "$TEMPDIR/parts/" . getfilename();

    system("$uncompress < $TEMPDIR/parts/$part > $newpart");
    if ($?) {
	unlink("$newpart");
	return 0;
    }
    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use external program to expand RAR archives
sub do_unrar(@) {
    my $part = shift;
    my $exec = shift;

    return 0 if (!$unrar);

    # Check whether we can really unrar it
    system("$unrar", "t", "-inul", "$TEMPDIR/parts/$part");
    return 0 if ($?);

    do_log(4,"Expanding RAR archive $part");

    $some_compression++;

    my @list = ();

    # We have to jump through hoops because there is no simple way to
    # just list all the files

    open(INPART, "$unrar v $TEMPDIR/parts/$part|");

    my $hypcount = 0;
    while(chop($_=<INPART>)) {
	if (/^------.*/o) {
	    $hypcount++;
	    last if ($hypcount == 2);
	    next;
	}
	if ($hypcount == 1) {
	    s/^\s//;
	    next if (/^\s{3}.*/o || /\/$/o);
	    push(@list, $_);
	}
    }
    close(INPART);

    store_mgr(\@list, "$TEMPDIR/parts/$part", "$unrar", "p", "-inul");

    unlink("$TEMPDIR/parts/$part") unless $exec;
    return 1;
}

# use external program to expand LHA archives
sub do_lha(@) {
    my $part = shift;
    my $exec = shift;
    my $checkerr = undef;

    return 0 if (!$lha);

    # Check whether we can really lha it
    open(LHA, "$lha lq $TEMPDIR/parts/$part 2>&1 |") || do_exit($REGERR, __LINE__);
    while(<LHA>) {
	$checkerr = 1 if (/Checksum error/io);
    }
    close(LHA);
    return 0 if ($? || $checkerr);

    do_log(4,"Expanding LHA archive $part");

    $some_compression++;

    my @list = ();

    open(INPART, "$lha lq $TEMPDIR/parts/$part|");
    while(chop($_=<INPART>)) {
	next if /\/$/o;
	push(@list, (split(/\s+/))[-1]);
    }
    close(INPART);

    store_mgr(\@list, "$TEMPDIR/parts/$part", "$lha", 'pq');

    unlink("$TEMPDIR/parts/$part") unless $exec;
    return 1;
}

# use external program to expand ARC archives
sub do_arc(@) {
    my $part = shift;

    return 0 if (!$arc);
    do_log(4,"Unarcing $part");

    $some_compression++;

    # may need to add error handling
    my @list = qx($arc ln $TEMPDIR/parts/$part);
    chop (@list);

    store_mgr(\@list, "$TEMPDIR/parts/$part", "$arc", 'p');

    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use external program to expand ZOO archives
sub do_zoo(@) {
    my $part = shift;

    return 0 if (!$zoo);
    do_log(4,"Expanding ZOO archive $part");

    # Zoo needs extension of .zoo!
    symlink("$TEMPDIR/parts/$part", "$TEMPDIR/parts/$part.zoo");

    $some_compression++;

    my @list = qx($zoo lf1q $TEMPDIR/parts/$part);
    chop (@list);

    store_mgr(\@list, "$TEMPDIR/parts/$part", "$zoo", 'xpqqq:');

    unlink("$TEMPDIR/parts/$part.zoo");
    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use external program to expand ARJ archives
sub do_unarj(@) {
    my $part = shift;

    return 0 if (!$unarj);
    do_log(4,"Expanding ARJ archive $part");

    # unarj needs extension of .arj!
    symlink("$TEMPDIR/parts/$part", "$TEMPDIR/parts/$part.arj");

    $some_compression++;

    # unarj has very limited extraction options!  This may not be secure!
    mkdir("$TEMPDIR/arj", oct('700'));
    chdir("$TEMPDIR/arj");

    system("$unarj e $TEMPDIR/parts/$part > /dev/null");
    return 0 if ($?);

    my @list = qx(ls $TEMPDIR/arj);
    chop (@list);

    foreach (@list) {
	my $newpart = "$TEMPDIR/parts/" . getfilename();
	($_) = $_ =~ /^(\S+)$/o;   # ugly way of fooling the taint checker
	move ("$_", "$newpart");
    }
    chdir("$TEMPBASE");
    rmdir_recursively("$TEMPDIR/arj");
    unlink("$TEMPDIR/parts/$part.arj");
    unlink("$TEMPDIR/parts/$part");
    return 1;
}

# use Convert-TNEF
sub do_tnef(@) {
    my $part = shift;

    do_log(4,"Extracting TNEF attachment $part");

    my $tnef = Convert::TNEF->read_in("$TEMPDIR/parts/$part",{ignore_checksum=>"true"});

    if ($tnef) {
	for ($tnef->attachments) {
	    if (my $handle = $_->datahandle) {
		my $newpart = "$TEMPDIR/parts/" . getfilename();

		open(OUTPART, ">$newpart") || do_exit($REGERR, __LINE__);
		if (defined(my $file = $handle->path)) {
		    copy($file, \*OUTPART);
		} else {
		    print OUTPART $handle->as_string;
		}
		close(OUTPART);
	    }
	}

	$tnef->purge;

	unlink("$TEMPDIR/parts/$part");
    } else {
	# Not TNEF - treat as atomic
	return 0;
    }

    return 1;
}

# Check for self-extracting archives.  Note that we don't rely on
# file magic here since it's not reliable.  Instead we will try each
# archiver.
sub do_executable(@) {
    my $part = shift;

    do_log(4,"Check whether $part is a self-extracting archive");

    # ZIP?
    return 2 if eval{do_unzip($part,1)};
    do_log(0,"do_executable/do_unzip failed, ignoring:\n".$@) if $@;

    # RAR?
    return 2 if eval{do_unrar($part,1)};
    do_log(0,"do_executable/do_unrar failed, ignoring:\n".$@) if $@;

    # LHA?
    return 2 if eval{do_lha($part,1)};
    do_log(0,"do_executable/do_unlha failed, ignoring:\n".$@) if $@;

    return 0;
}

#
# Utility routines

# extract listed files from archive and store in new file
sub store_mgr(@) {
    my ($list, $archive, $cmd, $args, $extargs) = @_;
    my $newpart = '';

    for (@$list) {
	next if (/\/$/o);		# Ignore directories
	$newpart = "$TEMPDIR/parts/" . getfilename();

	open(FH, '>' . $newpart) || do_exit($REGERR, __LINE__);
	# $extargs is there solely for unrar ...
	if ($extargs) {
	    fh_copy(\*FH, "$cmd", "$args", "$extargs", "$archive", $_);
	} else {
	    fh_copy(\*FH, "$cmd", "$args", "$archive", $_);
	}
	close(FH);
    }
}

#
# Locking/logging/exiting

#
sub setup_logging() {
    if ($DO_SYSLOG eq "yes") {
	($FACILITY = $SYSLOG_LEVEL) =~ s/(\w+)\.(\w+)/LOG_\U$1/;
	($PRIORITY = $SYSLOG_LEVEL) =~ s/(\w+)\.(\w+)/LOG_\U$2/;
	openlog("amavis", LOG_PID, eval "$FACILITY");
    } else {
	$log = new IO::File;
	$log->open(">>$LOGDIR/$LOGFILE") || die "Failed to open log file: $!";
    }
}

# Log either to syslog or a file
sub do_log(@) {
    my $level = shift;
    my $errmsg = shift;

    return unless ($errmsg);

    # create syslog-alike
    my $logline = strftime("%b %e %H:%M:%S ", localtime) . (uname)[1] . " $myname\[$$\]: $errmsg\n";

    if ($DEBUG eq "no") {
	if ($level <= $log_level) {
	    if ($DO_SYSLOG eq "yes") {
		syslog(eval "$PRIORITY", "%s", $errmsg);
	    } else {
		lock($log);
		print($log $logline);
		unlock($log);
	    }
	}
    } else {
	# Log everything, regardless of level
	print STDERR $logline;
    }
}

# Log (Resent-)Message-ID header
sub log_msg_id(@) {
    my $level = shift;
    my $msgid = $entity->head->get("Resent-Message-ID");
    my $resent = "resent-";

    unless ($msgid) {
	$msgid = $entity->head->get("Message-ID");
	$resent = "";
    }

    chomp ($msgid);
    do_log($level,"$resent" . "message-id=$msgid");
}

#
# Produce syntactically correct local part of an e-mail address
# using quoted-string form if needed, as per rfc2821.
sub rfc2821_mailbox_addr {
    my($mailbox) = @_;
    # atext: any character except controls, SP, and specials (rfc2821/rfc2822)
    my($atext) = "a-zA-Z0-9!#\$%&'*/=?^_`{|}~+-";
    # my($specials) = '()<>\[\]\\\\@:;,."';
    my($localpart,$domain);
    if ($mailbox =~ /^(.*)(\@[^@]*)$/o) {
	($localpart,$domain) = ($1,$2)  
    } else {
	($localpart,$domain) = ($mailbox,'');
    }
    if ($localpart !~ /^[$atext]+(\.[$atext]+)*$/o) {  # not dot-atom
	$localpart =~ s/(["\\])/\\$1/g;       # quoted-pair
	$localpart = '"' . $localpart . '"';  # make a qcontent out of it
    }
    $localpart . $domain;
}

#
# Removes a directory, along with its contents
sub rmdir_recursively(@) {
    my $dir = shift;
    my $f;
    local *DIR;
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) { 
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    rmdir_recursively("$dir/$f")  unless $f =~ /^\.\.?$/;
	} else {
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    rmdir($dir) or die "Can't remove directory $dir: $!";
    1;
}

#
# Removes a directory, along with its contents
# Does not do it recursively - refuses to delete any subdirectories
sub rmdir_flat {
    my $dir = shift;
    my $f;
    opendir(DIR, $dir) or die "Can't open directory $dir: $!";
    while (defined($f = readdir(DIR))) { 
	next if $f !~ /^(.+)$/;
	$f = $1;  # untaint
	if (-d "$dir/$f") {
	    die "Refused to unlink a subdirectory $dir/$f" unless $f =~ /^\.\.?$/;
	} else {
	    unlink("$dir/$f") or die "Can't remove file $dir/$f: $!";
	}
    }
    closedir(DIR) or die "Can't close directory $dir: $!";
    rmdir($dir) or die "Can't remove directory $dir: $!";
    1;
}

#
sub lock(@) {
    my $file = shift;
    flock($file, LOCK_EX) || do_exit($REGERR, __LINE__);
    seek($file, 0, 2) || do_exit($REGERR, __LINE__);
}

#
sub unlock(@) {
    my $file = shift;
    flock($file, LOCK_UN) || do_exit($REGERR, __LINE__);
}

#
sub retcode($) {
    my $code = shift;

    return WEXITSTATUS($code) if WIFEXITED($code);
    return 128+WTERMSIG($code) if WIFSIGNALED($code);
    return 255;
}

#
sub do_exit(@) {
    my $code = shift;
    my $line = shift;

    do_log(1,"do_exit:$line - ending execution with $code");

    $fh->close() if ($fh);

    if ($TEMPDIR && -d $TEMPDIR) {
	# since we know the directory structure, instead of doing
	# a recursive deletion (rmdir_recursively() or 'rm -rf'),
	# we choose to be more cautious and make two calls to rmdir_flat
	# to avoid a big surprise over an empty disk (in some fatal
	# case of misconfiguration or a bug)
	rmdir_flat("$TEMPDIR/parts") if -d "$TEMPDIR/parts";
	rmdir_flat($TEMPDIR);
    }

    if (\&Client) {
	send Client, "$code", 0;
	shutdown Client, 2; # shutdown socket completely
	Client->close();
	do_log(3,"socket shut down");
    }

    # if \&Server ?
    if ($$ == $parentpid) {
	unlink("$TEMPBASE/amavisd.pid");
	do_log(3,"removed pid file");
	unlink("$socketname");
	do_log(3,"removed socket");
    }

    ($DO_SYSLOG eq "yes") ? closelog() : $log->close();

    exit($REGERR) unless ($code == 0);
    exit(0);
}

#
# Main program starts here
#

# Set path explictly.  Don't trust environment
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

# detach thyself from the controlling terminal
daemonize() if ($DEBUG eq "no");

# save pid into file
# FIXME: do it in perl; exit if already exists
$parentpid = $$;
system("echo $parentpid >$TEMPBASE/amavisd.pid");

# Read config file
read_config();

# Be paranoid
umask(0077);

# Avoid taint bug in some versions of Perl (likely in 5.004, 5.005).
# The 5.6.1 is fine. To test, run this one-liner:
#   perl -Te '"$0 $$"; $r=$$; print eval{kill(0,$$);1}?"OK\n":"BUG\n"'
basename($0) =~ /^(.*)$/; $myname = $1;

setup_logging();

do_log(0,"starting.  $myname snapshot-20020300 Mon Jun 24 03:59:13 EDT 2002");

setup_socket() || die "socket setup failure: $!";

main_loop();

# Safeguard - shouldn't get here
do_exit(0, __LINE__);

