#!/usr/bin/perl -w
#
# etarpit

# Author: Ton Hospel
# GNU License or Perl Artistic (your choice)
# Inspired by ftp://ftp.iks-jena.de/pub/mitarb/lutz/teergrube/dead.end.pl
# This script can be memory, CPU and filedescriptor DOSsed.
# Run under a memory and fd ulimit and with low priority.

use strict;
use Socket;
use Sys::Hostname;
use Event;
use POE qw(Component::Server::TCP);
use Getopt::Long 2.11;

my $VERSION = "0.02";

&Getopt::Long::config("bundling", "require_order");

my ($version, $unsafe, $help, $address, $blackhole);
my $port   = "smtp";
my $repeat =  20;
my $delay  = 180;
my $server = "NoEmail 1.0";
my $slow_answer = 30;
my $log_file = "etarpit.log";

die "Could not parse your command line. Try $0 -h\n" unless
    GetOptions("port|p=s"	=> \$port,
               "address|a=s"	=> \$address,
               "delay=f"	=> \$delay,
               "repeat=o"	=> \$repeat,
               "server=s"	=> \$server,
               "log=s",		=> \$log_file,
               "hostname=s"	=> \my $hostname,
               "blackhole!"	=> \$blackhole,
               "b"		=> \$blackhole,
               "version!"	=> \$version,
               "v"		=> \$version,
               "unsafe!"	=> \$unsafe,
               "U"		=> \$unsafe,
               "help!"		=> \$help,
               "h"		=> \$help);

if ($version) {
    print<<"EOF";
etarpit (Ton Utils) $VERSION
EOF
    exit 0;
}
if ($help) {
    require Config;
    $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
    $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
    exec("perldoc", "-F", $unsafe ? "-U" : (), $0) || exit 1;
    # make parser happy
    %Config::Config = ();
}

die "No arguments please. Try $0 -h\n" if @ARGV;

$hostname = hostname unless defined($hostname);

open(local *LOG, ">>", $log_file) || die "Could not open $log_file: $!";
my $fh = select(LOG);
$|=1;
select($fh);

sub wlog {
    my $heap = shift;
    print LOG gmtime() . " UT: $heap->{remote_ip}: ", @_, "\n";
}

sub who($) {
    my $heap = shift;
    return
        exists $heap->{helo} ? ", helo: $heap->{helo}" : (),
        exists $heap->{from} ? ", from: $heap->{from}" : (),
        exists $heap->{to} ? ", to: $heap->{to}" : ();
}

sub respond($$$$$) {
    my ($kernel, $heap, $rep, $code, $msg) = @_;
    $rep ||= $repeat;
    $heap->{alarm} = $kernel->delay_set("slow", 0) unless @{$heap->{send}};
    push(@{$heap->{send}}, [$rep || $repeat, $code, $msg]);
}

sub slow {
    my ($kernel, $heap) = @_[KERNEL, HEAP, ARG0, ARG1, ARG2];
    my $work = $heap->{send}[0];
    if (--$work->[0] > 0) {
        $heap->{client}->put("$work->[1]-$work->[2]");
        $heap->{alarm} = $kernel->delay_set("slow", $delay);
    } else {
        $heap->{client}->put("$work->[1] $work->[2]");
        shift @{$heap->{send}};
        $kernel->yield("shutdown") if $work->[1] == 221;
        $heap->{alarm} = @{$heap->{send}} &&
            $kernel->delay_set("slow", $slow_answer);
    }
}

sub line {
    (my $kernel, my $heap, local $_) = @_[KERNEL, HEAP, ARG0];
    if (exists $heap->{data}) {
        if ($_ eq ".") {
            respond($kernel, $heap, 0, 
                    250, "Message accepted for destruction");
            wlog($heap, "destroying $heap->{data} lines of mail");
            delete $heap->{data};
        } else {
            $heap->{data}++;
        }
    } elsif (my ($greeter) = /^(?:helo|ehlo)\s+(.*)/i) {
        if (exists $heap->{helo}) {
            respond($kernel, $heap, 0, 503, "Duplicate HELO/EHLO");
        } else {
            respond($kernel, $heap, 0, 250, "Hello $heap->{remote_ip} [$heap->{remote_ip}], pleased to meet you");
            $heap->{helo} = $greeter;
        }
    } elsif (my ($from) = /^mail\s+from:\s*(.*)/i) {
        if (exists $heap->{from}) {
            respond($kernel, $heap, 0, 503, "Sender already specified");
        } else {
            respond($kernel, $heap, 0, 250, "$from... Sender ok");
            $heap->{from} = $from;
        }
    } elsif (my ($to) = /^rcpt\s+to:\s*(.*)/i) {
        if (exists $heap->{from}) {
            if ($blackhole) {
                respond($kernel, $heap, 0, 250, "$to... Recipient ok");
            } else {
                respond($kernel, $heap, 0, 554, "$to... This system does not process email");
            }
            $heap->{to} = $to;
        } else {
            respond($kernel, $heap, 0, 503, "Need MAIL before RCPT");
        }
    } elsif (/^quit/i) {
        $heap->{client}->pause_input;
        respond($kernel, $heap, 0, 221, "$hostname closing connection");
    } elsif (/^data/i && $blackhole) {
        respond($kernel, $heap, 0, 
                354, "Enter mail, end with "." on a line by itself");
        $heap->{data} = 0;
    } elsif (/^rset/i) {
        respond($kernel, $heap, 0, 250, "Reset state");
        wlog($heap, "RSET", who($heap));
        delete $heap->{to};
        delete $heap->{from};
    } elsif (/^help/i) {
        respond($kernel, $heap, 0, 502, "$server -- HELP not implemented");
    } else {
        respond($kernel, $heap, 1, 500, "Command unrecognized: $_");
    }
}

sub connected {
    my ($kernel, $heap) = @_[KERNEL, HEAP];

    # Horrible hack to get to the socket
    my $socket = $heap->{client}[$heap->{client}->HANDLE_INPUT];
    setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE, 1) ||
        die "Could not set keepalive on socket: $!";

    $heap->{send} = [];
    wlog($heap, "Connect");
    respond($kernel, $heap, 1, 220, "$hostname ESMTP $server; " . gmtime() . " +0000 (GMT)");
}

sub disconnect {
    my ($kernel, $heap) = @_[KERNEL, HEAP];
    $kernel->alarm_remove($heap->{alarm}) if $heap->{alarm};
    wlog($heap, "Disconnect", who($heap));
}

sub client_error {
    my ($heap, $syscall, $rc, $error) = @_[HEAP, ARG0, ARG1, ARG2, ARG3];
    return unless $rc;
    wlog($heap, "$syscall: $error", who($heap));
}

sub error {
    my ($syscall_name, $error_string) = @_[ARG0, ARG2];
    print STDERR "$syscall_name: $error_string";
}

sub default {
    # print STDERR "unhandled event $_[ARG0] (@_[ARG1..$#_])\n";
    die("calling non existant event ", $_[ARG0]) unless
        substr($_[ARG0], 0, 1) eq "_";
    return;
}

POE::Component::Server::TCP->new
  (Port => $port,
   defined($address) ? (Address => $address) : (),
   Error => \&error,

   ClientInput		=> \&line,
   ClientConnected	=> \&connected,
   ClientDisconnected	=> \&disconnect,
   ClientError		=> \&client_error,

   InlineStates => {
        #tstp => sub {
        #    # SIGTSTP hack, convert to SIGSTOP
        #    kill "STOP", $$;
        #    return 1;
        #},
        # $kernel->sig("TSTP", "tstp");
        _default => \&default,
        slow => \&slow,
   },
  );

$poe_kernel->run();
__END__

=head1 NAME

etarpit - dummy MTA. Keep spammers happy with useless activity.

=head1 SYNOPSIS

    etarpit [-p port] [--port port] [-a address] [--address address]
            [--repeat integer] [--delay float] [--server name] [--log file]
            [--hostname string] [-b] [--blackhole]
    etarpit [-v] [--version] [--unsafe] [-U] [-h] [--help]

=head1 DESCRIPTION

B<etarpit> is a dummy MTA. It will give valid answers to an attempt to transfer
mail through it, but will use lots of continuation lines and long delays to
make the connection run for as long as possible. In the end (if the remote
party hasn't given up by then) it will admit that it doesn't actually accept
mail. Typically the whole exchange will take a few hours.

The idea is to run this on IP's that shouldn't get mail and tie up
spammer resources.

=head1 OPTIONS

=over 4

=item -p port, --port port

The port on which the server will listen, given as a number or a name which
will be looked up in the local services database (for example
F</etc/services>). Defaults to C<smtp>.

=item -a address, --address address

The address the listening socket will bind to. It defaults to
INADDR_ANY or INADDR6_ANY when using IPv4 or IPv6, respectively.

=item --repeat integer

The number of times an answer gets repeated. Defaults to 20.

=item --delay float

The delay between successive answers expressed in seconds. Defaults to 180.

=item --server name

The name under which the server will announce itself to clients. Defaults to
C<NoEmail 1.0>.

=item --hostname string

The hostname used in the greeting message. If not given it will be the actual
hostname as returned by L<Sys::Hostname|Sys::Hostname/"hostname">.

=item --log file

Name of the file to which logdata will be appended. Defaults to F<etarpit.log>.

=item -b, --blackhole

Normally the dummy MTA finally rejects a mail attempt on the C<RCPT TO>. If you
give this option, it however will answer positively and accept the mail 
(C<DATA>), which will then be thrown away.

=item -h, --help

Show this help.

=item -U, --unsafe

Allow even root to run the perldoc.
Remember, the reason this is off by default is because it B<IS> unsafe.

=item -v, --version

Print version info.

=back

=head1 BUGS

None known

=head1 TODO

Allow filedescriptor passing where some other party does the accept.

=head1 SEE ALSO

L<Sys::Hostname>

=head1 AUTHOR

Ton Hospel (etarpit@ton.iguana.be)

=cut