
=head1 NAME

Blog::Spam::Plugin::drone - Lookup comment submissions in dronebl.org

=cut

=head1 ABOUT

This plugin is designed to test the submitters of comments against the
dropnbl.org realtime blacklist service.

An IP which is listed in the service will be refused the ability to
submit comments - and this result will be cached for a week.

=cut

=head1 AUTHOR

=over 4

=item Steve Kemp

http://www.steve.org.uk/

=back

=cut

=head1 LICENSE

Copyright (c) 2008-2010 by Steve Kemp.  All rights reserved.

This module is free software;
you can redistribute it and/or modify it under
the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut


package Blog::Spam::Plugin::drone;


use strict;
use warnings;

use File::Path;
use Net::DNS::Resolver;



=begin doc

Constructor.  Called when this plugin is instantiated.

=end doc

=cut

sub new
{
    my ( $proto, %supplied ) = (@_);
    my $class = ref($proto) || $proto;

    my $self = {};

    # verbose?
    $self->{ 'verbose' } = $supplied{ 'verbose' } || 0;

    bless( $self, $class );
    return $self;
}




=begin doc

Test whether the IP address submitting the comment is listed
in the drone blacklist:

     http://www.dronebl.org/

=end doc

=cut

sub testComment
{
    my ( $self, %params ) = (@_);

    #
    #  IP is mandatory - we will always have it.
    #
    my $ip = $params{ 'ip' };

    #
    # We cannot lookup IPv6 addresses.
    #
    return "OK" if ( $ip =~ /:/ );

    #
    #  Malformed IP?
    #
    return "SPAM" unless ( $ip =~ /^([0-9\.]+)$/ );

    #
    #  Get the state directory which we'll use as a cache.
    #
    my $state = $params{ 'parent' }->getStateDir();
    my $cdir  = $state . "/cache/drone/";

    #
    #  Is the result cached?
    #
    my $safe = $ip;
    $safe =~ s/[:\.]/-/g;
    if ( -e "$cdir/$safe" )
    {

        #
        #  Update the modification time so that it
        # persists longer than the expected time since
        # we've had a fresh hit.
        #
        $self->touchCache("$cdir/$safe");

        #
        #  Return the cached result
        #
        return ("SPAM:Listed in dronebl.org");
    }


    #
    #  Not found in the cache.  Query DNS, then add any
    # positive result to the cache
    #

    #
    #  Reverse the IP for querying.
    #
    my $reversed_ip = join( ".", reverse( split( /\./, $ip ) ) );


    my $res = new Net::DNS::Resolver;
    $res->tcp_timeout(30);
    $res->udp_timeout(30);

    my $packet = $res->query( "$reversed_ip.dnsbl.dronebl.org.", "A" );
    if ( ( defined($packet) ) &&
         ( defined( $packet->answer() ) ) )
    {

        #
        #  Cache the result
        #
        if ( !-d $cdir )
        {
            mkpath( $cdir, { verbose => 0 } );
        }

        $self->touchCache("$cdir/$safe");

        return ("SPAM:dronebl");
    }

    return ("OK");
}




=begin doc

Create/Update the mtime of a file in the cache
directory.

=end doc

=cut

sub touchCache
{
    my ( $self, $file ) = (@_);

    open( FILE, ">", $file ) or
      return;
    print FILE "\n";
    close(FILE);
}




=begin doc

Expire our cached drone entries once a week.

=end doc

=cut

sub expire
{
    my ( $self, $parent, $frequency ) = (@_);

    #
    #  Max age of files to keep.
    #
    my $max = $self->{ 'age' } || 7;

    if ( $frequency eq "daily" )
    {
        my $state = $parent->getStateDir();
        my $cdir  = $state . "/cache/drone/";

        foreach my $entry ( glob( $cdir . "/*" ) )
        {

            #
            #  We're invoked once per day, but we only
            # cleanup files older than a week.
            #
            my $age = int( -M $entry );

            if ( $age >= $max )
            {
                $self->{ 'verbose' } && print "\tRemoving: $entry\n";
                unlink($entry);
            }
            else
            {
                $self->{ 'verbose' } &&
                  print "\tLeaving $entry - $age days old <= $max\n";
            }
        }
    }
}

1;
