#! /usr/local/bin/perl
#
# unspool does all of the actual processing for the ACS.
#
#die "unspool.perl compiled successfully\n";
#
# If the lock file exists, we are already running. Die immediately.
if ( -e "/usr/personals/LCK..SPOOL" ) {
	exit 0;
}
#
# set up the environment for suid operations - no longer needed but...
#
$ENV{"PATH"} = "/bin:/usr/bin:/usr/local/bin:/usr/ucb:/usr/personals";
$ENV{"IFS"} = '' if $ENV{"IFS"} ne '';
$path = $ENV{"PATH"};

# set the permissions on all files we create to user only.
umask(0077);

# flush on selected channel
$| = 1;
#
# create the lock file
#
open(LCK,">/usr/personals/LCK..SPOOL");
close(LCK);

# open the address:alias database
if (! dbmopen(r2a,"/usr/personals/real2alias",0600)) {
	print STDERR ":::can't dbmopen real2alias: $!\n";
	exit(1);
}

# open the alias-index file and get the current alias.
if (open(INDEX,'</usr/personals/alias-index')) {
	$alias_index = <INDEX>;
	close(INDEX);
}
else {
	$alias_index = 'a';
}
#
# Process all the replies in the spool directory
#
$seq = $$;

while (</usr/personals/spool/REP*> ) {
	$repfile = $_;

	# check to make sure no fast connections are running. unspool
	# kicks off quite a few other processes, which can seriously
	# degrade throughput on a fast modem connected to a slow system.
	&fstchk;

	# open the spooled reply file
	open(MSG,"<$repfile");

	# read the first line of the message, which contains the recipient's
	# alias.
	$target_alias = <MSG>;

	# hack off the terminal newline
	chop $target_alias;

	# Load the message on MSG into an array
	@message = <MSG> ;
	close(MSG);

	# open the file in the repair directory to store the header and
	# status info in case something goes wrong.
	$replog = 0;
	$repname = "/usr/personals/repair/REP$seq-$target_alias";
	if ( open(REPLOG,">$repname")) {
		$replog = 1;
		$seq++;
	}

	# get the sender's address from the From: line
	$address = &getaddr;

	# write the header and the extracted address to the repair file
	if ($replog ) {
		print REPLOG @header ;
		print REPLOG "\n";
		print REPLOG @body ;
		print REPLOG "::: address = $address\n" ;
	}
	# if we didn't get a usable address, go on to the next message
	goto repfail if ( "$address" eq '' );

	# extract the username from the address
	$user = &getuser($address);

	# log it in the repair file
	print REPLOG "::: user = $user\n" if ( $replog );

	# if there is none, or if it's not acceptable, go to next message
	goto repfail if ( "$user" eq '' );

	# extract the subject from the Subject: line
	$subject = &getsubj;

	# if the subject is empty, replace it with something clever
	$subject = "(None)" if ( "$subject" eq '' );
	# and log it
	print REPLOG "::: subject = $subject\n" if ( $replog );

	# look up the sender's alias in the database. If s/he doesn't
	# have one, give hir one, and log it
	$sender_alias = &getsender($address);
	print REPLOG "::: sender_alias = $sender_alias\n" if ( $replog );

	# Lookup target_alias in real2alias db
	# WARNING: you cannot save time by jumping out of this loop
	# after the target_alias has been found. Perl's implementation
	# of the dbm stuff requires that "each" visit every entry in 
	# the data base before it resets. This was the origin of the
	# infamous reply to the wrong alias bug.
	$recip_address = '';
	$found = 0;
	while (($key,$value) = each %r2a) {
		if ( $found == 0 ) {
			if ( "$value" eq "$target_alias" ) {
				$recip_address = $key;
				$found = 1;
			}
		}
	}

	# non-existent target alias - send a terse message to the sender
	# explaining this.
	if ( "$recip_address" eq '' ) {
		# send a bounce message to sender
		# Using elm here is a horrendous kluge. We should probably
		# use smail instead.
		if ( ! open(ELM,"|/usr/local/bin/elm -s \"ACS Reply to $target_alias Failed\" $address") ) {
			print "Can\'t pipe into elm\n";
		}
		else {
			print ELM "Alias $target_alias not found in database.\nSorry.\nACS\n";
			close(ELM);
		}
		# log the failure
		if ( $replog ) {
			print REPLOG "::: No recip_address for $target_alias\n";
		}
		goto repfail;
	}

	# open a pipe into acsmail to send out the anonymous reply
	if (! open(REPLY,"|/usr/personals/acsmail -F $sender_alias@alembic.ACS.COM $recip_address")) {
		print "Can\'t pipe into acsmail\n";
		goto repfail;
	}

	# write the reply into acsmail's stdin. acsmail will add the other
	# header fields.
	print REPLY "Subject: $subject\n";
	print REPLY "To: $recip_address\n\n";
	print REPLY @body;
	close(REPLY);

	# since the reply apparently succeeded, unlink the repair file.
	unlink($repname);
	next;
	# something broke. Note it in the repair file and do the next one.
repfail:
	print REPLOG "::: Reply failed\n" if ( $replog );
	next;
} continue {
	# if a repair file is open, close it
	close(REPLOG) if ( $replog );
	# and delete the spooled reply file.
	unlink($repfile);
}
#
# Now do the messages to be posted
#
while (</usr/personals/spool/POST*> ) {
	$postfile = $_;

	# check for other things that shouldn't be disturbed
	&fstchk;

	# open the spooled POST file
	open(MSG,"<$postfile");

	# Load the message on MSG into an array
	@message = <MSG> ;
	close(MSG);

	# get the sender's address from the From: line
	$address = &getaddr;
	# if it's empty, forget it and do the next message
	goto postfail if ( "$address" eq '' );

	# get the username from the address
	$user = &getuser($address);

	# if the username is empty or forbidden, do the next message
	goto postfail if ( "$user" eq '' );

	# get the subject from the Subject: line
	$subject = &getsubj;

	# trash postings with "test" in the Subject: line
	next if ( $subject =~ /test/io );

	# if there is no subject, insert one
	$subject = "(None)" if ( $subject eq '' );

	# get the sender's alias. assign one if necessary.
	$alias = &getsender($address);

	# open a pipe into inews for the article
	if ( ! open(INEWS,"| /bin/inews -h")) {
		print "Can\'t pipe into inews\n";
		goto postfail;
	}

	# write the article into inews' stdin
	print INEWS "Path: $alias\n";
	print INEWS "From: ",$alias,"@alembic.ACS.COM\n";
	print INEWS "Newsgroups: alt.personals\n";
	print INEWS "Subject: $subject\n";
	print INEWS "Distribution: na\n";
	print INEWS "Reply-To: ",$alias,"@alembic.ACS.COM\n";
	print INEWS "Followup-To: sender\n";
	print INEWS "Organization: Anonymous Contact Service\n";
	print INEWS "\n";
	print INEWS @body;

	# add the ACS usage "signature"
	print INEWS "\n-- \n";
	print INEWS <<EOS;
To use this service, send email to:                   | There is a 25 line
Anonymous posting:      acs-post@alembic.ACS.COM      | limit on all posts
Anonymous reply:        <user's alias>@alembic.ACS.COM| and e-mail messages.
Test path/get an alias: acs-ping@alembic.ACS.COM      | Alternate path:
ACS administrator:      acs-admin@alembic.ACS.COM     | uunet!alembic!...
EOS
	close(INEWS);
postfail:
	next;
} continue {
	# delete the spooled POST file
	unlink($postfile);
}

#
# Process the acs-ping messages
#
while (</usr/personals/spool/PING*> ) {
	$pingfile = $_;

	# don't disturb high-priority processing
	&fstchk;

	# open the spooled PING file
	open(MSG,"<$pingfile");

	# Load the message on MSG into an array
	@message = <MSG> ;
	close(MSG);

	# get the sender's address from the From: line
	$address = &getaddr;

	# forget it and do the next one if no address
	goto pingfail if ( "$address" eq '' );

	# extract the username from the address
	$user = &getuser($address);

	# skip to next message if the username is empty or forbidden
	goto pingfail if ( "$user" eq '' );

	# extract the subject from the Subject: line
	$subject = &getsubj;

	# if the subject is empty, replace it with something clever
	$subject = "(None)" if ( "$subject" eq '' );

	# get the sender's alias, assigning one if necessary
	$sender_alias = &getsender($address);	
	$| = 1;

	# open a pipe into smail to send the echo back
	if ( ! open(REPLY,"|smail -F acs-ping@alembic.ACS.COM $address") ) {
		print "Can\'t pipe into smail\n";
	}
	else {
		# write the ping message into smail's stdin
		print REPLY "Subject: Message RCVD\n";
		print REPLY "To: $address\n\n";
		print REPLY "Your ping request has been received by acs-ping@alembic.ACS.COM\n";
		print REPLY "Your alias will be $sender_alias@alembic.ACS.COM\n";

		# Show them what a posted article would look like
		print REPLY "If you had posted this message, this is what it would\n";
		print REPLY "have looked like:\n\n";
		print REPLY "Path: $sender_alias\n";
		print REPLY "From: ",$sender_alias,"@alembic.ACS.COM\n";
		print REPLY "Newsgroups: alt.personals\n";
		print REPLY "Subject: $subject\n";
		print REPLY "Distribution: na\n";
		print REPLY "Reply-To: ",$sender_alias,"@alembic.ACS.COM\n";
		print REPLY "Followup-To: sender\n";
		print REPLY "Organization: Anonymous Contact Service\n";
		print REPLY "\n";
		print REPLY @body;

		# add the ACS usage "signature"
		print REPLY "\n-- \n";
		print REPLY <<EOS;
To use this service, send email to:                   | There is a 25 line
Anonymous posting:      acs-post@alembic.ACS.COM      | limit on all posts
Anonymous reply:        <user's alias>@alembic.ACS.COM| and e-mail messages.
Test path/get an alias: acs-ping@alembic.ACS.COM      | Alternate path:
ACS administrator:      acs-admin@alembic.ACS.COM     | uunet!alembic!...
EOS
		close(REPLY);
	}
pingfail:
	next;
} continue {
	# delete the spooled PING file
	unlink($pingfile);
}

# cleanup: close the real2alias database, delete the lock file, delete
# and rewrite the alias-index file, and exit.
dbmclose(r2a);
unlink("/usr/personals/LCK..SPOOL");
unlink('/usr/personals/alias-index');
open(INDEX,'>/usr/personals/alias-index') ||
	die "Can't open alias-index: $!\n";
print INDEX $alias_index;
close(INDEX);
exit(0);

# subroutine fstchk checks to see if there are any conditions on the
# system which unspool would interfere with. Mostly, this consists of
# high-speed data transfers and high-priority processes running. If
# fstchk finds such a condition, it sleeps for 30 seconds, then checks
# again to see if the condition still exists. It continues this loop
# forever.
sub fstchk {
	#
	# If we're using a high-speed line, sleep until the call ends
	# (otherwise the transfer rate drops through the floor)
	#
	while ( -e "/usr/spool/uucp/LCK/LCK..uunet" ) {
		sleep 30;
	}
} # end subroutine fstchk

#
# Subroutine getaddr splits the message in global array @message
# into global arrays @header and @body, truncates @body to 25
# lines, tries to find a signature in @body and deletes it if it
# finds one, the searches @header for a From: line and extracts
# the actual address from it if it can.
# Returns $address.
#
sub getaddr {
	#
	# split the message into body and header
hb:	for ( $line = 0 ; $line <= $#message; $line++ ) {
		if ( $message[$line] eq "\n" ) {
			# store the header
			@header = @message[ 0 .. $line-1 ];
			# store the first 25 lines of the body
			@body = @message [ $line+1 .. $line+25 ];
			last hb;
		}
	}
	#
	# Trash the signature if present 
sig:	for ($line = 0; $line <= $#body; $line++ ) {
		if ( $body[$line] eq "-- \n" || $body[$line] =~ /---/ 
			|| $body[$line] =~ /===/ ) {
			$#body = $line - 1;
			last sig;
		}
	}
	#
	# Get From: line from header
	$from = '';
from:	for ($line = 0; $line <= $#header; $line++ ) {
		if ( $header[$line] =~ /^From: (.*)/ ) {
			$from = $1;
			last from;
		}
	}
	#
	# No From: line
	#
	#
	if ( $line > $#header) {
		return '';
	}
	# Try to extract actual address from $from line
	# look for <bangpath> form first, since that's what uunet
	# put's into the From: line
	if ( $from =~ /<(.*)>/ ) {
		$Address = $1;
	}
	else {
		# try From: address ( comment )
		if ( $from =~ /(.*) \(.*\)/ ) {
			$Address = $1;
		}
		else {
			# just use whatever's there
			$Address = $from;
		}
	}
	# get rid of any whitespace following the address
	($Address,$junk) = split(/[ \t]/,$Address);
	# return the address
	$Address;
} # end subroutine getaddr

#
# subroutine getuser($address) -
# extract the username from an address and check to make sure it isn't
# one of the "forbidden" usernames. Returns either null or the username.
#

sub getuser {
	local($addr) = pop(@_);
	#
	# if sender is uucp, news, mailer-daemon, etc., junk the message
	# get the last ! component
	@phase1 = split(/!/,$addr);
	$usr = $phase1[$#phase1];
	# get whatever sits in front of an "@".
	@phase2 = split(/@/,$usr);
	$usr = $phase2[0];
	# get whatever precedes a "%"
	@phase3 = split(/%/,$usr);
	$usr = $phase3[0];

	# check for anything that might conceivably be the username
	# of something that bounces mail, rather than a person. We
	# also exclude root, simply because there are too many root
	# users doing system administration at some sites.
	study $usr;
	if ( $usr =~ /MAILER/i) { return(''); }
	if ( $usr =~ /DAEMON/i)	{ return(''); }
	if ( $usr =~ /uucp/i)	{ return(''); }
	if ( $usr =~ /POSTMASTER/i)	{ return(''); }
	if ( $usr =~ /DELIVER/i) { return(''); }
	if ( "$usr" eq "news" )	{ return(''); }
	if ( $usr =~ /smtp/i)	{ return(''); }
#	if ( $usr =~ /guest/i)	{ return(''); }
	if ( "$usr" eq "root" )	{ return(''); }
	# eliminate usernames containing acs-
	if ( $usr =~ /acs-/)	{ return(''); }
	$usr;
} # end subroutine getuser

# subroutine getsubj - search through the global array @header until
# we find a Subject: line. Extract and return the subject.

sub getsubj {
	#
	# Get Subject: line from header
	$subj = '';
	for ($line = 0; $line <= $#header; $line++ ) {
		if ( $header[$line] =~ /^Subject: (.*)$/ ) {
			$subj = $1;
			last ;
		}
	}
	$subj;
} # end subroutine getsubj

#
# subroutine getsender($address) - given the address of the sender of
# a message, find hir alias in the real2alias database and return the
# alias. If the sender is not in the database, add them. Returns the
# sender's alias.

sub getsender {
	local($addr) = pop(@_);
	#
	# Lookup sender in real2alias db
	$Salias = $r2a{$addr};
	if ( ! defined($Salias)) {
		# create alias for sender
		$alias_index++;
		open(INDEX,'>/usr/personals/alias-index') ||
			die "Can't open alias-index: $!\n";
		print INDEX $alias_index;
		close(INDEX);
		$Salias = "acs-".$alias_index;
		# add the newbie to the database
		$r2a{"$addr"} = $Salias;
		# Add alias to /usr/lib/aliases
		open(SYSALIAS,">>/usr/lib/aliases") || 
			die "Can't write to aliases file: $!\n";
		print SYSALIAS "$Salias: \"|/usr/personals/anon-reply $Salias\"\n";
		close(SYSALIAS);
		#
		# need to execute newaliases here if sendmail doesn't
		# support OD flag to automatically update dbm database
		# of course, this is irrelevant if the MTA doesn't
		# use dbm database.
		# system("/usr/ucb/newaliases");
	}
	# return the alias
	$Salias;
} # end subroutine getsender

