#!/usr/bin/perl
# Distributed RBL zone builder. Version 1.06. Published 2001.07.28
#
# Based on the version 1.04 written by 
#             Cyril A. Vechera cyril@piter.net 2000.05.12
# 
# Usage: build_drbl zones threshold [header]
#
# zones file format:
# zone [~]weight [nameserver]
#
# Weight is a value which depends on how strong do you trust in 
# the particular zone's maintainer. 
# Each address encountered in the zone gets that value as it's
# weight. 
# if '~' prepends the weight, the builder uses a random
# value in range from 0 to the given weight for each record.
# If an address is found in more than one zone, it's weight 
# will be the sum of weights received from all the zones. 
#
# Threshold defines the minimum weight an address must have to
# be included in the generated output. 
#
# Optional header just prepends the output. You should
# place your SOA, NS and other common records there.
# If you place $time$ somewhere in the header file, it will be replaced
# with the current time in seconds since epoch so you can use it as
# your SOA serial number.
#
# changes from v1.05.02 (2001.07.10)
#  by Dmitry Morozovsky <marck@rinet.ru>
#  - full path name to local zone files (currently without $ORIGIN support)
#    in zones.
#  - configurable $path_to_dig
#
# changes from v1.05.01 (2001.04.07)
#   by Andy Igoshin <ai@vsu.ru>
#   bind 9 compatibility.
#
# changes from v1.05 (2001.01.28)
#   by Andrey V. Stolyarov (crocodil@croco.net)
#
#  Comments corrected. No other changes are made. 
#
# changes from v1.04 (2001.01.24) 
#   by D Kelmi <miksir@sub.ru>
#   by Vladimir B. Grebenschikov <vova@express.ru>
#
#  &suck_zone changed to support TXT records
#  weight calculation bug fixed (in 'nested subnets aggregation')
#  drop_punk_ip feature added
#  optional adding of all original TXT records into the 
#  generated zone added.
#
# changes from v1.03 (2000.04.21)
#
#  fixed axfr processing
#
# changes from v1.02 (2000.04.03)
#
#  'random' bug fixed, minor wildcard correction
#
# changes from v1.01 (2000.03.21)
#
#  wildcard bug fixed
#
# changes from v1.0 (2000.03.15)
#
#  random weight support included via using '~' prefix in weight value

################################################################
# Configurable parameters section

# append_record_source
# set this to 1 if you wish TXT records in the generated zone 
# to contain the names of the zones they came from 
my $append_record_source = 1;

# append_TXT_records
# set this to 1 if you want original TXT records from all the source zones 
# to be included into the generated zone
my $append_TXT_records = 1;

# strict 
# Controls the builder's behaviour in case an A-record in a source zone 
# specifies an ip address different from the standard 127.0.0.2
# strict = 0  - simply ignore the actual ip address value in the source
#               A-records, accept everything. Nevertheless, generate
#               the output using 127.0.0.2 in all resulting A-records.
# strict = 1  - do not accept source A-records if they specify an address 
#		different from 127.0.0.2
# strict = 2  - if the ip-address specified in a zone with the higest weight
#               belongs to the 127.0.0.0/8 range, then take it as a value for
#               the generated A-record; otherwise, use 127.0.0.2
#               Note all source records are accepted in this case. 
my $strict = 2;

# short_result
# Set this to 1 if you want resulting TXT records to be short
my $short_result = 1;

# drop_punk_ip
# set this to 1 if you want to drop records for addresses which belong to
# networks blocked by another record. 
my $drop_punk_ip = 1;

# append_weight_value
# set this to 1 if you wish your TXT records to contain the outcome weight
my $append_weight_value = 1;

# put_full_subnets
# set this to 1 if you want records without the wildcart to be generated 
# for subnets. That is, if 10.11.12.0/24 is to be blocked, the builder will
# generate A-records for *.12.11.10 _and_ for 12.11.10. 
# in case this is set to 0, pnly *.12.11.10 is generated. 
my $put_full_subnets = 1;

# path to dig
my $path_to_dig = '/usr/bin/dig';

# Configurable parameters section END
#################################################################

$#ARGV >= 1 or die "Usage: build_drbl zones threshold [header]\n";
my ($zones, $thr, $header) = @ARGV;

srand ($$+time);

my (@zonelist, %zone, %weight, %ns, %random);
my (%source, %weighted, %remark, %result);
my (@recs, %ips, %ipsw);

# load zones file
open (ZONES, $zones) || die "Can't open $zones: $!\n";
while (<ZONES>) {
        my ($zone, $weight, $ns) = split;
        next if ( /^(;|#)/ );
        next unless $zone;
        
        my ($zl) = $zone.'@'.$ns;
        push (@zonelist, $zl);
        $zone{$zl} = $zone;
        if ($weight =~ s/^~//) {
                $random{$zl} = 1;
        }
        $weight{$zl} = $weight;
        $ns{$zl} = $ns;
}
close (ZONES);

# load zones
foreach my $zid (@zonelist) {
        $source{$zid} = &suck_zone ($zone{$zid}, $ns{$zid});
}

print STDERR "Generating resulting zone\n";

# calculate weights
foreach my $zid (@zonelist) {
        my $source = $source{$zid};
        foreach my $rec (keys %{$source}) {
                next if ($source->{$rec}->{'A'} ne "127.0.0.2" && $strict == 1);
                if ($ipsw{$rec} < $weight{$zid}) {
                    $ips{$rec} = $source->{$rec}->{'A'};
                    $ipsw{$rec} = $weight{$zid};
                }
                $weighted{$rec} += ($random{$zid}) ? rand ($weight{$zid}) : $weight{$zid};
                $remark{$rec} .= " $zid/$weight{$zid}" unless ($short_result);
                $remark{$rec} .= " $zone{$zid}/$weight{$zid}" if ($short_result);
                $txt{$rec} .= $source->{$rec}->{'TXT'}."\n" unless ($txt{$rec} =~ /\Q$source->{$rec}->{'TXT'}\E\n/);
        }
}

# nested subnets agregation
foreach my $rec (keys %weighted) {
        my $ext = $rec;
        while ( $ext =~ s/^(\d+\.)(.*)$/$2/o ) {
                # found ip from exist network?
                if ( defined $weighted{$ext} ) {
                        # add weight of network to weight of ip only for zones
                        # without this ip :)
                        foreach $rem (split(/\s+/, $remark{$ext})) {
                            next unless $rem;
                            next if ($remark{$rec} =~ /\b\Q$rem\E\b/);
                            (undef,$nw) = split(/\//, $rem);
                            $weighted{$rec} += $nw;
                            $remark{$rec} .= " $rem";
                        }
                }
        }
}

%result = ();

# cut off too light records
foreach my $rec (keys %weighted) {
        if ( $weighted{$rec} >= $thr ) {
                $result{$rec} = "weight: $weighted{$rec}";
                if ($remark{$rec} && $append_record_source) {
                        $result{$rec} .= ";$remark{$rec}";
                }
        }
}

# drop blocked ip from blocked networks
@recs = keys %result;

if ($drop_punk_ip) {
        foreach my $rec (@recs) {
                next unless $rec;
                map { $_ = '' if ( /\.\Q$rec\E$/ ) } @recs;
        }
}

# output
if ( $header ) {
        open (HEADER, $header) || die "Can't open $header: $!\n";
        while (<HEADER>) { s/\$time\$/time()/ge; print; }
        close (HEADER);
}

my ($sec, $min, $hour, $mday, $mon, $year) = localtime;
my ($date) = sprintf ("%04d.%02d.%02d %02d:%02d:%02d",
        $year+1900,$mon+1,$mday,$hour,$min,$sec);

print "\tIN\tTXT\tDRBL-Date: $date\n";
print "\tIN\tTXT\tDRBL-Threshold: $thr\n";

foreach my $zid (@zonelist) {
        print "\tIN\tTXT\tDRBL-Source: $zid/$weight{$zid}\n";
}

print "\n";

foreach my $rec (@recs) {
        next unless ($rec);
        my $ip = "127.0.0.2";
        $ip = $ips{$rec} if ($strict == 2 && $ips{$rec} =~ /^127\./);

        if ( ($rec =~ tr/\./\./) >= 4 || $put_full_subnets) {
                print "$rec\tIN\tA\t$ip\n";
                if ($append_TXT_records) {
                        foreach my $note (split(/\n/, $txt{$rec})) {
                                print "$rec\tIN\tTXT\t\"$note\"\n";
                        }
                }
                print "$rec\tIN\tTXT\t\"$result{$rec}\"\n" if ($append_weight_value);
        }

        if ( ($rec =~ tr/\./\./) < 3 ) {
                print "\n";
                print "*.$rec\tIN\tA\t$ip\n";
                if ($append_TXT_records) {
                        foreach my $note (split(/\n/, $txt{$rec})) {
                                print "*.$rec\tIN\tTXT\t\"$note\"\n";
                        }
                }
                print "*.$rec\tIN\tTXT\t\"$result{$rec}\"\n" if ($append_weight_value);
        }
        
        print "\n";
}

# output statistic... will be done later



sub suck_zone {
        my ($zone, $source) = @_;
        my ($table, $lname);
        my ($ttl, $class, $type, @data, $data);

        open (AXFR, ($source =~ m%^/%) ?
		"<$source" :
		"$path_to_dig \@$source $zone axfr|"
	) || die "Can't open file/dig zone: $!\n";
	print STDERR "Processing $zone at $source\n";

        $table = {};

        while (<AXFR>) {
                next if /^;/;
                $name = ''; chomp;
                if ( /^\s/ && $lname) {
                        ($ttl, $class, $type, @data) = split;
			if ($ttl eq 'IN') { # record without TTL
				unshift @data, $type;
				$type = $class;
				$class = $ttl;
				$ttl = '1D';	# really unneded
			}
                        $name = $lname;
                } elsif ( /^(\d+|\*)\./ ) {
                        ($name, $ttl, $class, $type, @data) = split;
			if ($ttl eq 'IN') { # record without TTL
				unshift @data, $type;
				$type = $class;
				$class = $ttl;
				$ttl = '1D';	# really unneded
			}
                        $lname = $name;
                } else {
                        $lname = '';
                }
                next if (!$name || ($type ne 'A' && $type ne 'TXT'));
		$name =~ s/[a-zA-Z\.]*$//g;
                $name =~ s/^\*\.//o;
                $data = join(' ', @data);
                $data =~ s/\"//g;
                ${$table}{$name} = {} if (!defined(${$table}{$name}));
                ${$table}{$name}->{'A'} = $data if ($type eq 'A');
                ${$table}{$name}->{'TXT'} .= $data."\n" if ($type eq 'TXT' && (${$table}{$name}->{'TXT'} !~ /\Q$data\E\n/));
        }

        close (AXFR);

        return $table;
}

