#!/usr/bin/perl
# 
# checkdbl.pl - TCP lookup table for Postfix header_checks 
#
# This script borrows considerably from the version posted to 
# spam-l by joao.gouveia@anubisnetworks.com on 2010-08-31. Here, 
# we query multiple DBLs and use spawn(8) instead of Net::Server
# for connection management. The simple goal is to query multiple
# DBLs for domain names that appear in email headers.
#
# To integrate in $config_directory/master.cf:
#
#  localhost:2526 inet  n       n       n       -       10      spawn
#    user=nobody argv=/path/to/checkdbl.pl
#
# And in $config_directory/main.cf:
#
#  header_checks = tcp:[127.0.0.1]:2526
#
# UPDATED: 2010-09-06

use Net::DNS;
use strict;
use warnings;

#
# Define the headers and DBL zones we care about.
#
our @headers = qw(from message-id reply-to);
our @zones   = qw(dbl.spamhaus.org multi.surbl.org black.uribl.com);

#
# Create our resolver object.
#
our $dns = Net::DNS::Resolver->new(
	udp_timeout  => 2,
	retry        => 2,
);

#
# Extract what appears to the right of '@', and verify that
# it is not an IP address; then, query DBLs and return as  
# soon as we get a hit. Do not check additional DBLs once 
# a query succeeds.
#
sub querybl {
	return undef unless /\@([\w.-]+\.[[:alpha:]]+)/;
	my $domain = $1;
	foreach my $zone (@zones) {
		my $query = $dns->query($domain . "." . ${zone}, "A");
		if ($query) {
			foreach my $rr ($query->answer) {
				return $domain if $rr->address=~/^127/;
			}
		}
	}
	return undef;
}

#
# Autoflush standard output.
#
select STDOUT; $|++;

#
# Process the headers as Postfix passes them our way,
# one line at a time. For now, also query DBLs for 
# domain names found in Resent-X headers, when X is
# defined in @headers.
#
while (<STDIN>) {
	chomp;
	if (/^get\s+(?:resent-)?([\w-]+)\s*:\s*(.+)$/i) {
		my ($hdr, $data) = ($1, $2);
		unless(grep(/^$hdr/i, @headers)) {
			print "200 DUNNO\n";
			next;
		}
		my $res = querybl($data);
		if ($res) {
			print "200 REJECT\n";
			next;
		}
	}
	print "200 DUNNO\n";
}