#!/usr/local/bin/perl

$version = "Kansas City POP Daemon Version 0.05";
#
#=pod
#
#David's Pop Daemon
#2 november 1999
#
#implementation goals:  
#
#        be in standard perl 5
#	implement rfc1725
#	contain usernames, passwords and directories in the source code
#	run standalone (from inetd can be done by crippling this easily)
#
#	read mail out of a directory where is has been placed one 
#	message per file (such as a MailDir)
#
#	Delete mail directly from the directory
#
#
#Discussion:
#
#	Qmail isn't the only MTA that can write to a directory;
#	
#	There should be another perl program called "PreSpool"
#	which can be used in a sendmail aliases file like so:
#
#	djb: "|/usr/local/kcpm/prespool.pl /usr/users/home/bernstein/MailDir/new"
#
#	and that will cause sendmail to deliver all incoming mails into that
#	directory, with unique file names even.
#
#
#=cut
#
=head1 NAME

popdaemon -- rfc1725 implementation.  Expects to find all
messages in a directory associted with each user, one message
per file.  This can be extended arbitrarily.

=head1 SCRIPT CATEGORIES


UNIX/System_administration
Mail


=head1 SYNOPSIS

After editing the user specific portions,

C<nohup popdaemon & > can be added to rc.local.



=head1 README

This program is a full implementation of rfc 1725,
with an adjustment made to unsplit header lines so that
Netscape Communicator will not drop the connection when
it gets a message-id that is too long.

All configuration is done within the code, which means
that it is open to being tied to the database(s) of your
choice.



=head1 COPYRIGHT

Copyright (c) 1999 David Nicol <davidnicol@acm.org>. License is
granted to modify and install as needed, with the expectation that
this copyright notice will remain.


=cut







#####USER CONFIGURATION PORTION:
# changing this to read from an external file
# would not be difficult, but you'd still have to
# edit something -- the external file -- what's the win?
# Add a Passwd and a Directory entry for each user.

$Passwd{'djb'} 		= 'Qtips';
$Directory{'djb'}	= '/usr/users/home/bernstein/MailDir/new';

#########################################################




use Socket;
use Fcntl ':flock';
use IO::Handle;
use IO::Socket;
use Carp;








# Open the server socket


        $PortNumber  = 110;

        $door = IO::Socket::INET->new(
                                Proto     => 'tcp',
                                LocalPort => $PortNumber,
                                Listen    => SOMAXCONN,
                                Reuse     => 1
        );

die "Cannot set up socket: $!" unless $door;

$timeout = 60;
$SIG{ALRM} = sub { die "alarm or timeout\n" };

sub SockData($){
        my $client = shift;
        my $hersockaddr    = getpeername($client);
        my ($port, $iaddr) = unpack_sockaddr_in($hersockaddr);
        my $herhostname    = gethostbyaddr($iaddr, AF_INET);
        my $herstraddr     = inet_ntoa($iaddr);
        return "$herhostname $herstraddr";
};




# from perldoc perlipc:

 sub REAPER {
 	# print "Handling sigCHLD\n";
	$waitedpid = wait;
	print "Reaped $waitedpid and got status [ $? ] \n";
    
 	$SIG{CHLD} = \&REAPER;  # still loathe sysV
}
$SIG{CHLD} = \&REAPER;





for(;;){
                until(  $client = $door->accept()){
                        print "Accepted false socket $!";
			sleep 1;
                };
		$F = fork;
		die "Fork weirdness: $!" if $F < 0;

                if($F){
			close $client;
			next;
		};
                
                # here we are in a new process

                close ($door);

                $client->autoflush();
		print "$$ New Connection\n";
		&AUTHORIZATION;
		print "$$ authorized\n";
		&TRANSACTION;
		print "$$ proceeding to update\n";
		&UPDATE;
		print "$$ done\n";
		exit;

};


sub OK($){
	my $A = shift;
        $A =~ s/\s+/ /g;
        $A =~ s/\s+\Z//g;
        print $client "+OK $A\r\n";
        print "S: +OK $A\r\n";
	alarm $timeout;
};

sub ERR($){
	my $A = shift;
        $A =~ s/\s+/ /g;
        $A =~ s/\s+\Z//g;
        print $client "-ERR $A\r\n";
        print "S: -ERR $A\r\n";
	alarm $timeout;
};

sub AUTHORIZATION{
	$Name = '';
	OK "TipJar POP3 Daemon $version".SockData($client).scalar(localtime);
	NEEDUSER:
        $Data = <$client>;
	print "C:$Data\n";
	if ($Data =~ m/^quit/i){
		OK "whatever";
		exit;
	};
        ($Name) =  $Data =~ m/^user (\w+)/i;
	unless($Name){
		ERR "The itsy bitsy spider walked up the water spout";
		die if ++$strikes > 5;
		goto NEEDUSER;
	};
	OK "User name ($Name) ok. Password, please.";
        $Data = <$client>;
	print "C:$Data\n";
	if ($Data =~ m/^quit/i){
		OK "whatever";
		exit;
	};
        my($Pass) =  $Data =~ m/^pass (.*)/i;
	$Pass =~ s/\s+\Z//g;
	unless($Passwd{$Name} eq $Pass){
		ERR "Down came the rain and washed the spider out";
		die if ++$strikes > 5;
		goto NEEDUSER;
	};
	
	$MailDir = $Directory{$Name};
	unless (-d $MailDir and opendir DIR, $MailDir ){
		ERR "$MailDir does not appear to be a readable directory";
		goto NEEDUSER;
	};

	chdir $MailDir;

	@Messages = grep {!/PopDaemonLock/} (grep {-f $_} (readdir DIR));

	# Lock the maildrop
	open LOCK, ">>.PopDaemonLock";
	unless(flock LOCK,LOCK_EX|LOCK_NB){
		ERR "Maildrop contains ".scalar(@Messages)." but it is already locked";
		goto NEEDUSER;
	};

	OK "$Name has ".scalar(@Messages)." messages";
};

sub TRANSACTION{
	%deletia = ();
	START:
        $_ = $Data = <$client>;
	unless(defined($Data)){
		print "Client closed connection\n";
		exit;
	};
	print "C:$Data\n";
	if (m/^quit/i){
		OK "Thanks for flying sneaker express";
		return;
	};
	if (m/^STAT/i){ &STAT; goto START};
	if (m/^LIST/i){ &LIST; goto START};
	if (m/^RETR/i){ &RETR; goto START};
	if (m/^DELE/i){ &DELE; goto START};
	if (m/^NOOP/i){ &NOOP; goto START};
	if (m/^RSET/i){ &RSET; goto START};
	# optional commands (rfc 1725)
	if (m/^TOP/i){ &TOP; goto START};
	if (m/^UIDL/i){ &UIDL; goto START};


	ERR "I'm from Missouri";

	goto START;
}

sub STAT{
	alarm 0;	#who knows how long reading the dir will take?
	$mm = 0;
	$nn = scalar(@Messages);
	foreach $M (@Messages){
		$mm += -s "$M";
	};
	OK "$nn $mm";
};

sub List($){

	my $M = $Messages[$_[0]-1];
	return if $deletia{$M};
	print $client $_[0],' ',(-s $M)."\r\n";
	print "S: ", $_[0],' ',(-s $M)."\r\n";
	alarm $timeout;

};

sub LIST{
	if (($d) = $Data =~/(\d+)/){
		unless(defined($M = $Messages[$d-1])){
			ERR "no message number $d";
			return;
		};
		if ($deletia{$M}){
			ERR "message $d deleted";
			return;
		};
		OK "Listing $d";
		List $d;
		return;
	};
	OK "Listing";
	$nn = scalar(@Messages);
	foreach $d (1..$nn){
		List $d;
	};
	print $client ".\r\n";
};

sub RETR{
	unless (($d) = $Data =~/(\d+)/){
		ERR "message number required";
		return;
	};
	$M = $Messages[$d-1];
	unless(defined($M)){
		ERR "no message $d";
		return;
	};
	if ($deletia{$M}){
		ERR "message $d deleted already";
		return;
	};
	OK "Here comes ".(-s $M)." bytes";
	alarm 0;
	open MESSAGE,"<$M";
	while (defined($line = <MESSAGE>)){
		print $client "." if $line =~ m/^\.\s*\Z/;
		print $client $line;
	};
	print $client ".\r\n";
	alarm $timeout;
};

sub DELE{
	unless (($d) = $Data =~/(\d+)/){
		ERR "message number required";
		return;
	};
	$M = $Messages[$d-1];
	unless(defined($M)){
		ERR "no message $d";
		return;
	};
	if ($deletia{$M}){
		ERR "message $d deleted already";
		return;
	};
	$deletia{$M} = 1;
	OK "message $d ($M) marked";
};

sub NOOP{
	OK "whatever";
};

sub RSET{
	%deletia=();
	OK "biz buzz";
};

sub TOP{
	unless (($d,$n) = $Data =~/(\d+) (\d+)/){
		ERR "RFC1725 says TWO numbers here";
		return;
	};
	$M = $Messages[$d-1];
	unless(defined($M)){
		ERR "no message $d";
		return;
	};
	if ($deletia{$M}){
		ERR "message $d deleted already";
		return;
	};
	OK "Here come headers for message $d ($M)";
	alarm 0;
	open MESSAGE,"<$M";
	$counter = -1;
	while (defined($line = <MESSAGE>) and --$counter){
                # escape single dots
		print $client "." if $line =~ m/^\.\s*\Z/;
                # mush first line of oversplit header (for mozilla)
                if (($HB) = $line =~ m/^(\S+\:)\s+\Z/){
                        $line = <MESSAGE>;
                        $line =~ s/^\s+//;
                        $line = "$HB $line";
                };
		print $client $line;
		$counter = $n if ($counter < 0 and not( $line =~ /\w/));
	};
	print $client ".\r\n";
	alarm $timeout;
};

sub UIDL{
	if (($d) = $Data =~/(\d+)/){
		unless(defined($M = $Messages[$d-1])){
			ERR "no message number $d";
			return;
		};
		if ($deletia{$M}){
			ERR "message $d deleted";
			return;
		};
		OK "$d $M";
		return;
	};
	OK "Listing file names";
	alarm 0;
	$nn = scalar(@Messages);
	foreach $d (1..$nn){
		print $client "$d $Messages[$d-1]\r\n";
	};
	alarm $timeout;
	print $client ".\r\n";
};


sub UPDATE{

	@DeleteMe = keys %deletia;
	while($Target = shift @DeleteMe){
		print "Trying to unlink $Target\n";
		
		-f $Target or (print( "<$Target> is not a file"),next);
		unlink $Target and print "unlinked $Target\n";
	};
};


__END__