#!/usr/bin/perl

##########################################################################
#      SMTarPit is an smtp honeypot/tarpit that runs under xinetd
## $Id: smtarpit,v 0.5.5 2005/03/09 14:20:30 paul_grosse$
#
# Copyright (C) 2004-2005 Paul Grosse
#
# 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.
#
# You can email Paul Grosse on: pagrosse at compuserve dot com
#
##########################################################################

# SMTarPit is a simple SMTP server that will run on a system that does not
# use smtp (port 25) for its own purposes but is configured to receive
# smtp request traffic. To avoid profiling, you are encourages to play
# around with the values in the configuration section below.
#
# Also, if it appears that we have someone logged into port 25 with
# telnet (ie, the time it takes for the responses is greater than
# 3 seconds or whatever you decide to set it as), the honeypot stays
# in honeypot mode (ie, lots of errors caused by typing errors?)
# otherwise, it toggles into tarpit mode (ie, long delays between
# requests and server responses - this server is very busy)
#
# In other words:
# * You have a spare server with its own domain name.
#
# * You set up a spambot honeypot on your webserver, full of false email
# addresses with its domain name so that it can get spidered (a one pixel
# square link from another website you know is visited a lot will do as
# spiders will not know the difference (for now)).
#
# * Somebody spidered it and is possibly trying to confirm the existence
# of those non-existent mailboxs by connecting to port 25, and seeing what
# happens.
#
# * They then use up a lot of their time achieving nothing on this honeypot
# instead of breaking in somewhere else.
#
# To get it to work:
#
# * copy this file to /usr/local/etc/ (in the example, anywhere will do as
# long as you tell the system where it is) and make sure that it is
# called 'smtarpit'
#
# * make sure that it is executable
#
# * you need to have a file in /etc/xinetd.d called 'smtp' containing
# the following (just copy it, paste it into a new file, remove the
# left set of hash marks (#) and save it there):
## begin #################### /etc/xinetd.d/smtp ##################
## default: on
##
## SMTarPit: a combined SMTP honeypot and tarpit
#service smtp
#{
#	socket_type     = stream
#	protocol        = tcp
#	wait            = no
#	user            = root
#	server          = /usr/local/etc/smtarpit
#       log_type        = FILE /var/log/pophp/nopopx 2048 2100
#	log_on_success  = PID HOST
#	log_on_failure  = HOST USERID
#	instances       = 10
#	bind            = 10.6.8.20
#}
## end #################### /etc/xinetd.d/smtp ##################
#
# You might want to change the number of instances and you will
# certainly want to change the address that it binds to.
#
# * in /etc/hosts.allow you need an entry like this:
# smtp : ALL : twist exec /usr/local/etc/smtarpit %h %a
#
# * kick it all into action.
#
# * Open up a console and type:
# netstat -atn | grep LISTEN
# if all is well, you should see the ip address you are using along
# with port 25 somewhere in the list ie:
# tcp     0    0 10.6.8.20:25     0.0.0.0:*    LISTEN
#
# * you will need your spare server to have its own domain name so
# that it can receive its own (honeypot) mail.
#
# You can test this program out just by calling it from a console.
# If you want to check that it is working on the server all right,
# just log into that ip:25 using telnet.
#
# I haven't got around to introducing errors in tarpit mode yet but
# that is just a matter of (having the) time.
#
# I have given this program some help pages and some commands that
# don't exist. You can add to those commands or the functionality of
# the existing ones (make it so that it reads a very long set of
# email addresses (slowly) on expand (EXPN) for example).

# declare subroutines that need it
sub printnlog ($);
sub printsoc ($);
sub schlafzeit ($);
sub checkaddress (@);
sub chkema ($);
sub wastetime ($);
sub htdisplay ($);
sub killed ($);
sub piped ($);
sub timedout ($);
sub dumplog ($);
sub pollstatus ($);

##### CONFIGURATION ########################
#                                          #

#### This program's name ####
# the name of the executable that will be seen in the process
# list. This is so that it can look to see how many tarpits
# already exist so that you can restrict the number without
# having to restart xinetd. (see Maximum number of instances
# below.)
#
# $progname = "smtarpit";
#
$progname = "smtarpit";

#### This program's location ####
# the location of this server - this isolates the server so that
# it can no no harm if, for some reason it was taken over by some,
# as-yet-uncovered, loophole in some part of the system.
#
# if you don't want to chroot the process, make the string empty...
#
# $chrootloc "/usr/local/etc/";
# or, if not chrooted,
# $chrootloc "";
#
$chrootloc = "/usr/local/etc/";

#### Log file's location ####
# Detailed log location (relative to the chroot).
# Note (1), start this with a '/' but don't end it with one.
# eg $logloc = "/log"; # is all right, just make sure that there
# is a directory and that this program has write access to it.
#
# Note (2), if you are running this on a system that does not have
# chroot, or you don't want to run is as chroot, just use the path
# from the real root for the log location ($logloc) and make the
# $chrootloc chroot location a null string.
#
# $logloc = "/log";
# or, if not chrooted,
# $logloc = "/usr/local/etc/log";
#
$logloc = "/log";

#### Maximum number of instances ####
# The maximum number of tarpits you want to be able to run at any
# one time on your system. Each one takes up some memory so there will
# be a limit as to how many you can run.
#
# $maxinst = 20;
#
$maxinst = 20;

#### Maximum time to be active (seconds) ####
# This is here so that if the tarpit is left unattended and the machine
# at the other end gets into a loop that it cannot get out of, the
# tarpit closes the connection when it goes around the loop and the time
# has exceeded the limit set here (in other words, set it to 1,000,000 and
# if after 1,000,098 seconds, it loops, it will then exit). 1,000,000 is
# roughly 11.6 days. Two weeks is roughly 1,200,000 seconds.
#
# $maxtime = 1200000;
#
$maxtime = 1200000;

#### Log Dump Time ####
# If you want to have SMTarPit dump the buffered log to the log file
# before it finishes running, set this to less than $maxtime.
#
# $dumptime = 1200000;
# or
# $dumptime = $maxtime;
#
$dumptime = $maxtime;

#### Time-out period ####
# This is the maximum amount of time (in seconds) that our tarpit will
# wait for input from the other end.
# If it is a machine at the other end, the delays should only be small any
# way but if it is a human being (for want of a better term), this could
# be several minutes whilst (s)he thinks about what they are going to do.
# However, this time period should be kept small because it does use up
# one of the processes on the tarpit server. Further, if it is too long,
# this could be used to check if it is a real server or not. So, around
# 3 to 5 minutes (180 to 300 seconds) should be a good idea of the time
# required. You never know, if you had it at only 20 seconds, the thrill
# of trying to beat the server with telnet might keep them occupied.
#
# $timeouttime = 240;
#
$timeouttime = 240;

#### Presented server host name and server type ####
# the name and type of this server - it puts this in the output
# to the other machine. This routine makes sure that you have the same
# server type to each server domain thus precluding searches for
# inconsistency
#
{
my (@srvdom, @srvtype, @linklist, $srvchc);

@srvdom = ("smtp.copper.foo.nu",
           "smtp.zinc.foo.nu",
           "smtp.boron.foo.nu",
           "smtp.oxygen.foo.nu",
           "smtp.fluorine.foo.nu",
           "smtp.neon.foo.com",
           "smtp.sodium.foo.com",
           "smtp.silicon.foo.com",
           "smtp.sulphur.foo.com",
           "smtp.cadmium.foo.com",
           "smtp.iron.foo.com",
           "smtp.manganese.foo.com");

@srvtype = ("Sendmail 8.12.9/8.12.1;",
            "ESMTP server (InterMail vM.4.01.03.37 201-229-121-137-20020806)",
            "Microsoft ESMTP MAIL Service, Version: 5.0.2195.4905");

# @linklist is a list that links each server name (index) to a server type,
# therefore, the number of elements you are going to use must be equal to
# the number of servers (remember that perl starts with index [0] ) and the
# values in the elements must not exceed the number of types of server minus
# one so, for the default system with 12 server names and three server types,
# we have 12 values (the index value is sorted out automatically) with values
# between 0 and 2 inclusive.
#
# Doing it this way (hard-linking server-name to -type) will mean that every
# time someone logs on, they will see no inconsistency in the server's
# identity

@linklist = qw(0 1 0 2 1 2 0 0 1 0 2 0);
$srvchc = int( rand($#srvdom + 1));

$servername = $srvdom[ $srvchc ];
$servertype = $srvtype[ $linklist [ $srvchc ] ];
};

#### Domains covered by server ####
# recipient domains for the server - these are just used to check that
# any email addresses it tries to send to are okay (ie, local).
# They don't have to be a full name such as "smtp.foo.bar.com" as they
# are only looked for at the end of the address so using "bar.com" will
# get "name@foo.bar.com", "name@home.bar.com" and even
# "name@my.home.foo.bar.com".
#
# @rcptdom = ("foo.com",
#             "bar.com");
#
@rcptdom = ("foo.com",
            "bar.com");

#### Mode decision time ####
# The decision time (in seconds) that we are going to use to determine
# whether to use a tarpit or a honeypot.
# If you find that you are getting mail servers that are reacting slowly,
# you can increase this time.
#
# $honeytartime = 3;
#
$honeytartime = 3;

#### Delay factor ####
# The amount of time it wastes. If this is too long, you will get
# time-outs (you will get them anyway but you can reduce them by
# choosing this value correctly.
# The value is used in the schlafzeit (sleep time) routine for
# teergrube (tarpit) mode. The maximum delay in teergrube is
# $delfac * 15.
# it is actually...
# sleep int(rand ($delfac * 5)) + ($delfac * 10);
# so setting it to 7 will give schlafzeit 1 calls lasting between
# 70 and 105 seconds. With 20 calls per command, that can add up.
#
# $delfac = int(rand 3) + 9;
# $delfac = 12;
#
$delfac = int(rand 3) + 9;

#### Enable HELP ####
# I have enabled help on this but if you want, you can disable it.
# If someone is profiling this server, they might try looking at
# the working of the help but you can write your own if you want to
# (it will only be looked at by a human at the other end).
# If you want to turn it off altogether, just change the value below
# to zero.
# One advantage to having it is that you can invent commands that keep
# them entertained for hours and help only tells them briefly enough
# to get their interest but not say too much.
#
# $enablehelp = 1;
#
$enablehelp = 1;

#### Logging level ####
# If you only want the quicklog (one line per exchange) then set this
# variable to 1. If set to 0, you will get the full log with all exchanges
# except the time-waster routine (you still get the end so you can see the
# response time for their next command).
#
# $onlyquicklog = 0
#
$onlyquicklog = 0;

#### Special domains ####
# This allows you to specify some special domains that you want to treat
# differently - maybe they have a short timeout because they are not
# really an ISP's MX but a process on a zombie machine.
# The $specdom variable is set to 0 for none and 1 for one or more
#
# $specdom = 1;
# or
# $specdom = 0;
#
# The $specdomdelfac is set to the new delay factor (see above) and
#
# $specdomdelfac = 2;
#
# the @specdoms array is the list of partial domain strings
# to match - ie, using foo.com will select mta.foo.com, my.foo.com and so on.

$specdom = 1;
$specdomdelfac = 1;
@specdoms = (
  'badfoo.com',
  'badbar.com'
);

#### Special IPs ####
# Same as special domains above but for IP addresses

$specip = 1;
$specipdelfac = 1;
@specips = (
  '123.45.67.89'
);

#### Naughty ####
# This allows you to mess up a sender's mail from:
# address by disallowing a character from it (only
# one though). by default, it is set to "_" but
# you can set it to anything. If you don't want to to
# take effect, just set it to something that won't
# be in an email address anyway such as '%'.
# This might just make them paranoid (they should be).
# Suggestions for ideas are: the letter 'q',
# the number '8'... You get the idea :-)
#
# $naughty = "_";
#
$naughty = "_";

#                                          #
##### END CONFIGURATION ####################

# you shouldn't need to touch anything below here under normal
# circumstances but you can look and improve if you want.

##### INITIALISATION #######################
#                                          #

## make STDOUT respond immediately
select(STDOUT);
$| = 1;

## mode honeypot or tarpit? start off as a honeypot
$teergrube = 0;

## make a note of the remote host IP from the xinetd environment
$rhost = $ENV{REMOTE_HOST} or $rhost = "127.0.0.1";
$rhostb = "[".$rhost."]";

# $process_state is the state that the SMTP honeypot server is in...
#    = 0 'helo' or 'ehlo' required. Let's be pedantic about this
#    = 1 'mail from' required
#    = 2 'rcpt to' required
#    = 3 'data' required ... but the mail box is full so that will fail.
$process_state = 0;

# first time in the loop: set in two places to prevent hacking by
# sending an incorrect but quick response
$f_loop = 1;
$ft_loop = 1;

## note the time now for log and salt purposes
$c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
$s_time = time;
$d_time = $s_time + $dumptime;

## set the number of recipients
$response_delta = -1;
$recips = 0;
$lastrecip = " - ";

## find out how many processes exist and set the limit appropriately
$rp = "ps -e | grep $progname";
@prun = readpipe ($rp);
if ( length($chrootloc) > 0) {
  #chroot the process
  chroot $chrootloc;
};
if ($maxinst > $#prun) {
  # we are not over the process limit so set limit time to now
  # plus the time limit
  $autoquittime = $maxtime + $s_time;
} else {
  # we are over the process limit so exit politely when we get
  # into the loop
  $autoquittime = $s_time;
};

## Set up interrupt capture
$SIG{'INT'} = 'killed';      # from a console (not telnet) on
                             #  local machine - [CTRL][C]
$SIG{'TERM'} = 'killed';     # command on a local machine (Bash) kill [PID]
$SIG{'KILL'} = 'killed';     # normally, this will just kill it but
                             #  it is included here just in case it
                             #  doesn't on your system.
$SIG{'HUP'} = 'killed';
$SIG{'TRAP'} = 'killed';
$SIG{'STOP'} = 'killed';
$SIG{'QUIT'} = 'killed';
$SIG{'ABRT'} = 'killed';
$SIG{'USR1'} = 'dumplog';    # In a console, type kill -SIGUSR1 [PID]
                             # used by a controlling program to make
                             # SMTarPit dump the detailed log. This is useful
                             # if you want to see what is going on with a
                             # particular connection
$SIG{'USR2'} = 'pollstatus'; # In a console, type kill -SIGUSR2 [PID]
                             #  Makes SMTarPit dump status info to a file
$SIG{'PIPE'} = 'piped';      # Issued by xinetd when other end drops
                             # the connection - how rude.
$SIG{'ALRM'} = 'timedout';   # used by this program to time-out connections
                             # thus preventing a DoS attack with telnet

#                                          #
##### END INITIALISATION ###################

## Let's get going...
##### open the ongoing log file ###
if ($onlyquicklog == 0) {
  open(SMTPLOG, ">>$logloc/smtplog");
} else {
  open(SMTPLOG, ">/dev/null");
};

## respond
$istr = "220 $servername $servertype ready";
print SMTPLOG "NEW $$ $rhost $c_time\n$$ $c_time $istr\n";
printsoc "$istr\r\n";

alarm $timeouttime;

##### start program loop ##
while (<STDIN>) {
  # cancel timer
  alarm 0;
  # remove line-ending characters and tidy up the string
  chomp;
  if (length($_) == 0) {
    alarm $timeouttime;
    next;
  };
  $_ = lc $_;
  s/\r//g;
  s/^ +//g;
  s/ +$//g;
  # just to look after the variable, we'll save it.
  $std_in = $_;
  # log it - note, we are doing this longhand here because we
  # don't want it echoed back to the user
  $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  print SMTPLOG "$$ $c_time $_\n";
  # check to see if time limit has been exceeded
  if ( $autoquittime < time ) {
    schlafzeit (3);
    printnlog "421 $servername closing connection.";
    print SMTPLOG "$$            --            Auto-Quitting\n";
    done (0);
  };
  # is this the first time???
  if ($f_loop) {
    # first time around the loop so assess the cracker
    $ft_loop = 0;
    # get the response time
    $f_time = time;
    $delta_t = $f_time - $s_time;
    $response_delta = $delta_t;
    # print the string in the SMTPLOG file
    print SMTPLOG "$$            --            delta_t = $delta_t seconds\n";
    if ($delta_t < $honeytartime) {
      # quick response so probably a mail server
      $teergrube = 1;
      print SMTPLOG "$$            --            Fast response: selecting tarpit mode\n";
    } else {
      # slow response so probably someone on
      # telnet or similar therefore $teergrube = 0
      print SMTPLOG "$$            --            Slow response: selecting honeypot mode\n";
    };
  };
  # now look at the commands it has received and respond
  # first, restore the variable in case it has been overwritten.
  $_ = $std_in;
  ########### HELO/EHLO ########################
  m/^(he|eh)lo\s+(.*)/ and do {
    if ($process_state == 0) {
      $helo = $2;
      $sifound = 0;
      if ($specip == 1) {
        foreach $si (@specips) {
          if ($rhost =~ m/$si/) {
            $sifound = 1;
          };
        };
      };
      $sdfound = 0;
      if ($specdom == 1) {
        foreach $sd (@specdoms) {
          if ($helo =~ m/$sd/) {
            $sdfound = 1;
          };
        };
      };
      if ($sifound == 1) {
        $delfac = $specipdelfac;
        $teergrube = 0;
        $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
        #print SMTPLOG "$$ $c_time     special case - delfac = 1\n";
        print SMTPLOG "$$ $c_time     special case - teergrube = 0\n";
        printnlog "250 $servername greets $helo $rhostb";
      } elsif ($sdfound == 1) {
        $delfac = $specdomdelfac;
        $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
        print SMTPLOG "$$ $c_time     special case - delfac = 1\n";
        printnlog "250 $servername greets $helo $rhostb";
      } else {
        schlafzeit (1);
        printnlog "250-$servername greets $helo $rhostb";
        wastetime (250);
      };
      $process_state = 1;
      $f_loop = 0;
    } else {
      schlafzeit (3);
      printnlog "503-$servername Duplicate HELO/EHLO";
      wastetime (503);
    };
    alarm $timeouttime;
    next;
  };
  ########### MAIL ########################
  /^mail\s+from:\s*(.*)/ and do {
    if ($process_state == 1) {
      $sender = $1;
      schlafzeit (1);
      my $s = $sender;
      if (checkaddress ($s, 1)) {
        if ($teergrube == 1) {
          printnlog "250-$sender Ok on this server";
          wastetime (250);
        } else {
          printnlog "250 $sender Ok on this server";
        };
        $process_state = 2;
      } else {
        if ($teergrube == 1) {
          printnlog "553-$sender name not allowed";
          wastetime (553);
        } else {
          printnlog "553 $sender name not allowed";
        };
      };
    } elsif ($process_state == 2) {
      schlafzeit (3);
      printnlog "503-Sender ($sender) already specified...";
      wastetime (503);
    } else {
      # proc state=0 -- not initialised
      schlafzeit (3);
      printnlog "503-HELO or EHLO or RSET required...";
      wastetime (503);
      $f_loop = 0;
    };
    alarm $timeouttime;
    next;
  };
  ########### RECIPIENT ########################
  /^rcpt\s+to:\s*(.*)/ and do {
    if ($process_state == 2 || $process_state == 3) {
      $recip = $1;
      $lastrecip = $recip;
      schlafzeit (1);
      if (checkaddress ($recip, 0)) {
        $recips++ ;
        if ($teergrube == 1) {
          printnlog "250-$recip Ok on this server";
          wastetime (250);
        } else {
          printnlog "250 $recip Ok on this server";
        };
        $process_state = 3;
      } else {
        printnlog "451-$recip - Action aborted: error in processing";
        wastetime (451);
      };
    } elsif ($process_state == 1) {
      schlafzeit (3);
      printnlog "503-MAIL required before RCPT...";
      wastetime (503);
    } else {
      # proc state=0 -- not initialised
      schlafzeit (3);
      printnlog "503-HELO or EHLO or RSET required...";
      wastetime (503);
      $f_loop = 0;
    };
    alarm $timeouttime;
    next;
  };
  ########### DATA ########################
  /^data/ and do {
    schlafzeit (1);
    if ($process_state == 3) {
      schlafzeit (1);
      printnlog "552-Requested mail action aborted: exceeded storage allocation";
      wastetime (552);
    } elsif ($process_state == 2) {
      schlafzeit (1);
      printnlog "503-RCPT required before DATA";
      wastetime (503);
    } elsif ($process_state == 1) {
      schlafzeit (1);
      printnlog "503-MAIL required before DATA";
      wastetime (503);
    } else {
      #proc state = 0, ie nothing much has happened yet
      $f_loop = 0;
      schlafzeit (1);
      printnlog "503-HELO/EHLO required before DATA";
      wastetime (503);
    };
    alarm $timeouttime;
    next;
  };
  ########### 'HELP' with subject ########################
  /^help\s+(.*)/ and do {
    schlafzeit (1);
    if ($enablehelp == 1) {
      $htopic = uc($1);
      schlafzeit (1);
      printnlog "214-HELP $htopic";
      htdisplay ($htopic);
    } else {
      printnlog "550-HELP not supported on this server";
      wastetime (550);
    };
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'HELP' on its own ########################
  /^help/ and do {
    if ($enablehelp == 1) {
      schlafzeit (1);
      printnlog "214-HELP Request...";
      wastetime (214);
    } else {
      printnlog "550-HELP not supported on this server";
      wastetime (550);
    };
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### VRFY ########################
  /^vrfy\s+(.*)/ and do {
    $vrecip = $1;
    schlafzeit (1);
    if (checkaddress ($vrecip, 0)) {
      if ($teergrube == 1) {
        printnlog "250-$vrecip Ok on this server";
        wastetime (250);
      } else {
        printnlog "250 $vrecip Ok on this server";
      };
      #$process_state = 3;
    } else {
      printnlog "553-$vrecip - Error.";
      wastetime (553);
    };
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'NOOP' ########################
  /^noop/ and do {
    schlafzeit (1);
    if ($teergrube == 1) {
      printnlog "250-No operation";
      wastetime (250);
    } else {
      printnlog "250 No operation";
    };
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'EXPN' ########################
  /^expn\s+(.*)/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### RESET ########################
  /^rset/ and do {
    schlafzeit (1);
    if (length($helo)) {
      $process_state = 1;
      printnlog "250-$servername reset - continuing session $helo";
    } else {
      $process_state = 0;
      printnlog "250-$servername reset";
    };
    wastetime (250);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### QUIT ########################
  /^quit/ and do {
    schlafzeit (3);
    printnlog "221 $servername $servertype closing connection.";
    done (0);
  };
  ########### ODD BITS AND BOBS (NON-EXISTENT ET CETERA) ###########
  ########### 'XHLP' ########################
  /^xhlp/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'XSIZ' ########################
  /^xsiz/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'XREMOTEQUEUE' ########################
  /^xremotequeue/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'ETRN' ########################
  /^etrn/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'PIPELINING' ########################
  /^pipelining/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### 'DSN' ########################
  /^dsn/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### '8BITMIME' ########################
  /^8bitmime/ and do {
    schlafzeit (1);
    printnlog "550-Command Rejected for policy reasons";
    wastetime (550);
    $f_loop = 0;
    alarm $timeouttime;
    next;
  };
  ########### EVERYTHING ELSE INCLUDING UNSUPPORTED FORMS OF ABOVE ######
  schlafzeit (3);
  printnlog "500-Syntax error/Command unrecognised.";
  wastetime (500);
  if ($f_loop == 1) {
    # first time around and no success. reset things otherwise
    # someone could swing things just by pressing enter. No, the clock is
    #still running on that first command
    $ft_loop = 1;
    $teergrube = 0;
  };
  # end of loop
};
done(0);
exit(0);

##### subroutines ###
## display the specific help topic details
sub htdisplay ($) {
  $ht = shift;
  if ($ht eq "HELO" || $ht eq "EHLO") {
    foreach ("HELO (hello) or EHLO (Extended Hello)",
             "are used to initiate a mail",
             "transfer session.",
             "...",
             "If you have already used HELO or",
             "EHLO, and then use RSET, you do not") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 need to use HELO or EHLO again.\r\n";
  } elsif ($ht eq "MAIL") {
    foreach ("This command is used to initiate a",
             "particular mail transfer.",
             "...",
             "In addition to the MAIL command,",
             "the same line needs to contain",
             "the email address of the sender",
             "enclosed in angle brackets.",
             "Anything other than this will cause",
             "an error.",
             "...",
             "This is used as follows...",
             "MAIL FROM:<john.doe\@foo.com>") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 where john.doe\@foo.com is the sender.\r\n";
  } elsif ($ht eq "RCPT") {
    foreach ("RCPT (Recipient) tells the server",
             "to whom the email is addressed.",
             "...",
             "On this server, that has to be",
             "someone with an account on this",
             "server.",
             "...",
             "The RCPT has to have a particular",
             "format, being accompanied by TO:",
             "the the recipient\'s email",
             "address in angle brackets.",
             "...",
             "For example...",
             "RCPT TO:<jane.dough\@bar.com>",
             "where jane.dough\@bar.com is") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 is the recipient.\r\n";
  } elsif ($ht eq "DATA") {
    foreach ("The DATA command tells the server",
             "that it is the intention of the",
             "client to send it the contents of",
             "the email that the MAIL and RCPT",
             "cammands have prepared it for.",
             "...",
             "The DATA command appears on a line") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on its own.\r\n";
  } elsif ($ht eq "RSET") {
    foreach ("The Reset command (RSET) resets",
             "the server so that a new mail",
             "transfer can occur.",
             "...",
             "If the client has already identified",
             "itself with either a HELO or a EHLO",
             "command, there is no need to use another",
             "HELO or EHLO command",
             "...") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 RSET appears on a line of its own.\r\n";
  } elsif ($ht eq "NOOP") {
    foreach ("The NOOP command performs no",
             "operation. However, it does",
             "reset time-outs so that connections") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 can stay open.\r\n";
  } elsif ($ht eq "VRFY") {
    foreach ("The Verify command (VRFY) verifies",
             "a user or a mailbox.",
             "...",
             "It is used either as follows...",
             "...",
             "VRFY DOE",
             "...",
             "or as",
             "...") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 VRFY john.doe\@foo.com.\r\n";
  } elsif ($ht eq "EXPN") {
    foreach ("Typing 'HELP' and then the name",
             "of a mailing list gives you the",
             "email addresses of everybody on",
             "that list.",
             "...",
             "for example,",
             "type the following...",
             "...",
             "EXPN <mailing_list_name>") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 and you will see what happens.\r\n";
  } elsif ($ht eq "HELP") {
    foreach ("Typing 'HELP' gives you a list",
             "of commands that you can use on",
	     "this server.",
             "...",
             "Typing 'HELP' and then the name",
             "of the command you need to",
             "find out more about.",
             "...",
             "for example,",
             "type the following...",
             "...",
             "HELP HELO") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 and you will see what happens.\r\n";
  } elsif ($ht eq "XHLP") {
    foreach ("The Extended Help (XHLP) command",
             "is experimental and not supported") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 fully on this server yet.\r\n";
  } elsif ($ht eq "XSIZ") {
    foreach ("",
             "is experimental and not supported") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 fully on this server yet.\r\n";
  } elsif ($ht eq "XREMOTEQUEUE") {
    foreach ("The XREMOTEQUEUE command",
             "is not supported fully") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on this server yet.\r\n";
  } elsif ($ht eq "ETRN") {
    foreach ("The ETRN command",
             "is not supported fully") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on this server yet.\r\n";
  } elsif ($ht eq "PIPELINING") {
    foreach ("The PIPELINING command",
             "is not supported fully") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on this server yet.\r\n";
  } elsif ($ht eq "DSN") {
    foreach ("The DSN command",
             "is not supported fully") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on this server yet.\r\n";
  } elsif ($ht eq "8BITMIME") {
    foreach ("The 8BITMIME command",
             "is not supported fully") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    schlafzeit (1);
    printsoc "214 on this server yet.\r\n";
  } elsif ($ht eq "QUIT") {
    schlafzeit (1);
    printsoc "214-The Quit command ends the\r\n";
    schlafzeit (1);
    printsoc "214 session.\r\n";
  } else {
    # ain't there
    foreach ("This server does not have any",
             "help information on the command...",
             "$ht",
             "... that you have typed in.") {
      schlafzeit (1);
      printsoc "214-$_\r\n";
    };
    wastetime (214);
  };
}
#check that the address is a valid one on an available (sub-) domain
sub checkaddress (@) {
  my $adr = shift;
  my $mode = shift;
  my $rt = 1;
  # there should only be one email address on this line
  # and it should be surrounded by angle brackets.
  # There could be white space there as well so remove that first.
  $adr =~ s/\s//g;
  # check for enclosing '<' and '>'
  if ($adr =~ m/^</) {
    #'>' might not be at the end so just look for it
    # it must be after the < which can only be at the beginning
    if ($adr =~ m/>/) {
      #extract the email address
      $adr =~ m/^<(.+)>/;
      $adr = $1;
      # Check that there is something there
      if ( defined ($adr) ) {
        # okay so far
        # check for '@' - there should only be one so use s///
        $atf = $adr =~ s/\@/\@/g;
        if ($atf == 1) {
          if ($mode == 1) {
            my $r = &chkema($adr);
            if ($adr =~ m/$naughty/) {
              return 0;
            };
            if ($r == 0) {
              return 1;
            } else {
              return 0;
            };
          };
          # split it
          @adrc = split /\@/, $adr;
          # There should only be one @ and that should not be at an end
          if ($#adrc == 1) {
            #the \@ was somewhere in the middle
            # check the right hand side
            # our domain names should be at the end.
            # check them one at a time (@rcptdom)
            $founddom = 0;
            foreach $c (@rcptdom) {
              if ($adrc[1] =~ m/($c)$/) {
                $founddom = 1;
              };
            };
            if ($founddom == 1) {
              my $r = &chkema($adr);
              if ($r == 0) {
                return 1;
              } else {
                return 0;
              };
            } else {
              $rt = 0;
            };
          } else {
            $rt = 0;
          };
        } else {
          $rt = 0;
        };
      } else {
        $rt = 0;
      };
    } else {
      $rt = 0;
    };
  } else {
    $rt = 0;
  };
  return $rt;
}
## check out an email address for anything that is obviously wrong
sub chkema ($) {
  my $ema = shift;
  $ema = lc($ema);
  # check allowed characters
  if ($ema =~ m/[^a-z0-9\-\.@\_]/g) {return 1;};
  # Check for two '-'s together
  if ($ema =~ m/\-\-/) {return 1;};
  # Check for two '_'s together
  if ($ema =~ m/\_\_/) {return 1;};
  # Split at @ sign
  @halves = split (/@/, $ema);
  # Should be only one
  if ($#halves >1) {return 2;};
  # Split left half at dots
  @lh = split (/\./, $halves[0]);
  if ($#lh < 0) {return 3;};
  # Split right half at dots
  @rh = split (/\./, $halves[1]);
  if ($#rh < 1) {return 4;};
  # rules apply to all but last so join together
  @segs = (@lh, @rh);
  # scan through @segs from [0] to [n-1]
  foreach $t (1..$#segs) {
    $m = $segs[$t - 1];
    # Check length
    if (length ($m) < 1) {return 5;};
    # First character is alpha, rest are any permitted
    $m =~ s/[a-z][a-z0-9\-\_]{0,}//g;
    if (length($m) > 0 ){return 5};
  };
  # Top level Domain
  $m = $segs[$#segs];
  # can only have between 2 and 4 alpha characters
  $m =~ s/^[a-z]{2,4}$//g;
  if (length($m) > 0) {return 6};
  return 0;
}
## print out a whole load of rubbish that is going to take
## forever to receive if in tarpit mode
sub wastetime ($) {
  my $sstr = shift;
  foreach ("Server Command List...",
           "HELO",
           "EHLO",
           "MAIL",
           "RCPT",
           "DATA",
           "RSET",
           "NOOP",
           "VRFY",
           "EXPN",
           "HELP",
           "XHLP",
           "XSIZ",
           "XREMOTEQUEUE",
           "ETRN",
           "PIPELINING",
           "DSN",
           "8BITMIME",
           "QUIT") {
    schlafzeit (1);
    printsoc "$sstr-$_\r\n";
  };
  schlafzeit (1);
  printsoc "$sstr Type HELP and then the command for help.\r\n";
  $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  print SMTPLOG "$$ $c_time          Wastetime Routine Finish\n";
}

## push the client mailer into schlafie-schlafie land
sub schlafzeit ($) {
  my $sst = shift;
  if ($teergrube == 1) {
    if ($sst == 1) {
      sleep int(rand ($delfac * 5)) + ($delfac * 10);
    } elsif ($sst == 2) {
      sleep int(rand ($delfac * 4)) + ($delfac * 8);
    } else {
      sleep int(rand $delfac ) + ($delfac / 3) + 1;
    };
  } else {
    sleep int(rand ($delfac / 2));
  };
}
## print output to the remote client and also to the poplog
# note that no new-line is in the string that is sent to this routine
sub printnlog ($) {
  my $pt_a_lg = shift;
  $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  printsoc "$pt_a_lg\r\n";
  print SMTPLOG "$$ $c_time $pt_a_lg\n";
  #look at the time and dump the log every 120 minutes or
  # however long is defined by $dumptime
  if (time > $d_time) {
    $d_time += $dumptime;
    close(SMTPLOG);
    if ($onlyquicklog == 0) {
      open(SMTPLOG, ">>$logloc/smtplog");
    } else {
      open(SMTPLOG, ">/dev/null");
    };
  };
}
## tidy up and log
sub done {
  $f_time = time;
  $delta_t = $f_time - $s_time;
  $maintime = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  open(CRACKLOG, ">>/$logloc/smtpquicklog");
    print CRACKLOG "$$ $rhost $maintime - duration = $delta_t\n";
  close(CRACKLOG);
  print SMTPLOG "$$            --            duration: $delta_t seconds\n";
  close(SMTPLOG);
  exit(0);
}

## process to perform if killed, terminated, interrupted...
sub killed ($) {
  my $s = shift;
  schlafzeit (3);
  $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  printnlog "421 $servername closing connection";
  print SMTPLOG "$$ $c_time  -  Signal - $s\n";
  done (0);
}

## process to perform if killed, terminated, interrupted...
sub piped ($) {
  my $s = shift;
  $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
  print SMTPLOG "$$ $c_time  -  PIPEd - Connection presumed closed\n";
  done (0);
}

## print to the machine at the other end
sub printsoc ($) {
  my $a = shift;
  eval {
    print "$a";
  };
  if (length ($@)) {
    $c_time = substr(localtime, 20, ) . " " . substr(localtime, 4, -5);
    print SMTPLOG "$$ $c_time  -  Connection presumed closed\n";
    done (0);
  };
}

## process to perform if timed out
sub timedout ($) {
  printnlog "421 Timed out $servername closing connection";
  print SMTPLOG "$$            --            Timed out $timeouttime\n";
  done (0);
}

## process to dump the detailed log to file
sub dumplog ($) {
  if ($onlyquicklog == 0) {
    close(SMTPLOG);
    open(SMTPLOG, ">>$logloc/smtplog");
  };
}

## process to dump status information to a file
sub pollstatus ($) {
  my $f_time = time;
  open(PSTAT, ">$logloc/pstat");
    print PSTAT "PID $$\nRHOST $rhost\n";
    print PSTAT "START $s_time\nNOW $f_time\n";
    print PSTAT "SNAME $servername\n";
    print PSTAT "STYPE $servertype\n";
    if (defined ($helo)) {
      $helo =~ tr/ /_/;
      print PSTAT "HELO $helo\n";
      print PSTAT "DELTAT $response_delta\n";
      if ($teergrube == 1) {
        print PSTAT "TEERGRUBE TARPIT\n";
      } else {
        print PSTAT "TEERGRUBE HONEYPOT\n";
      };
    } else {
      print PSTAT "NOHELO\n";
      print PSTAT "NODELTAT\n";
      print PSTAT "TEERGRUBE UNDEF\n";
    };
    if (defined ($sender)) {
      $sender =~ tr/ /_/;
      print PSTAT "SENDER $sender\n";
    } else {
      print PSTAT "NOSENDER\n";
    };
    print PSTAT "NUMRECIPS $recips\n";
    print PSTAT "LASTRECIP $lastrecip\n";
  close(PSTAT);
}

##### finish ###
