URIBL plugin

[Devin Carraway]

Saw on slashdot, liked the idea (it's occurred to me before, but I
didn't really think through it that thoroughly), so here's a first-stab
implementation.  Could use some refinement in the URI matching,
bare-hostname detection, that sort of thing, but it seems to work.  I
don't advise running it in reject mode until it's had more of a
shakedown.

(also found at http://devin.com/qpsmtpd/uribl)

-- 
Devin  \ aqua(at)devin.com, 1024D/E9ABFCD2;  http://www.devin.com
Carraway \ IRC: Requiem  GCS/CC/L s-:--- !a !tv C++++$ ULB+++$ O+@ P L+++

#!/usr/bin/perl -w

=head1 NAME

uribl - URIBL blocking plugin for qmpsmtpd

=head1 DESCRIPTION

This plugin implements the URIBL proposal, such as the Spam URI Realtime
Blocklist (SURBL; see <http://surbl.org/>).  Incoming messages are scanned
for URIs, which are then checked against one or more URIBLs in a fashion
similar to DNSBL systems.

=head1 CONFIGURATION

To enable the plugin, add it to I<~qpsmtpd/config/plugins>.  The list of
URIBLs to check should be placed in I<uribl_zones> in the config directory
(typically I<~qpsmtpd/config>).

You may specify the following config option(s):

=over 4

=item action

Specifies what to do when a URI is matched in a URIBL.  Available options are
I<add-header> (the default) I<deny> and I<denysoft>.  If set to add-header, an
X-URIBL-Match: header will be added explaining the URIBL entry found.  If set
to 'deny,' the delivery will be declined with a hard failure.  If set to
denysoft, the delivery will be soft failed (this is probably not a good idea.)

=back

=head1 BUGS

Does not yet detect URIs munged by URI percentage-style escape codes,
and may miss some other munging as well.

Does not attempt to pick out non-URI style hostnames, such as a bare
"www.domain.tld".

=head1 AUTHOR

Written by Devin Carraway <[EMAIL PROTECTED]>.  Newer versions may be found
(or not) at http://devin.com/qpsmtpd/.

=cut

use Net::DNS::Resolver;

use strict;
use warnings;

sub register {
        my ($self, $qp, %args) = @_;

        $self->{action} = $args{action} || 'add-header';
        $self->register_hook('data_post', 'data_handler');
}

sub data_handler {
        my ($self, $txn) = @_;
        my $l;
        my %sockets;
        my @uribl_zones = $self->qp->config('uribl_zones');
        $self->log(0, "URIBL zones: ".join(',',@uribl_zones));
        @uribl_zones or return DECLINED;
        my $res = new Net::DNS::Resolver or return DECLINED;

        $txn->body_resetpos;
        while ($l = $txn->body_getline) {
                chomp $l;
                last if !$l;
        }
        while ($l = $txn->body_getline) {
                chomp;
                if ($l =~ m{\w{3,16}://(?:\S+@)?(\d{7,})(?::\d+)?([/?\s]|$)}) {
                        my @octets = (
                                (($1 >> 24) & 0xff),
                                (($1 >> 16) & 0xff),
                                (($1 >> 8) & 0xff),
                                ($1 & 0xff)
                                );
                        my $fwd = join('.', @octets);
                        my $rev = join('.', reverse @octets);
                        $self->log(2, "uribl: matched pure-integer ipaddr $1 ($fwd)");
                        $sockets{"$rev\t$_"} ||= $res->bgsend("$rev.$_.", 'txt')
                                for @uribl_zones;
                }
                elsif ($l =~ m{\w{3,16}://(?:\S+@)?(\d+)\.(\d+)\.(\d+)\.(\d+)}) {
                        my $rev = "$4.$3.$2.$1";
                        $self->log(2, "uribl: matched URI ipaddr $1.$2.$3.$4");
                        $sockets{"$rev\t$_"} ||= $res->bgsend("$rev.$_.", 'txt')
                                for @uribl_zones;
                }
                elsif ($l =~ m{\w{3,16}://(?:\S+@)?([\w\-.]+\.\w+)}) {
                        $self->log(2, "uribl: matched URI hostname $1");
                        $sockets{"$1\t$_"} ||= $res->bgsend("$1.$_.", 'txt')
                                for @uribl_zones;
                }
        }
        $txn->body_resetpos;

        my %matches;
        while (keys %sockets) {
                my $c = 0;
                for my $s (keys %sockets) {
                        unless ($sockets{$s}) {
                                delete $sockets{$s};
                                next;
                        }
                        next unless $res->bgisready($sockets{$s});
                        my $packet = $res->bgread($sockets{$s});
                        unless ($packet) {
                                delete $sockets{$s};
                                next;
                        }
                        for my $rr ($packet->answer) {
                                $matches{$s} = $rr->txtdata
                                        if $rr->type eq 'TXT';
                        }
                        delete $sockets{$s};
                        $c++;
                }
                sleep 0.1 if keys %sockets and !$c;
        }
        for (keys %matches) {
                my ($host, $uribl) = split /\t/, $_;
                my $note = "$host in $uribl ($matches{$_})";
                $self->log(0, $note);
                if ($self->{action} eq 'add-header') {
                        $txn->header->add('X-URIBL-Match', $note);
                } elsif ($self->{action} eq 'deny') {
                        return (DENY, $note);
                } elsif ($self->{action} eq 'denysoft') {
                        return (DENYSOFT, $note);
                }
        }
        return DECLINED;
}

1;

signature.asc
Description: Digital signature