#!/usr/bin/perl -w
#
# rbl-output
# John Simpson <jms1@jms1.net> 2003-05-10
#
# list the rbl database in a format suitable for a tcprules input file,
# an rbldns "data" file (with or without the extra patch), or as a 
# tinydns "data" file.
#
# works as a command-line tool or as a CGI script (i.e. prints HTTP 
# text/plain headers before output if running under CGI.)
#
# 2007-11-11 jms1 - major code clean-up and re-organizatioin in order to 
#   combine the four output formats into one program, and to publish the
#   code on the web site.
#
###############################################################################
#
# Copyright (C) 2003,2004,2005,2006,2007 John Simpson.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 or version 3 of the
# license, at your option.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
###############################################################################

require 5.003 ;
use strict ;

use DBI ;
use Getopt::Std ;
use POSIX qw ( strftime ) ;

use lib "/usr/local/lib" ;
use IPaddr ;			# http://www.jms1.net/code/#ipaddr

###############################################################################
#
# configuration

# set the default output format. if the script is called from a command
# line, this can be overridden using options. choices are:
#
#	t	tcprules "rblsmtpd"	1.2.3.4:allow,RBLSMTPD="blah"
#
#	T	tcprules "deny"		1.2.3.4:deny
#
#	r	rbldns format		1.2.3.4
#					1.2.3.0/24
#
#	p	rbldns with patch	1.2.3.4:127.0.0.2:blah
#					1.2.3.0/24:127.0.0.2:blah
#
#	dzone	tinydns format		+4.3.2.1.zone:127.0.0.2
#					+*.3.2.1.zone:127.0.0.2
#					'4.3.2.1.zone:blah
#					'*.3.2.1.zone:blah
#
my $format = "t" ;

# if you are using format "d", you need to set the zone- the domain suffix
# to be added to the reversed IP address.
#
my $zone = "" ;

# if set, error message will be this URL with the IP added to the end
# otherwise, error message will be the comment and date from database
#
# this can be overridden on the command line. "-u URL" sets a new URL,
#   and "-U" sets this to blank (i.e. use info from the database.)
#
#my $info_url = "http://www.delete.net/lookup.cgi/" ;
my $info_url = "" ;

# if 0, list every entry in the database.
# if 1, watch for and skip entries which are a subset of the previous
#   entry (i.e. if you have 210.0.0.0/8, this would skip 210.4.0.0/16
#   since it's already blocked by the larger block's entry.)
#
# this can be overridden on the command line- "-o" sets it to 1,
#   and "-O" set it to 0.
#
my $skip_overlap = 1 ;

# DBI string and credentials to access the database
#
my $sql_server = "dbi:Pg(PrintError=>0):dbname=rbl" ;
my $sql_userid = "" ;
my $sql_passwd = "" ;

###############################################################################
#
# globals

my %fnote =
(
	"t" => "formatted for use as a \"tcpserver\" access control file" ,
	"T" => "formatted for use as a \"tcpserver\" access control file" ,
	"r" => "formatted for use as a data file for \"rbldns\"" ,
	"p" => "formatted for use as a data file for \"rbldns\" with patch:\n#   http://qmail.jms1.net/djbdns/rbldns-patch.shtml" ,
	"d" => "formatted for use as a \"tinydns\" data file" ,
) ;


my ( $now , $dbh , $query , $sth , @data , $lup , %opt ,
	$pblock , @lblock , $level ) ;

###############################################################################
###############################################################################
###############################################################################

if ( $ENV{"GATEWAY_INTERFACE"} )
{
	print <<EOF ;
Content-type: text/plain
Pragma: no-cache
Cache-control: no-cache

EOF

	my $pi = ( $ENV{"PATH_INFO"} || "" ) ;

	if ( $pi =~ m|/lup/| )
	{
		$opt{"l"} = 1 ;
	}
}
else
{
	getopts ( "tTrpd:oOu:Ul" , \%opt ) ;

	########################################
	# -t		tcpserver format :allow,RBLSMTPD=""
	# -T		tcpserver format :deny,WHY=""
	# -r		rbldns format
	# -p		rbldns with patch format 
	#		http://qmail.jms1.net/djbdns/rbldns-patch.shtml
	# -d zone	tinydns format, specify DNS zone
	#		i.e. "-d rbl.domain.xyz"

	my $c = 0 ;
	for my $k ( qw ( t T r p d ) )
	{
		if ( $opt{$k} )
		{
			$format = $k ;
			$c ++ ;
		}
	}

	die "You may not choose multiple output formats.\n"
		if ( $c > 1 ) ;

	if ( $format eq "d" )
	{
		$zone = $opt{"d"} ;
	}

	########################################
	# -o	skip blocks which are within other blocks
	# -O	print all blocks, even if they overlap

	die "You may not use both -o and -O\n"
		if ( $opt{"o"} && $opt{"O"} ) ;

	$skip_overlap = $opt{"O"} ? 0 : 1 ;

	########################################
	# -u URL	URL for error message
	# -U		no URL (use comments from database)

	die "You may not use both -u and -U\n"
		if ( $opt{"u"} && $opt{"U"} ) ;

	if ( $opt{"u"} )
	{
		$info_url = $opt{"u"} ;
	}
	elsif ( $opt{"U"} )
	{
		$info_url = "" ;
	}
}

###############################################################################

#my @d = localtime ;
#$now = sprintf ( "%04d-%02d-%02d %02d:%02d:%02d" ,
#	$d[5]+1900 , $d[4]+1 , $d[3] , $d[2] , $d[1] , $d[0] ) ;

$now = strftime ( "%Y-%m-%d %H:%M:%S %z" , localtime() ) ;

###############################################################################
#
# connect to the database

$dbh = DBI->connect ( $sql_server , $sql_userid , $sql_passwd )
	or die ( "Can\'t connect to database: " . $DBI::errstr . "\n" ) ;

###############################################################################
#
# if all we want is the "last updated" time, get that

if ( $opt{"l"} )
{
	$query = "SELECT val_d FROM control WHERE key = 'last updated'" ;
	$sth = $dbh->prepare ( $query )
		or die ( "lup prepare(): " . $DBI::errstr . "\n" ) ;
	$sth->execute()
		or die ( "lup execute(): " . $DBI::errstr . "\n" ) ;
	while ( my @z = $sth->fetchrow_array() )
	{
		$lup = $z[0] ;
	}
	$sth->finish() ;
	$dbh->disconnect() ;

	$lup =~ s|\.\d+| | ;		# remove microseconds
	$lup .= "0000" ;		# fix timezone
	$lup =~ s|( [\+\-]\d{4}).*|$1| ;

	print "$lup\n" ;
	exit 0 ;
}

###############################################################################
#
# get the list of RBL blocks
# also find the highest "added" value

$query = "SELECT block , added , comments FROM rbl ORDER BY block" ;
$sth = $dbh->prepare ( $query )
	or die ( "data prepare(): " . $DBI::errstr . "\n" ) ;
$sth->execute()
	or die ( "data execute(): " . $DBI::errstr . "\n" ) ;

$lup = "" ;
@data = () ;
while ( my ( $b , $a , $c ) = $sth->fetchrow_array() )
{
	$a ||= "" ;
	$c ||= "" ;

	if ( $a gt $lup )
	{
		$lup = $a ;
	}

	$a =~ s| .*|| ; 		# only want the date in the output

	push ( @data , $b ) ;
	push ( @data , $a ) ;
	push ( @data , $c ) ;
}
$sth->finish() ;

$lup =~ s|\.\d+| | ;			# remove microseconds
$lup .= "0000" ;			# fix timezone
$lup =~ s|( [\+\-]\d{4}).*|$1| ;

###############################################################################
#
# done with the database

$dbh->disconnect() ;

###############################################################################
###############################################################################
#
# print the header

my $z = $fnote{$format} ;

print <<EOF ;
# RBL list, $z
#
# Generated from database   $now
# Database was last updated $lup
EOF

if ( $skip_overlap )
{
	print <<EOF ;
#
# note: blocks are aggregated in this file.
# record count will not match database if any blocks overlap each other.
EOF
}

if ( $format eq "t" || $format eq "T" )
{
	print <<EOF ;
#
# NOTE: THIS IS NOT A COMPLETE "tcprules" FILE. the lines in this file should
# be combined with other static rules for your site to produce the actual
# file used by "tcprules" to generate your smtp.cdb file.
EOF
}

if ( $format eq "r" )
{
	my $msg = $info_url
		? "$info_url\$"
		: "We do not accept mail from \$" ;

	print <<EOF ;

:127.0.0.2:$msg
EOF
}

print "\n" ;

###############################################################################
# print the data

$level = 0 ;

while ( @data )
{
	my $block   = shift @data ;
	my $added   = shift @data ;
	my $comment = shift @data ;

	my $d = new IPaddr ( $block ) ;

	########################################
	# maybe skip overlapping blocks

	if ( $skip_overlap )
	{
		while ( $level > 0 )
		{
			last if ( $lblock[$level-1]->contains ( $d ) ) ;
			$lblock[$level-1] = undef ;
			$level -- ;
		}

		if ( $pblock && $pblock->contains ( $d ) )
		{
			$lblock[$level] = $pblock ;
			$level ++ ;
		}

		$pblock = $d ;

		next if $level ;
	}

	########################################
	# generate the output

	my $ip = $d->first()->ip_dq() ;
	my $msg = $info_url
		? "-DENIED $info_url$ip"
		: "-DENIED $comment on $added" ;
	$msg =~ s|"|'|g ;	# in case $comment has quotes in it

	if ( $format eq "t" )
	{
		print $d->tcpr() , ":allow,RBLSMTPD=\"$msg\"\n" ;
	}
	elsif ( $format eq "T" )
	{
		# environment variables on a ":deny" line is ignored. 
		#   i'm including it here so that if you ever look at 
		#   the file, you can see why the block was listed.

		$msg = "$comment on $added" ;
		$msg =~ s|"|'|g ;	# in case $comment has quotes in it

		print $d->tcpr() , ":deny,WHY=\"$msg\"\n" ;
	}
	elsif ( $format eq "r" )
	{
		my $z = $d->first()->ip_dqc() ;
		$z =~ s|/32$|| ;
		print "$z\n" ;
	}
	elsif ( $format eq "p" )
	{
		my $z = $d->first()->ip_dqc() ;
		$z =~ s|/32$|| ;
		print "$z:127.0.0.2:$msg\n" ;
	}
	elsif ( $format eq "d" )
	{
		my $bits = $d->mask_cidr() ;

		if ( $bits > 31 )
		{
			my $r = $d->rvip_dq() ;
			print "+$r.$zone:127.0.0.2\n" ;
			print "'$r.$zone:$msg\n" ;
		}
		elsif ( $bits > 24 )
		{
			my $z = $d->first() ;
			while ( $z )
			{
				my $r = $z->rvip_dq() ;
				print "+$r.$zone:127.0.0.2\n" ;
				print "'$r.$zone:$msg\n" ;
				$z = $z->next() ;
			}
		}
		elsif ( $bits > 16 )
		{
			my $z = $d->first() ;
			while ( $z )
			{
				my $r = $z->rvip_dq() ;
				$r =~ s|^0|\*| ;
				print "+$r.$zone:127.0.0.2\n" ;
				print "'$r.$zone:$msg\n" ;
				$z = $z->next(256) ;
			}
		}
		elsif ( $bits > 8 )
		{
			my $z = $d->first() ;
			while ( $z )
			{
				my $r = $z->rvip_dq() ;
				$r =~ s|^0\.0|\*| ;
				print "+$r.$zone:127.0.0.2\n" ;
				print "'$r.$zone:$msg\n" ;
				$z = $z->next(65536) ;
			}
		}
		else
		{
			my $z = $d->first() ;
			while ( $z )
			{
				my $r = $z->rvip_dq() ;
				$r =~ s|^0\.0\.0|\*| ;
				print "+$r.$zone:127.0.0.2\n" ;
				print "'$r.$zone:$msg\n" ;
				$z = $z->next(16777216) ;
			}
		}
	}
	else
	{
		die "Unknown \$format code \"$format\"\n" ;
	}
}

exit 0 ;