#!/usr/bin/perl
#-----------------------------------------------------------------------------
#
#  POPular -- A POP3 server and proxy for large mail systems
#
#  $Id: psmtpd,v 1.2 2001/02/09 15:59:07 sqrt Exp $
#
#  http://www.remote.org/jochen/mail/popular/
#
#-----------------------------------------------------------------------------
#
#  Copyright (C) 1999-2001  Jochen Topf <jochen@remote.org>
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  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.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
#
#-----------------------------------------------------------------------------

#-----------------------------------------------------------------------------
# config
#-----------------------------------------------------------------------------
my $SERVER_PORT		= 2525;		# port this server listens on
my $LISTEN_QUEUE	= 32;		# backlog queue for listen
my $POP_SPOOL		= "/pop";	# where all the mailboxes are
my $MKDIR_MODE		= 0755;		# mode for creating mailbox dirs
my $FILE_MODE		= 0644;		# mode for creating mail files
my $LOGFILE		= "/var/log/popular/psmtpd";
my $PIDFILE		= "/var/run/popular/psmtpd.pid";
my $PRGNAME		= "psmtpd";	# program name for logging
my $QUOTA		= 50;		# quota in MB for all mailboxes
my $QUOTAFILE           = "/etc/popular/mb";
					# directory for files for individual
					# quota lookup, undef for no lookup
my $NUMQUOTA		= 1000;		# max number of mails in a mailbox
my $MAX_PROC		= 5;		# maximum number of deliver processes
my $LOAD_CHECK_INTERVAL = 60;		# seconds between load checks
my $MAX_LOAD		= 10;		# don't accept connection if max load
					# is exceeded
my $SLEEPTIME_IF_LOAD_EXCEEDED = 30;	# number of seconds to sleep if load
					# exceeds max load
my $BANNER		= "POPular psmtpd SMTP Server Ready.";
					# SMTP greeting
my @ALLOWED_PEERS	= ("127.0.0.1", "192.168.130.1", "192.168.130.2");

#-----------------------------------------------------------------------------
# No user servicable parts beyond this line
#-----------------------------------------------------------------------------

use strict;
use Fcntl;
use Errno ":POSIX";
use POSIX qw(:sys_wait_h setsid);
use Socket;
use IO::Socket;
use IO::Select;
use DB_File;

my $HOSTNAME = `hostname`;
chomp $HOSTNAME;
(my $SHORTHOSTNAME=$HOSTNAME) =~ s/\.(.*)//;

if (!open(LOG, ">>$LOGFILE")) {
  print STDERR "Can't open logfile $LOGFILE: $! Running without logfile\n";
}
select(LOG);
$|=1;

xlogwrite("INFO", "Started");

my $sock = new IO::Socket::INET (LocalPort => $SERVER_PORT, Proto => 'tcp',
					Listen => $LISTEN_QUEUE, Reuse => 1);
if (! $sock) {
  die("Can't create socket: $!\n");
}


my $pid = fork;
if ($pid < 0) {		# error
  die("Can't fork\n");
} elsif ($pid == 0) {	# child
  close(STDIN);
  close(STDOUT);
  close(STDERR);
} else {		# parent
  exit 0;
}

POSIX::setsid();

if (! open(PIDFILE, ">$PIDFILE")) {
  xlogwrite("FATAL", "pid_file errmsg=$!");
  exit(1);
}
$\ = "\n";
print PIDFILE "$$";
close PIDFILE;
$\ = "\r\n";

#$SIG{CHLD} = sub { 1; };

my $reopen_log = 0;
$SIG{HUP} = sub { $reopen_log=1; };

my %ALLOWED_PEERS;
map { $ALLOWED_PEERS{$_} = 1; } @ALLOWED_PEERS;

my $sel = new IO::Select ($sock);
my $TIMEOUT = 1;
my $children_count = 0;
my $last_load_check = 0;
my $peer = "";
my @ready;
while (1) {

  if ($last_load_check + $LOAD_CHECK_INTERVAL < time()) {
    check_load();
    $last_load_check = time();
  }

  # if the maximum number of children are spawned we wait for one to return
  if ($children_count >= $MAX_PROC) {
    xlogwrite("FATAL", "too_many_children num=$MAX_PROC");
    my $pid = wait();
    my $rc = $? >> 8;
    my $sig = $? & 127;
    xlogwrite("FATAL", "child_error pid=$pid rc=$rc sig=$sig") if ($? != 0);
    $children_count--;
  }

  undef @ready;
  @ready = $sel->can_read($TIMEOUT);

  if ($reopen_log) {
    $reopen_log = 0;
    xlogwrite("INFO", "reopening_log");
    close LOG;
    if (open(LOG, ">>$LOGFILE")) {
      select(LOG);
      $|=1;
      xlogwrite("INFO", "log_reopened");
    }
  }
  reap_children();

  # if there was a timeout everything is done
  next unless (defined @ready);

  my $new_sock = $sock->accept();
  next unless (defined $new_sock);

  $peer = inet_ntoa($new_sock->peeraddr());
  if (! $ALLOWED_PEERS{$peer}) {
    xlogwrite("FATAL", "peer_not_allowed peer=$peer");
    close($new_sock);
    next;
  }
  xlogwrite("DEBUG", "connect from $peer");
  my $pid = fork();
  if ($pid < 0) {		# error
    xlogwrite("FATAL", "fork_error errmsg=$!");
  } elsif ($pid == 0) {		# child
    close($sock);
    talk_smtp($new_sock);
    exit(0);
  } else {			# parent
    $children_count++;
    close($new_sock);
  }
}

exit(0);


#-----------------------------------------------------------------------------
#
#  get_load()
#
#-----------------------------------------------------------------------------
sub get_load {
  open(LOAD, "/proc/loadavg") or return 0;
  my @load = split(/ /, <LOAD>);
  close LOAD;
  return $load[0];
}


#-----------------------------------------------------------------------------
#
#  check_load()
#
#-----------------------------------------------------------------------------
sub check_load {
  my $load;
  return if (($load = get_load()) <= $MAX_LOAD);

  xlogwrite("FATAL", "load current=$load max=$MAX_LOAD");

  do {
    sleep($SLEEPTIME_IF_LOAD_EXCEEDED);
  } while (($load = get_load()) > $MAX_LOAD);

  xlogwrite("FATAL", "resume_work current=$load max=$MAX_LOAD");
}


#-----------------------------------------------------------------------------
#
#  reap_children()
#
#-----------------------------------------------------------------------------
sub reap_children {
  my $pid;
  while (($pid = waitpid(-1, &WNOHANG)) > 0) {
    my $rc = $? >> 8;
    my $sig = $? & 127;
    xlogwrite("FATAL", "child_error pid=$pid rc=$rc sig=$sig") if ($? != 0);
    $children_count--;
  }
}


#-----------------------------------------------------------------------------
#
#  xlogwrite()
#
#-----------------------------------------------------------------------------
sub xlogwrite {
  my ($level, $msg) = @_;

  my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);

  $msg =~ s/([^\x20-\x7e])/sprintf("\\x%02x", ord($1))/e;

  my $s = sprintf("%04d%02d%02d %02d%02d%02d %s %s %s %s %s",
	1900+$year, 1+$mon, $mday,
	$hour, $min, $sec,
	$SHORTHOSTNAME, $PRGNAME, $$, $level, $msg);

  $\ = "\n";
  print LOG $s;
  $\ = "\r\n";
}


#-----------------------------------------------------------------------------
#
#  over_quota()
#
#-----------------------------------------------------------------------------
sub over_quota {
  my($mailbox) = @_;
  my $sum = 0;
  my $num = 0;
  my $thisquota = $QUOTA * 1024 * 1024;

  # If quota file is defined, we ask a DB file for the quota. Errors are
  # ignored here. If there is an error the quota will be the one defined
  # in the $QUOTA variable, defining a default or fallback quota.
  if (defined $QUOTAFILE) {
    my %h;
    my $quotafile = "$QUOTAFILE/" . substr($mailbox, 0, 1) . ".db";
    xlogwrite("DEBUG", "quotafile name=$quotafile");
    tie (%h, "DB_File", $quotafile, O_RDONLY) or xlogwrite("ERR", "tie_failed");
    if (defined $h{$mailbox}) {
      $thisquota = $h{$mailbox} * 1024 * 1024;
    } else {
      xlogwrite("ERR", "no_quota mailbox=$mailbox");
    }
    untie(%h);
  }

  foreach my $sd ("new", "cur") {
    return undef unless (opendir(MB, "$POP_SPOOL/$mailbox/$sd"));
    while (defined (my $f = readdir(MB))) {
      next if ($f =~ /^\./);
      $num++;
      if ($num == $NUMQUOTA) {
        xlogwrite("DEBUG", "quota max=$thisquota maxnum=$NUMQUOTA num=$num");
        return (1);
      }
      if ($f =~ /_(\d+)$/) {
        $sum += $1;
      } else {
        my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
		$ctime,$blksize,$blocks) = stat("$POP_SPOOL/$mailbox/$sd/$f");
        return undef unless (defined $dev);
        $sum += $size;
      }
    }
    closedir(MB);
  }
  xlogwrite("DEBUG", "quota max=$thisquota current=$sum maxnum=$NUMQUOTA num=$num");
  return ($sum > $thisquota);
}


#-----------------------------------------------------------------------------
#
#  get_line()
#
#-----------------------------------------------------------------------------
sub get_line {
  my ($socket) = @_;
  my ($line, $ucline);

  while (1) {
    $line = <$socket>;
    chomp $line;
    $ucline = uc($line);
    if (($ucline eq "NOOP") || ($ucline eq "RSET") || ($ucline eq "HELP")) {
      print $socket "250 OK";
      next;
    }
    if (($line =~ /^VRFY/i) || ($line =~ /^EXPN/i)) {
      print $socket "502 Command not implemented";
      next;
    }
    last;
  }

  if ($ucline eq "QUIT") {
    xlogwrite("INFO", "quit peer=$peer");
    print $socket "221 $HOSTNAME Service closing transmission channel";
    exit(0);
  }

  return $line;
}


#-----------------------------------------------------------------------------
#
#  talk_smtp()
#
#-----------------------------------------------------------------------------
sub talk_smtp {
  my ($s) = @_;

  $/ = "\r\n";
  $\ = "\r\n";

  print $s "220 $HOSTNAME $BANNER";

  while (1) {
    my $line = get_line($s); 
    last if ($line =~ /^(HE|EH)LO ?(.*)$/i);
    print $s "503 Waiting for HELO or EHLO";
  }

  print $s "250 Hi there!";

  SMTP:
  while (1) {
    my $line = get_line($s); 
    if ($line !~ /^MAIL FROM:<(.*)>$/i) {
      print $s "503 Bad sequence of commands";
      next;
    }

    my $from = $1;
    if ($from !~ /^([a-zA-Z0-9!#$%&'*+\/=?^_`{|}~."-]+@[a-zA-Z0-9.-]{4,1024})?$/) {
      print $s "501 Wrong address format";
      xlogwrite("INFO", "illegal_from_addr addr=$from");
      next;
    }

    print $s "250 OK";

    $line = get_line($s); 
    if ($line !~ /^RCPT TO:<(.*)>$/i) {
      print $s "503 Bad sequence of commands";
      next;
    }

    my $to = $1;
    if ($to !~ /^([a-zA-Z0-9._\/+=-]+)(@[a-zA-Z0-9.-]{4,1024})?$/) {
      print $s "501 Wrong address format";
      xlogwrite("INFO", "illegal_dest_addr addr=$to");
      next;
    }

    my $dir = $1;

    # check that this is a proper relative directory path
    if (substr($dir, 0, 1) eq "/" || $dir =~ /\.\./) {
      print $s "501 Wrong address format";
      next;
    }

    # create directory if it is not there
    if (! -d "$POP_SPOOL/$dir") {
      foreach my $d ("$POP_SPOOL/$dir", "$POP_SPOOL/$dir/new",
  			"$POP_SPOOL/$dir/cur", "$POP_SPOOL/$dir/tmp") {
        if (! mkdir($d, $MKDIR_MODE)) {
          print $s "450 Mailbox not found";
          xlogwrite("FATAL", "spool_error mailbox=$dir");
          next;
        }
      }
    }

    # check quota
    my $oq = over_quota($dir);
    if (! defined $oq) {
      print $s "450 Mailbox not found";
      xlogwrite("FATAL", "spool_error mailbox=$dir");
      next;
    }
    if ($oq) {
      print $s "552 Quota exceeded";
      xlogwrite("INFO", "over_quota mailbox=$dir host=$peer");
      next;
    }

    print $s "250 OK";

    $line = get_line($s); 
    if ($line !~ /^DATA/i) {
      print $s "503 Bad sequence of commands";
      next;
    }

    my $fn = time() . "." . $$;

    while (! sysopen(FILE, "$POP_SPOOL/$dir/tmp/$fn", O_WRONLY|O_CREAT|O_EXCL, $FILE_MODE)) {
      xlogwrite("DEBUG", "loop start");
      unless ($!{EEXIST}) {
        print $s "550 Mailbox open failed";
        xlogwrite("FATAL", "spool_error mailbox=$dir file=tmp/$fn errmsg=\"$!\"");
        next SMTP;
      }
      xlogwrite("DEBUG", "file_exists mailbox=$dir file=tmp/$fn");
      sleep(1);
      $fn = time() . "." . $$;
    }
    xlogwrite("DEBUG", "opened $POP_SPOOL/$dir/tmp/$fn");

    print $s "354 Start mail input; end with <CRLF>.<CRLF>";

#  print FILE "Return-path: <$from>";
#  my $count = length("Return-path: <$from>") + 2;

    my $count = 0;
    while ($line = <$s>) {
      chomp $line;
      last if ($line eq ".");
      substr($line, 0, 1) = "" if (substr($line, 0, 1) eq ".");
      $count += length($line) + 2;
      if (! print FILE $line) {
        print $s "451 Mailbox write failed";
        xlogwrite("FATAL", "print_failed host=$peer mailbox=$dir file=${fn}_$count");
        next;
      }
    }
    if (! close(FILE)) {
      print $s "451 Mailbox write failed";
      xlogwrite("FATAL", "close_failed host=$peer mailbox=$dir file=${fn}_$count");
      next;
    }
    unless (rename("$POP_SPOOL/$dir/tmp/$fn", "$POP_SPOOL/$dir/new/${fn}_$count")) {
      print $s "451 Mailbox write failed";
      xlogwrite("FATAL", "rename_failed host=$peer mailbox=$dir file=${fn}_$count errmsg=\"$!\"");
      next;
    }

    print $s "250 OK";

    xlogwrite("INFO", "mail host=$peer mailbox=$dir file=${fn}_$count size=$count");
  }
}


#-- THE END ------------------------------------------------------------------