=head1 NAME

client_stats

=head1 DESCRIPTION

Plugin to record per client statistics of successful and failed
deliveries, These can be used to distinguish between "good" and "bad"
clients.

=head1 CONFIG

The following parameters can be passed to denysoft_greylist:

=over 4

=item dbi_credentials <filename>

Name of the file which contains the datasource, username and password
for the database. The file should only be readable for the qpsmtpd user.

Default: none. This parameter must be specified!


=back

=head1 NOTES

This plugin makes use of the following connection notes:

=over

=item 'client_stats'

Contains the stats for the connected client at the beginning of this
connection.

=back

=head1 BUGS

=head1 AUTHOR

Peter J. Holzer <hjp@hjp.at>. 

=cut

use Data::Dumper;
use DBI;

my $dbh;

sub register {
  my ($self, $qp, %arg) = @_;
  $self->{_client_stats_credfile}     = $arg{dbi_credentials};
  my @cred = read_cred($self->{_client_stats_credfile});
  $dbh = DBI->connect($cred[0], $cred[1], $cred[2],
			 {RaiseError => 0, AutoCommit => 0});
  $dbh->{FetchHashKeyName} = 'NAME_lc';
  $self->register_hook("connect", "connect_handler");
  $self->register_hook("deny", "deny_handler");
  $self->register_hook("data_post", "data_post_handler");
}


my @net;
sub connect_handler {
    my ($self, $transaction) = @_;
    my $ip = $self->qp->connection->remote_ip || return (DECLINED);
    my @o = split(/\./, $ip);
    my $ipn = ($o[0] << 24) + ($o[1] << 16) + ($o[2] << 8) + $o[3];
    my @q;
    for (my ($mask, $bits) = (32, 0xFFFF_FFFF); $mask >= 0; $mask--, $bits <<= 1) {
	$ipn &= $bits;
	$o[0] = ($ipn >> 24) & 0xFF;
	$o[1] = ($ipn >> 16) & 0xFF;
	$o[2] = ($ipn >>  8) & 0xFF;
	$o[3] = ($ipn >>  0) & 0xFF;
	$net[$mask] = [@o];
	push (@q, "ip1=$o[0] and ip2=$o[1] and ip3=$o[2] and ip4=$o[3] and mask=$mask");
    }
    my $q = "select * from ipstats where " . join(" or ", @q);
    my $s = $dbh->selectall_hashref($q, "mask");
    for (my $mask = 32; $mask >= 0; $mask--) {
	if ($s->{$mask}) {
	    $s->{mostspecific} = $s->{$mask};
	    {
		local $Data::Dumper::Indent = 0;
		$self->log(LOGINFO,
			   Data::Dumper->Dump([$s->{mostspecific}], "client_stats"));
	    }
	    last;
	}
    }

    $self->qp->connection->notes('client_stats', $s);
    return DECLINED;
}


sub deny_handler {
    my ($self, $transaction, $plugin, $code, $message) = @_;

    return DECLINED unless($code =~ /^5/);

    my $sths = $dbh->prepare_cached(
	        "select * from ipstats
		    where ip1=? and ip2=? and ip3=? and ip4=? and mask=? for update"
              );
    my $sthi = $dbh->prepare_cached(
	        "insert into ipstats(ip1, ip2, ip3, ip4, mask, permfail) 
		 values(?,?,?,?,?,1)"
              );
    my $sthu = $dbh->prepare_cached(
		 "update ipstats
		    set permfail=permfail+1
		    where ip1=? and ip2=? and ip3=? and ip4=? and mask=?"
              );
    for my $mask (0..32) {
	my @ip = @{$net[$mask]};
	$self->log(LOGINFO, "incrementing permfail for $ip[0].$ip[1].$ip[2].$ip[3]/$mask");
	if ($dbh->selectrow_arrayref($sths, {}, @ip, $mask)) {
	    $sthu->execute(@ip, $mask);
	} else {
	    $sthi->execute(@ip, $mask);
	}
    }
    $dbh->commit;
    return DECLINED;
}


sub data_post_handler {
    my ($self, $transaction) = @_;
    my $n = $transaction->recipients();
    my $sths = $dbh->prepare_cached(
	        "select * from ipstats
		    where ip1=? and ip2=? and ip3=? and ip4=? and mask=? for update"
              );
    my $sthi = $dbh->prepare_cached(
	        "insert into ipstats(ip1, ip2, ip3, ip4, mask, success) 
		 values(?,?,?,?,?,?)"
              );
    my $sthu = $dbh->prepare_cached(
		 "update ipstats
		    set success=success+?
		    where ip1=? and ip2=? and ip3=? and ip4=? and mask=?"
              );
    for my $mask (0..32) {
	my @ip = @{$net[$mask]};
	$self->log(LOGINFO, "incrementing success for $ip[0].$ip[1].$ip[2].$ip[3]/$mask by $n");
	if ($dbh->selectrow_arrayref($sths, {}, @ip, $mask)) {
	    $sthu->execute($n, @ip, $mask);
	} else {
	    $sthi->execute(@ip, $mask, $n);
	}
    }
    $dbh->commit;
    return DECLINED;
}


sub read_cred {
    my ($fn) = @_;

    open(FN, "<$fn") or die "cannot open $fn: $!";
    my $line = <FN>; 
    close(FN);
    my @cred = split(/[\s\n]/, $line); 
    return @cred;
}