=head1 NAME
 
tarpit
 
=head1 DESCRIPTION
 
This plugin slows the connections
 
=head1 CONFIG
 
=over 4
 
=item <tarpit_initial> <tarpit_exponent> <tarpit_toplimit>
 
The sleep value is: 
   First time: tarpit_initial
   Next time: min(tarpit_previous + (tarpit_previous*tarpit_exponent), tarpit_toplimit)
 
We have a whitelist (tarpit_whitelist) in the configuration directory
 
It must be placed I<before> hosts_allow plugin (or any other pre_connection hook)
 
=back
 
=head1 BUGS
 
 
=head1 AUTHOR
 
Written by Leonardo Helman <lhelman@pert(punto)com(punto)ar>.
Pert Consultores SRL
Argentina
 
=head1 COPYRIGHT AND LICENSE
 
Copyright (c) 2005 Leonardo Helman. Pert Consultores SRL Argentina
 
This plugin is licensed under the same terms as the qpsmtpd package itself.
Please see the LICENSE file included with qpsmtpd for details.
 
=head1 VERSION
 
$Id: tarpit,v 1.10 2006/05/16 14:12:34 leoh Exp $
 
=cut
 
 
use strict;
use warnings;
 
use Time::HiRes;
 
my $VERSION = substr q$Revision: 1.10 $, 10;
 
sub init {
    my( $self, $qp, $tarpit_initial, $tarpit_exponent, $tarpit_toplimit )=@_;
    $self->{ _tarpit_initial }= $tarpit_initial || 2;
    $self->{ _tarpit_exponent }= $tarpit_exponent || 1.6;
    $self->{ _tarpit_toplimit }= $tarpit_toplimit || 20;
    $self->{ _tarpit_actual }= 0;
    $self->log( LOGNOTICE, "config: Tarpit $self->{ _tarpit_initial } $self->{ _tarpit_exponent } $self->{ _tarpit_toplimit }"  );
}
 
# qpsmtpd-forkserver is reusing connections
sub hook_pre_connection {
    my ($self,$transaction,%args) = @_;
 
    $self->{ _tarpit_actual }= 0;
    $self->qp->connection->notes('tarpit_whitelist_analyzed',0);
 
    return (DECLINED);
}
 
sub hook_ehlo {
  my ( $self )= @_;
 
  $self->doTarpit();
  return DECLINED;
}
 
sub hook_helo {
  my ( $self )= @_;
 
  $self->doTarpit();
  return DECLINED;
}
 
sub hook_rcpt {
  my ( $self )= @_;
 
  $self->doTarpit();
  return DECLINED;
}
 
sub hook_mail {
  my ( $self )= @_;
 
  $self->doTarpit();
  return DECLINED;
}
 
# a este llega con reset, y con quit, solo uso el tarpit si no es quit
sub hook_reset_transaction {
  my ( $self, $transaction, @args )= @_;
 
  if( lc($self->qp->connection->notes('original_string')) ne 'quit') {
    $self->doTarpit();
  }
  return DECLINED;
}
 
sub hook_deny {
  my ( $self, $transaction, $prev_hook, $return, $return_text ) = @_;
 
  $self->doTarpit();
  $self->nextTarpit();
  return DECLINED;
}
 
sub hook_unrecognized_command {
  my ($self) = @_;
 
  $self->doTarpit();
  $self->nextTarpit();
  return DECLINED;
}
 
sub nextTarpit {
  my ( $self )=@_;
 
  unless( $self->isWhitelisted() ) {
    if( $self->{_tarpit_actual} ) {
      $self->{_tarpit_actual} += $self->{_tarpit_actual}*$self->{_tarpit_exponent};
      if( $self->{_tarpit_actual} > $self->{_tarpit_toplimit} ) {
        $self->{_tarpit_actual}= $self->{_tarpit_toplimit};
      } 
    }
    else {
      $self->{_tarpit_actual} = $self->{_tarpit_initial};
    }
  }
  return DECLINED;
}
 
sub doTarpit {
  my ( $self )=@_;
 
  if( $self->{ _tarpit_actual } ) {
    $self->log( LOGNOTICE, "Tarpiting $self->{ _tarpit_actual }" );
    sleep( $self->{ _tarpit_actual } );
  }
  return DECLINED;
}
 
sub isWhitelisted {
  my( $self )=@_;
 
  unless( $self->qp->connection->notes('tarpit_whitelist_analyzed') ) {
    my $client_ip = $self->qp->connection->remote_ip;
    my @tarpit_whitelist = $self->qp->config("tarpit_whitelist");
    my %tarpit_whitelist = map { $_ => 1 } @tarpit_whitelist;
 
    $self->qp->connection->notes('tarpit_whitelist_analyzed', 1);
    $self->qp->connection->notes('tarpit_whitelist', 0);
    # TODO: Cambiar esto (en TODOS lados) por un chequeo por modulo de perl con formato cidr
    while ($client_ip) {
      if (exists($tarpit_whitelist{$client_ip}) ) {
        $self->log( LOGINFO, "The IP " . $self->qp->connection->remote_ip . " is in tarpit_whitelist" );
        $self->qp->connection->notes('tarpit_whitelist', 1);
        last;
      }
      $client_ip =~ s/\d+\.?$//; # strip off another 8 bits
    }
  }
 
 
  return $self->qp->connection->notes('tarpit_whitelist');
}
 
# vim:ft=perl: