#!/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 ------------------------------------------------------------------
syntax highlighted by Code2HTML, v. 0.9.1