#!/usr/bin/perl
#-----------------------------------------------------------------------------
#
#  popdummy.pl
#
#  http://www.remote.org/jochen/software/popdummy/
#
#-----------------------------------------------------------------------------
#
#  This is a very simplistic POP-Server written in Perl that returns always
#  the same mail. It is quite useful when you change the address of your
#  POP-Server and you want to tell everybody who is still using the old
#  server to switch to the new one. The script will keep track of the users
#  who got the change mail already and won't give it to them again. There
#  aren't any options or anything, just look at the code and change it to
#  suite you. Because it is written in perl and started from inetd this
#  script has a rather high overhead, it is not suitable for a real long
#  term use. Ideally it is run only for a few days after the switch to the
#  new server, consult the log file to find out how many users are still
#  using the old server.
#
#  The script is really simple, it doesn't do any authenticating and not
#  much error checking. Use it at your own risk, YMMV.
#
#-----------------------------------------------------------------------------
#
#  Copyright (C) 1999, 2000  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
#
#-----------------------------------------------------------------------------
#
#  Usage:
#
#  1) Fix config vars at beginning of script.
#
#  2) Start this from inetd with a line like this:
#
#  pop-3   stream  tcp     nowait  mail    /usr/bin/perl perl popdummy.pl
#
#  Use whatever username you like instead of 'mail'. Don't start as 'root'.
#
#-----------------------------------------------------------------------------

use strict;

# Local part of sender address
my $SENDERADDRESS='postmaster';

# Domain for sender address and 
my $SENDERDOMAIN='example.com';

# Real name of sender
my $SENDERNAME='Postmaster';

# Name of POP server for welcome banner
my $SERVERNAME='mail.example.com';

# Subject for mail
my $SUBJECT='Test';

# Date of the mail
my $MAILDATE='Mon, 19 Jan 2001 12:04:43 +0200';

# Text for mail message without headers
my $MAILTEXT=<<"EOF";
You are using the wrong POP-Server...
EOF

# Logfile. Logs timestamp, remote ip address and username
my $LOGFILE="/tmp/popdummy.log";

# Directory where the popdummy keeps info, who has read the message
# Create this directory. Must be writeable for the user popdummy is running as
my $LOCKDIR="/tmp/popdummylock";

#-----------------------------------------------------------------------------

alarm(60*10);

use Socket;
my $hersockaddr = getpeername(STDIN);
my $herstraddr;
if ($hersockaddr) {
  my ($port, $iaddr) = unpack_sockaddr_in($hersockaddr);
  $herstraddr = inet_ntoa($iaddr);
} else {
  $herstraddr ="LOCAL";
}

$|=1;

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

my $msgid = sprintf("X%4d%02d%02d", 1900+$year, $mon+1, $mday);
my $ts = sprintf("%4d%02d%02d-%02d%02d%02d", 1900+$year, $mon+1, $mday, $hour, $min, $sec);

my $msg = <<"EOF";
X-UIDL: $msgid
Return-Path: <$SENDERADDRESS\@$SENDERDOMAIN>
Date: $MAILDATE
From: $SENDERNAME <$SENDERADDRESS\@$SENDERDOMAIN>
Subject: $SUBJECT
Message-Id: <$msgid\@$SENDERDOMAIN>

EOF

$msg .= $MAILTEXT;

$msg =~ s/$/\r/gm;
my $msglen = length($msg);

open(LOG, ">>$LOGFILE");

print "+OK $SERVERNAME ready\r\n";

my $hatschon=0;
while(<STDIN>) {
  chop;
  chop if (/\r$/);

  if (/^quit$/i) {
    print "+OK closing\r\n";
    exit;
  }

  my $user;
  if (/^user (.*)$/i) {
    ($user = $1) =~ s/[^a-zA-Z0-9_.-]//g;
    print LOG "$ts FROM=$herstraddr USER=$user\n";
    if (-f "$LOCKDIR/$user") {
      $hatschon = 1;
    }
    print "+OK\r\n";
    next;
  }

  if (/^dele/i && $user) {
    open(LOCK, ">$LOCKDIR/$user");
    close LOCK;
  }

  if (/^xsender/i) {
    print "-ERR Not supported\r\n";
    next;
  }

  if (/^auth$/i) {
    print "-ERR Not supported\r\n";
    next;
  }

  if (/^stat$/i) {
    if ($hatschon) {
      print "+OK 0 0\r\n";
    } else {
      print "+OK 1 $msglen\r\n";
    }
    next;
  }

  if (/^list$/i) {
    if ($hatschon) {
      print "+OK Mailbox scan listing follows\r\n.\r\n";
    } else {
      print "+OK Mailbox scan listing follows\r\n1 $msglen\r\n.\r\n";
    }
    next;
  }

  if (/^uidl$/i) {
    if ($hatschon) {
      print "+OK Unique-ID listing follows\r\n.\r\n";
    } else {
      print "+OK Unique-ID listing follows\r\n1 $msgid\r\n.\r\n";
    }
    next;
  }

  if (/^retr (\d+)$/i) {
    print "+OK $msglen octets\r\n$msg.\r\n";
    next;
  }

  if (/^top (\d+) (\d+)$/i) {
    print "+OK $msglen octets\r\n$msg.\r\n";
    next;
  }

  print "+OK\r\n";
}

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